在日常工作和生活中我们经常使用电子记事本查找个人通讯录信息，或在单位的应用程序中查询客户档案或业务资料，这个过程中往往需要输入大量的汉字信息，对于熟悉计算机的人这已经是一件头疼的事，那些不太熟悉计算机或根本不懂汉字输入的用户简直就望而生畏。作为对数据检索技术的一种新的尝试，作者探索使用汉字拼音的首字符序列作为检索关键字，这样，用户不必使用汉字，只须简单地键入要查询信息的每个汉字的拼音首字符即可。比如你想查找关键字“中国人民银行”，你只需要输入“zgrmyh”。作者希望通过下面的例子，为广大计算机同行起一个抛砖引玉的作用，让我们开发的程序更加便捷、好用。
原理很简单，找出汉字表中拼音首字符分别为“A”至“Z”的汉字内码范围，这样，对于要检索的汉字只需要检查它的内码位于哪一个首字符的范围内，就可以判断出它的拼音首字符。
程序更简单，包括3个控件：一个列表存放着所有待检索的信息；一个列表用于存放检索后的信息；一个编辑框用于输入检索关键字（即拼音首字符序列）。详细如下：
1．进入Delphi创建一个新工程：Project1
2．在Form1上创建以下控件并填写属性：
控件类型 属性名称 属性值
Edit Name Search
ListBox Name SourceList
Items 输入一些字符串，如姓名等，用于提供检索数据
ListBox Name ResultList
3．键入以下两个函数
// 获取指定汉字的拼音索引字母，如：“汉”的索引字母是“H”
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;
// 在指定的字符串列表SourceStrs中检索符合拼音索引字符串
PYIndexStr的所有字符串，并返回。
function SearchByPYIndexStr
( SourceStrs:TStrings;
PYIndexStr:string):string;
label NotFound;
var
i, j :integer;
hzchar :string;
begin
for i:=0 to SourceStrs.Count-1 do
begin
for j:=1 to Length(PYIndexStr) do
begin
hzchar:=SourceStrs[i][2*j-1]
+ SourceStrs[i][2*j];
if (PYIndexStr[j]<>'?') and
(UpperCase(PYIndexStr[j]) <>
GetPYIndexChar(hzchar)) then goto NotFound;
end;
if result=' then result := SourceStrs[i]
else result := result + Char
(13) + SourceStrs[i];
NotFound:
end;
end;
4．增加编辑框Search的OnChange事件：
procedure TForm1.SearchChange(Sender: TObject);
var ResultStr:string;
begin
ResultStr:=';
ResultList.Items.Text := SearchByPYIndexStr
(Sourcelist.Items, Search.Text);
end;
5．编译运行后
在编辑框Search中输入要查询字符串的拼音首字符序列，检索结果列表ResultList就会列出检索到的信息，检索中还支持“？”通配符，对于难以确定的的文字使用“？”替代位置，可以实现更复杂的检索。
本程序在Delphi4.0中编译运行通过。
2008年10月2日星期四
2008年9月9日星期二
Delphi实现屏幕抓图技术
摘 要：本文以Delphi7.0作为开发平台，给出了网络监控软件中的两种屏幕抓图技术的设计方法和步骤。介绍了教师在计算机机房内教学时，如何监控学生计算机显示器上的画面，以保证教学的质量和效果。
引言
随着网络技术的飞速发展，计算机网络在各高等院校教学中的使用已非常普遍，但是，我们发现一个问题，在教学的过程中，由于老师是面对着学生，而背对着学生计算机的显示器，不能随时查看学生计算机显示器上的内容，所以，有的学生在教学中偷玩游戏，影响了教学的质量和效果，因此，设计一款网络监控软件，监控学生计算机，十分必要。为了实现这一目的，此系统应具有以下功能：
（1）教师用机可以循环显示学生计算机的显示器上的画面。
（2）教师用机可以动态显示某一学生计算机的显示器上的画面。
（3）教师用机可以对学生用计算机发出警告信息和控制信息。
（4）学生用计算机开机自动运行服务端监控程序。
（5）为了防止学生用计算机的服务端监控程序，被学生发现用Ctrl+Alt+Del关闭，在Ctrl+Alt+Del对话框中必须隐藏程序。同时，应该隐藏程序在任务栏的按钮。
本文结合应用实践，重点向大家介绍在Delphi7.0中可以采用的两种实现屏幕抓图技术的操作方法。
程序实现
（1）抓取屏幕图像的难点有两个：一是如何夺取屏幕的句柄，二是知道屏幕句柄后如何获取屏幕的图像。Borland公司的设计人员用画布（Tcanvas）对象封装了Windows的大部分图形输出功能，可以通过它以更直观的方式和Windows的屏幕打交道，而不必关心令人头疼的Windows API函数。具体程序如下：
procedure TForm1.Timer1Timer(Sender：TObject)；//抓取屏幕，并保存到Image控件中
var
Fullscreen：Tbitmap；
FullscreenCanvas：TCanvas；
dc：HDC；
begin
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；
（2）Delphi的第三方控件ScreenCapture，它是一个很好的免费的截图控件，可以轻松抓取任意大小（全屏当然行）、屏幕的任何位置，还可以设置所截图像的形状、以及用何种模式截图。下面介绍的是用TcmWindow模式截图，使用非常简单，使用效果可以与著名的抓图软件SnagIt32媲美。
procedure TForm1.BtnStartClick(Sender：TObject)；
begin
ScreenCapture1.start； //开始截图
end；
//当截取屏幕成功时，此事件发生
procedure TForm1.ScreenCapture1Capture(Sender：TObject；Bitmap：TBitmap)；
begin
//调整滚动窗口的大小以适应截获图像的大小
Scrollbox1.HorzScrollBar.Range：= Image1.width；
Scrollbox1.VertScrollBar.Range：= Image1.height；
end；
procedure TForm1.FormCreate(Sender：TObject)；
begin
//载入entntacp.dll文件
BtnStart.enabled：= ScreenCapture1.dllavailable；
//显示版本信息
caption：= '屏幕抓图软件' + ScreenCapture1.version；
end；
//当没有足够的内存支持截取屏幕时，此事件发生
procedure TForm1.ScreenCapture1Error(Sender：TObject)；
begin
MessageDlg('屏幕截取时发生一个错误！请关闭其他应用程序以获得更多内存资源.'， mtError，[mbOK]，0)；
end；
//当用户按“Esc”键，即取消屏幕截取时，此事件发生
procedure TForm1.ScreenCapture1UserCancelled(Sender：TObject)；
begin
MessageDlg('用户取消屏幕截取。'，mtInformation，[mbOK]，0)；
end；
引言
随着网络技术的飞速发展，计算机网络在各高等院校教学中的使用已非常普遍，但是，我们发现一个问题，在教学的过程中，由于老师是面对着学生，而背对着学生计算机的显示器，不能随时查看学生计算机显示器上的内容，所以，有的学生在教学中偷玩游戏，影响了教学的质量和效果，因此，设计一款网络监控软件，监控学生计算机，十分必要。为了实现这一目的，此系统应具有以下功能：
（1）教师用机可以循环显示学生计算机的显示器上的画面。
（2）教师用机可以动态显示某一学生计算机的显示器上的画面。
（3）教师用机可以对学生用计算机发出警告信息和控制信息。
（4）学生用计算机开机自动运行服务端监控程序。
（5）为了防止学生用计算机的服务端监控程序，被学生发现用Ctrl+Alt+Del关闭，在Ctrl+Alt+Del对话框中必须隐藏程序。同时，应该隐藏程序在任务栏的按钮。
本文结合应用实践，重点向大家介绍在Delphi7.0中可以采用的两种实现屏幕抓图技术的操作方法。
程序实现
（1）抓取屏幕图像的难点有两个：一是如何夺取屏幕的句柄，二是知道屏幕句柄后如何获取屏幕的图像。Borland公司的设计人员用画布（Tcanvas）对象封装了Windows的大部分图形输出功能，可以通过它以更直观的方式和Windows的屏幕打交道，而不必关心令人头疼的Windows API函数。具体程序如下：
procedure TForm1.Timer1Timer(Sender：TObject)；//抓取屏幕，并保存到Image控件中
var
Fullscreen：Tbitmap；
FullscreenCanvas：TCanvas；
dc：HDC；
begin
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；
（2）Delphi的第三方控件ScreenCapture，它是一个很好的免费的截图控件，可以轻松抓取任意大小（全屏当然行）、屏幕的任何位置，还可以设置所截图像的形状、以及用何种模式截图。下面介绍的是用TcmWindow模式截图，使用非常简单，使用效果可以与著名的抓图软件SnagIt32媲美。
procedure TForm1.BtnStartClick(Sender：TObject)；
begin
ScreenCapture1.start； //开始截图
end；
//当截取屏幕成功时，此事件发生
procedure TForm1.ScreenCapture1Capture(Sender：TObject；Bitmap：TBitmap)；
begin
//调整滚动窗口的大小以适应截获图像的大小
Scrollbox1.HorzScrollBar.Range：= Image1.width；
Scrollbox1.VertScrollBar.Range：= Image1.height；
end；
procedure TForm1.FormCreate(Sender：TObject)；
begin
//载入entntacp.dll文件
BtnStart.enabled：= ScreenCapture1.dllavailable；
//显示版本信息
caption：= '屏幕抓图软件' + ScreenCapture1.version；
end；
//当没有足够的内存支持截取屏幕时，此事件发生
procedure TForm1.ScreenCapture1Error(Sender：TObject)；
begin
MessageDlg('屏幕截取时发生一个错误！请关闭其他应用程序以获得更多内存资源.'， mtError，[mbOK]，0)；
end；
//当用户按“Esc”键，即取消屏幕截取时，此事件发生
procedure TForm1.ScreenCapture1UserCancelled(Sender：TObject)；
begin
MessageDlg('用户取消屏幕截取。'，mtInformation，[mbOK]，0)；
end；
简易对象垃圾回收框架for Delphi
1.1 我的一个出错程序
程序名称：呼叫处理模块的压力测试工具，分为客户端和服务端。
开发工具：Delhpi 5
相关技术：客户端通过与服务端建立Socket连接来模拟一组电话机的拨入、按键、等待、挂机等过程。服务端对Socket事件以及收到的数据包进行预处理，并转化为抽象的呼叫模型数据，然后发送给更上层的呼叫处理模块。由于呼叫处理模块是硬件无关的（与语音板卡、交换机类型均无关），因此通过此压力测试工具可以比较真实地模拟海量呼叫，以达到测试呼叫处理模块程序的逻辑正确性及其性能的目的。
由于系统设计时的某些考虑，该测试工具被分作客户端和服务端两个程序来实现，且采用socket进行通讯。现在想来，其实不如整合成一个程序实现更为简单——但也正因为采用两个程序来实现，才引发了后面的一些问题，并由此引入了简单的垃圾回收框架。
1.2 问题
在测试工具的使用过程中，我们发现当呼叫量巨大，且测试工具动作频繁的情况下，系统出现以下错误：
n 访问地址错(EAccessViolation)，代码地址位于$0046FC80附近，访问地址多为$00000028。
n 出现EinvalidCast错误，该错误表明对一个地址进行类类型转换时出错（采用as关键字）。
n 程序内多处断言失败，出现许多引用已销毁对象的情况。
仔细检查程序后，我仍然认为这一切简直是不可思议！而且，本来用于对别的程序进行测试的程序自身却出现这类问题，几乎让我无地自容！
为了挽回自己的声誉，我不得不成沉住气来仔细跟踪错误，排解问题！
2 解决办法
2.1 查错
其实问题的解决还比较顺利。
通过查看程序的调用栈，发现程序出错前总是停留在发送Socket数据包的过程里。接着，进一步通过单步跟踪，发现在发送数据包的过程中，Socket检测到对端连接已经断开，就会触发OnDisconnect事件。而我正是在ServerSocket的OnDisconnect事件中根据传递进来的Socket句柄，找到对应的对象将之销毁的。
我在ServerSocket的OnDisconnect事件中的代码如下：
procedure Txxxx.ServerClientDisconnect(Sender: TObject; Socket: TCustomWinSocket); Begin…FLines.DestroyLineBySocket(Socket);//正是这一句，在不合适的时机释放了对象…End;
问题是这么出现的。
比如，在某个过程中具有如下代码（前面为行号）：
1 FLine.DoSomething；
2 FLine.SendSocketData；
3 FLine.DoOtherThings；
其中，FLine是代表一路呼叫的对象。该对象内部引用了一个TCustomWinSocket指针。SendSocketData就是利用此Socket进行数据发送。
Flines是TLine对象的容器类的一个实例。
由此不难解读前述的各类错误：
1． 由于行2的Socket连接断开导致FLine对象释放，因此行3访问DoOtherThings几乎必然造成访问地址错；
2． 由于行2的对象销毁，因此程序中类似“Object as TLine”的代码导致第二类错误；
3． 由于对象提前销毁，善后处理工作未到位导致第三类错误；
2.2 解决方案
明白其原因后，问题解决起来就容易多了。
上述问题不外乎两个方案：
一， 判断实例是否存在
在DoOtherThings之后，判断FLine对象是否仍然处于Flines之中，若是则继续处理，否则结束处理；
二， 延迟销毁FLine对象
在ServerSocket的OnDisconnect中，将FLine对象抛入垃圾池，待时机成熟时再销毁。
考虑到方案一所要改动的代码量较大，同时，此种方案代码也不甚优美，因此决定采用方案二，即引入垃圾回收机制来解决问题。方案二的要点是选择合适的时机真正销毁对象。而对于这一点，问题倒不大，只需选择消息循环中处理消息的第一个环节进行回收即可。因为在之后的处理环节中，必然能够确保对FLine是否仍然有效的检查。
3 简易对象垃圾回收框架（untGarbagCollector）
3.1 概述
简易的垃圾回收非常简单：
n 使用TThreadList支持线程并发访问，并保存待回收的对象指针；
n 提供Put方法保存待回收对象；
n 提供Recycle方法进行真正的回收（因为所有对象均自TObject派生而来）。
3.2 实现代码
unit untGarbagCollector;interfaceusesClasses;typeTGarbagCollector = Class(TObject)privateFList: TThreadList;publicconstructor Create;destructor Destroy; override;procedure Put(const AObject: TObject);procedure Recycle(const MaxCount: Integer);end;function GarbagCollector: TGarbagCollector;implementationvar_GarbagCollector: TGarbagCollector;function GarbagCollector: TGarbagCollector;beginif not Assigned(_GarbagCollector) then_GarbagCollector := TGarbagCollector.Create;result := _GarbagCollector;end;{ TGarbagCollect }constructor TGarbagCollector.Create;beginFList := TThreadList.Create;end;destructor TGarbagCollector.Destroy;begintryRecycle(FList.LockList.Count);finallyFList.UnlockList;end;FList.Free;end;procedure TGarbagCollector.Put(const AObject: TObject);begintryFList.LockList.Add(AObject);finallyFList.UnlockList;end;end;procedure TGarbagCollector.Recycle(const MaxCount: Integer);varI: Integer;AList: TList;beginAList := FList.LockList;tryI := 0;while (AList.Count > 0) and (I < MaxCount) dobeginTObject(AList.Last).Free;AList.Delete(AList.Count - 1);Inc(I);end;finallyFList.UnlockList;end;end;initializationfinalizationif Assigned(_GarbagCollector) then_GarbagCollector.Free;end.
3.3 使用举例
引用untGarbagCollector单元后，可以直接使用GarbagCollector进行对象的销毁和回收。
n 销毁
AObject := TObject.Create;
GarbagCollector.Put(AObject);
n 回收
可以在定时器、线程以及其他场合调用Recycle方法。
MaxCount是用于控制每次销毁个数的参数，主要是怕一次性销毁太多占用过多的cpu。
（突然发现还可以扩展为限制时间进行销毁，比如每次销毁耗时不超过的n毫秒）。
3.4 使用场合
在本案例中，为了防止对象过早销毁引起访问冲突，而引入了垃圾回收技术。
在其它场合，比如为了提高某些程序的主观性能，也可以引入该技术。比如完成某些特定任务的程序，在处理过程中会产生临时的对象，而销毁这些对象又比较耗时。因此，为了尽早地结束任务，可以把这些临时对象保存至垃圾池中。待作业（任务）完成，并且等一段时间后cpu比较空闲时，再把临时对象真正销毁。此做法的真谛就是以空间换取时间——与某些系统预创建对象，并重复利用对象以提高性能的做法相同。
程序名称：呼叫处理模块的压力测试工具，分为客户端和服务端。
开发工具：Delhpi 5
相关技术：客户端通过与服务端建立Socket连接来模拟一组电话机的拨入、按键、等待、挂机等过程。服务端对Socket事件以及收到的数据包进行预处理，并转化为抽象的呼叫模型数据，然后发送给更上层的呼叫处理模块。由于呼叫处理模块是硬件无关的（与语音板卡、交换机类型均无关），因此通过此压力测试工具可以比较真实地模拟海量呼叫，以达到测试呼叫处理模块程序的逻辑正确性及其性能的目的。
由于系统设计时的某些考虑，该测试工具被分作客户端和服务端两个程序来实现，且采用socket进行通讯。现在想来，其实不如整合成一个程序实现更为简单——但也正因为采用两个程序来实现，才引发了后面的一些问题，并由此引入了简单的垃圾回收框架。
1.2 问题
在测试工具的使用过程中，我们发现当呼叫量巨大，且测试工具动作频繁的情况下，系统出现以下错误：
n 访问地址错(EAccessViolation)，代码地址位于$0046FC80附近，访问地址多为$00000028。
n 出现EinvalidCast错误，该错误表明对一个地址进行类类型转换时出错（采用as关键字）。
n 程序内多处断言失败，出现许多引用已销毁对象的情况。
仔细检查程序后，我仍然认为这一切简直是不可思议！而且，本来用于对别的程序进行测试的程序自身却出现这类问题，几乎让我无地自容！
为了挽回自己的声誉，我不得不成沉住气来仔细跟踪错误，排解问题！
2 解决办法
2.1 查错
其实问题的解决还比较顺利。
通过查看程序的调用栈，发现程序出错前总是停留在发送Socket数据包的过程里。接着，进一步通过单步跟踪，发现在发送数据包的过程中，Socket检测到对端连接已经断开，就会触发OnDisconnect事件。而我正是在ServerSocket的OnDisconnect事件中根据传递进来的Socket句柄，找到对应的对象将之销毁的。
我在ServerSocket的OnDisconnect事件中的代码如下：
procedure Txxxx.ServerClientDisconnect(Sender: TObject; Socket: TCustomWinSocket); Begin…FLines.DestroyLineBySocket(Socket);//正是这一句，在不合适的时机释放了对象…End;
问题是这么出现的。
比如，在某个过程中具有如下代码（前面为行号）：
1 FLine.DoSomething；
2 FLine.SendSocketData；
3 FLine.DoOtherThings；
其中，FLine是代表一路呼叫的对象。该对象内部引用了一个TCustomWinSocket指针。SendSocketData就是利用此Socket进行数据发送。
Flines是TLine对象的容器类的一个实例。
由此不难解读前述的各类错误：
1． 由于行2的Socket连接断开导致FLine对象释放，因此行3访问DoOtherThings几乎必然造成访问地址错；
2． 由于行2的对象销毁，因此程序中类似“Object as TLine”的代码导致第二类错误；
3． 由于对象提前销毁，善后处理工作未到位导致第三类错误；
2.2 解决方案
明白其原因后，问题解决起来就容易多了。
上述问题不外乎两个方案：
一， 判断实例是否存在
在DoOtherThings之后，判断FLine对象是否仍然处于Flines之中，若是则继续处理，否则结束处理；
二， 延迟销毁FLine对象
在ServerSocket的OnDisconnect中，将FLine对象抛入垃圾池，待时机成熟时再销毁。
考虑到方案一所要改动的代码量较大，同时，此种方案代码也不甚优美，因此决定采用方案二，即引入垃圾回收机制来解决问题。方案二的要点是选择合适的时机真正销毁对象。而对于这一点，问题倒不大，只需选择消息循环中处理消息的第一个环节进行回收即可。因为在之后的处理环节中，必然能够确保对FLine是否仍然有效的检查。
3 简易对象垃圾回收框架（untGarbagCollector）
3.1 概述
简易的垃圾回收非常简单：
n 使用TThreadList支持线程并发访问，并保存待回收的对象指针；
n 提供Put方法保存待回收对象；
n 提供Recycle方法进行真正的回收（因为所有对象均自TObject派生而来）。
3.2 实现代码
unit untGarbagCollector;interfaceusesClasses;typeTGarbagCollector = Class(TObject)privateFList: TThreadList;publicconstructor Create;destructor Destroy; override;procedure Put(const AObject: TObject);procedure Recycle(const MaxCount: Integer);end;function GarbagCollector: TGarbagCollector;implementationvar_GarbagCollector: TGarbagCollector;function GarbagCollector: TGarbagCollector;beginif not Assigned(_GarbagCollector) then_GarbagCollector := TGarbagCollector.Create;result := _GarbagCollector;end;{ TGarbagCollect }constructor TGarbagCollector.Create;beginFList := TThreadList.Create;end;destructor TGarbagCollector.Destroy;begintryRecycle(FList.LockList.Count);finallyFList.UnlockList;end;FList.Free;end;procedure TGarbagCollector.Put(const AObject: TObject);begintryFList.LockList.Add(AObject);finallyFList.UnlockList;end;end;procedure TGarbagCollector.Recycle(const MaxCount: Integer);varI: Integer;AList: TList;beginAList := FList.LockList;tryI := 0;while (AList.Count > 0) and (I < MaxCount) dobeginTObject(AList.Last).Free;AList.Delete(AList.Count - 1);Inc(I);end;finallyFList.UnlockList;end;end;initializationfinalizationif Assigned(_GarbagCollector) then_GarbagCollector.Free;end.
3.3 使用举例
引用untGarbagCollector单元后，可以直接使用GarbagCollector进行对象的销毁和回收。
n 销毁
AObject := TObject.Create;
GarbagCollector.Put(AObject);
n 回收
可以在定时器、线程以及其他场合调用Recycle方法。
MaxCount是用于控制每次销毁个数的参数，主要是怕一次性销毁太多占用过多的cpu。
（突然发现还可以扩展为限制时间进行销毁，比如每次销毁耗时不超过的n毫秒）。
3.4 使用场合
在本案例中，为了防止对象过早销毁引起访问冲突，而引入了垃圾回收技术。
在其它场合，比如为了提高某些程序的主观性能，也可以引入该技术。比如完成某些特定任务的程序，在处理过程中会产生临时的对象，而销毁这些对象又比较耗时。因此，为了尽早地结束任务，可以把这些临时对象保存至垃圾池中。待作业（任务）完成，并且等一段时间后cpu比较空闲时，再把临时对象真正销毁。此做法的真谛就是以空间换取时间——与某些系统预创建对象，并重复利用对象以提高性能的做法相同。
2008年8月31日星期日
delphi常用网络函数
{=========================================================================
功 能: 网络函数库
时 间: 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 := TNetResourceArra
{=================================================================
功 能: 映射网络驱动器
参 数:
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;
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.
功 能: 网络函数库
时 间: 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 := TNetResourceArra
{=================================================================
功 能: 映射网络驱动器
参 数:
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;
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.
通过字符串传递控件名
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, 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
var
cbx: TCheckBox;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
cbx:=TCheckBox.Create(Self);
cbx.Name := 'ww';
cbx.Caption := 'aaaaaaaaaa';
cbx.Parent := self;
cbx.Left :=100;
cbx.Top :=200;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TCheckBox(FindComponent('ww')).Caption := 'playclickme';
end;
end.
interface
uses
Windows, Messages, SysUtils, Variants, 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
var
cbx: TCheckBox;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
cbx:=TCheckBox.Create(Self);
cbx.Name := 'ww';
cbx.Caption := 'aaaaaaaaaa';
cbx.Parent := self;
cbx.Left :=100;
cbx.Top :=200;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TCheckBox(FindComponent('ww')).Caption := 'playclickme';
end;
end.
2008年8月29日星期五
delphi write text
procedure tform1.NewTxt(filename:string);
begin
if fileExists(FileName) then DeleteFile(FileName); {看文件是否存在,在就刪除}
AssignFile(Input, FileName);
ReWrite(Input);
Writeln( '将您要写入的文本写入到一个 .txt 文件');
Closefile(Input); {关闭文件}
end;
begin
if fileExists(FileName) then DeleteFile(FileName); {看文件是否存在,在就刪除}
AssignFile(Input, FileName);
ReWrite(Input);
Writeln( '将您要写入的文本写入到一个 .txt 文件');
Closefile(Input); {关闭文件}
end;
2008年8月27日星期三
GDI+ 在Delphi的应用 -- Photoshop浮雕效果
实现图像浮雕效果的一般原理是，将图像上每个像素点与其对角线的像素点形成差值，使相似颜色值淡化，不同颜色值突出，从而产生纵深感，达到浮雕的效果，具体的做法是用处于对角线的2个像素值相减，再加上一个背景常数，一般为128而成。这种算法的特点是简单快捷，缺点是不能调节图像浮雕效果的角度和深度。
用Photoshop实现图像浮雕效果，可以任意调节浮雕角度和深度（2个像素点的距离），还可以调整浮雕像素差值的数量。其基本算法原理和一般浮雕效果相同，但是具体做法不一样：对每个要处理的像素点，首先按照浮雕角度和深度计算处2个相应点的位置，然后计算这2个位置的颜色值，并使之形成差值，再乘上浮雕差值数量百分比，最后加上128的背景色。注意，这里计算的2个相应点是逻辑点，而不是实际的像素点，比如实现一个45度角，深度为3的图像浮雕效果，对每个像素点P(x, y)，其对应的2个逻辑点的位置分别是P0(x - 3 * 0.7071 / 2, y - 3 * 0.7071 / 2)和P1(x + 3 * 0.7071 / 2, y + 3 * 0.7071 / 2)，显然，对于这样的2个逻辑点，是不能直接从图像中找到其对应的像素点的，如果简单地对其四舍五入处理，将会造成大量的，由不同角度和深度而形成的相同的浮雕效果，这可不是我们想要的结果，而且使浮雕角度和深度参数失去了它原本的意义。为此，必须对原始图像按浮雕角度和深度进行缩放后，再对每个像素点进行浮雕效果处理，完毕再缩放回原图的大小，从而完成整个浮雕效果过程。下面是我经过反复试验后，写的Photoshop浮雕效果实现过程代码：
数据类型：
type
// 与GDI+ TBitmapData结构兼容的图像数据结构
TImageData = packed record
Width: LongWord; // 图像宽度
Height: LongWord; // 图像高度
Stride: LongWord; // 图像扫描线字节长度
PixelFormat: LongWord; // 未使用
Scan0: Pointer; // 图像数据地址
Reserved: LongWord; // 保留
end;
PImageData = ^TImageData;
// 获取TBitmap图像的TImageData数据结构，便于处理TBitmap图像
function GetImageData(Bmp: TBitmap): TImageData;
begin
Bmp.PixelFormat := pf32bit;
Result.Width := Bmp.Width;
Result.Height := Bmp.Height;
Result.Scan0 := Bmp.ScanLine[Bmp.Height - 1];
Result.Stride := Result.Width shl 2;
// Result.Stride := (((32 * Bmp.Width) + 31) and $ffffffe0) shr 3;
end;
过程代码：
// 获取二次线性插值颜色
function GetBoundColor(x, y: Integer; Source: TImageData): LongWord;
asm
push ebx
push edx
xor ebx, ebx // flag = 0
test eax, eax
jns @@1
xor eax, eax // if (x < 0)
or ebx, 1 // {x = 0; flag = 1}
jmp @@2
@@1:
cmp eax, [ecx]
jl @@2
mov eax, [ecx] // else if (x >= Source.Width)
dec eax // {x = Source.Width.Width - 1; flag = 1}
or ebx, 1
@@2:
test edx, edx
jns @@3
xor edx, edx // if (y < 0)
or ebx, 1 // {y = 0; flag = 1}
jmp @@5
@@3:
cmp edx, [ecx + 4]
jl @@5
mov edx, [ecx + 4] // else if (y >= Source.Height)
dec edx // {y = Source.Width.Height - 1; flag = 1}
or ebx, 1
@@5:
shl eax, 2 // ARGBColor = *(ARGB*)(Source.Scan0 +
imul edx, [ecx + 8] // y * Source.Stride + x * 4)
add edx, eax
mov eax, [ecx + 16]
add eax, edx
mov eax, [eax]
test ebx, 1
jz @@6 // if (flag = 1)
and eax, 0ffffffh // ARGBColor.a = 0
@@6:
pop edx
pop ebx
end;
function GetBilinearColor(x, y: Integer; Source: TImageData): LongWord;
var
colors: array[0..4] of LongWord;
m0, m1, m2, m3: LongWord;
asm
push ebx
mov ebx, eax
sar eax, 16
push eax // x0 = x >> 16
and ebx, 0ffffh
shr ebx, 8 // u = (x & 0xffff) >> 8
mov eax, edx
sar eax, 16
push eax // y0 = y >> 16
and edx, 0ffffh
shr edx, 8 // v = (y & 0xffff) >> 8
mov eax, edx
imul eax, ebx
mov m3, eax // m3 = v * u
mov eax, 255
sub eax, edx
push eax
imul eax, ebx
mov m2, eax // m2 = (255 - v) * u
neg ebx
add ebx, 255
imul edx, ebx
mov m1, edx // m1 = v * (255 - u)
pop eax
imul ebx
mov m0, eax // m0 = (255 - v) * (255 - u)
lea ebx, colors
pop edx
pop eax
push eax
push eax
push eax
call GetBoundColor
mov [ebx], eax // Colors[0] = GetColor(x0, y0)
pop eax
inc eax
call GetBoundColor
mov [ebx + 8], eax // Colors[2] = GetColor(x0 + 1, y0)
pop eax
inc edx
call GetBoundColor
mov [ebx + 4], eax // Colors[1] = GetColor(x0, y0 + 1)
pop eax
inc eax
call GetBoundColor
mov [ebx + 12], eax // Colors[3] = GetColor(x0 + 1, y0 + 1)
mov [ebx + 16], 0
mov ecx, 4
@CalcColor:
movzx eax, [ebx] // a(rgb) = (Colors[0].a(rgb) * m0 +
movzx edx, [ebx + 4] // Colors[1].a(rgb) * m1 +
imul eax, m0 // Colors[2].a(rgb) * m2 +
imul edx, m1 // Colors[3].a(rgb) * m3) >> 16
add edx, eax
movzx eax, [ebx + 8]
imul eax, m2
add edx, eax
movzx eax, [ebx + 12]
imul eax, m3
add eax, edx
shr eax, 16
add [ebx + 16], al
inc ebx
loop @CalcColor
mov eax, [ebx + 12] // return ARGBColor
pop ebx
end;
// Photoshop浮雕。参数：Data: 图像数据, Angle: 角度, Size: 长度, Num: 数量
procedure PSSculpture(Data: TImageData; Angle: Single;
Size: LongWord; Num: LongWord = 100);
var
x, y: Integer;
Width, Height: Integer;
xDelta, yDelta: Integer;
P: PRGBQuad;
P0, P1: TRGBQuad;
Buf: Pointer;
Src: TImageData;
begin
if Size = 0 then
raise Exception.Create('Sculpture can not be size 0');
Angle := PI * Angle / 180;
Size := Size shl 16;
if Num > 500 then Num := 500;
xDelta := Round((Cos(Angle) * Size) / 2);
yDelta := Round((Sin(Angle) * Size) / 2);
Width := Data.Width shl 16;
Height := Data.Height shl 16;
GetMem(Buf, Data.Height * Data.Stride);
try
Move(Data.Scan0^, Buf^, Data.Height * Data.Stride);
Move(Data, Src, Sizeof(TImageData));
Src.Scan0 := Buf;
P := Data.Scan0;
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
P0 := TRGBQuad(GetBilinearColor(x - xDelta, y - yDelta, Src));
P1 := TRGBQuad(GetBilinearColor(x + xDelta, y + yDelta, Src));
P^.rgbBlue := Max(0, Min(255, Num * (P0.rgbBlue - P1.rgbBlue) div 100 + 128));
P^.rgbGreen := Max(0, Min(255, Num * (P0.rgbGreen - P1.rgbGreen) div 100 + 128));
P^.rgbRed := Max(0, Min(255, Num * (P0.rgbRed - P1.rgbRed) div 100 + 128));
Inc(P);
Inc(x, $10000);
end;
Inc(y, $10000);
end;
finally
FreeMem(Buf);
end;
end;
// Photoshop浮雕。参数：Bmp: GDI+图像, Angle: 角度, Size: 长度, Num: 数量
procedure GdipPSSculpture(Bmp: TGpBitmap; Angle: Single;
Size: LongWord; Num: LongWord = 100);
var
Data: TBitmapData;
begin
Data := Bmp.LockBits(GpRect(0, 0, Bmp.Width, Bmp.Height), [imRead, imWrite], pf32bppARGB);
try
PSSculpture(TImageData(Data), Angle, Size, Num);
finally
Bmp.UnlockBits(Data);
end;
end;
// Photoshop浮雕。参数：Bmp: Bitmap图像, Angle: 角度, Size: 长度, Num: 数量
procedure BitmapPSSculpture(Bmp: TBitmap; Angle: Single;
Size: LongWord; Num: LongWord = 100);
begin
PSSculpture(GetImageData(Bmp), 360 - Angle, Size, Num);
end;
以上代码即可用GDI+实现图像浮雕效果，也可直接用Delphi的TBitmap实现图像浮雕效果，因为TBitmap图像地址GDI+的图像地址排列不一样，为了保证2者处理的效果完全一样，所以用360 - 原角度参数。本代码中浮雕角度参数与Phoposhop是不相同的，Photoshop是以右边为0度，逆时钟调整角度，而本代码是以左边为0度，顺时钟方向调整角度。
在上述代码中，并没有将原始图像进行实际的缩放，而是直接在原始图像数据地址上，通过二次线性插值法找到并计算出2个逻辑点的颜色值而形成差值的。其中的GetBilinearColor过程是以前就写好的定点数二次线性插值缩放过程中部分代码，浮雕效果实现过程中，没有用到其中的Alpha，所以，有关Alpha处理的语句完全可以去掉。
下面是一个用GDI+实现图像浮雕效果的测试程序代码：
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Gdiplus;
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
Button1: TButton;
Button2: TButton;
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
FBmp: TGpBitmap;
FSource: TGpBitmap;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Math, BitmapUtils, GpBmpUtils;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Angle: Single;
Size: LongWord;
Num: LongWord;
begin
if Assigned(FBmp) then
FBmp.Free;
FBmp := FSource.Clone(GpRect(0, 0, FSource.Width, FSource.Height), pf32bppARGB);
Angle := StrToFloat(Edit1.Text);
Size := StrToInt(Edit2.Text);
Num := StrToInt(Edit3.Text);
GdipPSSculpture(FBmp, Angle, Size, Num);
PaintBox1.Invalidate;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if (Key >= #32) and not (Key in ['0'..'9']) then
Key := #0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FSource := TGpBitmap.Create('D:\VclLib\GdiplusDemo\Media\20041001.jpg');
DoubleBuffered := True;
Button1.Click;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FSource.Free;
FBmp.Free;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGpGraphics;
begin
g := TGpGraphics.Create(PaintBox1.Canvas.Handle);
try
g.DrawImage(FSource, 0, 0);
g.TranslateTransform(0, FSource.Height);
g.DrawImage(FBmp, 0, 0);
finally
g.Free;
end;
end;
end.
和Photoshop浮雕效果对比，基本一致，说明我对其算法实现了完全“破解”，虽然这个算法不是很难，但也费了我不少时间。
代码中所用Gdiplus单元下载地址及BUG更正见文章《GDI+ for VCL基础 -- GDI+ 与 VCL》。建议和指导请来信：maozefa@hotmail.com
注：本文代码中有关定点处理二次线性插值的代码，参照了好友HouSisong的《图形图像处理－之－高质量的快速的图像缩放 中篇 二次线性插值和三次卷积插值》一文，在此表示感谢。
用Photoshop实现图像浮雕效果，可以任意调节浮雕角度和深度（2个像素点的距离），还可以调整浮雕像素差值的数量。其基本算法原理和一般浮雕效果相同，但是具体做法不一样：对每个要处理的像素点，首先按照浮雕角度和深度计算处2个相应点的位置，然后计算这2个位置的颜色值，并使之形成差值，再乘上浮雕差值数量百分比，最后加上128的背景色。注意，这里计算的2个相应点是逻辑点，而不是实际的像素点，比如实现一个45度角，深度为3的图像浮雕效果，对每个像素点P(x, y)，其对应的2个逻辑点的位置分别是P0(x - 3 * 0.7071 / 2, y - 3 * 0.7071 / 2)和P1(x + 3 * 0.7071 / 2, y + 3 * 0.7071 / 2)，显然，对于这样的2个逻辑点，是不能直接从图像中找到其对应的像素点的，如果简单地对其四舍五入处理，将会造成大量的，由不同角度和深度而形成的相同的浮雕效果，这可不是我们想要的结果，而且使浮雕角度和深度参数失去了它原本的意义。为此，必须对原始图像按浮雕角度和深度进行缩放后，再对每个像素点进行浮雕效果处理，完毕再缩放回原图的大小，从而完成整个浮雕效果过程。下面是我经过反复试验后，写的Photoshop浮雕效果实现过程代码：
数据类型：
type
// 与GDI+ TBitmapData结构兼容的图像数据结构
TImageData = packed record
Width: LongWord; // 图像宽度
Height: LongWord; // 图像高度
Stride: LongWord; // 图像扫描线字节长度
PixelFormat: LongWord; // 未使用
Scan0: Pointer; // 图像数据地址
Reserved: LongWord; // 保留
end;
PImageData = ^TImageData;
// 获取TBitmap图像的TImageData数据结构，便于处理TBitmap图像
function GetImageData(Bmp: TBitmap): TImageData;
begin
Bmp.PixelFormat := pf32bit;
Result.Width := Bmp.Width;
Result.Height := Bmp.Height;
Result.Scan0 := Bmp.ScanLine[Bmp.Height - 1];
Result.Stride := Result.Width shl 2;
// Result.Stride := (((32 * Bmp.Width) + 31) and $ffffffe0) shr 3;
end;
过程代码：
// 获取二次线性插值颜色
function GetBoundColor(x, y: Integer; Source: TImageData): LongWord;
asm
push ebx
push edx
xor ebx, ebx // flag = 0
test eax, eax
jns @@1
xor eax, eax // if (x < 0)
or ebx, 1 // {x = 0; flag = 1}
jmp @@2
@@1:
cmp eax, [ecx]
jl @@2
mov eax, [ecx] // else if (x >= Source.Width)
dec eax // {x = Source.Width.Width - 1; flag = 1}
or ebx, 1
@@2:
test edx, edx
jns @@3
xor edx, edx // if (y < 0)
or ebx, 1 // {y = 0; flag = 1}
jmp @@5
@@3:
cmp edx, [ecx + 4]
jl @@5
mov edx, [ecx + 4] // else if (y >= Source.Height)
dec edx // {y = Source.Width.Height - 1; flag = 1}
or ebx, 1
@@5:
shl eax, 2 // ARGBColor = *(ARGB*)(Source.Scan0 +
imul edx, [ecx + 8] // y * Source.Stride + x * 4)
add edx, eax
mov eax, [ecx + 16]
add eax, edx
mov eax, [eax]
test ebx, 1
jz @@6 // if (flag = 1)
and eax, 0ffffffh // ARGBColor.a = 0
@@6:
pop edx
pop ebx
end;
function GetBilinearColor(x, y: Integer; Source: TImageData): LongWord;
var
colors: array[0..4] of LongWord;
m0, m1, m2, m3: LongWord;
asm
push ebx
mov ebx, eax
sar eax, 16
push eax // x0 = x >> 16
and ebx, 0ffffh
shr ebx, 8 // u = (x & 0xffff) >> 8
mov eax, edx
sar eax, 16
push eax // y0 = y >> 16
and edx, 0ffffh
shr edx, 8 // v = (y & 0xffff) >> 8
mov eax, edx
imul eax, ebx
mov m3, eax // m3 = v * u
mov eax, 255
sub eax, edx
push eax
imul eax, ebx
mov m2, eax // m2 = (255 - v) * u
neg ebx
add ebx, 255
imul edx, ebx
mov m1, edx // m1 = v * (255 - u)
pop eax
imul ebx
mov m0, eax // m0 = (255 - v) * (255 - u)
lea ebx, colors
pop edx
pop eax
push eax
push eax
push eax
call GetBoundColor
mov [ebx], eax // Colors[0] = GetColor(x0, y0)
pop eax
inc eax
call GetBoundColor
mov [ebx + 8], eax // Colors[2] = GetColor(x0 + 1, y0)
pop eax
inc edx
call GetBoundColor
mov [ebx + 4], eax // Colors[1] = GetColor(x0, y0 + 1)
pop eax
inc eax
call GetBoundColor
mov [ebx + 12], eax // Colors[3] = GetColor(x0 + 1, y0 + 1)
mov [ebx + 16], 0
mov ecx, 4
@CalcColor:
movzx eax, [ebx] // a(rgb) = (Colors[0].a(rgb) * m0 +
movzx edx, [ebx + 4] // Colors[1].a(rgb) * m1 +
imul eax, m0 // Colors[2].a(rgb) * m2 +
imul edx, m1 // Colors[3].a(rgb) * m3) >> 16
add edx, eax
movzx eax, [ebx + 8]
imul eax, m2
add edx, eax
movzx eax, [ebx + 12]
imul eax, m3
add eax, edx
shr eax, 16
add [ebx + 16], al
inc ebx
loop @CalcColor
mov eax, [ebx + 12] // return ARGBColor
pop ebx
end;
// Photoshop浮雕。参数：Data: 图像数据, Angle: 角度, Size: 长度, Num: 数量
procedure PSSculpture(Data: TImageData; Angle: Single;
Size: LongWord; Num: LongWord = 100);
var
x, y: Integer;
Width, Height: Integer;
xDelta, yDelta: Integer;
P: PRGBQuad;
P0, P1: TRGBQuad;
Buf: Pointer;
Src: TImageData;
begin
if Size = 0 then
raise Exception.Create('Sculpture can not be size 0');
Angle := PI * Angle / 180;
Size := Size shl 16;
if Num > 500 then Num := 500;
xDelta := Round((Cos(Angle) * Size) / 2);
yDelta := Round((Sin(Angle) * Size) / 2);
Width := Data.Width shl 16;
Height := Data.Height shl 16;
GetMem(Buf, Data.Height * Data.Stride);
try
Move(Data.Scan0^, Buf^, Data.Height * Data.Stride);
Move(Data, Src, Sizeof(TImageData));
Src.Scan0 := Buf;
P := Data.Scan0;
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
P0 := TRGBQuad(GetBilinearColor(x - xDelta, y - yDelta, Src));
P1 := TRGBQuad(GetBilinearColor(x + xDelta, y + yDelta, Src));
P^.rgbBlue := Max(0, Min(255, Num * (P0.rgbBlue - P1.rgbBlue) div 100 + 128));
P^.rgbGreen := Max(0, Min(255, Num * (P0.rgbGreen - P1.rgbGreen) div 100 + 128));
P^.rgbRed := Max(0, Min(255, Num * (P0.rgbRed - P1.rgbRed) div 100 + 128));
Inc(P);
Inc(x, $10000);
end;
Inc(y, $10000);
end;
finally
FreeMem(Buf);
end;
end;
// Photoshop浮雕。参数：Bmp: GDI+图像, Angle: 角度, Size: 长度, Num: 数量
procedure GdipPSSculpture(Bmp: TGpBitmap; Angle: Single;
Size: LongWord; Num: LongWord = 100);
var
Data: TBitmapData;
begin
Data := Bmp.LockBits(GpRect(0, 0, Bmp.Width, Bmp.Height), [imRead, imWrite], pf32bppARGB);
try
PSSculpture(TImageData(Data), Angle, Size, Num);
finally
Bmp.UnlockBits(Data);
end;
end;
// Photoshop浮雕。参数：Bmp: Bitmap图像, Angle: 角度, Size: 长度, Num: 数量
procedure BitmapPSSculpture(Bmp: TBitmap; Angle: Single;
Size: LongWord; Num: LongWord = 100);
begin
PSSculpture(GetImageData(Bmp), 360 - Angle, Size, Num);
end;
以上代码即可用GDI+实现图像浮雕效果，也可直接用Delphi的TBitmap实现图像浮雕效果，因为TBitmap图像地址GDI+的图像地址排列不一样，为了保证2者处理的效果完全一样，所以用360 - 原角度参数。本代码中浮雕角度参数与Phoposhop是不相同的，Photoshop是以右边为0度，逆时钟调整角度，而本代码是以左边为0度，顺时钟方向调整角度。
在上述代码中，并没有将原始图像进行实际的缩放，而是直接在原始图像数据地址上，通过二次线性插值法找到并计算出2个逻辑点的颜色值而形成差值的。其中的GetBilinearColor过程是以前就写好的定点数二次线性插值缩放过程中部分代码，浮雕效果实现过程中，没有用到其中的Alpha，所以，有关Alpha处理的语句完全可以去掉。
下面是一个用GDI+实现图像浮雕效果的测试程序代码：
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Gdiplus;
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
Button1: TButton;
Button2: TButton;
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
FBmp: TGpBitmap;
FSource: TGpBitmap;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Math, BitmapUtils, GpBmpUtils;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Angle: Single;
Size: LongWord;
Num: LongWord;
begin
if Assigned(FBmp) then
FBmp.Free;
FBmp := FSource.Clone(GpRect(0, 0, FSource.Width, FSource.Height), pf32bppARGB);
Angle := StrToFloat(Edit1.Text);
Size := StrToInt(Edit2.Text);
Num := StrToInt(Edit3.Text);
GdipPSSculpture(FBmp, Angle, Size, Num);
PaintBox1.Invalidate;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if (Key >= #32) and not (Key in ['0'..'9']) then
Key := #0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FSource := TGpBitmap.Create('D:\VclLib\GdiplusDemo\Media\20041001.jpg');
DoubleBuffered := True;
Button1.Click;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FSource.Free;
FBmp.Free;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
g: TGpGraphics;
begin
g := TGpGraphics.Create(PaintBox1.Canvas.Handle);
try
g.DrawImage(FSource, 0, 0);
g.TranslateTransform(0, FSource.Height);
g.DrawImage(FBmp, 0, 0);
finally
g.Free;
end;
end;
end.
和Photoshop浮雕效果对比，基本一致，说明我对其算法实现了完全“破解”，虽然这个算法不是很难，但也费了我不少时间。
代码中所用Gdiplus单元下载地址及BUG更正见文章《GDI+ for VCL基础 -- GDI+ 与 VCL》。建议和指导请来信：maozefa@hotmail.com
注：本文代码中有关定点处理二次线性插值的代码，参照了好友HouSisong的《图形图像处理－之－高质量的快速的图像缩放 中篇 二次线性插值和三次卷积插值》一文，在此表示感谢。
delphi webbrowser中拦截弹出窗口
// Set OnNewWindow Event
FBrowser.OnNewWindow2 := OnIENewWindow;
procedure TfrmBizMain.OnIENewWindow(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
var
FBrowser: TIEBrowser;
begin
if ASender is TIEBrowser then
begin
Cancel := not actNewTab.Execute; // Create A New WebBrowser
if not Cancel then
begin
FBrowser := GetBrowser;// Get The Browser just Created
if Assigned(FBrowser) then
ppDisp := FBrowser.Application;
end;
end;
end;
FBrowser.OnNewWindow2 := OnIENewWindow;
procedure TfrmBizMain.OnIENewWindow(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
var
FBrowser: TIEBrowser;
begin
if ASender is TIEBrowser then
begin
Cancel := not actNewTab.Execute; // Create A New WebBrowser
if not Cancel then
begin
FBrowser := GetBrowser;// Get The Browser just Created
if Assigned(FBrowser) then
ppDisp := FBrowser.Application;
end;
end;
end;
2008年8月23日星期六
delphi's sendmessage
Windows系统是由消息机制驱动的，每个线程如果建立了一个窗口，则由系统分配一个消息队列用于窗口消息的处理。另外，消息也可以不经过消息队列而利用SendMessage函数直接发送给窗口，窗口过程将处理这个消息，但只有当消息被处理之后，SendMessage才能返回到调用程序。下面结合两个Delphi程序，讨论如何利用SendMessage向控件发送消息和控件对这种消息的响应。
用SendMessage向控件发送消息
在编程中，有时需要控件以特殊的风格显示，而这种要求又无法通过设置控件属性实现。例如，读取客户列表并显示在下拉框供用户选择，如果下拉框宽度太窄，则不能全部显示；如果将宽度定得太宽，界面又有不紧凑之感。因此希望能在运行期动态地确定下拉框显示区域的宽度，这种要求如果不用SendMessage函数就很难实现。
解决办法是，在读数据库时计算字符串的显示宽度，用显示宽度的最大值确定下拉框显示区域的宽度。再用SendMessage函数向下拉框发送CB_SETDROPPEDWIDTH消息和宽度值，下拉框根据消息中传来的信息，就可以进行正确显示。
部分源程序代码如下：
i:=0; //计数
MaxWidth:=0;
Query1.SQL.Clear;
Query1.SQL.Add(‘select Company from Customer’);
Query1.Open;
//读客户列表到下拉框
while not Query1.Eof do begin
ComboBox1.Items.add(Query1.FieldByName
(‘Company’).AsString);
Width:=ComboBox1.Font.Size ＊ Length
(ComboBox1.Items[i]);
if Width>MaxWidth then
MaxWidth:=Width; //找出最大值
Query1.Next;
i:=i＋1;
end;
Query1.Close;
ComboBox1.Text:=ComboBox1.Items[0];
//发送消息以确定显示区域的宽度
SendMessage(ComboBox1.Handle,
CB_SETDROPPEDWIDTH,MaxWidth,0);
利用SendMessage函数还可以实现一些有趣的效果，例如在按钮的Click事件中加入如下语句：
SendMessage(Button.Handle,BM_SETSTYLE,
BS_RADIOBUTTON,1);
运行后点击按钮，就可以把按钮变成一个收音机按钮。
控件接收SendMessage消息
上面讨论了用SendMessage向控件发送消息的过程。但凡事有利就有弊，用SendMessage发送的消息在处理上存在着一定困难。因为该消息不经过消息队列，所以无法用OnMessage方式来指定对消息的响应，甚至用HookMainWindow也不行，因为消息直接发送到控件，绕过了主窗体。要对这种类型的消息作出响应，需要重载控件的WndProc方法。
例如，对于一个列表框，滚动条的滚动消息就是用SendMessage方式发送的，因此该消息不在TlistBox的事件列表中。下面是处理控件响应该滚动消息的具体步骤。
1.首先从TlistBox继承一个TmyListBox类，并重载WndProc方法。在程序中加入下列定义：
type
TMyListBox=class(TListBox)
private
procedure WndProc(var Msg: TMessage);
override;
//重载WndProc，处理发送到控件的消息
public
end;
其中WndProc方法指定控件对消息的响应，输入参数是TMessage类型，该数据类型是一个记录，包含了消息代码和消息的参数，消息参数可以用Longint或Word方式获得。
2.对滚动事件做出响应，在WndProc方法中加入如下处理代码：
if (Msg.Msg=WM_VSCROLL) and
(Msg.WParamLo=SB_ENDSCROLL) then
begin
//获得鼠标位置对应的列
ItemIndex:=ItemAtPos(Point,true);
Form1.Edit1.Text:=inttostr(ItemIndex);
inherited;
end
else
inherited;
当程序接收到WM_VSCROLL消息，且WParamLo参数为SB_ENDSCROLL时，表示竖直滚动条停止滚动，就可以用ItemAtPos方法确定与鼠标位置对应的ItemIndex。ItemAtPos方法的Point参数是一个TPoint类型的变量，用来保存鼠标的位置。
3.定义方法ListBoxMouseMove，在鼠标移动时，将当前位置保存在Point中：
procedure TForm1.ListBoxMouseMove(Sender:
TObject; Shift: TShiftState; X,Y: Integer);
begin
Point.X:=X;
Point.Y:=Y;
end;
4.在运行期创建和初始化列表框，并指定列表框的MouseMove事件对应上一步定义的ListBoxMouseMove方法。在主窗体的Create事件中输入下面的代码：begin
Point.X:=0;
Point.Y:=0;
//创建自定义列表框
List:=TMyListBox.Create(Form1);
List.Parent:=Form1;
List.Left:=5;
List.Top:=30;
List.Width:=150;
List.Height:=200;
for i:=0 to 300 do
begin
List.Items.Add(inttostr(i)); //初始化
end;
//指定处理MouseMove事件的方法
List.OnMouseMove := ListBoxMouseMove;
end;
用SendMessage向控件发送消息
在编程中，有时需要控件以特殊的风格显示，而这种要求又无法通过设置控件属性实现。例如，读取客户列表并显示在下拉框供用户选择，如果下拉框宽度太窄，则不能全部显示；如果将宽度定得太宽，界面又有不紧凑之感。因此希望能在运行期动态地确定下拉框显示区域的宽度，这种要求如果不用SendMessage函数就很难实现。
解决办法是，在读数据库时计算字符串的显示宽度，用显示宽度的最大值确定下拉框显示区域的宽度。再用SendMessage函数向下拉框发送CB_SETDROPPEDWIDTH消息和宽度值，下拉框根据消息中传来的信息，就可以进行正确显示。
部分源程序代码如下：
i:=0; //计数
MaxWidth:=0;
Query1.SQL.Clear;
Query1.SQL.Add(‘select Company from Customer’);
Query1.Open;
//读客户列表到下拉框
while not Query1.Eof do begin
ComboBox1.Items.add(Query1.FieldByName
(‘Company’).AsString);
Width:=ComboBox1.Font.Size ＊ Length
(ComboBox1.Items[i]);
if Width>MaxWidth then
MaxWidth:=Width; //找出最大值
Query1.Next;
i:=i＋1;
end;
Query1.Close;
ComboBox1.Text:=ComboBox1.Items[0];
//发送消息以确定显示区域的宽度
SendMessage(ComboBox1.Handle,
CB_SETDROPPEDWIDTH,MaxWidth,0);
利用SendMessage函数还可以实现一些有趣的效果，例如在按钮的Click事件中加入如下语句：
SendMessage(Button.Handle,BM_SETSTYLE,
BS_RADIOBUTTON,1);
运行后点击按钮，就可以把按钮变成一个收音机按钮。
控件接收SendMessage消息
上面讨论了用SendMessage向控件发送消息的过程。但凡事有利就有弊，用SendMessage发送的消息在处理上存在着一定困难。因为该消息不经过消息队列，所以无法用OnMessage方式来指定对消息的响应，甚至用HookMainWindow也不行，因为消息直接发送到控件，绕过了主窗体。要对这种类型的消息作出响应，需要重载控件的WndProc方法。
例如，对于一个列表框，滚动条的滚动消息就是用SendMessage方式发送的，因此该消息不在TlistBox的事件列表中。下面是处理控件响应该滚动消息的具体步骤。
1.首先从TlistBox继承一个TmyListBox类，并重载WndProc方法。在程序中加入下列定义：
type
TMyListBox=class(TListBox)
private
procedure WndProc(var Msg: TMessage);
override;
//重载WndProc，处理发送到控件的消息
public
end;
其中WndProc方法指定控件对消息的响应，输入参数是TMessage类型，该数据类型是一个记录，包含了消息代码和消息的参数，消息参数可以用Longint或Word方式获得。
2.对滚动事件做出响应，在WndProc方法中加入如下处理代码：
if (Msg.Msg=WM_VSCROLL) and
(Msg.WParamLo=SB_ENDSCROLL) then
begin
//获得鼠标位置对应的列
ItemIndex:=ItemAtPos(Point,true);
Form1.Edit1.Text:=inttostr(ItemIndex);
inherited;
end
else
inherited;
当程序接收到WM_VSCROLL消息，且WParamLo参数为SB_ENDSCROLL时，表示竖直滚动条停止滚动，就可以用ItemAtPos方法确定与鼠标位置对应的ItemIndex。ItemAtPos方法的Point参数是一个TPoint类型的变量，用来保存鼠标的位置。
3.定义方法ListBoxMouseMove，在鼠标移动时，将当前位置保存在Point中：
procedure TForm1.ListBoxMouseMove(Sender:
TObject; Shift: TShiftState; X,Y: Integer);
begin
Point.X:=X;
Point.Y:=Y;
end;
4.在运行期创建和初始化列表框，并指定列表框的MouseMove事件对应上一步定义的ListBoxMouseMove方法。在主窗体的Create事件中输入下面的代码：begin
Point.X:=0;
Point.Y:=0;
//创建自定义列表框
List:=TMyListBox.Create(Form1);
List.Parent:=Form1;
List.Left:=5;
List.Top:=30;
List.Width:=150;
List.Height:=200;
for i:=0 to 300 do
begin
List.Items.Add(inttostr(i)); //初始化
end;
//指定处理MouseMove事件的方法
List.OnMouseMove := ListBoxMouseMove;
end;
2008年8月16日星期六
用DELPHI开发DirectX游戏
这不是一篇关于DirectX的祥细教程,而是讲解如何用DELPHI开发DirectX游戏.因为不管是网上或是书店,关于DirectX的书基本上是用C++或VC描述的.用DELPHI开发游戏的资料是少之又少,这篇文章的目的就是让读者能够学会如何利用已有的资料学习来开发游戏.
这篇文章面向的是对DirectX有一定了解,却不知道如何在DELPHI下开发DirectX游戏的读者.
推荐参考资料:
<<游戏编程指南>>,<>
DELPHI能不能开发游戏?
回答是当然,网上很多游戏论坛有不少人都认为开发游戏只能用C++或VC. DELPHI只适合来做做桌面应用,劝有这些观点的人先反汇编看看DELPHI和VC编释出来的代码,或是看看"奇迹时代"这个游戏,"奇迹时代"就是用DELPHI开发的,速度和画面优于帝国时代.DELPHI是完全面向对象,并能内嵌汇编,支持MMX指今(DELPHI中MMX寄存器为mm0-mm7).完全适合游戏开发的需要.其实不论VC,DELPHI都只是工具,只要内功好都能做出来好的程序或是游戏.
准备工作:
目前用DELPHI开发DirectX游戏有二种选择.一是使用jedi的DirectX声明(http://www.delphi-jedi.org).另一种是使用DelphiX控件.在这里我们准备使用jedi的DirectX声明包来开发DirectX游戏,之所以选择DirectX声明包是因为这样是以SDK方式来开发游戏,以后如果需要转到其它语言也不必重新学习DirectX.至于DelphiX控件我没用过,没发言权,不过偶是不用日货的 ;-)
先到以下地址下载DirectX的声明包(http://kuga.51.net/download/files/directx7.rar),并解压到你自定的目录中.再在DELPHI中选择Tools->Environment Options,在打开的窗口中选择Library选项卡,点击Library Path后面的按钮.会弹出来一个Directories窗口,再点击Greyed items denote invalid path右边的按钮.选择DirectX声明解压到的目录.再点击ADD按钮,这样就把DirectX声明所在的目录添加到了DELPHI 的Library路径中.就可以直接在uses中引用DirectX声明中的单元了.这个声明包里自带了几个例子,可以作为入门的参考.
调试经验:
开发全屏游戏时最好把设计时的屏幕分辩率设为和游戏一样的分辩率,以免调试时频繁切换分辩率而损伤屏幕.
开发全屏游戏最好是在WIN2000/XP下,不然在98下调试时游戏进入死循环或产生异常时.机子很容易就会当掉.在2000/XP下全屏游戏进入死循环时可以按ALT+TAB切换到DELPHI中(但这时由于DirectX游戏是全屏,独占了屏幕,屏幕上不会有变化,所以要多试几次),按CTRL+F2就可以结束游戏.如果是异常的话,切换到DELPHI中先按下回车再按CTRL+F2就可以结束调试游戏了.
注意:
如果你是使用DELPHI7的话,请把DirectDraw.pas中的145行{$IFDEF VER140}改为{$IFDEF VER150}才能正常编释.
最好使用API的方式来建立游戏主窗口而不是使用VCL的TFORM类.
先让我们来看看用C++和DELPHI初始化DirectDraw对像的代码段.
c++版:
BOOL InitDDraw( )
{
LPDIRECTDRAW7 lpDD; // DirectDraw对象的指针
if ( DirectDrawCreateEx (NULL, (void **)&lpDD, IID_IDirectDraw7, NULL) != DD_OK )
return FALSE; {创建DirectDraw对象}
{里使用了 if ( xxx ！= DD_OK) 的方法进行错误检测，这是最常用的方法}
if (lpDD->SetCooperativeLevel(hwnd,DDSCL_EXCLUSIVE|DDSCL_FULLSCREEN) != DD_OK )
return FALSE; {设置DirectDraw控制级}
if ( lpDD->SetDisplayMode( 640, 480, 32, 0, DDSDM_STANDARDVGAMODE ) != DD_OK )
return FALSE; {置显示模式}
}
DELPHI版:
function TForm1.InitDirectDraw: Boolean;
var
lpDD: IDirectDraw7;
begin
Result := False; {先假设初始化失败}
{建立DirectDraw对象}
if DirectDrawCreateEx(nil, lpDD, IID_IDIRECTDRAW7, nil) <> DD_OK then
exit;
{设定DirectDraw的控制级,第一个参数为DirectDraw窗口的句柄,这里把控级级设为的全屏加独占模式}
if lpDD.SetCooperativeLevel(Hwnd, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN) <> DD_OK then
exit;
{设定显示模式,第一,二个参数为分辩率大小,第三个参数用来设置显示模式的颜色位数,
第四个参数设定屏幕的刷新率,0为默认值,第四个参数唯一有效的值只有DDSDM_STANDARDVGAMODE}
if lpDD.SetDisplayMode(640, 480, 32, 0, DDSDM_STANDARDVGAMODE) <> DD_OK then
exit;
Result := True;
end;
可以看出来,这二段代码除了语法和对象名外完全一样,只要了解了这点,我们完全可以参考VC或C++的资料,然后用DELPHI做出自己的游戏了.DELPHI中DirectX声明中的对象名,结构名和VC不一样,一般的对应关系如下:
DELPHI VC
DirectDraw对象 IDirectDraw7 LPDIRECTDRAW7
页面对象 IDirectDrawSurface7 LPDIRECTDRAWSURFACE7
DirectDraw的页面描述 TDDSurfaceDesc2 DDSURFACEDESC2
基本上只是前缀不一样,由于篇幅,这儿就不一一列出所有对像和结构了.
这篇文章面向的是对DirectX有一定了解,却不知道如何在DELPHI下开发DirectX游戏的读者.
推荐参考资料:
<<游戏编程指南>>,<
DELPHI能不能开发游戏?
回答是当然,网上很多游戏论坛有不少人都认为开发游戏只能用C++或VC. DELPHI只适合来做做桌面应用,劝有这些观点的人先反汇编看看DELPHI和VC编释出来的代码,或是看看"奇迹时代"这个游戏,"奇迹时代"就是用DELPHI开发的,速度和画面优于帝国时代.DELPHI是完全面向对象,并能内嵌汇编,支持MMX指今(DELPHI中MMX寄存器为mm0-mm7).完全适合游戏开发的需要.其实不论VC,DELPHI都只是工具,只要内功好都能做出来好的程序或是游戏.
准备工作:
目前用DELPHI开发DirectX游戏有二种选择.一是使用jedi的DirectX声明(http://www.delphi-jedi.org).另一种是使用DelphiX控件.在这里我们准备使用jedi的DirectX声明包来开发DirectX游戏,之所以选择DirectX声明包是因为这样是以SDK方式来开发游戏,以后如果需要转到其它语言也不必重新学习DirectX.至于DelphiX控件我没用过,没发言权,不过偶是不用日货的 ;-)
先到以下地址下载DirectX的声明包(http://kuga.51.net/download/files/directx7.rar),并解压到你自定的目录中.再在DELPHI中选择Tools->Environment Options,在打开的窗口中选择Library选项卡,点击Library Path后面的按钮.会弹出来一个Directories窗口,再点击Greyed items denote invalid path右边的按钮.选择DirectX声明解压到的目录.再点击ADD按钮,这样就把DirectX声明所在的目录添加到了DELPHI 的Library路径中.就可以直接在uses中引用DirectX声明中的单元了.这个声明包里自带了几个例子,可以作为入门的参考.
调试经验:
开发全屏游戏时最好把设计时的屏幕分辩率设为和游戏一样的分辩率,以免调试时频繁切换分辩率而损伤屏幕.
开发全屏游戏最好是在WIN2000/XP下,不然在98下调试时游戏进入死循环或产生异常时.机子很容易就会当掉.在2000/XP下全屏游戏进入死循环时可以按ALT+TAB切换到DELPHI中(但这时由于DirectX游戏是全屏,独占了屏幕,屏幕上不会有变化,所以要多试几次),按CTRL+F2就可以结束游戏.如果是异常的话,切换到DELPHI中先按下回车再按CTRL+F2就可以结束调试游戏了.
注意:
如果你是使用DELPHI7的话,请把DirectDraw.pas中的145行{$IFDEF VER140}改为{$IFDEF VER150}才能正常编释.
最好使用API的方式来建立游戏主窗口而不是使用VCL的TFORM类.
先让我们来看看用C++和DELPHI初始化DirectDraw对像的代码段.
c++版:
BOOL InitDDraw( )
{
LPDIRECTDRAW7 lpDD; // DirectDraw对象的指针
if ( DirectDrawCreateEx (NULL, (void **)&lpDD, IID_IDirectDraw7, NULL) != DD_OK )
return FALSE; {创建DirectDraw对象}
{里使用了 if ( xxx ！= DD_OK) 的方法进行错误检测，这是最常用的方法}
if (lpDD->SetCooperativeLevel(hwnd,DDSCL_EXCLUSIVE|DDSCL_FULLSCREEN) != DD_OK )
return FALSE; {设置DirectDraw控制级}
if ( lpDD->SetDisplayMode( 640, 480, 32, 0, DDSDM_STANDARDVGAMODE ) != DD_OK )
return FALSE; {置显示模式}
}
DELPHI版:
function TForm1.InitDirectDraw: Boolean;
var
lpDD: IDirectDraw7;
begin
Result := False; {先假设初始化失败}
{建立DirectDraw对象}
if DirectDrawCreateEx(nil, lpDD, IID_IDIRECTDRAW7, nil) <> DD_OK then
exit;
{设定DirectDraw的控制级,第一个参数为DirectDraw窗口的句柄,这里把控级级设为的全屏加独占模式}
if lpDD.SetCooperativeLevel(Hwnd, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN) <> DD_OK then
exit;
{设定显示模式,第一,二个参数为分辩率大小,第三个参数用来设置显示模式的颜色位数,
第四个参数设定屏幕的刷新率,0为默认值,第四个参数唯一有效的值只有DDSDM_STANDARDVGAMODE}
if lpDD.SetDisplayMode(640, 480, 32, 0, DDSDM_STANDARDVGAMODE) <> DD_OK then
exit;
Result := True;
end;
可以看出来,这二段代码除了语法和对象名外完全一样,只要了解了这点,我们完全可以参考VC或C++的资料,然后用DELPHI做出自己的游戏了.DELPHI中DirectX声明中的对象名,结构名和VC不一样,一般的对应关系如下:
DELPHI VC
DirectDraw对象 IDirectDraw7 LPDIRECTDRAW7
页面对象 IDirectDrawSurface7 LPDIRECTDRAWSURFACE7
DirectDraw的页面描述 TDDSurfaceDesc2 DDSURFACEDESC2
基本上只是前缀不一样,由于篇幅,这儿就不一一列出所有对像和结构了.
订阅：
博文 (Atom)
