2010年10月27日星期三

ADOTable数据的排序(转)

摘自:http://hi.baidu.com/noscan/blog/item/cf57d3a96db9ddf61e17a2d9.html

      大家在使用Delphi进行开发的时候,经常会使用到ADOTable和 AdoQuery控件进行数据操作,后者比较灵活,可以利用SQL语句来控制,而前者功能相对单一,使用ADOTable进行数据排序就是没有Query 控件那样使用order by 来的方便,不过这里还是有两种方法的,也很简单。

        方法一:使用sort,方法如下


     ADOTable.sort:='FieldName DESC'; //降序排列DESC要大写
      ADOTable.sort:='FieldName ASC'; //升序排列ASC要大写

      方法二:使用IndexFieldNames,方法如下
       ADOTable.IndexFieldNames:='FieldName1,FieldName2,...';
      这个方法可以按照多字段排序,不过好像只能按升序排列

    上面两种方法都很简单,有兴趣的可以试一试。

    不过我在用的过程中也遇到一个问题,就是在使用ReportMachine打印这些已经排序的数据时出来的都是空白,查看发现数据都空了,不知道是怎么回事?

2010年10月25日星期一

delphi操作注册表(转)

摘自:http://blog.csdn.net/hhf383530895/archive/2009/03/11/3981110.aspx

一、创建和释放TRegistry对象
1.
创建TRegistry对象。为了操作注册表,要创建一个TRegistry对象:ARegistry:=TRegistry.Create
2.
释放TRegistry对象。对注册表操作结束后,应释放TRegistry对象所占内存:ARegistry.Destroy

二、指定要操作的键
操作注册表时,首先应指定操作的主键:先给属性RootKey赋值以指定根键,然后用方法OpenKey来指定要操作的主键名。
1.指定根键(RootKey)。
根键是注册表的入口,也注册表信息的分类,其值可为:
HKEY-CLASSES-ROOT:存储整个系统对象类信息,如ActiveX对象注册、文件关联等信息。
HKEY-CURRENT-USER:存储当前用户的配置信息。为属性RootKey的默认值。
HKEY-LOCAL-MACHINE:存储当前系统的软硬件配置信息。应用程序自己的信息可以存储在该根键下。
HKEY-USERS:存储所有用户通用的配置信息。
还可以是HKEY-CURRENT-CONFIG、HKEY-DYN-DATA。
2.指定要操作的主键。
Function OpenKey(constKey:string;CanCreate:Boolean):Boolean;
constKeyKey:主键名,是键名全名中除去根键的部分,如Software。
CanCreate:在指定的主键名不存在时,是否允许创建该主键,True表示允许。
返回值True表示操作成功。
3.关闭当前主键。
在读取或存储信息之后,应及时将关闭当前主键:procedure CloseKey。

三、从注册表中读取信息
Read系列方法从注册表读取指定的信息(字符串、二进制和十六进制),并转换为指定的类型。
1.Read系列方法。
functionReadString(constName:string):string;
读取一个字符串值,Name为字符串名称。
functionReadInteger(constName:string):Integer;
读取一个整数值,Name为整数名称。
functionReadBinaryData(constName:string;varBuffer;BufSize:Integer):Integer;
读取二进制值,Name为二进制值名称,Buffer为接收缓冲区,BufSize为缓冲区大小,返回为实际读取的字节数。
其它方法还有:ReadBool、ReadCurrency、ReadDate、ReadDateTime、ReadFloat、ReadTime。

2.读取信息一例(显示Windows的版本)。
在HKEY-LOCAL-MACHINE下,有三个字符串值Version、VersionNumber和SubVersionNumber,用于记录当前Windows的版本号。
{请在Uses中包
含Registry单元}
procedureTForm1.Button1Click(Sender:TObject);
var
ARegistry:TRegistry;
begin
ARegistry:=TRegistry.Create;
//建立一个TRegistry实例
withARegistrydo
begin
RootKey:=HKEY-LOCAL-MACHINE;//指定根键为HKEY-LOCAL-MACHINE
//打开主键Software
ifOpenKey(′Software′,false)then
begin
memo1.lines.add('Windows版本:′+ReadString(′Version′));
memo1.lines.add('Windows版本号:′+ReadString(′VersionNumber′));
memo1.lines.add(′Windows子版本号:′+ReadString(′SubVersionNumber′));
end;
CloseKey;//关闭主键
Destroy;//释放内存
end;
end;

四、向注册表中写入信息
Write系列方法将信息转化为指定的类型,并写入注册表。
1.Write系列方法。
procedureWriteString(constName,value:string);
写入一个字符串值,Name为字符串的名称,value为字符串值。
procedureWriteInteger(constName:string;value:Integer);
写入一个整数值。
procedureWriteBinaryData(constName:string;varBuffer;BufSize:Integer);
写入二进制值,Name为二进制值的名称,Buffer为包含二进制值的缓冲区,BufSize为缓冲区大小。
其它方法还有:WriteBool、WriteCurrency、WriteDate、WriteDateTime、WriteFloat、WriteTime。
2.写入信息一例。
下面程序使Delphi随Windows启动而自动运行。
var
ARegistry:TRegistry;
begin
ARegistry:=TRegistry.Create;
//建立一个TRegistry实例
withARegistrydo
begin
RootKey:=HKEY-LOCAL-MACHINE;
ifOpenKey(′Software′,True)then
WriteString(′delphi′,′C:Files.exe′);
CloseKey;
Destroy;
end;
end;

五、键值维护
除了在注册表中读取、存储外,程序可能还需要增加主键、删除主键、主键改名、数据值改名等。
1.
创建新主键:functionCreateKey(constKey:string):Boolean
Key
即为主键名,返回值True表示操作成功。
2.
删除主键:functionDeleteKey(constKey:string):Boolean
Key
即为主键名,返回值True表示操作成功。

/////////////////////////////////

aregistry := tregistry.Create;
   with aregistry do
begin
    rootkey:=HKEY_LOCAL_MACHINE;
    if openkey('\software\abc\b\',false) then
     begin
     // if hassubkeys then
          movekey('a','c',FALSE);     //打开主键,MOVEKEY的第一个参数是由主键的任一子键做参数,子键权复制
          showmessage('操作成功');
     end;
     closekey;
     destroy;
end;
end;


Delphi实现程序只运行一次并激活已打开的程序 (转)

摘自:http://apps.hi.baidu.com/share/detail/5107720

我们的程序有时候只允许运行一次,并且最好的情况是,如果程序第二次运行,就激活原来的程序。网上有很多的方法实现程序只运行一次,但对于激活原来的窗口却都不怎么好。
关 键就在于激活原来的程序,一般的做法是在工程开始时,打开互斥量对象,如果打不开表示程序还没有运行,创建一个互斥量对象;如果打得开表示程序已经运行 了,查找程序中一个特定的窗口,一般是主窗口,然后发送一个自定义消息,主窗口在这个消息处理中激活自己。我原来就是这么做的,却发现有很多问题。
主窗口在消息处理函数中激活不了自己,众所周知激活一个窗口最有效的方法当然就是SetForegroundWindow,但在主窗口中调用这个函数激活自己的效果却是只在标题栏闪了一闪,如果在其他进程调用该函数则不会有问题;另外,如果程序是最小化的,它连闪都不闪了。
对于这些问题,我想了下面的办法,在知道原程序已经运行后,用FindWindow找原程序主窗口的句柄,找到了,就发送一个自定义消息过去,而在原程序主窗口的消息处理函数中,只是调用Application.Restore方法,这样如果原程序是最小化的就会还原过来。在发送消息之后,紧接着我调用SetForegroundWindow并传入原程序主窗口的句柄,由于上面的处理,原程序肯定不是最小化了,且调用SetForegroundWindow的地方已经不是原程序了(是第二次运行的程序,也可以说是另一个进程),所以原程序可以很好的被激活。
看来一切都很好,当然不是,不然就不会有下面的代码了,我又发现了一些问题,首先当主窗体不是活动窗口时,比如主窗体被隐藏了,而目前活动的窗体是其他窗体,则上面的代码无效。另一个,如果主窗体前面有一个ShowModal的窗体,则上面的代码后,主窗体跑到ShowModal窗体的前面了。
只有继续探索了,看来问题出在SetForegroundWindow上,激活那个窗体都不好,因为那个窗体都有可能不在,有没有办法激活工程呢,我在Application中找方法,我找到Application.BringToFront,也许这个有点用,于是新建一个工程,加一个Timer控件,然后每隔3秒调用一次Application.BringToFront,运行看结果。可惜窗体仍然只是闪一下,并没有激活,这和我上面说的在自己进程中激活自己的结果一样,可能BringToFront方法里面也调用了SetForegroundWindow了吧,但它激活哪个窗口呢,这让我好奇,打开源码来看,看到了如下有代码:
procedure TApplication.BringToFront;
var
   TopWindow: HWnd;
begin
  
if Handle <> 0 then
  
begin
     TopWindow := GetLastActivePopup(Handle);
    
if (TopWindow <> 0) and (TopWindow <> Handle) and
       IsWindowVisible(TopWindow)
and IsWindowEnabled(TopWindow) then
       SetForegroundWindow(TopWindow);
  
end;
end;
原来是用GetLastActivePopup这个API找到程序拥有的窗体中最近激活的窗体,然后再激活它。
哈,我有了一个技术方案,首先我要在第二次运行的程序中找到第一次运行的程序的ApplicationHandle,然后调用SendMessage(APPHandle, WM_SYSCOMMAND, SC_RESTORE, 0)Application类有处理这个消息的,最终它会调用Application.Restore方法,让自己变为显示的状态,即最大化或正常。接着,就执行上面方法中的代码,让第一次运行的程序激活。现在关键是怎么找到第一次运行的ApplicationHandle,自然而然就想到了共享内存的技术,程序第一次运行时,先打开一个内存映射文件,如果打不开,则表示程序第一次运行,建一个内存映射文件对象,开辟一块共享的内存,这块内存保存ApplicationHandle。程序第二次运行,打开内存映射文件,可以打开了,得到一块共享内存,并取得了第一次运行程序的ApplicationHandle,然后,用我上面说的方法,即可大功告成。
花了一个小时的试验,最终有了下面的代码,结果非常成功:
unit wdRunOnce;

{*******************************************
* brief: 让程序只运行一次
* autor: linzhenqun
* date: 2005-12-28
* email: linzhengqun@163.com
* blog: http://blog.csdn.net/linzhengqun
********************************************}

interface

(* 程序是否已经运行,如果运行则激活它 *)
function AppHasRun(AppHandle: THandle): Boolean;


implementation
uses
   Windows, Messages;

const
   MapFileName =
'{CAF49BBB-AF40-4FDE-8757-51D5AEB5BBBF}';

type
  
//共享内存
   PShareMem = ^TShareMem;
   TShareMem =
record
     AppHandle: THandle;  
//保存程序的句柄
  
end;

var
   hMapFile: THandle;
   PSMem: PShareMem;

procedure CreateMapFile;
begin
   hMapFile := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapFileName));
  
if hMapFile = 0 then
  
begin
     hMapFile := CreateFileMapping($FFFFFFFF,
nil, PAGE_READWRITE, 0,
       SizeOf(TShareMem), MapFileName);
     PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE
or FILE_MAP_READ, 0, 0, 0);
    
if PSMem = nil then
    
begin
       CloseHandle(hMapFile);
       Exit;
    
end;
     PSMem^.AppHandle :=
0;
  
end
  
else begin
     PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE
or FILE_MAP_READ, 0, 0, 0);
    
if PSMem = nil then
    
begin
       CloseHandle(hMapFile);
    
end
  
end;
end;

procedure FreeMapFile;
begin
   UnMapViewOfFile(PSMem);
   CloseHandle(hMapFile);
end;

function AppHasRun(AppHandle: THandle): Boolean;
var
   TopWindow: HWnd;
begin
   Result := False;
  
if PSMem <> nil then
  
begin
    
if PSMem^.AppHandle <> 0 then
    
begin
       SendMessage(PSMem^.AppHandle, WM_SYSCOMMAND, SC_RESTORE,
0);
       TopWindow := GetLastActivePopup(PSMem^.AppHandle);
      
if (TopWindow <> 0) and (TopWindow <> PSMem^.AppHandle) and
         IsWindowVisible(TopWindow)
and IsWindowEnabled(TopWindow) then
         SetForegroundWindow(TopWindow);
       Result := True;
    
end
    
else
       PSMem^.AppHandle := AppHandle;
  
end;
end;

initialization
   CreateMapFile;

finalization
   FreeMapFile;

end.
你所要做的,就是将这个单元加进你的程序中,然后在你的工程文件中调用AppHasRun,并传入ApplicationHandle,你的程序就可以只运行一次了,工程大概如下:
program Project1;

uses
   Forms,
   Unit1
in 'Unit1.pas' {Form1}
   wdRunOnce
in 'wdRunOnce.pas',
   Unit2
in 'Unit2.pas' {Form2}

{$R *.res}

begin
   Application.Initialize;
  
if not AppHasRun(Application.Handle) then
     Application.CreateForm(TForm1, Form1);
   Application.Run;
end.
多新建一些窗口测试一下吧,不过要注意新建的窗口得不能是自动创建的。
来自: http://hi.baidu.com/selectking/blog/item/150cca1354ca7c025aaf53e6.html

2010年10月24日星期日

UML学习笔记(转)

摘自:http://blog.csdn.net/DiaoShengjie/archive/2006/06/02/769427.aspx

1.建模
  
  1.1 为什么要建模
  
  建立大厦和建立狗窝的区别是建设狗窝不需要设计。要生产合格的软件就要有一套关于体系结构、过程和工具的规范。
  
  建模的定义:建模是对现实的简化。
  
  建模的目标:
  1)模型帮助我们按照实际情况或按照我们所需要的样式对系统进行可视化。
  2)模型允许我们详细说明系统的结构和行为。
  3)模型给出一个知道我们构造系统的模板。
  4)模型对我们的决策进行文档化。
  
  建模就是把复杂的系统变成小的系统,采用“各个击破”的原则逐一解决。
  
  1.2 建模原理
  
  1)选择创建什么模型很重要,模型要反映你难于处理的开发问题。
  2)模型要在不同的精度级别上来表示。你可以根据观察的角色和观察的原因来选择精度。
  3)建造模型要和现实相连。
  4)重要的系统需要用一组独立的模型去处理。在面向对象的软件体系中,为了理解系统的体系结构,你需要几个互补和连锁的视图:用例图、设计视图、进程视图、实现视图和实施视图。
  
  1.3 面向对象的建模
  
  面向算法的建模在需求发生变化或者系统增长后就变得难以维护。
  
  面向对象的建模把对象和类作为其主要构造块。例如,在三层结构中,我们可以在用户接口层、中间层和数据库层中找到你想要的对象。
  
  
  2 UML介绍
  
  
  2.1 概述
  UML可以对软件密集型系统的制品进行可视化、详述、构造和文档化。最好把它用于以用况(用例)为驱动、以体系结构为中心、跌代及增量的过程中。
  
  UML是一种语言,它是一种可视化的语言,它是一组图形符号。它可用于详细描述。它又是一种构造语言,可以直接生成代码。用Rational XDE就可以实现从UML到C#,或者从C#到UML的双向工程。
  
  2.2 UML的概念模型
  学习建模的三个要素:UML的基本构造块、这些构造块放在一起的规则、一些运用于整个UML的公共机制。
  
  UML中由一些四种事物
  1)结构事物 --- 类、接口、协作(它是一个交互,它是由一组共同工作以提供某协作行为的角色和其它元素构成的一个群体。)、用例、主动类(至少拥有一个进程或者线程,其元素的行为可以和其它元素的行为并发)、构件(如COM+和Java Bean)、节点。
  2)行为事物 --- 交互、状态机(描述了一个对象或者一个交互在生命期内响应事件所经历的状态序列)。
  3)分组事物 --- 包
  4)注释事物 --- 注解
  
  UML中的四种关系
  1)依赖 --- 两个事物间的语义关系
  2)关联 --- 是一种结构关系,如聚合
  3)泛化 --- 一般/特殊关系
  4)实现 --- 用在两种地方:接口和实现他们之间的类和构件之间;用例和实现他们的协作之间。
  
  UML中的图
  1)类图 --- 系统的静态状态图,包含主动类的类图给除系统的静态进程视图。
  2)对象图
  3)用例图
  4)顺序图
  5)协作图
  6)状态图
  7)活动图 --- 强调对象间的控制流程
  8)构件图
  9)实施图
  
  2.3 体系结构
  
  我们用5个互联的视图来描述软件密集型系统的体系结构:
  
  1)系统的用例图
  2)系统的设计视图 --- 静态方面由类图和对象图描述,动态方面由交互图、状态图和活动图描述。
  3)系统的进程视图 --- 包含了形成系统并发和同步机制的线程和进程。
  4)系统的实现视图 --- 主要针对系统发布的配置管理。
  5)系统的实施视图
  
  2.4 软件开发生命周期
  
  用况驱动
  以体系结构为中心
  跌代过程 --- 涉及到一连串可执行发布的管理。
  
  软件开发生命周期的四个阶段:
  初始
  细化
  构造
  移交

 
3 Hello World
  
  4 类
  
  4.3.1 对系统的词汇建模
  
  需要做如下工作:
  1)识别用户用于描述问题或解决问题的事物。
  2)对于每个抽象,识别一个职责集。
  3)提供为实现每个类的职责所需的属性和操作。
  
  4.3.2 对系统中职责的分布建模
  
  抽象出来的类要适中,不要过大过小。
  
  需要如下工作:
  1) 识别一组为了完成某些行为而紧密协同工作的类。
  2) 对上面的每一个类识别出一组职责。
  3) 从整体上观察这些类,过大的分解,过小的合并。
  4) 考虑相映的协作方式,重新分配职责。
  
  5 关系
  
  面向对象建模中三种最重要的关系:
  
  依赖 --- 使用关系
  泛化 --- 一般/特殊关系
  关联 --- 结构关系
  
  当你开始建模是,特别是解决这些对象的动态协作时,你还会遇到两种其它的关系:链(可能发送消息的对象间的实例)和转换(状态机中不同状态的连接)
  
  
  对简单依赖建模 ---(如一个类作为另一个类的参数) 依赖从操作的类指向当作参数的类。
  对单继承建模
  对结构关系建模
  
  6 公共机制
  
  四个公共机制可以使UML简化:详述、修饰、公共划分和扩展
  
  构造型、标记值和约束使UML提供的用以增加新的构造块、创建新的特性以及描述新的语义的机制。
  
  
  
  7 图
  
  有5种最重要的互补视图:用例视图、设计视图、进程视图、实现视图和实施视图
  
  每一种视图包含结构建模(静态)和行为建模(动态)
  
  建图的两种方法:正向工程和逆向工程
  
  
  一些术语:
  系统:由子系统组成; 子系统:由元素组成; 模型:对现实的简化; 视图:对系统模型的组织和结构的投影,注重于系统的一个方面。
  
  结构图:类图、对象图、构件图、实施图。
  行为图: 用况图、顺序图、协作图、状态图、活动图。
  
  顺序图和协作图统称交互图。顺序图强调消息的时间次序,协作图强调收发消息的对象的结构组织。
  
  活动图强调对象之间的控制流。
  
  
  如何选择视图来建模?
  1)视图能够表达系统的体系结构,能够暴露项目的技术风险。
  2)决定用哪些制品来捕获视图的基本细节。
  3)作为你的过程策略的一部分,决定把那种视图至于某种形式或者半形式的控制之下。
  4)保留废弃的视图。
  
  两种系统建模的方法:
  1)针对同一模型,用不同层次上的细节描述图。
  2)在不同的抽象层次上,从一个模型跟踪到另一个模型的方法建模。
  
  8 类图
  
  类图包括如下内容:
  
  类
  接口
  协作
  依赖、泛化和关联关系。
  
  对系统的静态设计视图建模时使用类图的3种方式:
  1)对系统的词汇建模
  2)对简单协作建模 --- 协作提供的一些合作行为强于其所有元素行为之和。
  3)对逻辑数据库模式建模
  
  
  9 高级类
  
  在UML中更一般的构造块是类元,类元包括:类、接口、数据类型、信号、构件、节点、用况和子系统。他是描述结构特性和行为特性的机制。
原文blog来源:http://spaces.msn.com/treadstonestephen/

SIP协议解析与实现(转)

摘自:http://blog.csdn.net/DiaoShengjie/archive/2007/05/14/1608008.aspx

本文将按照RFC3261逐步的介绍SIP协议,介绍了c和c++语言的实现,分析了osip库的使用和实现。
第一章 概述
一 概述
SIP协议是一个基于应用层的会话控制协议。它可以创建、修改、终止多媒体会话(会议),也可以邀请参与者加入到一个现有的会话。
因 为SIP是一个基于应用层的协议,所以它不是一套完整的通讯系统方案,它需要和其它的方案或者协议结合起来实现整套系统。例如,实时传输协议(RTP) (RFC1889)用来传输音视频等实时的流媒体数据。实时流协议(RTSP)(RFC2326)用来控制媒体流的传递。媒体网关控制协议 (MEGACO)(RFC3015)用来控制PSTN网关。
由此可见,SIP协议应该用来组合其它协议,从而实现完整的服务。但是,SIP基础的功能和操作不依赖于其它协议。
二 第一个例子 
 

图1
下面引用RFC3261的例子来说明sip的基本功能,包括:定位终端,发送通讯请求,协商会话参数,建立会话和撤销建立的会话。图1 显示了用户Alice和Bob使用SIP交换信息的一个典型的例子(每一个消息用字母F和一个数字来标号,标号的前面有一个简短的消息类型说明)。在这个 例子中,Alice使用一个在她的PC机中的SIP应用程序呼叫Bob,Bob使用他的SIP电话,这个SIP电话登录了互联网。同时,请注意两个SIP 代理服务器在Alice和Bob的会话的建立中起到的作用。
Alice呼叫Bob是使用他的SIP标识符。SIP标识符是一种 URI(Uniform Resource Identifier),称之为SIP URI。SIP URI格式很象email地址,包含一个用户名和一个主机名,如:sip:bob@biloxi.com。这里biloxi.com是Bob的SIP服务 提供者的域名。Alice的SIP URI是:sip:alice@atlanta.com。SIP也支持安全URI,叫做SIPS URI,例如,sips:bob@biloxi.com。一个向SIPS URI的呼叫使用加密传输(也就是TLS)来携带从呼叫者到被呼叫者所有的SIP消息。
SIP是一个与HTTP协议很像的,请求/应答式的事务模 型。每一个事务最少由一个要完成特定方法或功能的请求,和服务器端的一个应答组成。在这个例子中,这个事务从Alice的软电话发送一个INVITE请求 到Bob的SIP URI开始。INVITE是一个SIP消息,它表示请求者Alice想与Bob通话。INVITE请求包含一些头域。头域被称为属性,可以提供关于这个消 息的额外信息。关于头域我们一会儿将会详细说明它们。图1中的INVITE信息(F1)可能像这样:
INVITE sip:bob@biloxi.com SIP/2.0
Via: SIP/2.0/UDP pc33.atlanta.com;branch=z9hG4bK776asdhds
Max-Forwards: 70
To: Bob <sip:bob@biloxi.com>
From: Alice <sip:alice@atlanta.com>;tag=1928301774
Call-ID: a84b4c76e66710@pc33.atlanta.com
CSeq: 314159 INVITE
Contact: <sip:alice@pc33.atlanta.com>
Content-Type: application/sdp
Content-Length: 142
 
(Alice's SDP not shown)       
第一行文本是这个请求的方法名(INVITE)。后面的行是多个头域。这里只列出了最少需要的头域。先在这里对这些头域做一个简要的介绍:
Via头域包含Alice希望收到对于这个请求的应答的地址。也就是她告诉请求的接收者,应答应该发送到 pc33.atlanta.com。后面的branch参数是这个事务的标识符。
To头域包含一个显示名(Bob)和一个SIP URI或者SIPS URI,这里是使用的SIP URI(sip:bob@biloxi.com)。这个SIP URI就是这个请求要发送的目标。
From 头域也包含一个显示名(Alice)和一个SIP URI或者SIPS URI,这里是使用的SIP URI(sip:alice@atlanta.com)来指出请求的发起人。这个头域还包含了一个tag参数,这个参数包含了一个随机字符串 (1928301774),这个字符串的数字会被软电话自动增加,它主要起到鉴别的作用,后面还会说明它。
Call-ID头域包含一个全局唯一标 识符来标识这次呼叫。这个标识符使用一个随即字符串和软电话所在的主机名(或者IP地址)一起生成。这样,To头域、From头域和Call-ID这三个 头域就可以唯一的确定了Alice和Bob的这条点对点的通信关系,并且将这个通信关系交给一个对话(dialog)来处理了。
Cseq头域(命令序列)包含一个整数和一个方法名字。在这个对话中每一个新的请求都会增加这个整数的值,保证这个数值是有序的。
Contact 头域包含一个SIP URI或者SIPS URI指出一个能够接触到Alice的直接路由,一般这个SIP URI由用户名和一个完全限定域名(FQDN)构成。因为许多终端系统没有注册域名,所以也可以使用IP地址代替FQDN。Via头域向对方指出了这个请 求的应答应该发送到哪里,而Contact头域向对方指出了将来的请求应该发送到哪里。
Max-Forwards头域限制了在这个请求传送到目的地的时候最多可以有多少跳。它包含一个整数,在每一跳这个整数都会被减少。
Content-Type头域描述消息体的类型(在这个例子里消息体采用了SDP描述,但是消息体内容没有给出)。
Content-Length头域指出了消息体的字节数。
在后面我们将完整的介绍SIP头域(RFC3261第20节)。
在会话中像媒体类型、编码方式、采样率等信息都不使用SIP描述,而是在消息体中使用其它会话描述协议的格式。这个例子中采用了SDP描述(RFC2327)。
软 电话不知道Bob或者拥有biloxi.com域名的SIP服务器,它将INVITE请求发送给为Alice提供服务的域名为atlanta.com的 SIP服务器。关于Alice如何获得atlanta.com SIP服务器的地址,可以使用由Alice的软电话指定,或者使用DHCP探测到等方式。
atlanta.com SIP服务器是一个SIP代理服务器。一个代理服务器接收SIP请求,为请求的发送者转发请求。在这个例子中,代理服务器接收到INVITE请求后发送一 个100应答(Trying)给Alice的软电话。100应答(Trying)指出这个INVITE请求已经被代理服务器接收到,并且已被经进一步向目 的地路由。SIP中的应答使用3位数字表示,每一个编号都表示一个描述短语。这个100应答(Trying)也同样包含和INVITE请求一样的To、 From、Call-ID、CSeq和Via以及branch参数,这样可以使Alice的软电话知道这个应答是对应发送的INVITE请求的。 atlanta.com代理服务器定位出biloxi.com代理服务器(这可能需要通过域名解析服务器(DNS)等实现,后面还会详细讲解)获得了它的 IP地址,并且准备把INVITE请求转发给biloxi.com代理服务器。在转发请求之前,atlanta.com代理服务器增加了一个额外的Via 头域,这个Via头域包含自己的地址(这时候这个INVITE请求的第一个Via头域包含Alice的软电话的地址)。biloxi.com代理服务器接 收到这个INVITE请求,并且也发送一个100(Trying)应答给atlanta.com代理服务器指出它已经接收到这个INVITE请求,并正在 处理这个请求。biloxi.com代理服务器知道Bob的IP地址(这可能需要定位服务),它又在这个INVITE请求中加入了一个新的Via头域,值 为自己的地址,然后它把这个INVITE请求发送给Bob的SIP电话。
Bob的SIP电话接收到这个INVITE请求,发送一个 180(Ringing)应答,同时使用铃声通知Bob有一个来自Alice的呼叫,让Bob决定是否接听。这个180(Ringing)应答反向经过这 两个代理服务器被发送到Alice。每一个代理服务器使用Via头域决定向哪里发送这个应答,并且把移除它自己添加的Via头域。这样,虽然只有初始的 INVITE请求发送的时候使用了DNS服务和定位服务,而这个180(Ringing)应答没有使用,同时代理服务器也不需要记录整个通讯的状态,但是 这个应答还是能够成功的发送给请求的发送者Alice。
当alice的软电话接收到180(Ringing)应答后,它将这个消息告诉给Alice,也许使用一个声音(彩铃)或者在Alice的屏幕上显示一个消息。
在 这个例子中,Bob决定接听电话,当他按下接听按钮时,他的SIP电话发送200(OK)应答表示接受了这个呼叫。这个200(OK)应答包含一个消息 体,消息体使用SDP描述Bob准备和Alice建立的会话的媒体类型等信息。这样,Alice和Bob交换了一次SIP信息:Alice用INVITE 请求发送一次给Bob,Bob用200(OK)应答发送一次给Alice。这个交换实现了基本的协商能力和简单的offer/answer模型。如果 Bob不希望接听电话,或者他现在正忙(接听其它电话),那么他会发送一个错误应答而不是200(OK)应答。一个错误应答将不会建立会话。
Bob发送的200(OK)应答可能是这样的:
SIP/2.0 200 OK
Via: SIP/2.0/UDP server10.biloxi.com
;branch=z9hG4bKnashds8;received=192.0.2.3
Via: SIP/2.0/UDP bigbox3.site3.atlanta.com
;branch=z9hG4bK77ef4c2312983.1;received=192.0.2.2
Via: SIP/2.0/UDP pc33.atlanta.com
;branch=z9hG4bK776asdhds ;received=192.0.2.1
To: Bob <sip:bob@biloxi.com>;tag=a6c85cf
From: Alice <sip:alice@atlanta.com>;tag=1928301774
Call-ID: a84b4c76e66710@pc33.atlanta.com
CSeq: 314159 INVITE
Contact: <sip:bob@192.0.2.4>
Content-Type: application/sdp
Content-Length: 131
 
(Bob's SDP not shown)      
应 答的第一行包含一个应答代码(200)和一个解释短语(OK)。其它行就是应答的头域。Via,To,From,Call-ID和CSeq头域的值都从 INVITE请求拷贝而来(这时候应该有3个Via头域,分别由Alice的SIP软电话,atlanta.com代理服务器,和biloxi.com代 理服务器添加)。Bob的SIP电话添加一个tag参数到To头域。以后所有的属于这个对话的请求和应答都要包含这个tag参数。
当Alice的 软电话接收到这个200(OK)应答后,马上停止响铃并显示呼叫已经被接听了。最后,Alice发送一个确认信息(ACK)给Bob的SIP电话,表示自 己收到了最终应答(200(OK))。这个例子中的最终应答由Alice直接发送给了Bob,这是因为Alice的软电话从Contact头域里面可以得 到Bob的地址信息。通过INVITA/200/ACK的三步握手,SIP会话就建立起来了。关于SIP会话建立的详细步骤请参看RFC3261第13 节。
现在Alice和Bob的多媒体会话已经建立起来了,他们可以发送通过SDP协商好的格式的媒体数据了。一般来说,媒体数据包的传输与SIP消息的传输采用不同的通信方式。SIP消息大多通过代理服务器转发,而媒体数据多使用点对点的传输。
在 会话过程中,无论是Alice还是Bob决定改变这个媒体会话,都要通过发送一个re-INVITE请求。这个re-INVITE请求包含新的媒体描述 (可能是SDP),它不会建立新的会话,而是修改当前已经存在的会话。对方接收到这个请求后,发送一个200(OK)同意这个改变,最后请求者发送 ACK。如果对方不同意这个修改,可能会发送一个错误应答,比如488(不接受)。但是这个失败应答不会使已存在的会话退出,而是继续使用以前协商的媒体 进行通信。关于修改一个会话的详细说明,请参看RFC3261第14节。
最后,Bob发送BYE消息挂断电话。BYE消息直接发送到Alice的 软电话。Alice发送200(OK)确定接收到了BYE消息,并且终止这个会话。Bob不用发送ACK,因为ACK只有在接收到对INVITE的应答时 才被发送。关于终止一个会话更详细的说明,请参看RFC3261第15节。
还有一个问题就是关于biloxi.com服务器如何获得Bob的位 置。Bob的SIP电话开机的时候会向一个注册服务器发送REGISTER消息。REGISTER消息的作用是将Bob的SIP URI或者SIPS URI与Bob当前使用的电话地址进行帮定,并将这个帮定信息保存到数据库中,这被称之为定位服务(location service)。biloxi.com代理服务器使用定位服务获得Bob的地址。注册服务器、代理服务器、定位服务器都是逻辑上的服务器,而不是物理上 的服务器,所以他们可以位于同一台服务器上。

2010年10月23日星期六

用Delphi创建服务程序 Services Application (转)


摘自:http://bbs.yd153.com/dispbbs.asp?BoardID=2&ID=694

Windows 2000/XP和2003等支持一种叫做"服务程序"的东西.程序作为服务启动有以下几个好处:

    (1)不用登陆进系统即可运行.
    (2)具有SYSTEM特权.所以你在进程管理器里面是无法结束它的.

    笔者在2003年为一公司开发机顶盒项目的时候,曾经写过课件上传和媒体服务,下面就介绍一下如何用Delphi7创建一个Service程序.
    运 行Delphi7,选择菜单File-->New-->Other--->Service Application.将生成一个服务程序的框架.将工程保存为ServiceDemo.dpr和Unit_Main.pas,然后回到主框架.我们注 意到,Service有几个属性.其中以下几个是我们比较常用的:

    (1)DisplayName:服务的显示名称
    (2)Name:服务名称.

    我 们在这里将DisplayName的值改为"Delphi服务演示程序",Name改为"DelphiService".编译这个项目,将得到 ServiceDemo.exe.这已经是一个服务程序了!进入CMD模式,切换致工程所在目录,运行命令"ServiceDemo.exe /install",将提示服务安装成功!然后"net start DelphiService"将启动这个服务.进入控制面版-->管理工具-->服务,将显示这个服务和当前状态.不过这个服务现在什么也干 不了,因为我们还没有写代码:)先"net stop DelphiService"停止再"ServiceDemo.exe /uninstall"删除这个服务.回到Delphi7的IDE.

    我们的计划是为这个服务添加一个主窗口,运行后任务栏显示程序的图标,双击图标将显示主窗口,上面有一个按钮,点击该按钮将实现Ctrl+Alt+Del功能.

    实 际上,服务程序莫认是工作于Winlogon桌面的,可以打开控制面板,查看我们刚才那个服务的属性-->登陆,其中"允许服务与桌面交互"是不打 钩的.怎么办?呵呵,回到IDE,注意那个布尔属性:Interactive,当这个属性为True的时候,该服务程序就可以与桌面交互了.

    File-->New-->Form为服务添加窗口FrmMain,单元保存为Unit_FrmMain,并且把这个窗口设置为手工创建.完成后的代码如下:


unit Unit_Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs, Unit_FrmMain;

type
TDelphiService = class(TService)
procedure ServiceContinue(Sender: TService; var Continued: Boolean);
procedure ServiceExecute(Sender: TService);
procedure ServicePause(Sender: TService; var Paused: Boolean);
procedure ServiceShutdown(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;

var
DelphiService: TDelphiService;
FrmMain: TFrmMain;
implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
DelphiService.Controller(CtrlCode);
end;

function TDelphiService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;

procedure TDelphiService.ServiceContinue(Sender: TService;
var Continued: Boolean);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;

procedure TDelphiService.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
Sleep(10);
ServiceThread.ProcessRequests(False);
end;
end;

procedure TDelphiService.ServicePause(Sender: TService;
var Paused: Boolean);
begin
Paused := True;
end;

procedure TDelphiService.ServiceShutdown(Sender: TService);
begin
gbCanClose := true;
FrmMain.Free;
Status := csStopped;
ReportStatus();
end;

procedure TDelphiService.ServiceStart(Sender: TService;
var Started: Boolean);
begin
Started := True;
Svcmgr.Application.CreateForm(TFrmMain, FrmMain);
gbCanClose := False;
FrmMain.Hide;
end;

procedure TDelphiService.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Stopped := True;
gbCanClose := True;
FrmMain.Free;
end;

end.


主窗口单元如下:

unit Unit_FrmMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, ShellApi, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;

const
WM_TrayIcon = WM_USER + 1234;
type
TFrmMain = class(TForm)
Timer1: TTimer;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
IconData: TNotifyIconData;
procedure AddIconToTray;
procedure DelIconFromTray;
procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
procedure SysButtonMsg(var Msg: TMessage); message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
FrmMain: TFrmMain;
gbCanClose: Boolean;
implementation

{$R *.dfm}

procedure TFrmMain.FormCreate(Sender: TObject);
begin
FormStyle := fsStayOnTop; {窗口最前}
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW); {不在任务栏显示}
gbCanClose := False;
Timer1.Interval := 1000;
Timer1.Enabled := True;
end;

procedure TFrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := gbCanClose;
if not CanClose then
begin
Hide;
end;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
begin
Timer1.Enabled := False;
DelIconFromTray;
end;

procedure TFrmMain.AddIconToTray;
begin
ZeroMemory(@IconData, SizeOf(TNotifyIconData));
IconData.cbSize := SizeOf(TNotifyIconData);
IconData.Wnd := Handle;
IconData.uID := 1;
IconData.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
IconData.uCallbackMessage := WM_TrayIcon;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := 'Delphi服务演示程序';
Shell_NotifyIcon(NIM_ADD, @IconData);
end;

procedure TFrmMain.DelIconFromTray;
begin
Shell_NotifyIcon(NIM_DELETE, @IconData);
end;

procedure TFrmMain.SysButtonMsg(var Msg: TMessage);
begin
if (Msg.wParam = SC_CLOSE) or
(Msg.wParam = SC_MINIMIZE) then Hide
else inherited; // 执行默认动作
end;

procedure TFrmMain.TrayIconMessage(var Msg: TMessage);
begin
if (Msg.LParam = WM_LBUTTONDBLCLK) then Show();
end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
begin
AddIconToTray;
end;

procedure SendHokKey;stdcall;
var
HDesk_WL: HDESK;
begin
HDesk_WL := OpenDesktop ('Winlogon', 0, False, DESKTOP_JOURNALPLAYBACK);
if (HDesk_WL <> 0) then
if (SetThreadDesktop (HDesk_WL) = True) then
PostMessage(HWND_BROADCAST, WM_HOTKEY, 0, MAKELONG (MOD_ALT or MOD_CONTROL, VK_DELETE));
end;

procedure TFrmMain.Button1Click(Sender: TObject);
var
dwThreadID : DWORD;
begin
CreateThread(nil, 0, @SendHokKey, nil, 0, dwThreadID);
end;

end.


补充:
(1)关于更多服务程序的演示程序,请访问以下 http://www.torry.net/pages.php?id=226 ,上面包含了多个演示如何控制和管理系统服务的代码.

(2)请切记:Windows实际上存在多个桌面.例如屏幕传输会出现白屏,可能有两个原因:一是系统处于锁定或未登陆桌面,二是处于屏幕保护桌面.这时候要将当前桌面切换到该桌面才能抓屏.

(3)关于服务程序与桌面交互,还有种动态切换方法.大概单元如下:
unit ServiceDesktop;

interface

function InitServiceDesktop: boolean;
procedure DoneServiceDeskTop;

implementation

uses Windows, SysUtils;

const
DefaultWindowStation = 'WinSta0';
DefaultDesktop = 'Default';
var
hwinstaSave: HWINSTA;
hdeskSave: HDESK;
hwinstaUser: HWINSTA;
hdeskUser: HDESK;
function InitServiceDesktop: boolean;
var
dwThreadId: DWORD;
begin
dwThreadId := GetCurrentThreadID;
// Ensure connection to service window station and desktop, and
// save their handles.
hwinstaSave := GetProcessWindowStation;
hdeskSave := GetThreadDesktop(dwThreadId);


hwinstaUser := OpenWindowStation(DefaultWindowStation, FALSE, MAXIMUM_ALLOWED);
if hwinstaUser = 0 then
begin
OutputDebugString(PChar('OpenWindowStation failed' + SysErrorMessage(GetLastError)));
Result := false;
exit;
end;

if not SetProcessWindowStation(hwinstaUser) then
begin
OutputDebugString('SetProcessWindowStation failed');
Result := false;
exit;
end;

hdeskUser := OpenDesktop(DefaultDesktop, 0, FALSE, MAXIMUM_ALLOWED);
if hdeskUser = 0 then
begin
OutputDebugString('OpenDesktop failed');
SetProcessWindowStation(hwinstaSave);
CloseWindowStation(hwinstaUser);
Result := false;
exit;
end;
Result := SetThreadDesktop(hdeskUser);
if not Result then
OutputDebugString(PChar('SetThreadDesktop' + SysErrorMessage(GetLastError)));
end;

procedure DoneServiceDeskTop;
begin
// Restore window station and desktop.
SetThreadDesktop(hdeskSave);
SetProcessWindowStation(hwinstaSave);
if hwinstaUser <> 0 then
CloseWindowStation(hwinstaUser);
if hdeskUser <> 0 then
CloseDesktop(hdeskUser);
end;

initialization
InitServiceDesktop;
finalization
DoneServiceDesktop;
end.
更详细的演示代码请参看: http://www.torry.net/samples/samples/os/isarticle.zip



(4)关于安装服务如何添加服务描述.有两种方法:一是修改注册表.服务的详细信息都位于HKEY_LOCAL_MACHINE\SYSTEM \ControlSet001\Services\下面,例如我们刚才那个服务就位于HKEY_LOCAL_MACHINE\SYSTEM \ControlSet001\Services\DelphiService下.第二种方法就是先用QueryServiceConfig2函数获取服 务信息,然后ChangeServiceConfig2来改变描述.用Delphi实现的话,单元如下:

unit WinSvcEx;

interface

uses Windows, WinSvc;

const
//
// Service config info levels
//
SERVICE_CONFIG_DESCRIPTION = 1;
SERVICE_CONFIG_FAILURE_ACTIONS = 2;

//
// DLL name of imported functions
//
AdvApiDLL = 'advapi32.dll';
type
//
// Service description string
//
PServiceDescriptionA = ^TServiceDescriptionA;
PServiceDescriptionW = ^TServiceDescriptionW;
PServiceDescription = PServiceDescriptionA;
{$EXTERNALSYM _SERVICE_DESCRIPTIONA}
_SERVICE_DESCRIPTIONA = record
lpDescription : PAnsiChar;
end;
{$EXTERNALSYM _SERVICE_DESCRIPTIONW}
_SERVICE_DESCRIPTIONW = record
lpDescription : PWideChar;
end;
{$EXTERNALSYM _SERVICE_DESCRIPTION}
_SERVICE_DESCRIPTION = _SERVICE_DESCRIPTIONA;
{$EXTERNALSYM SERVICE_DESCRIPTIONA}
SERVICE_DESCRIPTIONA = _SERVICE_DESCRIPTIONA;
{$EXTERNALSYM SERVICE_DESCRIPTIONW}
SERVICE_DESCRIPTIONW = _SERVICE_DESCRIPTIONW;
{$EXTERNALSYM SERVICE_DESCRIPTION}
SERVICE_DESCRIPTION = _SERVICE_DESCRIPTIONA;
TServiceDescriptionA = _SERVICE_DESCRIPTIONA;
TServiceDescriptionW = _SERVICE_DESCRIPTIONW;
TServiceDescription = TServiceDescriptionA;

//
// Actions to take on service failure
//
{$EXTERNALSYM _SC_ACTION_TYPE}
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
{$EXTERNALSYM SC_ACTION_TYPE}
SC_ACTION_TYPE = _SC_ACTION_TYPE;

PServiceAction = ^TServiceAction;
{$EXTERNALSYM _SC_ACTION}
_SC_ACTION = record
aType : SC_ACTION_TYPE;
Delay : DWORD;
end;
{$EXTERNALSYM SC_ACTION}
SC_ACTION = _SC_ACTION;
TServiceAction = _SC_ACTION;

PServiceFailureActionsA = ^TServiceFailureActionsA;
PServiceFailureActionsW = ^TServiceFailureActionsW;
PServiceFailureActions = PServiceFailureActionsA;
{$EXTERNALSYM _SERVICE_FAILURE_ACTIONSA}
_SERVICE_FAILURE_ACTIONSA = record
dwResetPeriod : DWORD;
lpRebootMsg : LPSTR;
lpCommand : LPSTR;
cActions : DWORD;
lpsaActions : ^SC_ACTION;
end;
{$EXTERNALSYM _SERVICE_FAILURE_ACTIONSW}
_SERVICE_FAILURE_ACTIONSW = record
dwResetPeriod : DWORD;
lpRebootMsg : LPWSTR;
lpCommand : LPWSTR;
cActions : DWORD;
lpsaActions : ^SC_ACTION;
end;
{$EXTERNALSYM _SERVICE_FAILURE_ACTIONS}
_SERVICE_FAILURE_ACTIONS = _SERVICE_FAILURE_ACTIONSA;
{$EXTERNALSYM SERVICE_FAILURE_ACTIONSA}
SERVICE_FAILURE_ACTIONSA = _SERVICE_FAILURE_ACTIONSA;
{$EXTERNALSYM SERVICE_FAILURE_ACTIONSW}
SERVICE_FAILURE_ACTIONSW = _SERVICE_FAILURE_ACTIONSW;
{$EXTERNALSYM SERVICE_FAILURE_ACTIONS}
SERVICE_FAILURE_ACTIONS = _SERVICE_FAILURE_ACTIONSA;
TServiceFailureActionsA = _SERVICE_FAILURE_ACTIONSA;
TServiceFailureActionsW = _SERVICE_FAILURE_ACTIONSW;
TServiceFailureActions = TServiceFailureActionsA;

///////////////////////////////////////////////////////////////////////////
// API Function Prototypes
///////////////////////////////////////////////////////////////////////////
TQueryServiceConfig2 = function (hService : SC_HANDLE; dwInfoLevel : DWORD; lpBuffer : pointer;
cbBufSize : DWORD; var pcbBytesNeeded) : BOOL; stdcall;
TChangeServiceConfig2 = function (hService : SC_HANDLE; dwInfoLevel : DWORD; lpInfo : pointer) : BOOL; stdcall;

var
hDLL : THandle ;
LibLoaded : boolean ;

var
OSVersionInfo : TOSVersionInfo;

{$EXTERNALSYM QueryServiceConfig2A}
QueryServiceConfig2A : TQueryServiceConfig2;
{$EXTERNALSYM QueryServiceConfig2W}
QueryServiceConfig2W : TQueryServiceConfig2;
{$EXTERNALSYM QueryServiceConfig2}
QueryServiceConfig2 : TQueryServiceConfig2;

{$EXTERNALSYM ChangeServiceConfig2A}
ChangeServiceConfig2A : TChangeServiceConfig2;
{$EXTERNALSYM ChangeServiceConfig2W}
ChangeServiceConfig2W : TChangeServiceConfig2;
{$EXTERNALSYM ChangeServiceConfig2}
ChangeServiceConfig2 : TChangeServiceConfig2;

implementation

initialization
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
GetVersionEx(OSVersionInfo);
if (OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and (OSVersionInfo.dwMajorVersion >= 5) then
begin
if hDLL = 0 then
begin
hDLL:=GetModuleHandle(AdvApiDLL);
LibLoaded := False;
if hDLL = 0 then
begin
hDLL := LoadLibrary(AdvApiDLL);
LibLoaded := True;
end;
end;

if hDLL <> 0 then
begin
@QueryServiceConfig2A := GetProcAddress(hDLL, 'QueryServiceConfig2A');
@QueryServiceConfig2W := GetProcAddress(hDLL, 'QueryServiceConfig2W');
@QueryServiceConfig2 := @QueryServiceConfig2A;
@ChangeServiceConfig2A := GetProcAddress(hDLL, 'ChangeServiceConfig2A');
@ChangeServiceConfig2W := GetProcAddress(hDLL, 'ChangeServiceConfig2W');
@ChangeServiceConfig2 := @ChangeServiceConfig2A;
end;
end
else
begin
@QueryServiceConfig2A := nil;
@QueryServiceConfig2W := nil;
@QueryServiceConfig2 := nil;
@ChangeServiceConfig2A := nil;
@ChangeServiceConfig2W := nil;
@ChangeServiceConfig2 := nil;
end;

finalization
if (hDLL <> 0) and LibLoaded then
FreeLibrary(hDLL);

end.

unit winntService;

interface

uses
Windows,WinSvc,WinSvcEx;

function InstallService(const strServiceName,strDisplayName,strDescription,strFilename: string):Boolean;
//eg:InstallService('服务名称','显示名称','描述信息','服务文件');
procedure UninstallService(strServiceName:string);
implementation

function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;
asm
PUSH EDI
PUSH ESI
PUSH EBX
MOV ESI,EAX
MOV EDI,EDX
MOV EBX,ECX
XOR AL,AL
TEST ECX,ECX
JZ @@1
REPNE SCASB
JNE @@1
INC ECX
@@1: SUB EBX,ECX
MOV EDI,ESI
MOV ESI,EDX
MOV EDX,EDI
MOV ECX,EBX
SHR ECX,2
REP MOVSD
MOV ECX,EBX
AND ECX,3
REP MOVSB
STOSB
MOV EAX,EDX
POP EBX
POP ESI
POP EDI
end;

function StrPCopy(Dest: PChar; const Source: string): PChar;
begin
Result := StrLCopy(Dest, PChar(Source), Length(Source));
end;

function InstallService(const strServiceName,strDisplayName,strDescription,strFilename: string):Boolean;
var
//ss : TServiceStatus;
//psTemp : PChar;
hSCM,hSCS:THandle;

srvdesc : PServiceDescription;
desc : string;
//SrvType : DWord;

lpServiceArgVectors:pchar;
begin
Result:=False;
//psTemp := nil;
//SrvType := SERVICE_WIN32_OWN_PROCESS and SERVICE_INTERACTIVE_PROCESS;
hSCM:=OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);//连接服务数据库
if hSCM=0 then Exit;//MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),'服务程序管理器',MB_ICONERROR+MB_TOPMOST);


hSCS:=CreateService( //创建服务函数
hSCM, // 服务控制管理句柄
Pchar(strServiceName), // 服务名称
Pchar(strDisplayName), // 显示的服务名称
SERVICE_ALL_ACCESS, // 存取权利
SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS,// 服务类型 SERVICE_WIN32_SHARE_PROCESS
SERVICE_AUTO_START, // 启动类型
SERVICE_ERROR_IGNORE, // 错误控制类型
Pchar(strFilename), // 服务程序
nil, // 组服务名称
nil, // 组标识
nil, // 依赖的服务
nil, // 启动服务帐号
nil); // 启动服务口令
if hSCS=0 then Exit;//MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),Pchar(Application.Title),MB_ICONERROR+MB_TOPMOST);

if Assigned(ChangeServiceConfig2) then
begin
desc := Copy(strDescription,1,1024);
GetMem(srvdesc,SizeOf(TServiceDescription));
GetMem(srvdesc^.lpDescription,Length(desc) + 1);
try
StrPCopy(srvdesc^.lpDescription, desc);
ChangeServiceConfig2(hSCS,SERVICE_CONFIG_DESCRIPTION,srvdesc);
finally
FreeMem(srvdesc^.lpDescription);
FreeMem(srvdesc);
end;
end;
lpServiceArgVectors := nil;
if not StartService(hSCS, 0, lpServiceArgVectors) then //启动服务
Exit; //MessageBox(hHandle,Pchar(SysErrorMessage(GetLastError)),Pchar(Application.Title),MB_ICONERROR+MB_TOPMOST);
CloseServiceHandle(hSCS); //关闭句柄
Result:=True;
end;

procedure UninstallService(strServiceName:string);
var
SCManager: SC_HANDLE;
Service: SC_HANDLE;
Status: TServiceStatus;
begin
SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if SCManager = 0 then Exit;
try
Service := OpenService(SCManager, Pchar(strServiceName), SERVICE_ALL_ACCESS);
ControlService(Service, SERVICE_CONTROL_STOP, Status);
DeleteService(Service);
CloseServiceHandle(Service);
finally
CloseServiceHandle(SCManager);
end;
end;

end.

(5)如何暴力关闭一个服务程序,实现我们以前那个"NT工具箱"的功能?首先,根据进程名称来杀死进程是用以下函数:
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;

但是对于服务程序,它会提示"拒绝访问".其实只要程序拥有Debug权限即可:
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);
result:=EnablePrivilege(hToken, 'SeDebugPrivilege', True);
CloseHandle(hToken);
end;

使用方法:
EnableDebugPrivilege;//提升权限
KillTask('xxxx.exe');//关闭该服务程序.

-----------------------------------作者:陈经韬 来源:CnXHacker.Net ----------------

 

2010年10月22日星期五

Delphi中AdoTable通过Locate方法快速定位记录(转)

摘自:http://blog.csdn.net/kunshan_shenbin/archive/2010/07/31/5779354.aspx

Locate可以将当前光标定位在符合条件的记录上,Locate的第一个参数是条件字段,第二个参数是条件
值,第三个参数指出在查找时是否考虑大小写,是否部分匹配。Locate可以设置多个条件,如下所示:
Table1.Locate('company;contact;phone',VarArrayOf(['Sight Diver','P ','408-431-1000']),[loPartialKey]);

又如:

  1. var  
  2.   LocateSuccess: Boolean;  
  3.   SearchOptions: TLocateOptions;  
  4.   vField:Variant;  
  5. begin  
  6.   SearchOptions := [loPartialKey];  
  7.   vField:=VarArrayCreate([0,1],VarOleStr);  
  8.   vField[0]:='2222';  
  9.   vField[1]:='二222';  
  10.   LocateSuccess := Table1.Locate('A_NO;A_NAME', vField ,SearchOptions);  
  11.   if LocateSuccess then  
  12.     Label1.Caption:='找到了'  
  13.   else  
  14.     Label1.Caption:='找不到';  
  15. end;  

参与第三个参数的介绍:

loCaseInsensitive : 忽略大小写

loPartialKey : 是否采用局部相同的找法。此时, 只要搜寻条件的字串相等於栏位内容的开头文字, 即使长度不等, 仍然可判定为相等.( 就好像 xBASE 的 set exact off 的情形 )

用以下的例子来说明比较容易懂. 假定 Table1 为 :

cu_no cu_name
AMKB 王大同
ACJC 金士钦
BDFD 林火金

若 sTest 为 'AMKB':
  Table1.Locate('cu_no', sTest, [])
  ==> 当然可以找到 

若 sTest 为 'AC':
  Table1.Locate('cu_no', sTest, [])
    ==> 找不到
  Table1.Locate('cu_no', sTest, [loPartialKey])
    ==> 找到 'ACJC 金士钦 ' 这笔记录.
        因为集合中有 loPartialKey 这个项目, 此时, 'AC' 相同於 'ACJC'
        的开头两个字元, 即使两者长度不等, 也算找到.

若 sTest 为 'ac':
  Table1.Locate('cu_no', sTest, [loPartialKey])
    ==> 找不到, 因为区分大小写之故, 所以 'AC' 虽开头相同於 'ACJC',
        也不能算作符合条件.
  Table1.Locate('cu_no', sTest, [loCaseInsensitive, loPartialKey])
    ==> 找到 ACJC 金士钦 这笔记录.
        此时不再区分大小写了. 可以顺利找到接近的资料.

简言之, Locate() 的第三引数如果是空集合, 那表示找到的资料必须大小写与资料长度均相等, 也就是完全相等的方式搜寻资料 ; 而集合中的元素, 视情况加入 loCaseInsensitive( 不区分大小写 ) . loPartialKey( 局部相等 ) 则提供了搜寻近似资料的弹性作法.

如果条件只有中文字呢? loCaseInsensitive 就没有什麽意义, 加与不加都不影响结果 ; 局部搜寻仍是有效的

2010年10月21日星期四

delphi之多线程编程(二)(转)

摘自:http://www.birdol.com/article/delphi-duoxiancheng-2.html

四、多线程同步之 Mutex (互斥对象)
原理分析:
互斥对象是系统内核对象, 各线程都可以拥有它, 谁拥有谁就能执行;
执行完毕, 用 ReleaseMutex 函数释放拥有权, 以让其他等待的线程使用.
其他线程可用 WaitForSingleObject 函数排队等候(等候也可以理解为排队申请).

使用过程:
var hMutex: THandle; {应该先声明一个全局的互斥句柄} 
CreateMutex          {建立一个互斥对象} 
WaitForSingleObject  {用等待函数排队等候} 
ReleaseMutex         {释放拥有权} 
CloseHandle          {最后释放互斥对象} 
 
 
ReleaseMutex、CloseHandle 的参数都是 CreateMutex 返回的句柄, 关键是 CreateMutex 函数: 
 
function CreateMutex( 
  lpMutexAttributes: PSecurityAttributes; 
  bInitialOwner: BOOL; {是否让创建者(此例中是主线程)拥有该互斥对象} 
  lpName: PWideChar    {可以给此互斥对象取个名字, 如果不要名字可赋值为 nil} 
): THandle; 

1、第一个参数前面说过. 
2、第二个参数在这里一定要是 False, 如果让主线程拥有互斥, 从理论上讲, 得等程序退出后其他线程才有机会; 
   取值 False 时, 第一个执行的线程将会最先拥有互斥对象, 一旦拥有其他线程就得先等等. 
3、第三个参数, 如果给个名字, 函数将从系统中寻找是否有重名的互斥对象, 如果有则返回同名对象的存在的句柄; 
   如果赋值为 nil 将直接创建一个新的互斥对象; 下个例子将会有名字. }
本例效果图:

unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  end
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
var 
  f: Integer;      {用这个变量协调一下各线程输出的位置} 
  hMutex: THandle; {互斥对象的句柄} 
 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
  i,y: Integer; 
begin 
  Inc(f); 
  y := 20 * f; 
  for i := 0 to 50000 do 
  begin 
    if WaitForSingleObject(hMutex, INFINITE) = WAIT_OBJECT_0 then 
    begin 
      Form1.Canvas.Lock; 
      Form1.Canvas.TextOut(20, y, IntToStr(i)); 
      Form1.Canvas.Unlock; 
      Sleep(0); {稍稍耽搁一点, 不然有时 Canvas 会协调不过来} 
      ReleaseMutex(hMutex); 
    end
  end
  Result := 0
end
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  ThreadID: DWORD; 
begin 
  Repaint; 
  f := 0
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
end
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  hMutex := CreateMutex(nil, False, nil); 
end
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  CloseHandle(hMutex); 
end
 
end.
SyncObjs 单元下有封装好的 TMutex 类, 好像不如 Api 快, 内部机制也稍有区别, 但使用方法差不多:
unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  end
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
uses SyncObjs; 
var 
  f: Integer; 
  MyMutex: TMutex; 
 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
  i,y: Integer; 
begin 
  Inc(f); 
  y := 20 * f; 
  for i := 0 to 50000 do 
  begin 
    if MyMutex.WaitFor(INFINITE) = wrSignaled then 
    begin 
      Form1.Canvas.Lock; 
      Form1.Canvas.TextOut(20, y, IntToStr(i)); 
      Form1.Canvas.Unlock; 
      MyMutex.Release; 
    end
  end
  Result := 0
end
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  ThreadID: DWORD; 
begin 
  Repaint; 
  f := 0
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
end
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  MyMutex := TMutex.Create(False); 
end
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  MyMutex.Free; 
end
 
end.
Mutex 作为系统核心对象是可以跨进程的(临界区就不行), 我们可以利用互斥对象禁止程序重复启动.

工作思路:
先用 OpenMutex 尝试打开一个自定义名称的 Mutex 对象, 如果打开失败说明之前没有这个对象存在;
如果之前没有这个对象, 马上用 CreateMutex 建立一个, 此时的程序应该是第一次启动;
再重复启动时, 那个 OpenMutex 就有结果了, 然后强制退出.
最后在程序结束时用 CloseHandle 释放 Mutex 对象.
function OpenMutex( 
  dwDesiredAccess: DWORD; {打开权限} 
  bInheritHandle: BOOL;   {能否被当前程序创建的进程继承} 
  pName: PWideChar        {Mutex 对象的名称} 
): THandle; stdcall;      {成功返回 Mutex 的句柄; 失败返回 0} 

注意, 这里的 CreateMutex 函数应该有个名了, 因为 OpenMutex 要用到;
另外, CreateMutex 的第二个参数已经不重要了(也就是 True 和 False 都行), 因为这里是用其名称来判断的.

程序可以这样写:
unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs; 
 
type 
  TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  end
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
var 
  hMutex: THandle; 
const 
  NameMutex = 'MyMutex'
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  if OpenMutex(MUTEX_ALL_ACCESS, False, NameMutex) <> 0 then 
  begin 
    ShowMessage('该程序已启动'); 
    Application.Terminate; 
  end
  hMutex := CreateMutex(nil, False, NameMutex); 
end
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  CloseHandle(hMutex); 
end
 
end

这一般都是写在 dpr 主程序里, 省得让后启动的程序执行些无用的代码:
program Project1; 
 
uses 
  Forms, Windows, 
  Unit1 in 'Unit1.pas' {Form1}
 
{$R *.res} 
 
var 
  hMutex: THandle; 
const 
  NameMutex = 'MyMutex'
 
begin 
  {主线程入口} 
  if OpenMutex(MUTEX_ALL_ACCESS, False, NameMutex) <> 0 then 
  begin 
    MessageBox(0'该程序已启动''提示', MB_OK); 
    Application.Terminate; 
  end
  hMutex := CreateMutex(nil, False, NameMutex); 
 
  Application.Initialize; 
  Application.MainFormOnTaskbar := True; 
  Application.CreateForm(TForm1, Form1); 
  Application.Run; 
 
  CloseHandle(hMutex); 
  {主线程出口} 
end
五、多线程同步之 Semaphore (信号对象)
之前已经有了两种多线程的同步方法:
CriticalSection(临界区) 和 Mutex(互斥), 这两种同步方法差不多, 只是作用域不同;
CriticalSection(临界区) 类似于只有一个蹲位的公共厕所, 只能一个个地进;
Mutex(互斥) 对象类似于接力赛中的接力棒, 某一时刻只能一个人持有, 谁拿着谁跑.

什么是 Semaphore(信号或叫信号量)呢?
譬如到银行办业务、或者到车站买票, 原来只有一个服务员, 不管有多少人排队等候, 业务只能一个个地来.
假如增加了业务窗口, 可以同时受理几个业务呢?
这就类似与 Semaphore 对象, Semaphore 可以同时处理等待函数(如: WaitForSingleObject)申请的几个线程.

Semaphore 的工作思路如下:
1、首先要通过 CreateSemaphore(安全设置, 初始信号数, 信号总数, 信号名称) 建立信号对象;
参数四: 和 Mutex 一样, 它可以有个名称, 也可以没有, 本例就没有要名称(nil); 有名称的一般用于跨进程.
参数三: 信号总数, 是 Semaphore 最大处理能力, 就像银行一共有多少个业务窗口一样;
参数二: 初始信号数, 这就像银行的业务窗口很多, 但打开了几个可不一定, 如果没打开和没有一样;
参数一: 安全设置和前面一样, 使用默认(nil)即可.

2、要接受 Semaphore 服务(或叫协调)的线程, 同样需要用等待函数(如: WaitForSingleObject)排队等候;

3、当一个线程使用完一个信号, 应该用 ReleaseSemaphore(信号句柄, 1, nil) 让出可用信号给其他线程;
参数三: 一般是 nil, 如果给个数字指针, 可以接受到此时(之前)总共闲置多少个信号;
参数二: 一般是 1, 表示增加一个可用信号;
如果要增加 CreateSemaphore 时的初始信号, 也可以通过 ReleaseSemaphore.

4、最后, 作为系统内核对象, 要用 CloseHandle 关闭.

另外, 在 Semaphore 的总数是 1 的情况下, 就和 Mutex(互斥) 一样了.

在本例中, 每点击按钮, 将建立一个信号总数为 5 的信号对象, 初始信号来自 Edit1; 同时有 5 个线程去排队.
本例也附上了 Delphi 中 TSemaphore 类的例子, 但没有过多地纠缠于细节, 是为了尽快理出多线程的整体思路.
本例效果图:


unit Unit1; 
interface 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Edit1: TEdit; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  end
var 
  Form1: TForm1; 
implementation 
{$R *.dfm} 
var 
  f: Integer;          {用这个变量协调一下各线程输出的位置} 
  hSemaphore: THandle; {信号对象的句柄} 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
  i,y: Integer; 
begin 
  Inc(f); 
  y := 20 * f; 
  if WaitForSingleObject(hSemaphore, INFINITE) = WAIT_OBJECT_0 then 
  begin 
    for i := 0 to 100 do 
    begin 
      Form1.Canvas.Lock; 
      Form1.Canvas.TextOut(20, y, IntToStr(i)); 
      Form1.Canvas.Unlock; 
      Sleep(1); {以免 Canvas 忙不过来} 
    end
  end
  ReleaseSemaphore(hSemaphore, 1nil); 
  Result := 0
end
procedure TForm1.Button1Click(Sender: TObject); 
var 
  ThreadID: DWORD; 
begin 
  {不知是不是之前创建过 Semaphore 对象, 假如有先关闭} 
  CloseHandle(hSemaphore); 
  {创建 Semaphore 对象} 
  hSemaphore := CreateSemaphore(nil, StrToInt(Edit1.Text), 5nil); 
  Self.Repaint; 
  f := 0
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
end
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Edit1.Text := '1'
end
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  CloseHandle(hSemaphore); 
end
end.

再用 SyncObjs 单元下的 TSemaphore 类实现一次, 使用方法差不多, 运行效果也一样:

unit Unit1; 
interface 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Edit1: TEdit; 
    procedure Button1Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Edit1KeyPress(Sender: TObject; var Key: Char); 
  end
var 
  Form1: TForm1; 
implementation 
{$R *.dfm} 
uses SyncObjs; 
var 
  f: Integer; 
  MySemaphore: TSemaphore; 
function MyThreadFun(p: Pointer): DWORD; stdcall; 
var 
  i,y: Integer; 
begin 
  Inc(f); 
  y := 20 * f; 
  if MySemaphore.WaitFor(INFINITE) = wrSignaled then 
  begin 
    for i := 0 to 1000 do 
    begin 
      Form1.Canvas.Lock; 
      Form1.Canvas.TextOut(20, y, IntToStr(i)); 
      Form1.Canvas.Unlock; 
      Sleep(1); 
    end
  end
  MySemaphore.Release; 
  Result := 0
end
procedure TForm1.Button1Click(Sender: TObject); 
var 
  ThreadID: DWORD; 
begin 
  if Assigned(MySemaphore) then MySemaphore.Free; 
  MySemaphore := TSemaphore.Create(nil, StrToInt(Edit1.Text), 5''); 
  Self.Repaint; 
  f := 0
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
  CreateThread(nil0, @MyThreadFun, nil0, ThreadID); 
end
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Edit1.Text := '1'
end
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  if Assigned(MySemaphore) then MySemaphore.Free; 
end
end.